From: Adam Megacz Date: Sat, 16 Apr 2011 23:56:37 +0000 (-0700) Subject: merge up to ghc HEAD 16-Apr-2011 X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=6cec61d14a324285dbb8ce73d4c7215f1f8d6766;hp=163d12852002a67c5b661b4b3e7e3c5bb6faa5f3 merge up to ghc HEAD 16-Apr-2011 --- diff --git a/.gitignore b/.gitignore index 44a3b95..bbcff22 100644 --- a/.gitignore +++ b/.gitignore @@ -22,6 +22,7 @@ *.o.cmd *.depend* log +tags autom4te.cache config.log @@ -48,6 +49,7 @@ configure /libraries/haskeline/ /libraries/haskell2010/ /libraries/haskell98/ +/libraries/hoopl/ /libraries/hpc/ /libraries/integer-gmp/ /libraries/integer-simple/ @@ -74,6 +76,12 @@ configure # ----------------------------------------------------------------------------- # specific generated files +/bindist-list +/bindistprep/ +/bindisttest/HelloWorld +/bindisttest/a/ +/bindisttest/install\ dir/ +/bindisttest/output /ch01.html /ch02.html /compiler/cmm/CmmLex.hs @@ -108,6 +116,9 @@ configure /docs/man/ghc.1 /docs/users_guide/ug-book.xml /docs/users_guide/ug-ent.xml +/docs/users_guide/users_guide.xml +/docs/users_guide/users_guide/ +/docs/users_guide/what_glasgow_exts_does.gen.xml /driver/ghci/ghc-pkg-inplace /driver/ghci/ghci-inplace /driver/mangler/dist/ghc-asm @@ -143,6 +154,16 @@ configure /libraries/bin-package-db/ghc.mk /libraries/bootstrapping.conf /libraries/prologue.txt +/libraries/doc-index*.html +/libraries/frames.html +/libraries/haddock-util.js +/libraries/hslogo-16.png +/libraries/index-frames.html +/libraries/index.html +/libraries/minus.gif +/libraries/ocean.css +/libraries/plus.gif +/libraries/synopsis.png /libraries/stamp/ /libraries/time/ /libraries/*/dist-boot/ @@ -165,6 +186,7 @@ configure /rts/sm/Evac_thr.c /rts/sm/Scav_thr.c /stage3.package.conf +/testsuite_summary.txt /testlog /utils/*/dist*/ /utils/ext-core/Driver diff --git a/HACKING b/HACKING index 3c5db04..8ceff18 100644 --- a/HACKING +++ b/HACKING @@ -20,11 +20,16 @@ The GHC Developer's Wiki Quick Start for developers - http://hackage.haskell.org/trac/ghc/wiki/Building/Hacking - + http://hackage.haskell.org/trac/ghc/wiki/Building/Hacking + This section on the wiki will get you up and running with a - serviceable build tree in no time: - + serviceable build tree in no time. + + Don't skip this! By default, GHC builds with all optimizations + and profiling; most hackers will want a quicker build, so creating + a mk/build.mk file and knowing how to rebuild only parts of GHC is + very important. + This is part of the "Building GHC" section of the wiki, which has more detailed information on GHC's build system should you need it. diff --git a/README b/README index 72a9609..c7d390d 100644 --- a/README +++ b/README @@ -27,35 +27,18 @@ There are two ways to get a source tree: which contains GHC itself and the "boot" libraries. - 2. Check out the source code from darcs - --------------------------------------- + 2. Check out the source code from git + ------------------------------------- - The recommended way to get a darcs checkout is to start off by - downloading a snapshot with a name like: + First get the GHC git repository: - ghc-HEAD-2009-09-09-ghc-corelibs-testsuite.tar.bz2 + $ git clone http://darcs.haskell.org/ghc.git/ - from: - - http://darcs.haskell.org/ - - and then untar it and bring it up-to-date with: - - $ cd ghc - $ ./darcs-all get - - - Alternatively you can use darcs to get the repos, but it will take a - lot longer. First get the GHC darcs repository: - - $ darcs get http://darcs.haskell.org/ghc/ - - Then run the darcs-all script in that repository + Then run the sync-all script in that repository to get the other repositories: $ cd ghc - $ chmod +x darcs-all - $ ./darcs-all get + $ ./sync-all get This checks out the "boot" packages. @@ -71,7 +54,7 @@ NB. you need GHC installed in order to build GHC, because the compiler is itself written in Haskell. For instructions on how to port GHC to a new platform, see the Building Guide. -If you're building from darcs sources (as opposed to a source +If you're building from git sources (as opposed to a source distribution) then you also need to install Happy [4] and Alex [5]. For building library documentation, you'll need Haddock [6]. To build @@ -86,13 +69,12 @@ Quick start: the following gives you a default build: $ make install The "perl boot" step is only necessary if this is a tree checked out -from darcs. For source distributions downloaded from GHC's web site, +from git. For source distributions downloaded from GHC's web site, this step has already been performed. These steps give you the default build, which includes everything optimised and built in various ways (eg. profiling libs are built). -It can take a long time. To customise the build, see the file -HACKING. +It can take a long time. To customise the build, see the file HACKING. diff --git a/aclocal.m4 b/aclocal.m4 index ae9e41e..0e72d22 100644 --- a/aclocal.m4 +++ b/aclocal.m4 @@ -94,14 +94,10 @@ AC_DEFUN([FPTOOLS_SET_C_LD_FLAGS], AC_MSG_CHECKING([Setting up $2, $3, $4 and $5]) case $$1 in i386-apple-darwin) - # By default, gcc on OS X will generate SSE - # instructions, which need things 16-byte aligned, - # but we don't 16-byte align things. Thus drop - # back to generic i686 compatibility. Trac #2983. - $2="$$2 -march=i686 -m32" - $3="$$3 -march=i686 -m32" + $2="$$2 -m32" + $3="$$3 -m32" $4="$$4 -arch i386" - $5="$$5 -march=i686 -m32" + $5="$$5 -m32" ;; x86_64-apple-darwin) $2="$$2 -m64" @@ -111,16 +107,6 @@ AC_DEFUN([FPTOOLS_SET_C_LD_FLAGS], ;; esac - case $$1 in - i386-apple-darwin|x86_64-apple-darwin) - # We support back to OS X 10.5 - $2="$$2 -isysroot /Developer/SDKs/MacOSX10.5.sdk -mmacosx-version-min=10.5" - $3="$$3 -isysroot /Developer/SDKs/MacOSX10.5.sdk -mmacosx-version-min=10.5" - $4="$$4 -macosx_version_min 10.5" - $5="$$5 -isysroot /Developer/SDKs/MacOSX10.5.sdk -mmacosx-version-min=10.5" - ;; - esac - # If gcc knows about the stack protector, turn it off. # Otherwise the stack-smash handler gets triggered. echo 'int main(void) {return 0;}' > conftest.c @@ -494,6 +480,31 @@ AC_SUBST([LdXFlag]) ])# FP_PROG_LD_X +# FP_PROG_LD_BUILD_ID +# ------------ + +# Sets the output variable LdHasBuildId to YES if ld supports +# --build-id, or NO otherwise. +AC_DEFUN([FP_PROG_LD_BUILD_ID], +[ +AC_CACHE_CHECK([whether ld understands --build-id], [fp_cv_ld_build_id], +[echo 'foo() {}' > conftest.c +${CC-cc} -c conftest.c +if ${LdCmd} -r --build-id=none -o conftest2.o conftest.o > /dev/null 2>&1; then + fp_cv_ld_build_id=yes +else + fp_cv_ld_build_id=no +fi +rm -rf conftest*]) +if test "$fp_cv_ld_build_id" = yes; then + LdHasBuildId=YES +else + LdHasBuildId=NO +fi +AC_SUBST([LdHasBuildId]) +])# FP_PROG_LD_BUILD_ID + + # FP_PROG_LD_IS_GNU # ----------------- # Sets the output variable LdIsGNULd to YES or NO, depending on whether it is @@ -1079,18 +1090,9 @@ AC_SUBST([GhcPkgCmd]) # Determine which extra flags we need to pass gcc when we invoke it # to compile .hc code. # -# Some OSs (Mandrake Linux, in particular) configure GCC with -# -momit-leaf-frame-pointer on by default. If this is the case, we -# need to turn it off for mangling to work. The test is currently a -# bit crude, using only the version number of gcc. -# # -fwrapv is needed for gcc to emit well-behaved code in the presence of # integer wrap around. (Trac #952) # -# -fno-unit-at-a-time or -fno-toplevel-reoder is necessary to avoid gcc -# reordering things in the module and confusing the manger and/or splitter. -# (eg. Trac #1427) -# AC_DEFUN([FP_GCC_EXTRA_FLAGS], [AC_REQUIRE([FP_HAVE_GCC]) AC_CACHE_CHECK([for extra options to pass gcc when compiling via C], [fp_cv_gcc_extra_opts], @@ -1098,24 +1100,6 @@ AC_CACHE_CHECK([for extra options to pass gcc when compiling via C], [fp_cv_gcc_ FP_COMPARE_VERSIONS([$fp_cv_gcc_version], [-ge], [3.4], [fp_cv_gcc_extra_opts="$fp_cv_gcc_extra_opts -fwrapv"], []) - case $TargetPlatform in - i386-*|x86_64-*) - FP_COMPARE_VERSIONS([$fp_cv_gcc_version], [-ge], [3.2], - [fp_cv_gcc_extra_opts="$fp_cv_gcc_extra_opts -mno-omit-leaf-frame-pointer"], - []) - FP_COMPARE_VERSIONS([$fp_cv_gcc_version], [-ge], [3.4], - [FP_COMPARE_VERSIONS([$fp_cv_gcc_version], [-ge], [4.2], - [fp_cv_gcc_extra_opts="$fp_cv_gcc_extra_opts -fno-toplevel-reorder"], - [fp_cv_gcc_extra_opts="$fp_cv_gcc_extra_opts -fno-unit-at-a-time"] - )], - []) - ;; - sparc-*-solaris2) - FP_COMPARE_VERSIONS([$fp_cv_gcc_version], [-ge], [4.2], - [fp_cv_gcc_extra_opts="$fp_cv_gcc_extra_opts -fno-toplevel-reorder"], - []) - ;; - esac ]) AC_SUBST([GccExtraViaCOpts],$fp_cv_gcc_extra_opts) ]) @@ -1458,7 +1442,7 @@ case "$1" in hppa*) $2="hppa" ;; - i386) + i386|i486|i586|i686) $2="i386" ;; ia64) @@ -1511,7 +1495,15 @@ case "$1" in # -------------------------------- # converts vendor from gnu to ghc naming, and assigns the result to $target_var AC_DEFUN([GHC_CONVERT_VENDOR],[ -$2="$1" + case "$1" in + pc|gentoo) # like i686-pc-linux-gnu and i686-gentoo-freebsd8 + $2="unknown" + ;; + *) + #pass thru by default + $2="$1" + ;; + esac ]) # GHC_CONVERT_OS(os, target_var) @@ -1526,6 +1518,9 @@ case "$1" in freebsd|netbsd|openbsd|dragonfly|osf1|osf3|hpux|linuxaout|kfreebsdgnu|freebsd2|solaris2|cygwin32|mingw32|darwin|gnu|nextstep2|nextstep3|sunos4|ultrix|irix|aix|haiku) $2="$1" ;; + freebsd8) # like i686-gentoo-freebsd8 + $2="freebsd" + ;; *) echo "Unknown OS $1" exit 1 diff --git a/bindisttest/ghc.mk b/bindisttest/ghc.mk index a3e97b0..e051be0 100644 --- a/bindisttest/ghc.mk +++ b/bindisttest/ghc.mk @@ -19,7 +19,7 @@ endif .PHONY: test_bindist test_bindist: "$(RM)" $(RM_OPTS_REC) bindisttest/$(BIN_DIST_INST_SUBDIR) - "$(RM)" $(RM_OPTS_REC) bindisttest/a/b/c/* + "$(RM)" $(RM_OPTS_REC) bindisttest/a "$(RM)" $(RM_OPTS) bindisttest/HelloWorld "$(RM)" $(RM_OPTS) bindisttest/HelloWorld.o "$(RM)" $(RM_OPTS) bindisttest/HelloWorld.hi @@ -30,6 +30,9 @@ test_bindist: # NB. tar has funny interpretation of filenames sometimes (thinking # c:/foo is a remote file), so it's safer to bzip and then pipe into # tar rather than using tar -xjf: + mkdir bindisttest/a + mkdir bindisttest/a/b + mkdir bindisttest/a/b/c cd bindisttest/a/b/c/ && $(BZIP2_CMD) -cd ../../../../$(BIN_DIST_TEST_TAR_BZ2) | $(TAR_CMD) -xf - $(SHELL) bindisttest/checkBinaries.sh $(ProjectVersion) ifeq "$(Windows)" "YES" diff --git a/boot b/boot old mode 100644 new mode 100755 index f47bdf6..66bff3e --- a/boot +++ b/boot @@ -5,8 +5,10 @@ use strict; use Cwd; my %required_tag; +my $validate; $required_tag{"-"} = 1; +$validate = 0; while ($#ARGV ne -1) { my $arg = shift @ARGV; @@ -14,11 +16,32 @@ while ($#ARGV ne -1) { if ($arg =~ /^--required-tag=(.*)/) { $required_tag{$1} = 1; } + elsif ($arg =~ /^--validate$/) { + $validate = 1; + } else { die "Bad arg: $arg"; } } +{ + local $/ = undef; + open FILE, "packages" or die "Couldn't open file: $!"; + binmode FILE; + my $string = ; + close FILE; + + if ($string =~ /\r/) { + print STDERR <) { # If $tag is not "-" then it is an optional repository, so its # absence isn't an error. if (defined($required_tag{$tag})) { - # We would like to just check for an _darcs directory here, - # but in an lndir tree we avoid making _darcs directories, + # We would like to just check for a .git directory here, + # but in an lndir tree we avoid making .git directories, # so it doesn't exist. We therefore require that every repo # has a LICENSE file instead. if (! -f "$dir/LICENSE") { print STDERR "Error: $dir/LICENSE doesn't exist.\n"; - die "Maybe you haven't done './darcs-all get'?"; + die "Maybe you haven't done './sync-all get'?"; } } } @@ -70,10 +93,19 @@ foreach $dir (".", glob("libraries/*/")) { } } -# Alas, darcs doesn't handle file permissions, so fix a few of them. -for my $file ("boot", "darcs-all", "validate") { - if (-f $file) { - chmod 0755, $file - or die "Can't chmod 0755 $file: $!"; - } +if ($validate eq 0 && ! -f "mk/build.mk") { + print <) { chomp; + s/\r//g; if (/.+/) { push @library_dirs, "$package/$_"; } diff --git a/compiler/basicTypes/IdInfo.lhs b/compiler/basicTypes/IdInfo.lhs index 1c01ba4..ec1f122 100644 --- a/compiler/basicTypes/IdInfo.lhs +++ b/compiler/basicTypes/IdInfo.lhs @@ -46,6 +46,7 @@ module IdInfo ( -- ** The SpecInfo type SpecInfo(..), + emptySpecInfo, isEmptySpecInfo, specInfoFreeVars, specInfoRules, seqSpecInfo, setSpecInfoHead, specInfo, setSpecInfo, diff --git a/compiler/basicTypes/SrcLoc.lhs b/compiler/basicTypes/SrcLoc.lhs index 06f8ec8..5dcdabe 100644 --- a/compiler/basicTypes/SrcLoc.lhs +++ b/compiler/basicTypes/SrcLoc.lhs @@ -278,20 +278,18 @@ mkSrcSpan loc1 loc2 combineSrcSpans :: SrcSpan -> SrcSpan -> SrcSpan combineSrcSpans (UnhelpfulSpan _) r = r -- this seems more useful combineSrcSpans l (UnhelpfulSpan _) = l -combineSrcSpans start end - = case line1 `compare` line2 of - EQ -> case col1 `compare` col2 of - EQ -> SrcSpanPoint file line1 col1 - LT -> SrcSpanOneLine file line1 col1 col2 - GT -> SrcSpanOneLine file line1 col2 col1 - LT -> SrcSpanMultiLine file line1 col1 line2 col2 - GT -> SrcSpanMultiLine file line2 col2 line1 col1 +combineSrcSpans span1 span2 + = if line_start == line_end + then if col_start == col_end + then SrcSpanPoint file line_start col_start + else SrcSpanOneLine file line_start col_start col_end + else SrcSpanMultiLine file line_start col_start line_end col_end where - line1 = srcSpanStartLine start - col1 = srcSpanStartCol start - line2 = srcSpanEndLine end - col2 = srcSpanEndCol end - file = srcSpanFile start + (line_start, col_start) = min (srcSpanStartLine span1, srcSpanStartCol span1) + (srcSpanStartLine span2, srcSpanStartCol span2) + (line_end, col_end) = max (srcSpanEndLine span1, srcSpanEndCol span1) + (srcSpanEndLine span2, srcSpanEndCol span2) + file = srcSpanFile span1 \end{code} %************************************************************************ diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs index 4e9ef8c..c40f3b7 100644 --- a/compiler/cmm/CLabel.hs +++ b/compiler/cmm/CLabel.hs @@ -51,9 +51,7 @@ module CLabel ( mkAsmTempLabel, - mkModuleInitLabel, - mkPlainModuleInitLabel, - mkModuleInitTableLabel, + mkPlainModuleInitLabel, mkSplitMarkerLabel, mkDirty_MUT_VAR_Label, @@ -70,10 +68,7 @@ module CLabel ( mkRtsPrimOpLabel, mkRtsSlowTickyCtrLabel, - moduleRegdLabel, - moduleRegTableLabel, - - mkSelectorInfoLabel, + mkSelectorInfoLabel, mkSelectorEntryLabel, mkCmmInfoLabel, @@ -102,7 +97,6 @@ module CLabel ( mkDeadStripPreventer, mkHpcTicksLabel, - mkHpcModuleNameLabel, hasCAF, infoLblToEntryLbl, entryLblToInfoLbl, cvtToClosureLbl, cvtToSRTLbl, @@ -202,23 +196,9 @@ data CLabel | StringLitLabel {-# UNPACK #-} !Unique - | ModuleInitLabel - Module -- the module name - String -- its "way" - -- at some point we might want some kind of version number in - -- the module init label, to guard against compiling modules in - -- the wrong order. We can't use the interface file version however, - -- because we don't always recompile modules which depend on a module - -- whose version has changed. - - | PlainModuleInitLabel -- without the version & way info + | PlainModuleInitLabel -- without the version & way info Module - | ModuleInitTableLabel -- table of imported modules to init - Module - - | ModuleRegdLabel - | CC_Label CostCentre | CCS_Label CostCentreStack @@ -242,9 +222,6 @@ data CLabel -- | Per-module table of tick locations | HpcTicksLabel Module - -- | Per-module name of the module for Hpc - | HpcModuleNameLabel - -- | Label of an StgLargeSRT | LargeSRTLabel {-# UNPACK #-} !Unique @@ -494,7 +471,6 @@ mkRtsSlowTickyCtrLabel pat = RtsLabel (RtsSlowTickyCtr pat) -- Constructing Code Coverage Labels mkHpcTicksLabel = HpcTicksLabel -mkHpcModuleNameLabel = HpcModuleNameLabel -- Constructing labels used for dynamic linking @@ -519,19 +495,9 @@ mkStringLitLabel = StringLitLabel mkAsmTempLabel :: Uniquable a => a -> CLabel mkAsmTempLabel a = AsmTempLabel (getUnique a) -mkModuleInitLabel :: Module -> String -> CLabel -mkModuleInitLabel mod way = ModuleInitLabel mod way - mkPlainModuleInitLabel :: Module -> CLabel mkPlainModuleInitLabel mod = PlainModuleInitLabel mod -mkModuleInitTableLabel :: Module -> CLabel -mkModuleInitTableLabel mod = ModuleInitTableLabel mod - -moduleRegdLabel = ModuleRegdLabel -moduleRegTableLabel = ModuleInitTableLabel - - -- ----------------------------------------------------------------------------- -- Converting between info labels and entry/ret labels. @@ -560,6 +526,7 @@ entryLblToInfoLbl l cvtToClosureLbl (IdLabel n c InfoTable) = IdLabel n c Closure cvtToClosureLbl (IdLabel n c Entry) = IdLabel n c Closure cvtToClosureLbl (IdLabel n c ConEntry) = IdLabel n c Closure +cvtToClosureLbl (IdLabel n c RednCounts) = IdLabel n c Closure cvtToClosureLbl l@(IdLabel n c Closure) = l cvtToClosureLbl l = pprPanic "cvtToClosureLbl" (pprCLabel l) @@ -594,10 +561,7 @@ needsCDecl (LargeSRTLabel _) = False needsCDecl (LargeBitmapLabel _) = False needsCDecl (IdLabel _ _ _) = True needsCDecl (CaseLabel _ _) = True -needsCDecl (ModuleInitLabel _ _) = True -needsCDecl (PlainModuleInitLabel _) = True -needsCDecl (ModuleInitTableLabel _) = True -needsCDecl ModuleRegdLabel = False +needsCDecl (PlainModuleInitLabel _) = True needsCDecl (StringLitLabel _) = False needsCDecl (AsmTempLabel _) = False @@ -615,7 +579,6 @@ needsCDecl l@(ForeignLabel{}) = not (isMathFun l) needsCDecl (CC_Label _) = True needsCDecl (CCS_Label _) = True needsCDecl (HpcTicksLabel _) = True -needsCDecl HpcModuleNameLabel = False -- | Check whether a label is a local temporary for native code generation @@ -728,11 +691,8 @@ externallyVisibleCLabel :: CLabel -> Bool -- not C "static" externallyVisibleCLabel (CaseLabel _ _) = False externallyVisibleCLabel (StringLitLabel _) = False externallyVisibleCLabel (AsmTempLabel _) = False -externallyVisibleCLabel (ModuleInitLabel _ _) = True externallyVisibleCLabel (PlainModuleInitLabel _)= True -externallyVisibleCLabel (ModuleInitTableLabel _)= False -externallyVisibleCLabel ModuleRegdLabel = False -externallyVisibleCLabel (RtsLabel _) = True +externallyVisibleCLabel (RtsLabel _) = True externallyVisibleCLabel (CmmLabel _ _ _) = True externallyVisibleCLabel (ForeignLabel{}) = True externallyVisibleCLabel (IdLabel name _ _) = isExternalName name @@ -740,8 +700,7 @@ externallyVisibleCLabel (CC_Label _) = True externallyVisibleCLabel (CCS_Label _) = True externallyVisibleCLabel (DynamicLinkerLabel _ _) = False externallyVisibleCLabel (HpcTicksLabel _) = True -externallyVisibleCLabel HpcModuleNameLabel = False -externallyVisibleCLabel (LargeBitmapLabel _) = False +externallyVisibleCLabel (LargeBitmapLabel _) = False externallyVisibleCLabel (LargeSRTLabel _) = False -- ----------------------------------------------------------------------------- @@ -780,9 +739,7 @@ labelType (RtsLabel (RtsApInfoTable _ _)) = DataLabel labelType (RtsLabel (RtsApFast _)) = CodeLabel labelType (CaseLabel _ CaseReturnInfo) = DataLabel labelType (CaseLabel _ _) = CodeLabel -labelType (ModuleInitLabel _ _) = CodeLabel labelType (PlainModuleInitLabel _) = CodeLabel -labelType (ModuleInitTableLabel _) = DataLabel labelType (LargeSRTLabel _) = DataLabel labelType (LargeBitmapLabel _) = DataLabel labelType (ForeignLabel _ _ _ IsFunction) = CodeLabel @@ -840,10 +797,8 @@ labelDynamic this_pkg lbl = CmmLabel pkg _ _ -> True #endif - ModuleInitLabel m _ -> not opt_Static && this_pkg /= (modulePackageId m) PlainModuleInitLabel m -> not opt_Static && this_pkg /= (modulePackageId m) - ModuleInitTableLabel m -> not opt_Static && this_pkg /= (modulePackageId m) - + -- Note that DynamicLinkerLabels do NOT require dynamic linking themselves. _ -> False @@ -1011,9 +966,6 @@ pprCLbl (RtsLabel (RtsPrimOp primop)) pprCLbl (RtsLabel (RtsSlowTickyCtr pat)) = ptext (sLit "SLOW_CALL_") <> text pat <> ptext (sLit "_ctr") -pprCLbl ModuleRegdLabel - = ptext (sLit "_module_registered") - pprCLbl (ForeignLabel str _ _ _) = ftext str @@ -1022,22 +974,12 @@ pprCLbl (IdLabel name cafs flavor) = ppr name <> ppIdFlavor name flavor pprCLbl (CC_Label cc) = ppr cc pprCLbl (CCS_Label ccs) = ppr ccs -pprCLbl (ModuleInitLabel mod way) - = ptext (sLit "__stginit_") <> ppr mod - <> char '_' <> text way - pprCLbl (PlainModuleInitLabel mod) = ptext (sLit "__stginit_") <> ppr mod -pprCLbl (ModuleInitTableLabel mod) - = ptext (sLit "__stginittable_") <> ppr mod - pprCLbl (HpcTicksLabel mod) = ptext (sLit "_hpc_tickboxes_") <> ppr mod <> ptext (sLit "_hpc") -pprCLbl HpcModuleNameLabel - = ptext (sLit "_hpc_module_name_str") - ppIdFlavor :: Name -> IdLabelInfo -> SDoc ppIdFlavor n x = pp_cSEP <> closureSuffix' n <> (case x of diff --git a/compiler/cmm/Cmm.hs b/compiler/cmm/Cmm.hs index 2e9f952..54b4b11 100644 --- a/compiler/cmm/Cmm.hs +++ b/compiler/cmm/Cmm.hs @@ -9,10 +9,11 @@ #endif module Cmm - ( CmmGraph(..), CmmBlock + ( CmmGraph, GenCmmGraph(..), CmmBlock , CmmStackInfo(..), CmmTopInfo(..), Cmm, CmmTop , CmmReplGraph, CmmFwdRewrite, CmmBwdRewrite + , modifyGraph , lastNode, replaceLastNode, insertBetween , ofBlockMap, toBlockMap, insertBlock , ofBlockList, toBlockList, bodyToBlockList @@ -41,7 +42,8 @@ import Panic ------------------------------------------------- -- CmmBlock, CmmGraph and Cmm -data CmmGraph = CmmGraph { g_entry :: BlockId, g_graph :: Graph CmmNode C C } +type CmmGraph = GenCmmGraph CmmNode +data GenCmmGraph n = CmmGraph { g_entry :: BlockId, g_graph :: Graph n C C } type CmmBlock = Block CmmNode C C type CmmReplGraph e x = FuelUniqSM (Maybe (Graph CmmNode e x)) @@ -56,6 +58,9 @@ type CmmTop = GenCmmTop CmmStatic CmmTopInfo CmmGraph ------------------------------------------------- -- Manipulating CmmGraphs +modifyGraph :: (Graph n C C -> Graph n' C C) -> GenCmmGraph n -> GenCmmGraph n' +modifyGraph f g = CmmGraph {g_entry=g_entry g, g_graph=f (g_graph g)} + toBlockMap :: CmmGraph -> LabelMap CmmBlock toBlockMap (CmmGraph {g_graph=GMany NothingO body NothingO}) = body @@ -150,26 +155,26 @@ insertBetween b ms succId = insert $ lastNode b -- Running dataflow analysis and/or rewrites -- Constructing forward and backward analysis-only pass -analFwd :: Monad m => DataflowLattice f -> FwdTransfer CmmNode f -> FwdPass m CmmNode f -analBwd :: Monad m => DataflowLattice f -> BwdTransfer CmmNode f -> BwdPass m CmmNode f +analFwd :: Monad m => DataflowLattice f -> FwdTransfer n f -> FwdPass m n f +analBwd :: Monad m => DataflowLattice f -> BwdTransfer n f -> BwdPass m n f analFwd lat xfer = analRewFwd lat xfer noFwdRewrite analBwd lat xfer = analRewBwd lat xfer noBwdRewrite -- Constructing forward and backward analysis + rewrite pass -analRewFwd :: Monad m => DataflowLattice f -> FwdTransfer CmmNode f -> FwdRewrite m CmmNode f -> FwdPass m CmmNode f -analRewBwd :: Monad m => DataflowLattice f -> BwdTransfer CmmNode f -> BwdRewrite m CmmNode f -> BwdPass m CmmNode f +analRewFwd :: Monad m => DataflowLattice f -> FwdTransfer n f -> FwdRewrite m n f -> FwdPass m n f +analRewBwd :: Monad m => DataflowLattice f -> BwdTransfer n f -> BwdRewrite m n f -> BwdPass m n f analRewFwd lat xfer rew = FwdPass {fp_lattice = lat, fp_transfer = xfer, fp_rewrite = rew} analRewBwd lat xfer rew = BwdPass {bp_lattice = lat, bp_transfer = xfer, bp_rewrite = rew} -- Running forward and backward dataflow analysis + optional rewrite -dataflowPassFwd :: CmmGraph -> [(BlockId, f)] -> FwdPass FuelUniqSM CmmNode f -> FuelUniqSM (CmmGraph, BlockEnv f) +dataflowPassFwd :: NonLocal n => GenCmmGraph n -> [(BlockId, f)] -> FwdPass FuelUniqSM n f -> FuelUniqSM (GenCmmGraph n, BlockEnv f) dataflowPassFwd (CmmGraph {g_entry=entry, g_graph=graph}) facts fwd = do (graph, facts, NothingO) <- analyzeAndRewriteFwd fwd (JustC [entry]) graph (mkFactBase (fp_lattice fwd) facts) return (CmmGraph {g_entry=entry, g_graph=graph}, facts) -dataflowPassBwd :: CmmGraph -> [(BlockId, f)] -> BwdPass FuelUniqSM CmmNode f -> FuelUniqSM (CmmGraph, BlockEnv f) +dataflowPassBwd :: NonLocal n => GenCmmGraph n -> [(BlockId, f)] -> BwdPass FuelUniqSM n f -> FuelUniqSM (GenCmmGraph n, BlockEnv f) dataflowPassBwd (CmmGraph {g_entry=entry, g_graph=graph}) facts bwd = do (graph, facts, NothingO) <- analyzeAndRewriteBwd bwd (JustC [entry]) graph (mkFactBase (bp_lattice bwd) facts) return (CmmGraph {g_entry=entry, g_graph=graph}, facts) diff --git a/compiler/cmm/CmmCPS.hs b/compiler/cmm/CmmCPS.hs index 372562c..b9f6db3 100644 --- a/compiler/cmm/CmmCPS.hs +++ b/compiler/cmm/CmmCPS.hs @@ -71,10 +71,10 @@ cpsTop _ p@(CmmData {}) = return ([], [(Map.empty, p)]) cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}}) l g) = do -- Why bother doing it this early? - -- g <- dual_rewrite Opt_D_dump_cmmz "spills and reloads" + -- g <- dual_rewrite run Opt_D_dump_cmmz "spills and reloads" -- (dualLivenessWithInsertion callPPs) g -- g <- run $ insertLateReloads g -- Duplicate reloads just before uses - -- g <- dual_rewrite Opt_D_dump_cmmz "Dead Assignment Elimination" + -- g <- dual_rewrite runOptimization Opt_D_dump_cmmz "Dead Assignment Elimination" -- (removeDeadAssignmentsAndReloads callPPs) g dump Opt_D_dump_cmmz "Pre common block elimination" g g <- return $ elimCommonBlocks g @@ -91,16 +91,16 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}}) ----------- Spills and reloads ------------------- g <- -- pprTrace "pre Spills" (ppr g) $ - dual_rewrite Opt_D_dump_cmmz "spills and reloads" + dual_rewrite run Opt_D_dump_cmmz "spills and reloads" (dualLivenessWithInsertion procPoints) g -- Insert spills at defns; reloads at return points g <- -- pprTrace "pre insertLateReloads" (ppr g) $ - run $ insertLateReloads g -- Duplicate reloads just before uses + runOptimization $ insertLateReloads g -- Duplicate reloads just before uses dump Opt_D_dump_cmmz "Post late reloads" g g <- -- pprTrace "post insertLateReloads" (ppr g) $ - dual_rewrite Opt_D_dump_cmmz "Dead Assignment Elimination" + dual_rewrite runOptimization Opt_D_dump_cmmz "Dead Assignment Elimination" (removeDeadAssignmentsAndReloads procPoints) g -- Remove redundant reloads (and any other redundant asst) @@ -146,12 +146,16 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}}) where dflags = hsc_dflags hsc_env mbpprTrace x y z = if dopt Opt_D_dump_cmmz dflags then pprTrace x y z else z dump f txt g = dumpIfSet_dyn dflags f txt (ppr g) - - run = runFuelIO (hsc_OptFuel hsc_env) - - dual_rewrite flag txt pass g = + -- Runs a required transformation/analysis + run = runInfiniteFuelIO (hsc_OptFuel hsc_env) + -- Runs an optional transformation/analysis (and should + -- thus be subject to optimization fuel) + runOptimization = runFuelIO (hsc_OptFuel hsc_env) + + -- pass 'run' or 'runOptimization' for 'r' + dual_rewrite r flag txt pass g = do dump flag ("Pre " ++ txt) g - g <- run $ pass g + g <- r $ pass g dump flag ("Post " ++ txt) $ g return g diff --git a/compiler/cmm/CmmExpr.hs b/compiler/cmm/CmmExpr.hs index 3ae2996..55a5b73 100644 --- a/compiler/cmm/CmmExpr.hs +++ b/compiler/cmm/CmmExpr.hs @@ -42,8 +42,8 @@ data CmmExpr | CmmRegOff CmmReg Int -- CmmRegOff reg i -- ** is shorthand only, meaning ** - -- CmmMachOp (MO_S_Add rep (CmmReg reg) (CmmLit (CmmInt i rep))) - -- where rep = cmmRegType reg + -- CmmMachOp (MO_Add rep) [x, CmmLit (CmmInt (fromIntegral i) rep)] + -- where rep = typeWidth (cmmRegType reg) instance Eq CmmExpr where -- Equality ignores the types CmmLit l1 == CmmLit l2 = l1==l2 @@ -124,6 +124,8 @@ cmmExprType (CmmReg reg) = cmmRegType reg cmmExprType (CmmMachOp op args) = machOpResultType op (map cmmExprType args) cmmExprType (CmmRegOff reg _) = cmmRegType reg cmmExprType (CmmStackSlot _ _) = bWord -- an address +-- Careful though: what is stored at the stack slot may be bigger than +-- an address cmmLitType :: CmmLit -> CmmType cmmLitType (CmmInt _ width) = cmmBits width diff --git a/compiler/cmm/CmmLint.hs b/compiler/cmm/CmmLint.hs index 95b1eef..c14ad65 100644 --- a/compiler/cmm/CmmLint.hs +++ b/compiler/cmm/CmmLint.hs @@ -24,7 +24,6 @@ import OldPprCmm() import Constants import FastString -import Control.Monad import Data.Maybe -- ----------------------------------------------------------------------------- @@ -70,8 +69,10 @@ lintCmmBlock labels (BasicBlock id stmts) lintCmmExpr :: CmmExpr -> CmmLint CmmType lintCmmExpr (CmmLoad expr rep) = do _ <- lintCmmExpr expr - when (widthInBytes (typeWidth rep) >= wORD_SIZE) $ - cmmCheckWordAddress expr + -- Disabled, if we have the inlining phase before the lint phase, + -- we can have funny offsets due to pointer tagging. -- EZY + -- when (widthInBytes (typeWidth rep) >= wORD_SIZE) $ + -- cmmCheckWordAddress expr return rep lintCmmExpr expr@(CmmMachOp op args) = do tys <- mapM lintCmmExpr args @@ -99,14 +100,14 @@ isOffsetOp _ = False -- This expression should be an address from which a word can be loaded: -- check for funny-looking sub-word offsets. -cmmCheckWordAddress :: CmmExpr -> CmmLint () -cmmCheckWordAddress e@(CmmMachOp op [arg, CmmLit (CmmInt i _)]) +_cmmCheckWordAddress :: CmmExpr -> CmmLint () +_cmmCheckWordAddress e@(CmmMachOp op [arg, CmmLit (CmmInt i _)]) | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral wORD_SIZE /= 0 = cmmLintDubiousWordOffset e -cmmCheckWordAddress e@(CmmMachOp op [CmmLit (CmmInt i _), arg]) +_cmmCheckWordAddress e@(CmmMachOp op [CmmLit (CmmInt i _), arg]) | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral wORD_SIZE /= 0 = cmmLintDubiousWordOffset e -cmmCheckWordAddress _ +_cmmCheckWordAddress _ = return () -- No warnings for unaligned arithmetic with the node register, diff --git a/compiler/cmm/CmmLive.hs b/compiler/cmm/CmmLive.hs index 78867b0..c87a3a9 100644 --- a/compiler/cmm/CmmLive.hs +++ b/compiler/cmm/CmmLive.hs @@ -63,12 +63,12 @@ gen a live = foldRegsUsed extendRegSet live a kill :: DefinerOfLocalRegs a => a -> RegSet -> RegSet kill a live = foldRegsDefd delOneFromUniqSet live a +-- Testing! xferLive :: BwdTransfer CmmNode CmmLive xferLive = mkBTransfer3 fst mid lst where fst _ f = f mid :: CmmNode O O -> CmmLive -> CmmLive - mid n f = gen_kill n $ case n of CmmUnsafeForeignCall {} -> emptyRegSet - _ -> f + mid n f = gen_kill n f lst :: CmmNode O C -> FactBase CmmLive -> CmmLive lst n f = gen_kill n $ case n of CmmCall {} -> emptyRegSet CmmForeignCall {} -> emptyRegSet diff --git a/compiler/cmm/CmmNode.hs b/compiler/cmm/CmmNode.hs index 93564ac..e67321c 100644 --- a/compiler/cmm/CmmNode.hs +++ b/compiler/cmm/CmmNode.hs @@ -92,6 +92,8 @@ data CmmNode e x where A MidForeign call is used for *unsafe* foreign calls; a LastForeign call is used for *safe* foreign calls. Unsafe ones are easy: think of them as a "fat machine instruction". +In particular, they do *not* kill all live registers (there was a bit +of code in GHC that conservatively assumed otherwise.) Safe ones are trickier. A safe foreign call r = f(x) diff --git a/compiler/cmm/CmmOpt.hs b/compiler/cmm/CmmOpt.hs index df0555f..c71f188 100644 --- a/compiler/cmm/CmmOpt.hs +++ b/compiler/cmm/CmmOpt.hs @@ -115,12 +115,15 @@ cmmMiniInlineStmts uses (stmt@(CmmAssign (CmmLocal (LocalReg u _)) expr) : stmts cmmMiniInlineStmts uses (stmt:stmts) = stmt : cmmMiniInlineStmts uses stmts -lookForInline u expr (stmt : rest) +lookForInline u expr stmts = lookForInline' u expr regset stmts + where regset = foldRegsUsed extendRegSet emptyRegSet expr + +lookForInline' u expr regset (stmt : rest) | Just 1 <- lookupUFM (countUses stmt) u, ok_to_inline = Just (inlineStmt u expr stmt : rest) | ok_to_skip - = case lookForInline u expr rest of + = case lookForInline' u expr regset rest of Nothing -> Nothing Just stmts -> Just (stmt:stmts) @@ -137,12 +140,18 @@ lookForInline u expr (stmt : rest) CmmCall{} -> hasNoGlobalRegs expr _ -> True - -- We can skip over assignments to other tempoararies, because we - -- know that expressions aren't side-effecting and temporaries are - -- single-assignment. + -- Expressions aren't side-effecting. Temporaries may or may not + -- be single-assignment depending on the source (the old code + -- generator creates single-assignment code, but hand-written Cmm + -- and Cmm from the new code generator is not single-assignment.) + -- So we do an extra check to make sure that the register being + -- changed is not one we were relying on. I don't know how much of a + -- performance hit this is (we have to create a regset for every + -- instruction.) -- EZY ok_to_skip = case stmt of CmmNop -> True - CmmAssign (CmmLocal (LocalReg u' _)) rhs | u' /= u -> True + CmmComment{} -> True + CmmAssign (CmmLocal r@(LocalReg u' _)) rhs | u' /= u && not (r `elemRegSet` regset) -> True CmmAssign g@(CmmGlobal _) rhs -> not (g `regUsedIn` expr) _other -> False diff --git a/compiler/cmm/CmmSpillReload.hs b/compiler/cmm/CmmSpillReload.hs index 4e2dd38..17364ad 100644 --- a/compiler/cmm/CmmSpillReload.hs +++ b/compiler/cmm/CmmSpillReload.hs @@ -100,11 +100,11 @@ dualLiveTransfers entry procPoints = mkBTransfer3 first middle last where check live id x = if id == entry then noLiveOnEntry id (in_regs live) x else x middle :: CmmNode O O -> DualLive -> DualLive - middle m live = changeStack updSlots $ changeRegs (xferLiveMiddle m) (changeRegs regs_in live) - where xferLiveMiddle = case getBTransfer3 xferLive of (_, middle, _) -> middle - regs_in :: RegSet -> RegSet - regs_in live = case m of CmmUnsafeForeignCall {} -> emptyRegSet - _ -> live + middle m = changeStack updSlots + . changeRegs updRegs + where -- Reuse middle of liveness analysis from CmmLive + updRegs = case getBTransfer3 xferLive of (_, middle, _) -> middle m + updSlots live = foldSlotsUsed reload (foldSlotsDefd spill live m) m spill live s@(RegSlot r, _, _) = check s $ deleteFromRegSet live r spill live _ = live diff --git a/compiler/cmm/MkGraph.hs b/compiler/cmm/MkGraph.hs index 69b481b..c9e422f 100644 --- a/compiler/cmm/MkGraph.hs +++ b/compiler/cmm/MkGraph.hs @@ -24,7 +24,7 @@ module MkGraph , copyInOflow, copyInSlot, copyOutOflow, copyOutSlot -- Reexport of needed Cmm stuff , Convention(..), ForeignConvention(..), ForeignTarget(..) - , CmmStackInfo(..), CmmTopInfo(..), CmmGraph(..) + , CmmStackInfo(..), CmmTopInfo(..), CmmGraph, GenCmmGraph(..) , Cmm, CmmTop ) where diff --git a/compiler/cmm/OptimizationFuel.hs b/compiler/cmm/OptimizationFuel.hs index 057a965..f624c1c 100644 --- a/compiler/cmm/OptimizationFuel.hs +++ b/compiler/cmm/OptimizationFuel.hs @@ -6,12 +6,12 @@ -- the optimiser with varying amount of fuel to find out the exact number of -- steps where a bug is introduced in the output. module OptimizationFuel - ( OptimizationFuel, amountOfFuel, tankFilledTo, anyFuelLeft, oneLessFuel + ( OptimizationFuel, amountOfFuel, tankFilledTo, unlimitedFuel, anyFuelLeft, oneLessFuel , OptFuelState, initOptFuelState , FuelConsumer, FuelUsingMonad, FuelState , fuelGet, fuelSet, lastFuelPass, setFuelPass , fuelExhausted, fuelDec1, tryWithFuel - , runFuelIO, fuelConsumingPass + , runFuelIO, runInfiniteFuelIO, fuelConsumingPass , FuelUniqSM , liftUniq ) @@ -21,9 +21,7 @@ import Data.IORef import Control.Monad import StaticFlags (opt_Fuel) import UniqSupply -#ifdef DEBUG import Panic -#endif import Compiler.Hoopl import Compiler.Hoopl.GHC (getFuel, setFuel) @@ -51,8 +49,8 @@ amountOfFuel :: OptimizationFuel -> Int anyFuelLeft :: OptimizationFuel -> Bool oneLessFuel :: OptimizationFuel -> OptimizationFuel +unlimitedFuel :: OptimizationFuel -#ifdef DEBUG newtype OptimizationFuel = OptimizationFuel Int deriving Show @@ -61,16 +59,7 @@ amountOfFuel (OptimizationFuel f) = f anyFuelLeft (OptimizationFuel f) = f > 0 oneLessFuel (OptimizationFuel f) = ASSERT (f > 0) (OptimizationFuel (f - 1)) -#else --- type OptimizationFuel = State# () -- would like this, but it won't work -data OptimizationFuel = OptimizationFuel - deriving Show -tankFilledTo _ = OptimizationFuel -amountOfFuel _ = maxBound - -anyFuelLeft _ = True -oneLessFuel _ = OptimizationFuel -#endif +unlimitedFuel = OptimizationFuel infiniteFuel data FuelState = FuelState { fs_fuel :: OptimizationFuel, fs_lastpass :: String } newtype FuelUniqSM a = FUSM { unFUSM :: FuelState -> UniqSM (a, FuelState) } @@ -92,6 +81,16 @@ runFuelIO fs (FUSM f) = writeIORef (fuel_ref fs) fuel' return a +-- ToDo: Do we need the pass_ref when we are doing infinite fueld +-- transformations? +runInfiniteFuelIO :: OptFuelState -> FuelUniqSM a -> IO a +runInfiniteFuelIO fs (FUSM f) = + do pass <- readIORef (pass_ref fs) + u <- mkSplitUniqSupply 'u' + let (a, FuelState _ pass') = initUs_ u $ f (FuelState unlimitedFuel pass) + writeIORef (pass_ref fs) pass' + return a + instance Monad FuelUniqSM where FUSM f >>= k = FUSM (\s -> f s >>= \(a, s') -> unFUSM (k a) s') return a = FUSM (\s -> return (a, s)) diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs index 10c9f18..10f4e8b 100644 --- a/compiler/cmm/PprC.hs +++ b/compiler/cmm/PprC.hs @@ -50,6 +50,7 @@ import Outputable import Constants import BasicTypes import CLabel +import Util -- The rest import Data.List @@ -104,18 +105,19 @@ pprTop (CmmProc info clbl (ListGraph blocks)) = then pprDataExterns info $$ pprWordArray (entryLblToInfoLbl clbl) info else empty) $$ - (case blocks of - [] -> empty - -- the first block doesn't get a label: - (BasicBlock _ stmts : rest) -> vcat [ + (vcat [ blankLine, extern_decls, (if (externallyVisibleCLabel clbl) then mkFN_ else mkIF_) (pprCLabel clbl) <+> lbrace, nest 8 temp_decls, nest 8 mkFB_, - nest 8 (vcat (map pprStmt stmts)) $$ - vcat (map pprBBlock rest), + case blocks of + [] -> empty + -- the first block doesn't get a label: + (BasicBlock _ stmts : rest) -> + nest 8 (vcat (map pprStmt stmts)) $$ + vcat (map pprBBlock rest), nest 8 mkFE_, rbrace ] ) @@ -1022,18 +1024,6 @@ machRep_S_CType _ = panic "machRep_S_CType" pprStringInCStyle :: [Word8] -> SDoc pprStringInCStyle s = doubleQuotes (text (concatMap charToC s)) -charToC :: Word8 -> String -charToC w = - case chr (fromIntegral w) of - '\"' -> "\\\"" - '\'' -> "\\\'" - '\\' -> "\\\\" - c | c >= ' ' && c <= '~' -> [c] - | otherwise -> ['\\', - chr (ord '0' + ord c `div` 64), - chr (ord '0' + ord c `div` 8 `mod` 8), - chr (ord '0' + ord c `mod` 8)] - -- --------------------------------------------------------------------------- -- Initialising static objects with floating-point numbers. We can't -- just emit the floating point number, because C will cast it to an int diff --git a/compiler/codeGen/CgClosure.lhs b/compiler/codeGen/CgClosure.lhs index da44122..d158bf7 100644 --- a/compiler/codeGen/CgClosure.lhs +++ b/compiler/codeGen/CgClosure.lhs @@ -250,7 +250,6 @@ closureCodeBody _binder_info cl_info cc [{- No args i.e. thunk -}] body = do -- in update frame CAF/DICT functions will be -- subsumed by this enclosing cc { enterCostCentre cl_info cc body - ; stmtsC [CmmComment $ mkFastString $ showSDoc $ ppr body] ; cgExpr body } } diff --git a/compiler/codeGen/CgHpc.hs b/compiler/codeGen/CgHpc.hs index 8da2715..4875650 100644 --- a/compiler/codeGen/CgHpc.hs +++ b/compiler/codeGen/CgHpc.hs @@ -6,24 +6,14 @@ -- ----------------------------------------------------------------------------- -module CgHpc (cgTickBox, initHpc, hpcTable) where +module CgHpc (cgTickBox, hpcTable) where import OldCmm import CLabel import Module import OldCmmUtils -import CgUtils import CgMonad -import CgForeignCall -import ForeignCall -import ClosureInfo -import FastString import HscTypes -import Panic -import BasicTypes - -import Data.Char -import Data.Word cgTickBox :: Module -> Int -> Code cgTickBox mod n = do @@ -40,47 +30,10 @@ cgTickBox mod n = do hpcTable :: Module -> HpcInfo -> Code hpcTable this_mod (HpcInfo hpc_tickCount _) = do - emitData ReadOnlyData - [ CmmDataLabel mkHpcModuleNameLabel - , CmmString $ map (fromIntegral . ord) - (full_name_str) - ++ [0] - ] emitData Data $ [ CmmDataLabel (mkHpcTicksLabel this_mod) ] ++ [ CmmStaticLit (CmmInt 0 W64) | _ <- take hpc_tickCount [0::Int ..] ] - where - module_name_str = moduleNameString (Module.moduleName this_mod) - full_name_str = if modulePackageId this_mod == mainPackageId - then module_name_str - else packageIdString (modulePackageId this_mod) ++ "/" ++ - module_name_str hpcTable _ (NoHpcInfo {}) = error "TODO: impossible" - -initHpc :: Module -> HpcInfo -> Code -initHpc this_mod (HpcInfo tickCount hashNo) - = do { id <- newTemp bWord - ; emitForeignCall' - PlayRisky - [CmmHinted id NoHint] - (CmmCallee - (CmmLit $ CmmLabel $ mkForeignLabel mod_alloc Nothing ForeignLabelInThisPackage IsFunction) - CCallConv - ) - [ CmmHinted (mkLblExpr mkHpcModuleNameLabel) AddrHint - , CmmHinted (word32 tickCount) NoHint - , CmmHinted (word32 hashNo) NoHint - , CmmHinted (CmmLit $ CmmLabel $ mkHpcTicksLabel $ this_mod) AddrHint - ] - (Just []) - NoC_SRT -- No SRT b/c we PlayRisky - CmmMayReturn - } - where - word32 i = CmmLit (CmmInt (fromIntegral (fromIntegral i :: Word32)) W32) - mod_alloc = mkFastString "hs_hpc_module" -initHpc _ (NoHpcInfo {}) = panic "initHpc: NoHpcInfo" - diff --git a/compiler/codeGen/CgProf.hs b/compiler/codeGen/CgProf.hs index 0cf209e..243aa1d 100644 --- a/compiler/codeGen/CgProf.hs +++ b/compiler/codeGen/CgProf.hs @@ -16,8 +16,7 @@ module CgProf ( costCentreFrom, curCCS, curCCSAddr, emitCostCentreDecl, emitCostCentreStackDecl, - emitRegisterCC, emitRegisterCCS, - emitSetCCC, emitCCS, + emitSetCCC, emitCCS, -- Lag/drag/void stuff ldvEnter, ldvEnterClosure, ldvRecordCreate @@ -348,56 +347,6 @@ sizeof_ccs_words (ws,ms) = SIZEOF_CostCentreStack `divMod` wORD_SIZE -- --------------------------------------------------------------------------- --- Registering CCs and CCSs - --- (cc)->link = CC_LIST; --- CC_LIST = (cc); --- (cc)->ccID = CC_ID++; - -emitRegisterCC :: CostCentre -> Code -emitRegisterCC cc = do - { tmp <- newTemp cInt - ; stmtsC [ - CmmStore (cmmOffsetB cc_lit oFFSET_CostCentre_link) - (CmmLoad cC_LIST bWord), - CmmStore cC_LIST cc_lit, - CmmAssign (CmmLocal tmp) (CmmLoad cC_ID cInt), - CmmStore (cmmOffsetB cc_lit oFFSET_CostCentre_ccID) (CmmReg (CmmLocal tmp)), - CmmStore cC_ID (cmmRegOffB (CmmLocal tmp) 1) - ] - } - where - cc_lit = CmmLit (CmmLabel (mkCCLabel cc)) - --- (ccs)->prevStack = CCS_LIST; --- CCS_LIST = (ccs); --- (ccs)->ccsID = CCS_ID++; - -emitRegisterCCS :: CostCentreStack -> Code -emitRegisterCCS ccs = do - { tmp <- newTemp cInt - ; stmtsC [ - CmmStore (cmmOffsetB ccs_lit oFFSET_CostCentreStack_prevStack) - (CmmLoad cCS_LIST bWord), - CmmStore cCS_LIST ccs_lit, - CmmAssign (CmmLocal tmp) (CmmLoad cCS_ID cInt), - CmmStore (cmmOffsetB ccs_lit oFFSET_CostCentreStack_ccsID) (CmmReg (CmmLocal tmp)), - CmmStore cCS_ID (cmmRegOffB (CmmLocal tmp) 1) - ] - } - where - ccs_lit = CmmLit (CmmLabel (mkCCSLabel ccs)) - - -cC_LIST, cC_ID :: CmmExpr -cC_LIST = CmmLit (CmmLabel (mkCmmDataLabel rtsPackageId (fsLit "CC_LIST"))) -cC_ID = CmmLit (CmmLabel (mkCmmDataLabel rtsPackageId (fsLit "CC_ID"))) - -cCS_LIST, cCS_ID :: CmmExpr -cCS_LIST = CmmLit (CmmLabel (mkCmmDataLabel rtsPackageId (fsLit "CCS_LIST"))) -cCS_ID = CmmLit (CmmLabel (mkCmmDataLabel rtsPackageId (fsLit "CCS_ID"))) - --- --------------------------------------------------------------------------- -- Set the current cost centre stack emitSetCCC :: CostCentre -> Code diff --git a/compiler/codeGen/CodeGen.lhs b/compiler/codeGen/CodeGen.lhs index 6ce8fca..7a7bf48 100644 --- a/compiler/codeGen/CodeGen.lhs +++ b/compiler/codeGen/CodeGen.lhs @@ -29,7 +29,6 @@ import CgHpc import CLabel import OldCmm -import OldCmmUtils import OldPprCmm import StgSyn @@ -51,8 +50,7 @@ import Panic codeGen :: DynFlags -> Module -> [TyCon] - -> [Module] -- directly-imported modules - -> CollectedCCs -- (Local/global) cost-centres needing declaring/registering. + -> CollectedCCs -- (Local/global) cost-centres needing declaring/registering. -> [(StgBinding,[(Id,[Id])])] -- Bindings to convert, with SRTs -> HpcInfo -> IO [Cmm] -- Output @@ -61,8 +59,7 @@ codeGen :: DynFlags -- possible for object splitting to split up the -- pieces later. -codeGen dflags this_mod data_tycons imported_mods - cost_centre_info stg_binds hpc_info +codeGen dflags this_mod data_tycons cost_centre_info stg_binds hpc_info = do { showPass dflags "CodeGen" @@ -73,167 +70,46 @@ codeGen dflags this_mod data_tycons imported_mods { cmm_binds <- mapM (getCmm . cgTopBinding dflags) stg_binds ; cmm_tycons <- mapM cgTyCon data_tycons ; cmm_init <- getCmm (mkModuleInit dflags cost_centre_info - this_mod imported_mods hpc_info) - ; return (cmm_binds ++ concat cmm_tycons ++ [cmm_init]) + this_mod hpc_info) + ; return (cmm_init : cmm_binds ++ concat cmm_tycons) } -- Put datatype_stuff after code_stuff, because the -- datatype closure table (for enumeration types) to -- (say) PrelBase_True_closure, which is defined in -- code_stuff + -- Note [codegen-split-init] the cmm_init block must + -- come FIRST. This is because when -split-objs is on + -- we need to combine this block with its + -- initialisation routines; see Note + -- [pipeline-split-init]. + ; dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (pprCmms code_stuff) ; return code_stuff } -\end{code} - -%************************************************************************ -%* * -\subsection[codegen-init]{Module initialisation code} -%* * -%************************************************************************ - -/* ----------------------------------------------------------------------------- - Module initialisation - - The module initialisation code looks like this, roughly: - - FN(__stginit_Foo) { - JMP_(__stginit_Foo_1_p) - } - - FN(__stginit_Foo_1_p) { - ... - } - - We have one version of the init code with a module version and the - 'way' attached to it. The version number helps to catch cases - where modules are not compiled in dependency order before being - linked: if a module has been compiled since any modules which depend on - it, then the latter modules will refer to a different version in their - init blocks and a link error will ensue. - - The 'way' suffix helps to catch cases where modules compiled in different - ways are linked together (eg. profiled and non-profiled). - - We provide a plain, unadorned, version of the module init code - which just jumps to the version with the label and way attached. The - reason for this is that when using foreign exports, the caller of - startupHaskell() must supply the name of the init function for the "top" - module in the program, and we don't want to require that this name - has the version and way info appended to it. - -------------------------------------------------------------------------- */ - -We initialise the module tree by keeping a work-stack, - * pointed to by Sp - * that grows downward - * Sp points to the last occupied slot - -\begin{code} -mkModuleInit +mkModuleInit :: DynFlags -> CollectedCCs -- cost centre info -> Module - -> [Module] - -> HpcInfo + -> HpcInfo -> Code -mkModuleInit dflags cost_centre_info this_mod imported_mods hpc_info - = do { -- Allocate the static boolean that records if this - -- module has been registered already - emitData Data [CmmDataLabel moduleRegdLabel, - CmmStaticLit zeroCLit] +mkModuleInit dflags cost_centre_info this_mod hpc_info + = do { -- Allocate the static boolean that records if this ; whenC (opt_Hpc) $ hpcTable this_mod hpc_info - -- we emit a recursive descent module search for all modules - -- and *choose* to chase it in :Main, below. - -- In this way, Hpc enabled modules can interact seamlessly with - -- not Hpc enabled moduled, provided Main is compiled with Hpc. - - ; emitSimpleProc real_init_lbl $ do - { ret_blk <- forkLabelledCode ret_code - - ; init_blk <- forkLabelledCode $ do - { mod_init_code; stmtC (CmmBranch ret_blk) } - - ; stmtC (CmmCondBranch (cmmNeWord (CmmLit zeroCLit) mod_reg_val) - ret_blk) - ; stmtC (CmmBranch init_blk) - } - - -- Make the "plain" procedure jump to the "real" init procedure - ; emitSimpleProc plain_init_lbl jump_to_init - - -- When compiling the module in which the 'main' function lives, - -- (that is, this_mod == main_mod) - -- we inject an extra stg_init procedure for stg_init_ZCMain, for the - -- RTS to invoke. We must consult the -main-is flag in case the - -- user specified a different function to Main.main - - -- Notice that the recursive descent is optional, depending on what options - -- are enabled. - - ; whenC (this_mod == main_mod) - (emitSimpleProc plain_main_init_lbl rec_descent_init) - } - where - -- The way string we attach to the __stginit label to catch - -- accidental linking of modules compiled in different ways. We - -- omit "dyn" from this way, because we want to be able to load - -- both dynamic and non-dynamic modules into a dynamic GHC. - way = mkBuildTag (filter want_way (ways dflags)) - want_way w = not (wayRTSOnly w) && wayName w /= WayDyn - - main_mod = mainModIs dflags - - plain_init_lbl = mkPlainModuleInitLabel this_mod - real_init_lbl = mkModuleInitLabel this_mod way - plain_main_init_lbl = mkPlainModuleInitLabel rOOT_MAIN - - jump_to_init = stmtC (CmmJump (mkLblExpr real_init_lbl) []) - - mod_reg_val = CmmLoad (mkLblExpr moduleRegdLabel) bWord - - -- Main refers to GHC.TopHandler.runIO, so make sure we call the - -- init function for GHC.TopHandler. - extra_imported_mods - | this_mod == main_mod = [gHC_TOP_HANDLER] - | otherwise = [] - - mod_init_code = do - { -- Set mod_reg to 1 to record that we've been here - stmtC (CmmStore (mkLblExpr moduleRegdLabel) (CmmLit (mkIntCLit 1))) - ; whenC (opt_SccProfilingOn) $ do initCostCentres cost_centre_info - ; whenC (opt_Hpc) $ - initHpc this_mod hpc_info - - ; mapCs (registerModuleImport way) - (imported_mods++extra_imported_mods) - - } - - -- The return-code pops the work stack by - -- incrementing Sp, and then jumpd to the popped item - ret_code = stmtsC [ CmmAssign spReg (cmmRegOffW spReg 1) - , CmmJump (CmmLoad (cmmRegOffW spReg (-1)) bWord) [] ] - - - rec_descent_init = if opt_SccProfilingOn || isHpcUsed hpc_info - then jump_to_init - else ret_code - ------------------------ -registerModuleImport :: String -> Module -> Code -registerModuleImport way mod - | mod == gHC_PRIM - = nopC - | otherwise -- Push the init procedure onto the work stack - = stmtsC [ CmmAssign spReg (cmmRegOffW spReg (-1)) - , CmmStore (CmmReg spReg) (mkLblExpr (mkModuleInitLabel mod way)) ] + -- For backwards compatibility: user code may refer to this + -- label for calling hs_add_root(). + ; emitData Data $ [ CmmDataLabel (mkPlainModuleInitLabel this_mod) ] + + ; whenC (this_mod == mainModIs dflags) $ + emitSimpleProc (mkPlainModuleInitLabel rOOT_MAIN) $ return () + } \end{code} @@ -252,9 +128,7 @@ initCostCentres (local_CCs, ___extern_CCs, singleton_CCSs) | otherwise = do { mapM_ emitCostCentreDecl local_CCs ; mapM_ emitCostCentreStackDecl singleton_CCSs - ; mapM_ emitRegisterCC local_CCs - ; mapM_ emitRegisterCCS singleton_CCSs - } + } \end{code} %************************************************************************ diff --git a/compiler/codeGen/StgCmm.hs b/compiler/codeGen/StgCmm.hs index 26ace07..2bfe187 100644 --- a/compiler/codeGen/StgCmm.hs +++ b/compiler/codeGen/StgCmm.hs @@ -24,16 +24,13 @@ import StgCmmHpc import StgCmmTicky import MkGraph -import CmmDecl import CmmExpr -import CmmUtils +import CmmDecl import CLabel import PprCmm import StgSyn -import PrelNames import DynFlags -import StaticFlags import HscTypes import CostCentre @@ -50,17 +47,14 @@ import Outputable codeGen :: DynFlags -> Module -> [TyCon] - -> [Module] -- Directly-imported modules - -> CollectedCCs -- (Local/global) cost-centres needing declaring/registering. + -> CollectedCCs -- (Local/global) cost-centres needing declaring/registering. -> [(StgBinding,[(Id,[Id])])] -- Bindings to convert, with SRTs -> HpcInfo -> IO [Cmm] -- Output -codeGen dflags this_mod data_tycons imported_mods +codeGen dflags this_mod data_tycons cost_centre_info stg_binds hpc_info = do { showPass dflags "New CodeGen" - ; let way = buildTag dflags - main_mod = mainModIs dflags -- Why? -- ; mapM_ (\x -> seq x (return ())) data_tycons @@ -68,10 +62,9 @@ codeGen dflags this_mod data_tycons imported_mods ; code_stuff <- initC dflags this_mod $ do { cmm_binds <- mapM (getCmm . cgTopBinding dflags) stg_binds ; cmm_tycons <- mapM cgTyCon data_tycons - ; cmm_init <- getCmm (mkModuleInit way cost_centre_info - this_mod main_mod - imported_mods hpc_info) - ; return (cmm_binds ++ concat cmm_tycons ++ [cmm_init]) + ; cmm_init <- getCmm (mkModuleInit cost_centre_info + this_mod hpc_info) + ; return (cmm_init : cmm_binds ++ concat cmm_tycons) } -- Put datatype_stuff after code_stuff, because the -- datatype closure table (for enumeration types) to @@ -82,6 +75,12 @@ codeGen dflags this_mod data_tycons imported_mods -- possible for object splitting to split up the -- pieces later. + -- Note [codegen-split-init] the cmm_init block must + -- come FIRST. This is because when -split-objs is on + -- we need to combine this block with its + -- initialisation routines; see Note + -- [pipeline-split-init]. + ; dumpIfSet_dyn dflags Opt_D_dump_cmmz "New Cmm" (pprCmms code_stuff) ; return code_stuff } @@ -173,89 +172,18 @@ We initialise the module tree by keeping a work-stack, -} mkModuleInit - :: String -- the "way" - -> CollectedCCs -- cost centre info + :: CollectedCCs -- cost centre info -> Module - -> Module -- name of the Main module - -> [Module] - -> HpcInfo + -> HpcInfo -> FCode () -mkModuleInit way cost_centre_info this_mod main_mod imported_mods hpc_info - = do { -- Allocate the static boolean that records if this - -- module has been registered already - emitData Data [CmmDataLabel moduleRegdLabel, - CmmStaticLit zeroCLit] - - ; init_hpc <- initHpc this_mod hpc_info - ; init_prof <- initCostCentres cost_centre_info - - -- We emit a recursive descent module search for all modules - -- and *choose* to chase it in :Main, below. - -- In this way, Hpc enabled modules can interact seamlessly with - -- not Hpc enabled moduled, provided Main is compiled with Hpc. - - ; updfr_sz <- getUpdFrameOff - ; tail <- getCode (pushUpdateFrame imports - (do updfr_sz' <- getUpdFrameOff - emit $ mkReturn (ret_e updfr_sz') [] (pop_ret_loc updfr_sz'))) - ; emitSimpleProc real_init_lbl $ (withFreshLabel "ret_block" $ \retId -> catAGraphs - [ check_already_done retId updfr_sz - , init_prof - , init_hpc - , tail]) - -- Make the "plain" procedure jump to the "real" init procedure - ; emitSimpleProc plain_init_lbl (jump_to_init updfr_sz) - - -- When compiling the module in which the 'main' function lives, - -- (that is, this_mod == main_mod) - -- we inject an extra stg_init procedure for stg_init_ZCMain, for the - -- RTS to invoke. We must consult the -main-is flag in case the - -- user specified a different function to Main.main - - -- Notice that the recursive descent is optional, depending on what options - -- are enabled. - - - ; whenC (this_mod == main_mod) - (emitSimpleProc plain_main_init_lbl (rec_descent_init updfr_sz)) - } - where - plain_init_lbl = mkPlainModuleInitLabel this_mod - real_init_lbl = mkModuleInitLabel this_mod way - plain_main_init_lbl = mkPlainModuleInitLabel rOOT_MAIN - - jump_to_init updfr_sz = mkJump (mkLblExpr real_init_lbl) [] updfr_sz - - - -- Main refers to GHC.TopHandler.runIO, so make sure we call the - -- init function for GHC.TopHandler. - extra_imported_mods - | this_mod == main_mod = [gHC_TOP_HANDLER] - | otherwise = [] - all_imported_mods = imported_mods ++ extra_imported_mods - imports = map (\mod -> mkLblExpr (mkModuleInitLabel mod way)) - (filter (gHC_PRIM /=) all_imported_mods) - - mod_reg_val = CmmLoad (mkLblExpr moduleRegdLabel) bWord - check_already_done retId updfr_sz - = mkCmmIfThenElse (cmmNeWord (CmmLit zeroCLit) mod_reg_val) - (mkLabel retId <*> mkReturn (ret_e updfr_sz) [] (pop_ret_loc updfr_sz)) mkNop - <*> -- Set mod_reg to 1 to record that we've been here - mkStore (mkLblExpr moduleRegdLabel) (CmmLit (mkIntCLit 1)) - - -- The return-code pops the work stack by - -- incrementing Sp, and then jumps to the popped item - ret_e updfr_sz = CmmLoad (CmmStackSlot (CallArea Old) updfr_sz) gcWord - ret_code updfr_sz = mkJump (ret_e updfr_sz) [] (pop_ret_loc updfr_sz) - -- mkAssign spReg (cmmRegOffW spReg 1) <*> - -- mkJump (CmmLoad (cmmRegOffW spReg (-1)) bWord) [] updfr_sz - - pop_ret_loc updfr_sz = updfr_sz - widthInBytes (typeWidth bWord) - - rec_descent_init updfr_sz = - if opt_SccProfilingOn || isHpcUsed hpc_info - then jump_to_init updfr_sz - else ret_code updfr_sz + +mkModuleInit cost_centre_info this_mod hpc_info + = do { initHpc this_mod hpc_info + ; initCostCentres cost_centre_info + -- For backwards compatibility: user code may refer to this + -- label for calling hs_add_root(). + ; emitData Data $ [ CmmDataLabel (mkPlainModuleInitLabel this_mod) ] + } --------------------------------------------------------------- -- Generating static stuff for algebraic data types diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs index bfb749c..2947d33 100644 --- a/compiler/codeGen/StgCmmBind.hs +++ b/compiler/codeGen/StgCmmBind.hs @@ -301,7 +301,7 @@ mkRhsClosure bndr cc _ fvs upd_flag srt args body (map toVarArg fv_details) -- RETURN - ; return $ (regIdInfo bndr lf_info tmp, init) } + ; regIdInfo bndr lf_info tmp init } -- Use with care; if used inappropriately, it could break invariants. stripNV :: NonVoid a -> a @@ -336,7 +336,7 @@ cgStdThunk bndr cc _bndr_info body lf_info payload ; (tmp, init) <- allocDynClosure closure_info use_cc blame_cc payload_w_offsets -- RETURN - ; returnFC $ (regIdInfo bndr lf_info tmp, init) } + ; regIdInfo bndr lf_info tmp init } mkClosureLFInfo :: Id -- The binder -> TopLevelFlag -- True of top level diff --git a/compiler/codeGen/StgCmmClosure.hs b/compiler/codeGen/StgCmmClosure.hs index fe09f68..d617743 100644 --- a/compiler/codeGen/StgCmmClosure.hs +++ b/compiler/codeGen/StgCmmClosure.hs @@ -304,13 +304,15 @@ type DynTag = Int -- The tag on a *pointer* {- Note [Data constructor dynamic tags] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The family size of a data type (the number of constructors) -can be either: +The family size of a data type (the number of constructors +or the arity of a function) can be either: * small, if the family size < 2**tag_bits * big, otherwise. Small families can have the constructor tag in the tag bits. -Big families only use the tag value 1 to represent evaluatedness. -} +Big families only use the tag value 1 to represent evaluatedness. +We don't have very many tag bits: for example, we have 2 bits on +x86-32 and 3 bits on x86-64. -} isSmallFamily :: Int -> Bool isSmallFamily fam_size = fam_size <= mAX_PTR_TAG diff --git a/compiler/codeGen/StgCmmCon.hs b/compiler/codeGen/StgCmmCon.hs index 633d577..368bc53 100644 --- a/compiler/codeGen/StgCmmCon.hs +++ b/compiler/codeGen/StgCmmCon.hs @@ -193,7 +193,7 @@ buildDynCon binder ccs con args = do { let (cl_info, args_w_offsets) = layOutDynConstr con (addArgReps args) -- No void args in args_w_offsets ; (tmp, init) <- allocDynClosure cl_info use_cc blame_cc args_w_offsets - ; return (regIdInfo binder lf_info tmp, init) } + ; regIdInfo binder lf_info tmp init } where lf_info = mkConLFInfo con diff --git a/compiler/codeGen/StgCmmEnv.hs b/compiler/codeGen/StgCmmEnv.hs index 469f58d..369e199 100644 --- a/compiler/codeGen/StgCmmEnv.hs +++ b/compiler/codeGen/StgCmmEnv.hs @@ -37,6 +37,7 @@ import CLabel import BlockId import CmmExpr import CmmUtils +import MkGraph (CmmAGraph, mkAssign, (<*>)) import FastString import Id import VarEnv @@ -86,9 +87,16 @@ litIdInfo :: Id -> LambdaFormInfo -> CmmLit -> CgIdInfo litIdInfo id lf_info lit = --mkCgIdInfo id lf_info (CmmLit lit) mkCgIdInfo id lf_info (addDynTag (CmmLit lit) (lfDynTag lf_info)) -regIdInfo :: Id -> LambdaFormInfo -> LocalReg -> CgIdInfo -regIdInfo id lf_info reg = - mkCgIdInfo id lf_info (addDynTag (CmmReg (CmmLocal reg)) (lfDynTag lf_info)) +-- Because the register may be spilled to the stack in untagged form, we +-- modify the initialization code 'init' to immediately tag the +-- register, and store a plain register in the CgIdInfo. We allocate +-- a new register in order to keep single-assignment and help out the +-- inliner. -- EZY +regIdInfo :: Id -> LambdaFormInfo -> LocalReg -> CmmAGraph -> FCode (CgIdInfo, CmmAGraph) +regIdInfo id lf_info reg init = do + reg' <- newTemp (localRegType reg) + let init' = init <*> mkAssign (CmmLocal reg') (addDynTag (CmmReg (CmmLocal reg)) (lfDynTag lf_info)) + return (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg')), init') idInfoToAmode :: CgIdInfo -> CmmExpr -- Returns a CmmExpr for the *tagged* pointer diff --git a/compiler/codeGen/StgCmmHpc.hs b/compiler/codeGen/StgCmmHpc.hs index a93af34..fae3bef 100644 --- a/compiler/codeGen/StgCmmHpc.hs +++ b/compiler/codeGen/StgCmmHpc.hs @@ -8,9 +8,7 @@ module StgCmmHpc ( initHpc, mkTickBox ) where -import StgCmmUtils import StgCmmMonad -import StgCmmForeign import MkGraph import CmmDecl @@ -18,11 +16,8 @@ import CmmExpr import CLabel import Module import CmmUtils -import FastString import HscTypes -import Data.Char import StaticFlags -import BasicTypes mkTickBox :: Module -> Int -> CmmAGraph mkTickBox mod n @@ -35,41 +30,15 @@ mkTickBox mod n (CmmLit $ CmmLabel $ mkHpcTicksLabel $ mod) n -initHpc :: Module -> HpcInfo -> FCode CmmAGraph +initHpc :: Module -> HpcInfo -> FCode () -- Emit top-level tables for HPC and return code to initialise initHpc _ (NoHpcInfo {}) - = return mkNop -initHpc this_mod (HpcInfo tickCount hashNo) - = getCode $ whenC opt_Hpc $ - do { emitData ReadOnlyData - [ CmmDataLabel mkHpcModuleNameLabel - , CmmString $ map (fromIntegral . ord) - (full_name_str) - ++ [0] - ] - ; emitData Data $ [ CmmDataLabel (mkHpcTicksLabel this_mod) + = return () +initHpc this_mod (HpcInfo tickCount _hashNo) + = whenC opt_Hpc $ + do { emitData Data $ [ CmmDataLabel (mkHpcTicksLabel this_mod) ] ++ [ CmmStaticLit (CmmInt 0 W64) | _ <- take tickCount [0::Int ..] ] - - ; id <- newTemp bWord -- TODO FIXME NOW - ; emitCCall - [(id,NoHint)] - (CmmLit $ CmmLabel $ mkForeignLabel mod_alloc Nothing ForeignLabelInThisPackage IsFunction) - [ (mkLblExpr mkHpcModuleNameLabel,AddrHint) - , (CmmLit $ mkIntCLit tickCount,NoHint) - , (CmmLit $ mkIntCLit hashNo,NoHint) - , (CmmLit $ CmmLabel $ mkHpcTicksLabel $ this_mod,AddrHint) - ] } - where - mod_alloc = mkFastString "hs_hpc_module" - module_name_str = moduleNameString (Module.moduleName this_mod) - full_name_str = if modulePackageId this_mod == mainPackageId - then module_name_str - else packageIdString (modulePackageId this_mod) ++ "/" ++ - module_name_str - - - diff --git a/compiler/codeGen/StgCmmProf.hs b/compiler/codeGen/StgCmmProf.hs index 36d05ac..08bf529 100644 --- a/compiler/codeGen/StgCmmProf.hs +++ b/compiler/codeGen/StgCmmProf.hs @@ -348,14 +348,12 @@ ifProfilingL xs -- Initialising Cost Centres & CCSs --------------------------------------------------------------- -initCostCentres :: CollectedCCs -> FCode CmmAGraph --- Emit the declarations, and return code to register them +initCostCentres :: CollectedCCs -> FCode () +-- Emit the declarations initCostCentres (local_CCs, ___extern_CCs, singleton_CCSs) - = getCode $ whenC opt_SccProfilingOn $ + = whenC opt_SccProfilingOn $ do { mapM_ emitCostCentreDecl local_CCs - ; mapM_ emitCostCentreStackDecl singleton_CCSs - ; emit $ catAGraphs $ map mkRegisterCC local_CCs - ; emit $ catAGraphs $ map mkRegisterCCS singleton_CCSs } + ; mapM_ emitCostCentreStackDecl singleton_CCSs } emitCostCentreDecl :: CostCentre -> FCode () @@ -409,54 +407,6 @@ sizeof_ccs_words (ws,ms) = SIZEOF_CostCentreStack `divMod` wORD_SIZE -- --------------------------------------------------------------------------- --- Registering CCs and CCSs - --- (cc)->link = CC_LIST; --- CC_LIST = (cc); --- (cc)->ccID = CC_ID++; - -mkRegisterCC :: CostCentre -> CmmAGraph -mkRegisterCC cc - = withTemp cInt $ \tmp -> - catAGraphs [ - mkStore (cmmOffsetB cc_lit oFFSET_CostCentre_link) - (CmmLoad cC_LIST bWord), - mkStore cC_LIST cc_lit, - mkAssign (CmmLocal tmp) (CmmLoad cC_ID cInt), - mkStore (cmmOffsetB cc_lit oFFSET_CostCentre_ccID) (CmmReg (CmmLocal tmp)), - mkStore cC_ID (cmmRegOffB (CmmLocal tmp) 1) - ] - where - cc_lit = CmmLit (CmmLabel (mkCCLabel cc)) - --- (ccs)->prevStack = CCS_LIST; --- CCS_LIST = (ccs); --- (ccs)->ccsID = CCS_ID++; - -mkRegisterCCS :: CostCentreStack -> CmmAGraph -mkRegisterCCS ccs - = withTemp cInt $ \ tmp -> - catAGraphs [ - mkStore (cmmOffsetB ccs_lit oFFSET_CostCentreStack_prevStack) - (CmmLoad cCS_LIST bWord), - mkStore cCS_LIST ccs_lit, - mkAssign (CmmLocal tmp) (CmmLoad cCS_ID cInt), - mkStore (cmmOffsetB ccs_lit oFFSET_CostCentreStack_ccsID) (CmmReg (CmmLocal tmp)), - mkStore cCS_ID (cmmRegOffB (CmmLocal tmp) 1) - ] - where - ccs_lit = CmmLit (CmmLabel (mkCCSLabel ccs)) - - -cC_LIST, cC_ID :: CmmExpr -cC_LIST = CmmLit (CmmLabel (mkCmmDataLabel rtsPackageId (fsLit "CC_LIST"))) -cC_ID = CmmLit (CmmLabel (mkCmmDataLabel rtsPackageId (fsLit "CC_ID"))) - -cCS_LIST, cCS_ID :: CmmExpr -cCS_LIST = CmmLit (CmmLabel (mkCmmDataLabel rtsPackageId (fsLit "CCS_LIST"))) -cCS_ID = CmmLit (CmmLabel (mkCmmDataLabel rtsPackageId (fsLit "CCS_ID"))) - --- --------------------------------------------------------------------------- -- Set the current cost centre stack emitSetCCC :: CostCentre -> FCode () diff --git a/compiler/coreSyn/CorePrep.lhs b/compiler/coreSyn/CorePrep.lhs index 540fa2d..42379b4 100644 --- a/compiler/coreSyn/CorePrep.lhs +++ b/compiler/coreSyn/CorePrep.lhs @@ -18,6 +18,7 @@ import CoreFVs import CoreMonad ( endPass, CoreToDo(..) ) import CoreSyn import CoreSubst +import OccurAnal ( occurAnalyseExpr ) import Type import Coercion import TyCon @@ -248,6 +249,61 @@ always fully applied, and the bindings are just there to support partial applications. But it's easier to let them through. +Note [Dead code in CorePrep] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Imagine that we got an input program like this: + + f :: Show b => Int -> (Int, b -> Maybe Int -> Int) + f x = (g True (Just x) + g () (Just x), g) + where + g :: Show a => a -> Maybe Int -> Int + g _ Nothing = x + g y (Just z) = if z > 100 then g y (Just (z + length (show y))) else g y unknown + +After specialisation and SpecConstr, we would get something like this: + + f :: Show b => Int -> (Int, b -> Maybe Int -> Int) + f x = (g$Bool_True_Just x + g$Unit_Unit_Just x, g) + where + {-# RULES g $dBool = g$Bool + g $dUnit = g$Unit #-} + g = ... + {-# RULES forall x. g$Bool True (Just x) = g$Bool_True_Just x #-} + g$Bool = ... + {-# RULES forall x. g$Unit () (Just x) = g$Unit_Unit_Just x #-} + g$Unit = ... + g$Bool_True_Just = ... + g$Unit_Unit_Just = ... + +Note that the g$Bool and g$Unit functions are actually dead code: they are only kept +alive by the occurrence analyser because they are referred to by the rules of g, +which is being kept alive by the fact that it is used (unspecialised) in the returned pair. + +However, at the CorePrep stage there is no way that the rules for g will ever fire, +and it really seems like a shame to produce an output program that goes to the trouble +of allocating a closure for the unreachable g$Bool and g$Unit functions. + +The way we fix this is to: + * In cloneBndr, drop all unfoldings/rules + * In deFloatTop, run the occurrence analyser on each top-level RHS to drop + the dead local bindings + +The reason we don't just OccAnal the whole output of CorePrep is that the tidier +ensures that all top-level binders are GlobalIds, so they don't show up in the free +variables any longer. So if you run the occurrence analyser on the output of CoreTidy +(or later) you e.g. turn this program: + + Rec { + f = ... f ... + } + +Into this one: + + f = ... f ... + +(Since f is not considered to be free in its own RHS.) + + %************************************************************************ %* * The main code @@ -901,8 +957,12 @@ deFloatTop :: Floats -> [CoreBind] deFloatTop (Floats _ floats) = foldrOL get [] floats where - get (FloatLet b) bs = b:bs + get (FloatLet b) bs = occurAnalyseRHSs b : bs get b _ = pprPanic "corePrepPgm" (ppr b) + + -- See Note [Dead code in CorePrep] + occurAnalyseRHSs (NonRec x e) = NonRec x (occurAnalyseExpr e) + occurAnalyseRHSs (Rec xes) = Rec [(x, occurAnalyseExpr e) | (x, e) <- xes] ------------------------------------------- canFloatFromNoCaf :: Floats -> CpeRhs -> Maybe (Floats, CpeRhs) @@ -1012,7 +1072,13 @@ cloneBndr :: CorePrepEnv -> Var -> UniqSM (CorePrepEnv, Var) cloneBndr env bndr | isLocalId bndr = do bndr' <- setVarUnique bndr <$> getUniqueM - return (extendCorePrepEnv env bndr bndr', bndr') + + -- We are going to OccAnal soon, so drop (now-useless) rules/unfoldings + -- so that we can drop more stuff as dead code. + -- See also Note [Dead code in CorePrep] + let bndr'' = bndr' `setIdUnfolding` noUnfolding + `setIdSpecialisation` emptySpecInfo + return (extendCorePrepEnv env bndr bndr'', bndr'') | otherwise -- Top level things, which we don't want -- to clone, have become GlobalIds by now diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs index 0eab695..70e1db7 100644 --- a/compiler/coreSyn/CoreUtils.lhs +++ b/compiler/coreSyn/CoreUtils.lhs @@ -32,6 +32,7 @@ module CoreUtils ( -- * Expression and bindings size coreBindsSize, exprSize, + CoreStats(..), coreBindsStats, -- * Hashing hashExpr, @@ -1120,6 +1121,7 @@ coreBindsSize bs = foldr ((+) . bindSize) 0 bs exprSize :: CoreExpr -> Int -- ^ A measure of the size of the expressions, strictly greater than 0 -- It also forces the expression pretty drastically as a side effect +-- Counts *leaves*, not internal nodes. Types and coercions are not counted. exprSize (Var v) = v `seq` 1 exprSize (Lit lit) = lit `seq` 1 exprSize (App f a) = exprSize f + exprSize a @@ -1154,6 +1156,62 @@ altSize :: CoreAlt -> Int altSize (c,bs,e) = c `seq` varsSize bs + exprSize e \end{code} +\begin{code} +data CoreStats = CS { cs_tm, cs_ty, cs_co :: Int } + +plusCS :: CoreStats -> CoreStats -> CoreStats +plusCS (CS { cs_tm = p1, cs_ty = q1, cs_co = r1 }) + (CS { cs_tm = p2, cs_ty = q2, cs_co = r2 }) + = CS { cs_tm = p1+p2, cs_ty = q1+q2, cs_co = r1+r2 } + +zeroCS, oneTM :: CoreStats +zeroCS = CS { cs_tm = 0, cs_ty = 0, cs_co = 0 } +oneTM = zeroCS { cs_tm = 1 } + +sumCS :: (a -> CoreStats) -> [a] -> CoreStats +sumCS f = foldr (plusCS . f) zeroCS + +coreBindsStats :: [CoreBind] -> CoreStats +coreBindsStats = sumCS bindStats + +bindStats :: CoreBind -> CoreStats +bindStats (NonRec v r) = bindingStats v r +bindStats (Rec prs) = sumCS (\(v,r) -> bindingStats v r) prs + +bindingStats :: Var -> CoreExpr -> CoreStats +bindingStats v r = bndrStats v `plusCS` exprStats r + +bndrStats :: Var -> CoreStats +bndrStats v = oneTM `plusCS` tyStats (varType v) + +exprStats :: CoreExpr -> CoreStats +exprStats (Var {}) = oneTM +exprStats (Lit {}) = oneTM +exprStats (App f (Type t))= tyCoStats (exprType f) t +exprStats (App f a) = exprStats f `plusCS` exprStats a +exprStats (Lam b e) = bndrStats b `plusCS` exprStats e +exprStats (Let b e) = bindStats b `plusCS` exprStats e +exprStats (Case e b _ as) = exprStats e `plusCS` bndrStats b `plusCS` sumCS altStats as +exprStats (Cast e co) = coStats co `plusCS` exprStats e +exprStats (Note _ e) = exprStats e +exprStats (Type ty) = zeroCS { cs_ty = typeSize ty } + -- Ugh (might be a co) + +altStats :: CoreAlt -> CoreStats +altStats (_, bs, r) = sumCS bndrStats bs `plusCS` exprStats r + +tyCoStats :: Type -> Type -> CoreStats +tyCoStats fun_ty arg + = case splitForAllTy_maybe fun_ty of + Just (tv,_) | isCoVar tv -> coStats arg + _ -> tyStats arg + +tyStats :: Type -> CoreStats +tyStats ty = zeroCS { cs_ty = typeSize ty } + +coStats :: Coercion -> CoreStats +coStats co = zeroCS { cs_co = typeSize co } +\end{code} %************************************************************************ %* * diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs index 95b70f0..b28f3eb 100644 --- a/compiler/deSugar/Coverage.lhs +++ b/compiler/deSugar/Coverage.lhs @@ -5,7 +5,7 @@ \section[Coverage]{@coverage@: the main function} \begin{code} -module Coverage (addCoverageTicksToBinds) where +module Coverage (addCoverageTicksToBinds, hpcInitCode) where import HsSyn import Module @@ -25,6 +25,8 @@ import StaticFlags import TyCon import MonadUtils import Maybes +import CLabel +import Util import Data.Array import System.Directory ( createDirectoryIfMissing ) @@ -871,3 +873,56 @@ mixHash :: FilePath -> Integer -> Int -> [MixEntry] -> Int mixHash file tm tabstop entries = fromIntegral $ hashString (show $ Mix file tm 0 tabstop entries) \end{code} + +%************************************************************************ +%* * +%* initialisation +%* * +%************************************************************************ + +Each module compiled with -fhpc declares an initialisation function of +the form `hpc_init_()`, which is emitted into the _stub.c file +and annotated with __attribute__((constructor)) so that it gets +executed at startup time. + +The function's purpose is to call hs_hpc_module to register this +module with the RTS, and it looks something like this: + +static void hpc_init_Main(void) __attribute__((constructor)); +static void hpc_init_Main(void) +{extern StgWord64 _hpc_tickboxes_Main_hpc[]; + hs_hpc_module("Main",8,1150288664,_hpc_tickboxes_Main_hpc);} + +\begin{code} +hpcInitCode :: Module -> HpcInfo -> SDoc +hpcInitCode _ (NoHpcInfo {}) = empty +hpcInitCode this_mod (HpcInfo tickCount hashNo) + = vcat + [ text "static void hpc_init_" <> ppr this_mod + <> text "(void) __attribute__((constructor));" + , text "static void hpc_init_" <> ppr this_mod <> text "(void)" + , braces (vcat [ + ptext (sLit "extern StgWord64 ") <> tickboxes <> + ptext (sLit "[]") <> semi, + ptext (sLit "hs_hpc_module") <> + parens (hcat (punctuate comma [ + doubleQuotes full_name_str, + int tickCount, -- really StgWord32 + int hashNo, -- really StgWord32 + tickboxes + ])) <> semi + ]) + ] + where + tickboxes = pprCLabel (mkHpcTicksLabel $ this_mod) + + module_name = hcat (map (text.charToC) $ + bytesFS (moduleNameFS (Module.moduleName this_mod))) + package_name = hcat (map (text.charToC) $ + bytesFS (packageIdFS (modulePackageId this_mod))) + full_name_str + | modulePackageId this_mod == mainPackageId + = module_name + | otherwise + = package_name <> char '/' <> module_name +\end{code} diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs index 5fb4ebb..603c858 100644 --- a/compiler/deSugar/Desugar.lhs +++ b/compiler/deSugar/Desugar.lhs @@ -110,10 +110,14 @@ deSugar hsc_env ; ds_vects <- mapM dsVect vects ; hetmet_brak <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_brak_name else return undefined ; hetmet_esc <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_esc_name else return undefined + ; let hpc_init + | opt_Hpc = hpcInitCode mod ds_hpc_info + | otherwise = empty ; return ( ds_ev_binds , foreign_prs `appOL` core_prs `appOL` spec_prs , spec_rules ++ ds_rules, ds_vects - , ds_fords, ds_hpc_info, modBreaks, hetmet_brak, hetmet_esc) } + , ds_fords `appendStubC` hpc_init + , ds_hpc_info, modBreaks, hetmet_brak, hetmet_esc) } ; case mb_res of { Nothing -> return (msgs, Nothing) ; diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index af67979..e34c696 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -1726,7 +1726,7 @@ templateHaskellNames = [ varStrictTypeName, -- Type forallTName, varTName, conTName, appTName, - tupleTName, arrowTName, listTName, sigTName, + tupleTName, unboxedTupleTName, arrowTName, listTName, sigTName, -- TyVarBndr plainTVName, kindedTVName, -- Kind @@ -2031,7 +2031,7 @@ quotePatName = qqFun (fsLit "quotePat") quotePatKey quoteDecName = qqFun (fsLit "quoteDec") quoteDecKey quoteTypeName = qqFun (fsLit "quoteType") quoteTypeKey --- TyConUniques available: 100-129 +-- TyConUniques available: 200-299 -- Check in PrelNames if you want to change this expTyConKey, matchTyConKey, clauseTyConKey, qTyConKey, expQTyConKey, @@ -2041,33 +2041,33 @@ expTyConKey, matchTyConKey, clauseTyConKey, qTyConKey, expQTyConKey, fieldExpTyConKey, fieldPatTyConKey, nameTyConKey, patQTyConKey, fieldPatQTyConKey, fieldExpQTyConKey, funDepTyConKey, predTyConKey, predQTyConKey, decsQTyConKey :: Unique -expTyConKey = mkPreludeTyConUnique 100 -matchTyConKey = mkPreludeTyConUnique 101 -clauseTyConKey = mkPreludeTyConUnique 102 -qTyConKey = mkPreludeTyConUnique 103 -expQTyConKey = mkPreludeTyConUnique 104 -decQTyConKey = mkPreludeTyConUnique 105 -patTyConKey = mkPreludeTyConUnique 106 -matchQTyConKey = mkPreludeTyConUnique 107 -clauseQTyConKey = mkPreludeTyConUnique 108 -stmtQTyConKey = mkPreludeTyConUnique 109 -conQTyConKey = mkPreludeTyConUnique 110 -typeQTyConKey = mkPreludeTyConUnique 111 -typeTyConKey = mkPreludeTyConUnique 112 -decTyConKey = mkPreludeTyConUnique 113 -varStrictTypeQTyConKey = mkPreludeTyConUnique 114 -strictTypeQTyConKey = mkPreludeTyConUnique 115 -fieldExpTyConKey = mkPreludeTyConUnique 116 -fieldPatTyConKey = mkPreludeTyConUnique 117 -nameTyConKey = mkPreludeTyConUnique 118 -patQTyConKey = mkPreludeTyConUnique 119 -fieldPatQTyConKey = mkPreludeTyConUnique 120 -fieldExpQTyConKey = mkPreludeTyConUnique 121 -funDepTyConKey = mkPreludeTyConUnique 122 -predTyConKey = mkPreludeTyConUnique 123 -predQTyConKey = mkPreludeTyConUnique 124 -tyVarBndrTyConKey = mkPreludeTyConUnique 125 -decsQTyConKey = mkPreludeTyConUnique 126 +expTyConKey = mkPreludeTyConUnique 200 +matchTyConKey = mkPreludeTyConUnique 201 +clauseTyConKey = mkPreludeTyConUnique 202 +qTyConKey = mkPreludeTyConUnique 203 +expQTyConKey = mkPreludeTyConUnique 204 +decQTyConKey = mkPreludeTyConUnique 205 +patTyConKey = mkPreludeTyConUnique 206 +matchQTyConKey = mkPreludeTyConUnique 207 +clauseQTyConKey = mkPreludeTyConUnique 208 +stmtQTyConKey = mkPreludeTyConUnique 209 +conQTyConKey = mkPreludeTyConUnique 210 +typeQTyConKey = mkPreludeTyConUnique 211 +typeTyConKey = mkPreludeTyConUnique 212 +decTyConKey = mkPreludeTyConUnique 213 +varStrictTypeQTyConKey = mkPreludeTyConUnique 214 +strictTypeQTyConKey = mkPreludeTyConUnique 215 +fieldExpTyConKey = mkPreludeTyConUnique 216 +fieldPatTyConKey = mkPreludeTyConUnique 217 +nameTyConKey = mkPreludeTyConUnique 218 +patQTyConKey = mkPreludeTyConUnique 219 +fieldPatQTyConKey = mkPreludeTyConUnique 220 +fieldExpQTyConKey = mkPreludeTyConUnique 221 +funDepTyConKey = mkPreludeTyConUnique 222 +predTyConKey = mkPreludeTyConUnique 223 +predQTyConKey = mkPreludeTyConUnique 224 +tyVarBndrTyConKey = mkPreludeTyConUnique 225 +decsQTyConKey = mkPreludeTyConUnique 226 -- IdUniques available: 200-399 -- If you want to change this, make sure you check in PrelNames @@ -2090,47 +2090,47 @@ mkNameLIdKey = mkPreludeMiscIdUnique 209 -- data Lit = ... charLIdKey, stringLIdKey, integerLIdKey, intPrimLIdKey, wordPrimLIdKey, floatPrimLIdKey, doublePrimLIdKey, rationalLIdKey :: Unique -charLIdKey = mkPreludeMiscIdUnique 210 -stringLIdKey = mkPreludeMiscIdUnique 211 -integerLIdKey = mkPreludeMiscIdUnique 212 -intPrimLIdKey = mkPreludeMiscIdUnique 213 -wordPrimLIdKey = mkPreludeMiscIdUnique 214 -floatPrimLIdKey = mkPreludeMiscIdUnique 215 -doublePrimLIdKey = mkPreludeMiscIdUnique 216 -rationalLIdKey = mkPreludeMiscIdUnique 217 +charLIdKey = mkPreludeMiscIdUnique 220 +stringLIdKey = mkPreludeMiscIdUnique 221 +integerLIdKey = mkPreludeMiscIdUnique 222 +intPrimLIdKey = mkPreludeMiscIdUnique 223 +wordPrimLIdKey = mkPreludeMiscIdUnique 224 +floatPrimLIdKey = mkPreludeMiscIdUnique 225 +doublePrimLIdKey = mkPreludeMiscIdUnique 226 +rationalLIdKey = mkPreludeMiscIdUnique 227 liftStringIdKey :: Unique -liftStringIdKey = mkPreludeMiscIdUnique 218 +liftStringIdKey = mkPreludeMiscIdUnique 228 -- data Pat = ... litPIdKey, varPIdKey, tupPIdKey, unboxedTupPIdKey, conPIdKey, infixPIdKey, tildePIdKey, bangPIdKey, asPIdKey, wildPIdKey, recPIdKey, listPIdKey, sigPIdKey, viewPIdKey :: Unique -litPIdKey = mkPreludeMiscIdUnique 220 -varPIdKey = mkPreludeMiscIdUnique 221 -tupPIdKey = mkPreludeMiscIdUnique 222 -unboxedTupPIdKey = mkPreludeMiscIdUnique 362 -conPIdKey = mkPreludeMiscIdUnique 223 -infixPIdKey = mkPreludeMiscIdUnique 312 -tildePIdKey = mkPreludeMiscIdUnique 224 -bangPIdKey = mkPreludeMiscIdUnique 359 -asPIdKey = mkPreludeMiscIdUnique 225 -wildPIdKey = mkPreludeMiscIdUnique 226 -recPIdKey = mkPreludeMiscIdUnique 227 -listPIdKey = mkPreludeMiscIdUnique 228 -sigPIdKey = mkPreludeMiscIdUnique 229 -viewPIdKey = mkPreludeMiscIdUnique 360 +litPIdKey = mkPreludeMiscIdUnique 240 +varPIdKey = mkPreludeMiscIdUnique 241 +tupPIdKey = mkPreludeMiscIdUnique 242 +unboxedTupPIdKey = mkPreludeMiscIdUnique 243 +conPIdKey = mkPreludeMiscIdUnique 244 +infixPIdKey = mkPreludeMiscIdUnique 245 +tildePIdKey = mkPreludeMiscIdUnique 246 +bangPIdKey = mkPreludeMiscIdUnique 247 +asPIdKey = mkPreludeMiscIdUnique 248 +wildPIdKey = mkPreludeMiscIdUnique 249 +recPIdKey = mkPreludeMiscIdUnique 250 +listPIdKey = mkPreludeMiscIdUnique 251 +sigPIdKey = mkPreludeMiscIdUnique 252 +viewPIdKey = mkPreludeMiscIdUnique 253 -- type FieldPat = ... fieldPatIdKey :: Unique -fieldPatIdKey = mkPreludeMiscIdUnique 230 +fieldPatIdKey = mkPreludeMiscIdUnique 260 -- data Match = ... matchIdKey :: Unique -matchIdKey = mkPreludeMiscIdUnique 231 +matchIdKey = mkPreludeMiscIdUnique 261 -- data Clause = ... clauseIdKey :: Unique -clauseIdKey = mkPreludeMiscIdUnique 232 +clauseIdKey = mkPreludeMiscIdUnique 262 -- data Exp = ... @@ -2140,156 +2140,156 @@ varEIdKey, conEIdKey, litEIdKey, appEIdKey, infixEIdKey, infixAppIdKey, letEIdKey, caseEIdKey, doEIdKey, compEIdKey, fromEIdKey, fromThenEIdKey, fromToEIdKey, fromThenToEIdKey, listEIdKey, sigEIdKey, recConEIdKey, recUpdEIdKey :: Unique -varEIdKey = mkPreludeMiscIdUnique 240 -conEIdKey = mkPreludeMiscIdUnique 241 -litEIdKey = mkPreludeMiscIdUnique 242 -appEIdKey = mkPreludeMiscIdUnique 243 -infixEIdKey = mkPreludeMiscIdUnique 244 -infixAppIdKey = mkPreludeMiscIdUnique 245 -sectionLIdKey = mkPreludeMiscIdUnique 246 -sectionRIdKey = mkPreludeMiscIdUnique 247 -lamEIdKey = mkPreludeMiscIdUnique 248 -tupEIdKey = mkPreludeMiscIdUnique 249 -unboxedTupEIdKey = mkPreludeMiscIdUnique 263 -condEIdKey = mkPreludeMiscIdUnique 250 -letEIdKey = mkPreludeMiscIdUnique 251 -caseEIdKey = mkPreludeMiscIdUnique 252 -doEIdKey = mkPreludeMiscIdUnique 253 -compEIdKey = mkPreludeMiscIdUnique 254 -fromEIdKey = mkPreludeMiscIdUnique 255 -fromThenEIdKey = mkPreludeMiscIdUnique 256 -fromToEIdKey = mkPreludeMiscIdUnique 257 -fromThenToEIdKey = mkPreludeMiscIdUnique 258 -listEIdKey = mkPreludeMiscIdUnique 259 -sigEIdKey = mkPreludeMiscIdUnique 260 -recConEIdKey = mkPreludeMiscIdUnique 261 -recUpdEIdKey = mkPreludeMiscIdUnique 262 +varEIdKey = mkPreludeMiscIdUnique 270 +conEIdKey = mkPreludeMiscIdUnique 271 +litEIdKey = mkPreludeMiscIdUnique 272 +appEIdKey = mkPreludeMiscIdUnique 273 +infixEIdKey = mkPreludeMiscIdUnique 274 +infixAppIdKey = mkPreludeMiscIdUnique 275 +sectionLIdKey = mkPreludeMiscIdUnique 276 +sectionRIdKey = mkPreludeMiscIdUnique 277 +lamEIdKey = mkPreludeMiscIdUnique 278 +tupEIdKey = mkPreludeMiscIdUnique 279 +unboxedTupEIdKey = mkPreludeMiscIdUnique 280 +condEIdKey = mkPreludeMiscIdUnique 281 +letEIdKey = mkPreludeMiscIdUnique 282 +caseEIdKey = mkPreludeMiscIdUnique 283 +doEIdKey = mkPreludeMiscIdUnique 284 +compEIdKey = mkPreludeMiscIdUnique 285 +fromEIdKey = mkPreludeMiscIdUnique 286 +fromThenEIdKey = mkPreludeMiscIdUnique 287 +fromToEIdKey = mkPreludeMiscIdUnique 288 +fromThenToEIdKey = mkPreludeMiscIdUnique 289 +listEIdKey = mkPreludeMiscIdUnique 290 +sigEIdKey = mkPreludeMiscIdUnique 291 +recConEIdKey = mkPreludeMiscIdUnique 292 +recUpdEIdKey = mkPreludeMiscIdUnique 293 -- type FieldExp = ... fieldExpIdKey :: Unique -fieldExpIdKey = mkPreludeMiscIdUnique 265 +fieldExpIdKey = mkPreludeMiscIdUnique 310 -- data Body = ... guardedBIdKey, normalBIdKey :: Unique -guardedBIdKey = mkPreludeMiscIdUnique 266 -normalBIdKey = mkPreludeMiscIdUnique 267 +guardedBIdKey = mkPreludeMiscIdUnique 311 +normalBIdKey = mkPreludeMiscIdUnique 312 -- data Guard = ... normalGEIdKey, patGEIdKey :: Unique -normalGEIdKey = mkPreludeMiscIdUnique 310 -patGEIdKey = mkPreludeMiscIdUnique 311 +normalGEIdKey = mkPreludeMiscIdUnique 313 +patGEIdKey = mkPreludeMiscIdUnique 314 -- data Stmt = ... bindSIdKey, letSIdKey, noBindSIdKey, parSIdKey :: Unique -bindSIdKey = mkPreludeMiscIdUnique 268 -letSIdKey = mkPreludeMiscIdUnique 269 -noBindSIdKey = mkPreludeMiscIdUnique 270 -parSIdKey = mkPreludeMiscIdUnique 271 +bindSIdKey = mkPreludeMiscIdUnique 320 +letSIdKey = mkPreludeMiscIdUnique 321 +noBindSIdKey = mkPreludeMiscIdUnique 322 +parSIdKey = mkPreludeMiscIdUnique 323 -- data Dec = ... funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey, classDIdKey, instanceDIdKey, sigDIdKey, forImpDIdKey, pragInlDIdKey, pragSpecDIdKey, pragSpecInlDIdKey, familyNoKindDIdKey, familyKindDIdKey, dataInstDIdKey, newtypeInstDIdKey, tySynInstDIdKey :: Unique -funDIdKey = mkPreludeMiscIdUnique 272 -valDIdKey = mkPreludeMiscIdUnique 273 -dataDIdKey = mkPreludeMiscIdUnique 274 -newtypeDIdKey = mkPreludeMiscIdUnique 275 -tySynDIdKey = mkPreludeMiscIdUnique 276 -classDIdKey = mkPreludeMiscIdUnique 277 -instanceDIdKey = mkPreludeMiscIdUnique 278 -sigDIdKey = mkPreludeMiscIdUnique 279 -forImpDIdKey = mkPreludeMiscIdUnique 297 -pragInlDIdKey = mkPreludeMiscIdUnique 348 -pragSpecDIdKey = mkPreludeMiscIdUnique 349 -pragSpecInlDIdKey = mkPreludeMiscIdUnique 352 -familyNoKindDIdKey= mkPreludeMiscIdUnique 340 -familyKindDIdKey = mkPreludeMiscIdUnique 353 -dataInstDIdKey = mkPreludeMiscIdUnique 341 -newtypeInstDIdKey = mkPreludeMiscIdUnique 342 -tySynInstDIdKey = mkPreludeMiscIdUnique 343 +funDIdKey = mkPreludeMiscIdUnique 330 +valDIdKey = mkPreludeMiscIdUnique 331 +dataDIdKey = mkPreludeMiscIdUnique 332 +newtypeDIdKey = mkPreludeMiscIdUnique 333 +tySynDIdKey = mkPreludeMiscIdUnique 334 +classDIdKey = mkPreludeMiscIdUnique 335 +instanceDIdKey = mkPreludeMiscIdUnique 336 +sigDIdKey = mkPreludeMiscIdUnique 337 +forImpDIdKey = mkPreludeMiscIdUnique 338 +pragInlDIdKey = mkPreludeMiscIdUnique 339 +pragSpecDIdKey = mkPreludeMiscIdUnique 340 +pragSpecInlDIdKey = mkPreludeMiscIdUnique 341 +familyNoKindDIdKey = mkPreludeMiscIdUnique 342 +familyKindDIdKey = mkPreludeMiscIdUnique 343 +dataInstDIdKey = mkPreludeMiscIdUnique 344 +newtypeInstDIdKey = mkPreludeMiscIdUnique 345 +tySynInstDIdKey = mkPreludeMiscIdUnique 346 -- type Cxt = ... cxtIdKey :: Unique -cxtIdKey = mkPreludeMiscIdUnique 280 +cxtIdKey = mkPreludeMiscIdUnique 360 -- data Pred = ... classPIdKey, equalPIdKey :: Unique -classPIdKey = mkPreludeMiscIdUnique 346 -equalPIdKey = mkPreludeMiscIdUnique 347 +classPIdKey = mkPreludeMiscIdUnique 361 +equalPIdKey = mkPreludeMiscIdUnique 362 -- data Strict = ... isStrictKey, notStrictKey :: Unique -isStrictKey = mkPreludeMiscIdUnique 281 -notStrictKey = mkPreludeMiscIdUnique 282 +isStrictKey = mkPreludeMiscIdUnique 363 +notStrictKey = mkPreludeMiscIdUnique 364 -- data Con = ... normalCIdKey, recCIdKey, infixCIdKey, forallCIdKey :: Unique -normalCIdKey = mkPreludeMiscIdUnique 283 -recCIdKey = mkPreludeMiscIdUnique 284 -infixCIdKey = mkPreludeMiscIdUnique 285 -forallCIdKey = mkPreludeMiscIdUnique 288 +normalCIdKey = mkPreludeMiscIdUnique 370 +recCIdKey = mkPreludeMiscIdUnique 371 +infixCIdKey = mkPreludeMiscIdUnique 372 +forallCIdKey = mkPreludeMiscIdUnique 373 -- type StrictType = ... strictTKey :: Unique -strictTKey = mkPreludeMiscIdUnique 286 +strictTKey = mkPreludeMiscIdUnique 374 -- type VarStrictType = ... varStrictTKey :: Unique -varStrictTKey = mkPreludeMiscIdUnique 287 +varStrictTKey = mkPreludeMiscIdUnique 375 -- data Type = ... forallTIdKey, varTIdKey, conTIdKey, tupleTIdKey, unboxedTupleTIdKey, arrowTIdKey, listTIdKey, appTIdKey, sigTIdKey :: Unique -forallTIdKey = mkPreludeMiscIdUnique 290 -varTIdKey = mkPreludeMiscIdUnique 291 -conTIdKey = mkPreludeMiscIdUnique 292 -tupleTIdKey = mkPreludeMiscIdUnique 294 -unboxedTupleTIdKey = mkPreludeMiscIdUnique 361 -arrowTIdKey = mkPreludeMiscIdUnique 295 -listTIdKey = mkPreludeMiscIdUnique 296 -appTIdKey = mkPreludeMiscIdUnique 293 -sigTIdKey = mkPreludeMiscIdUnique 358 +forallTIdKey = mkPreludeMiscIdUnique 380 +varTIdKey = mkPreludeMiscIdUnique 381 +conTIdKey = mkPreludeMiscIdUnique 382 +tupleTIdKey = mkPreludeMiscIdUnique 383 +unboxedTupleTIdKey = mkPreludeMiscIdUnique 384 +arrowTIdKey = mkPreludeMiscIdUnique 385 +listTIdKey = mkPreludeMiscIdUnique 386 +appTIdKey = mkPreludeMiscIdUnique 387 +sigTIdKey = mkPreludeMiscIdUnique 388 -- data TyVarBndr = ... plainTVIdKey, kindedTVIdKey :: Unique -plainTVIdKey = mkPreludeMiscIdUnique 354 -kindedTVIdKey = mkPreludeMiscIdUnique 355 +plainTVIdKey = mkPreludeMiscIdUnique 390 +kindedTVIdKey = mkPreludeMiscIdUnique 391 -- data Kind = ... starKIdKey, arrowKIdKey :: Unique -starKIdKey = mkPreludeMiscIdUnique 356 -arrowKIdKey = mkPreludeMiscIdUnique 357 +starKIdKey = mkPreludeMiscIdUnique 392 +arrowKIdKey = mkPreludeMiscIdUnique 393 -- data Callconv = ... cCallIdKey, stdCallIdKey :: Unique -cCallIdKey = mkPreludeMiscIdUnique 300 -stdCallIdKey = mkPreludeMiscIdUnique 301 +cCallIdKey = mkPreludeMiscIdUnique 394 +stdCallIdKey = mkPreludeMiscIdUnique 395 -- data Safety = ... unsafeIdKey, safeIdKey, threadsafeIdKey, interruptibleIdKey :: Unique -unsafeIdKey = mkPreludeMiscIdUnique 305 -safeIdKey = mkPreludeMiscIdUnique 306 -threadsafeIdKey = mkPreludeMiscIdUnique 307 -interruptibleIdKey = mkPreludeMiscIdUnique 308 +unsafeIdKey = mkPreludeMiscIdUnique 400 +safeIdKey = mkPreludeMiscIdUnique 401 +threadsafeIdKey = mkPreludeMiscIdUnique 402 +interruptibleIdKey = mkPreludeMiscIdUnique 403 -- data InlineSpec = inlineSpecNoPhaseIdKey, inlineSpecPhaseIdKey :: Unique -inlineSpecNoPhaseIdKey = mkPreludeMiscIdUnique 350 -inlineSpecPhaseIdKey = mkPreludeMiscIdUnique 351 +inlineSpecNoPhaseIdKey = mkPreludeMiscIdUnique 404 +inlineSpecPhaseIdKey = mkPreludeMiscIdUnique 405 -- data FunDep = ... funDepIdKey :: Unique -funDepIdKey = mkPreludeMiscIdUnique 320 +funDepIdKey = mkPreludeMiscIdUnique 406 -- data FamFlavour = ... typeFamIdKey, dataFamIdKey :: Unique -typeFamIdKey = mkPreludeMiscIdUnique 344 -dataFamIdKey = mkPreludeMiscIdUnique 345 +typeFamIdKey = mkPreludeMiscIdUnique 407 +dataFamIdKey = mkPreludeMiscIdUnique 408 -- quasiquoting quoteExpKey, quotePatKey, quoteDecKey, quoteTypeKey :: Unique -quoteExpKey = mkPreludeMiscIdUnique 321 -quotePatKey = mkPreludeMiscIdUnique 322 -quoteDecKey = mkPreludeMiscIdUnique 323 -quoteTypeKey = mkPreludeMiscIdUnique 324 +quoteExpKey = mkPreludeMiscIdUnique 410 +quotePatKey = mkPreludeMiscIdUnique 411 +quoteDecKey = mkPreludeMiscIdUnique 412 +quoteTypeKey = mkPreludeMiscIdUnique 413 diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index 8cb64ab..0a56719 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -351,6 +351,7 @@ Library TysPrim TysWiredIn CostCentre + ProfInit SCCfinal RnBinds RnEnv diff --git a/compiler/ghc.mk b/compiler/ghc.mk index 0def1c1..a7a353d 100644 --- a/compiler/ghc.mk +++ b/compiler/ghc.mk @@ -140,6 +140,8 @@ compiler/stage%/build/Config.hs : mk/config.mk mk/project.mk | $$(dir $$@)/. @echo 'cMKDLL = "$(BLD_DLL)"' >> $@ @echo 'cLdIsGNULd :: String' >> $@ @echo 'cLdIsGNULd = "$(LdIsGNULd)"' >> $@ + @echo 'cLdHasBuildId :: String' >> $@ + @echo 'cLdHasBuildId = "$(LdHasBuildId)"' >> $@ @echo 'cLD_X :: String' >> $@ @echo 'cLD_X = "$(LD_X)"' >> $@ @echo 'cGHC_DRIVER_DIR :: String' >> $@ @@ -152,10 +154,6 @@ compiler/stage%/build/Config.hs : mk/config.mk mk/project.mk | $$(dir $$@)/. @echo 'cGHC_UNLIT_PGM = "$(GHC_UNLIT_PGM)"' >> $@ @echo 'cGHC_UNLIT_DIR :: String' >> $@ @echo 'cGHC_UNLIT_DIR = "$(GHC_UNLIT_DIR)"' >> $@ - @echo 'cGHC_MANGLER_PGM :: String' >> $@ - @echo 'cGHC_MANGLER_PGM = "$(GHC_MANGLER_PGM)"' >> $@ - @echo 'cGHC_MANGLER_DIR :: String' >> $@ - @echo 'cGHC_MANGLER_DIR = "$(GHC_MANGLER_DIR)"' >> $@ @echo 'cGHC_SPLIT_PGM :: String' >> $@ @echo 'cGHC_SPLIT_PGM = "$(GHC_SPLIT_PGM)"' >> $@ @echo 'cGHC_SPLIT_DIR :: String' >> $@ @@ -495,6 +493,18 @@ compiler_stage1_HC_OPTS += $(GhcStage1HcOpts) compiler_stage2_HC_OPTS += $(GhcStage2HcOpts) compiler_stage3_HC_OPTS += $(GhcStage3HcOpts) +ifeq "$(GhcStage1DefaultNewCodegen)" "YES" +compiler_stage1_HC_OPTS += -DGHC_DEFAULT_NEW_CODEGEN +endif + +ifeq "$(GhcStage2DefaultNewCodegen)" "YES" +compiler_stage2_HC_OPTS += -DGHC_DEFAULT_NEW_CODEGEN +endif + +ifeq "$(GhcStage3DefaultNewCodegen)" "YES" +compiler_stage3_HC_OPTS += -DGHC_DEFAULT_NEW_CODEGEN +endif + ifneq "$(BINDIST)" "YES" compiler_stage2_TAGS_HC_OPTS = -package ghc diff --git a/compiler/ghci/Linker.lhs b/compiler/ghci/Linker.lhs index bd0bb35..eaf4521 100644 --- a/compiler/ghci/Linker.lhs +++ b/compiler/ghci/Linker.lhs @@ -245,11 +245,18 @@ dataConInfoPtrToName x = do where (modWords, occWord) = ASSERT (length rest1 > 0) (parseModOcc [] (tail rest1)) parseModOcc :: [[Word8]] -> [Word8] -> ([[Word8]], [Word8]) - parseModOcc acc str + -- We only look for dots if str could start with a module name, + -- i.e. if it starts with an upper case character. + -- Otherwise we might think that "X.:->" is the module name in + -- "X.:->.+", whereas actually "X" is the module name and + -- ":->.+" is a constructor name. + parseModOcc acc str@(c : _) + | isUpper $ chr $ fromIntegral c = case break (== dot) str of (top, []) -> (acc, top) - (top, _:bot) -> parseModOcc (top : acc) bot - + (top, _ : bot) -> parseModOcc (top : acc) bot + parseModOcc acc str = (acc, str) + -- | Get the 'HValue' associated with the given name. -- -- May cause loading the module that contains the name. diff --git a/compiler/hetmet b/compiler/hetmet index 6c949de..b18f84a 160000 --- a/compiler/hetmet +++ b/compiler/hetmet @@ -1 +1 @@ -Subproject commit 6c949de6b044bda942fd0553e3eb9c0386a94e44 +Subproject commit b18f84ae40af08b3df0214593f4e4eb0665cdf7d diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs index bf75f4c..13f3cd7 100644 --- a/compiler/hsSyn/HsUtils.lhs +++ b/compiler/hsSyn/HsUtils.lhs @@ -61,7 +61,10 @@ module HsUtils( collectSigTysFromPats, collectSigTysFromPat, hsTyClDeclBinders, hsTyClDeclsBinders, - hsForeignDeclsBinders, hsGroupBinders + hsForeignDeclsBinders, hsGroupBinders, + + -- Collecting implicit binders + lStmtsImplicits, hsValBindsImplicits, lPatImplicits ) where import HsDecls @@ -81,8 +84,11 @@ import NameSet import BasicTypes import SrcLoc import FastString +import Outputable import Util import Bag + +import Data.Either \end{code} @@ -617,6 +623,81 @@ hsConDeclsBinders cons %************************************************************************ %* * + Collecting binders the user did not write +%* * +%************************************************************************ + +The job of this family of functions is to run through binding sites and find the set of all Names +that were defined "implicitly", without being explicitly written by the user. + +The main purpose is to find names introduced by record wildcards so that we can avoid +warning the user when they don't use those names (#4404) + +\begin{code} +lStmtsImplicits :: [LStmtLR Name idR] -> NameSet +lStmtsImplicits = hs_lstmts + where + hs_lstmts :: [LStmtLR Name idR] -> NameSet + hs_lstmts = foldr (\stmt rest -> unionNameSets (hs_stmt (unLoc stmt)) rest) emptyNameSet + + hs_stmt (BindStmt pat _ _ _) = lPatImplicits pat + hs_stmt (LetStmt binds) = hs_local_binds binds + hs_stmt (ExprStmt _ _ _) = emptyNameSet + hs_stmt (ParStmt xs) = hs_lstmts $ concatMap fst xs + + hs_stmt (TransformStmt stmts _ _ _) = hs_lstmts stmts + hs_stmt (GroupStmt stmts _ _ _) = hs_lstmts stmts + hs_stmt (RecStmt { recS_stmts = ss }) = hs_lstmts ss + + hs_local_binds (HsValBinds val_binds) = hsValBindsImplicits val_binds + hs_local_binds (HsIPBinds _) = emptyNameSet + hs_local_binds EmptyLocalBinds = emptyNameSet + +hsValBindsImplicits :: HsValBindsLR Name idR -> NameSet +hsValBindsImplicits (ValBindsOut binds _) + = unionManyNameSets [foldBag unionNameSets (hs_bind . unLoc) emptyNameSet hs_binds | (_rec, hs_binds) <- binds] + where + hs_bind (PatBind { pat_lhs = lpat }) = lPatImplicits lpat + hs_bind _ = emptyNameSet +hsValBindsImplicits (ValBindsIn {}) = pprPanic "hsValBindsImplicits: ValBindsIn" empty + +lPatImplicits :: LPat Name -> NameSet +lPatImplicits = hs_lpat + where + hs_lpat (L _ pat) = hs_pat pat + + hs_lpats = foldr (\pat rest -> hs_lpat pat `unionNameSets` rest) emptyNameSet + + hs_pat (LazyPat pat) = hs_lpat pat + hs_pat (BangPat pat) = hs_lpat pat + hs_pat (AsPat _ pat) = hs_lpat pat + hs_pat (ViewPat _ pat _) = hs_lpat pat + hs_pat (ParPat pat) = hs_lpat pat + hs_pat (ListPat pats _) = hs_lpats pats + hs_pat (PArrPat pats _) = hs_lpats pats + hs_pat (TuplePat pats _ _) = hs_lpats pats + + hs_pat (SigPatIn pat _) = hs_lpat pat + hs_pat (SigPatOut pat _) = hs_lpat pat + hs_pat (CoPat _ pat _) = hs_pat pat + + hs_pat (ConPatIn _ ps) = details ps + hs_pat (ConPatOut {pat_args=ps}) = details ps + + hs_pat _ = emptyNameSet + + details (PrefixCon ps) = hs_lpats ps + details (RecCon fs) = hs_lpats explicit `unionNameSets` mkNameSet (collectPatsBinders implicit) + where (explicit, implicit) = partitionEithers [if pat_explicit then Left pat else Right pat + | (i, fld) <- [0..] `zip` rec_flds fs + , let pat = hsRecFieldArg fld + pat_explicit = maybe True (i<) (rec_dotdot fs)] + details (InfixCon p1 p2) = hs_lpat p1 `unionNameSets` hs_lpat p2 +\end{code} + + +%************************************************************************ +%* * Collecting type signatures from patterns %* * %************************************************************************ diff --git a/compiler/llvmGen/LlvmMangler.hs b/compiler/llvmGen/LlvmMangler.hs index 7f1c786..7b38ed8 100644 --- a/compiler/llvmGen/LlvmMangler.hs +++ b/compiler/llvmGen/LlvmMangler.hs @@ -24,11 +24,12 @@ infoSec = B.pack "\t.section\t__STRIP,__me" newInfoSec = B.pack "\n\t.text" newLine = B.pack "\n" spInst = B.pack ", %esp\n" -jmpInst = B.pack "jmp" +jmpInst = B.pack "\n\tjmp" -infoLen, spFix :: Int +infoLen, spFix, labelStart :: Int infoLen = B.length infoSec spFix = 4 +labelStart = B.length jmpInst + 1 -- Search Predicates eolPred, dollarPred, commaPred :: Char -> Bool @@ -107,7 +108,9 @@ fixupStack f f' | B.null f' = fixupStack f f' = let -- fixup add ops (a, c) = B.breakSubstring jmpInst f - (l, b) = B.break eolPred c + -- we matched on a '\n' so go past it + (l', b) = B.break eolPred $ B.tail c + l = (B.head c) `B.cons` l' (a', n) = B.breakEnd dollarPred a (n', x) = B.break commaPred n num = B.pack $ show $ readInt n' + spFix @@ -115,7 +118,7 @@ fixupStack f f' = then f' `B.append` f -- We need to avoid processing jumps to labels, they are of the form: -- jmp\tL..., jmp\t_f..., jmpl\t_f..., jmpl\t*%eax... - else if B.index c 4 == 'L' + else if B.index c labelStart == 'L' then fixupStack b $ f' `B.append` a `B.append` l else fixupStack b $ f' `B.append` a' `B.append` num `B.append` x `B.append` l @@ -123,6 +126,6 @@ fixupStack f f' = -- | read an int or error readInt :: B.ByteString -> Int readInt str | B.all isDigit str = (read . B.unpack) str - | otherwise = error $ "LLvmMangler Cannot read" ++ show str + | otherwise = error $ "LLvmMangler Cannot read" ++ show str ++ "as it's not an Int" diff --git a/compiler/main/CodeOutput.lhs b/compiler/main/CodeOutput.lhs index 85f3402..f503077 100644 --- a/compiler/main/CodeOutput.lhs +++ b/compiler/main/CodeOutput.lhs @@ -30,6 +30,7 @@ import OldCmm ( RawCmm ) import HscTypes import DynFlags import Config +import SysTools import ErrUtils ( dumpIfSet_dyn, showPass, ghcExit ) import Outputable @@ -56,7 +57,7 @@ codeOutput :: DynFlags -> ForeignStubs -> [PackageId] -> [RawCmm] -- Compiled C-- - -> IO (Bool{-stub_h_exists-}, Bool{-stub_c_exists-}) + -> IO (Bool{-stub_h_exists-}, Maybe FilePath{-stub_c_exists-}) codeOutput dflags this_mod location foreign_stubs pkg_deps flat_abstractC = @@ -212,18 +213,21 @@ outputJava dflags filenm mod tycons core_binds \begin{code} outputForeignStubs :: DynFlags -> Module -> ModLocation -> ForeignStubs -> IO (Bool, -- Header file created - Bool) -- C file created + Maybe FilePath) -- C file created outputForeignStubs dflags mod location stubs - = case stubs of - NoStubs -> do + = do + let stub_h = mkStubPaths dflags (moduleName mod) location + stub_c <- newTempName dflags "c" + + case stubs of + NoStubs -> do -- When compiling External Core files, may need to use stub -- files from a previous compilation - stub_c_exists <- doesFileExist stub_c - stub_h_exists <- doesFileExist stub_h - return (stub_h_exists, stub_c_exists) + stub_h_exists <- doesFileExist stub_h + return (stub_h_exists, Nothing) - ForeignStubs h_code c_code -> do - let + ForeignStubs h_code c_code -> do + let stub_c_output_d = pprCode CStyle c_code stub_c_output_w = showSDoc stub_c_output_d @@ -232,7 +236,7 @@ outputForeignStubs dflags mod location stubs stub_h_output_w = showSDoc stub_h_output_d -- in - createDirectoryHierarchy (takeDirectory stub_c) + createDirectoryHierarchy (takeDirectory stub_h) dumpIfSet_dyn dflags Opt_D_dump_foreign "Foreign export header file" stub_h_output_d @@ -266,10 +270,10 @@ outputForeignStubs dflags mod location stubs -- isn't really HC code, so we need to define IN_STG_CODE==0 to -- avoid the register variables etc. being enabled. - return (stub_h_file_exists, stub_c_file_exists) - where - (stub_c, stub_h, _) = mkStubPaths dflags (moduleName mod) location - + return (stub_h_file_exists, if stub_c_file_exists + then Just stub_c + else Nothing ) + where cplusplus_hdr = "#ifdef __cplusplus\nextern \"C\" {\n#endif\n" cplusplus_ftr = "#ifdef __cplusplus\n}\n#endif\n" diff --git a/compiler/main/DriverPhases.hs b/compiler/main/DriverPhases.hs index d85335f..f6a9738 100644 --- a/compiler/main/DriverPhases.hs +++ b/compiler/main/DriverPhases.hs @@ -75,8 +75,8 @@ data Phase | Hsc HscSource | Ccpp | Cc + | Cobjc | HCc -- Haskellised C (as opposed to vanilla C) compilation - | Mangle -- assembly mangling, now done by a separate script. | SplitMangle -- after mangler if splitting | SplitAs | As @@ -85,6 +85,7 @@ data Phase | LlvmMangle -- Fix up TNTC by processing assembly produced by LLVM | CmmCpp -- pre-process Cmm source | Cmm -- parse & compile Cmm code + | MergeStub -- merge in the stub object file -- The final phase is a pseudo-phase that tells the pipeline to stop. -- There is no runPhase case for it. @@ -110,8 +111,8 @@ eqPhase (HsPp _) (HsPp _) = True eqPhase (Hsc _) (Hsc _) = True eqPhase Ccpp Ccpp = True eqPhase Cc Cc = True +eqPhase Cobjc Cobjc = True eqPhase HCc HCc = True -eqPhase Mangle Mangle = True eqPhase SplitMangle SplitMangle = True eqPhase SplitAs SplitAs = True eqPhase As As = True @@ -120,6 +121,7 @@ eqPhase LlvmLlc LlvmLlc = True eqPhase LlvmMangle LlvmMangle = True eqPhase CmmCpp CmmCpp = True eqPhase Cmm Cmm = True +eqPhase MergeStub MergeStub = True eqPhase StopLn StopLn = True eqPhase _ _ = False @@ -133,13 +135,11 @@ x `happensBefore` y = after_x `eqPhase` y || after_x `happensBefore` y after_x = nextPhase x nextPhase :: Phase -> Phase --- A conservative approximation the next phase, used in happensBefore +-- A conservative approximation to the next phase, used in happensBefore nextPhase (Unlit sf) = Cpp sf nextPhase (Cpp sf) = HsPp sf nextPhase (HsPp sf) = Hsc sf nextPhase (Hsc _) = HCc -nextPhase HCc = Mangle -nextPhase Mangle = SplitMangle nextPhase SplitMangle = As nextPhase As = SplitAs nextPhase LlvmOpt = LlvmLlc @@ -149,11 +149,14 @@ nextPhase LlvmLlc = LlvmMangle nextPhase LlvmLlc = As #endif nextPhase LlvmMangle = As -nextPhase SplitAs = StopLn +nextPhase SplitAs = MergeStub nextPhase Ccpp = As nextPhase Cc = As +nextPhase Cobjc = As nextPhase CmmCpp = Cmm nextPhase Cmm = HCc +nextPhase HCc = As +nextPhase MergeStub = StopLn nextPhase StopLn = panic "nextPhase: nothing after StopLn" -- the first compilation phase for a given file is determined @@ -170,9 +173,9 @@ startPhase "hc" = HCc startPhase "c" = Cc startPhase "cpp" = Ccpp startPhase "C" = Cc +startPhase "m" = Cobjc startPhase "cc" = Ccpp startPhase "cxx" = Ccpp -startPhase "raw_s" = Mangle startPhase "split_s" = SplitMangle startPhase "s" = As startPhase "S" = As @@ -199,8 +202,8 @@ phaseInputExt (Hsc _) = "hspp" -- intermediate only -- output filename. That could be fixed, but watch out. phaseInputExt HCc = "hc" phaseInputExt Ccpp = "cpp" +phaseInputExt Cobjc = "m" phaseInputExt Cc = "c" -phaseInputExt Mangle = "raw_s" phaseInputExt SplitMangle = "split_s" -- not really generated phaseInputExt As = "s" phaseInputExt LlvmOpt = "ll" @@ -209,6 +212,7 @@ phaseInputExt LlvmMangle = "lm_s" phaseInputExt SplitAs = "split_s" -- not really generated phaseInputExt CmmCpp = "cmm" phaseInputExt Cmm = "cmmcpp" +phaseInputExt MergeStub = "o" phaseInputExt StopLn = "o" haskellish_src_suffixes, haskellish_suffixes, cish_suffixes, @@ -217,7 +221,7 @@ haskellish_src_suffixes, haskellish_suffixes, cish_suffixes, haskellish_src_suffixes = haskellish_user_src_suffixes ++ [ "hspp", "hscpp", "hcr", "cmm", "cmmcpp" ] haskellish_suffixes = haskellish_src_suffixes ++ ["hc", "raw_s"] -cish_suffixes = [ "c", "cpp", "C", "cc", "cxx", "s", "S", "ll", "bc" ] +cish_suffixes = [ "c", "cpp", "C", "cc", "cxx", "s", "S", "ll", "bc", "m" ] extcoreish_suffixes = [ "hcr" ] -- Will not be deleted as temp files: haskellish_user_src_suffixes = [ "hs", "lhs", "hs-boot", "lhs-boot" ] diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index 97ee683..488012d 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -1,4 +1,5 @@ {-# OPTIONS -fno-cse #-} +{-# LANGUAGE NamedFieldPuns #-} -- -fno-cse is needed for GLOBAL_VAR's to behave properly ----------------------------------------------------------------------------- @@ -62,6 +63,7 @@ import Control.Monad import Data.List ( isSuffixOf ) import Data.Maybe import System.Environment +import Data.Char -- --------------------------------------------------------------------------- -- Pre-process @@ -78,7 +80,7 @@ preprocess :: HscEnv preprocess hsc_env (filename, mb_phase) = ASSERT2(isJust mb_phase || isHaskellSrcFilename filename, text filename) runPipeline anyHsc hsc_env (filename, mb_phase) - Nothing Temporary Nothing{-no ModLocation-} + Nothing Temporary Nothing{-no ModLocation-} Nothing{-no stub-} -- --------------------------------------------------------------------------- @@ -141,7 +143,7 @@ compile' (nothingCompiler, interactiveCompiler, batchCompiler) hsc_env = hsc_env0 {hsc_dflags = dflags} -- Figure out what lang we're generating - let hsc_lang = hscMaybeAdjustTarget dflags StopLn src_flavour (hscTarget dflags) + let hsc_lang = hscTarget dflags -- ... and what the next phase should be let next_phase = hscNextPhase dflags src_flavour hsc_lang -- ... and what file to generate the output into @@ -158,12 +160,7 @@ compile' (nothingCompiler, interactiveCompiler, batchCompiler) source_unchanged = isJust maybe_old_linkable && not force_recomp object_filename = ml_obj_file location - let getStubLinkable False = return [] - getStubLinkable True - = do stub_o <- compileStub hsc_env' this_mod location - return [ DotO stub_o ] - - handleBatch HscNoRecomp + let handleBatch HscNoRecomp = ASSERT (isJust maybe_old_linkable) return maybe_old_linkable @@ -175,22 +172,27 @@ compile' (nothingCompiler, interactiveCompiler, batchCompiler) return maybe_old_linkable | otherwise - = do stub_unlinked <- getStubLinkable hasStub - (hs_unlinked, unlinked_time) <- + = do (hs_unlinked, unlinked_time) <- case hsc_lang of - HscNothing - -> return ([], ms_hs_date summary) + HscNothing -> + return ([], ms_hs_date summary) -- We're in --make mode: finish the compilation pipeline. - _other - -> do _ <- runPipeline StopLn hsc_env' (output_fn,Nothing) + _other -> do + maybe_stub_o <- case hasStub of + Nothing -> return Nothing + Just stub_c -> do + stub_o <- compileStub hsc_env' stub_c + return (Just stub_o) + _ <- runPipeline StopLn hsc_env' (output_fn,Nothing) (Just basename) Persistent (Just location) + maybe_stub_o -- The object filename comes from the ModLocation - o_time <- getModificationTime object_filename - return ([DotO object_filename], o_time) - let linkable = LM unlinked_time this_mod - (hs_unlinked ++ stub_unlinked) + o_time <- getModificationTime object_filename + return ([DotO object_filename], o_time) + + let linkable = LM unlinked_time this_mod hs_unlinked return (Just linkable) handleInterpreted HscNoRecomp @@ -200,7 +202,12 @@ compile' (nothingCompiler, interactiveCompiler, batchCompiler) = ASSERT (isHsBoot src_flavour) return maybe_old_linkable handleInterpreted (HscRecomp hasStub (Just (comp_bc, modBreaks))) - = do stub_unlinked <- getStubLinkable hasStub + = do stub_o <- case hasStub of + Nothing -> return [] + Just stub_c -> do + stub_o <- compileStub hsc_env' stub_c + return [DotO stub_o] + let hs_unlinked = [BCOs comp_bc modBreaks] unlinked_time = ms_hs_date summary -- Why do we use the timestamp of the source file here, @@ -210,7 +217,7 @@ compile' (nothingCompiler, interactiveCompiler, batchCompiler) -- if the source is modified, then the linkable will -- be out of date. let linkable = LM unlinked_time this_mod - (hs_unlinked ++ stub_unlinked) + (hs_unlinked ++ stub_o) return (Just linkable) let -- runCompiler :: Compiler result -> (result -> Maybe Linkable) @@ -235,31 +242,17 @@ compile' (nothingCompiler, interactiveCompiler, batchCompiler) -- The _stub.c file is derived from the haskell source file, possibly taking -- into account the -stubdir option. -- --- Consequently, we derive the _stub.o filename from the haskell object --- filename. --- --- This isn't necessarily the same as the object filename we --- would get if we just compiled the _stub.c file using the pipeline. --- For example: --- --- ghc src/A.hs -odir obj --- --- results in obj/A.o, and src/A_stub.c. If we compile src/A_stub.c with --- -odir obj, we would get obj/src/A_stub.o, which is wrong; we want --- obj/A_stub.o. +-- The object file created by compiling the _stub.c file is put into a +-- temporary file, which will be later combined with the main .o file +-- (see the MergeStubs phase). -compileStub :: HscEnv -> Module -> ModLocation -> IO FilePath -compileStub hsc_env mod location = do - -- compile the _stub.c file w/ gcc - let (stub_c,_,stub_o) = mkStubPaths (hsc_dflags hsc_env) - (moduleName mod) location - - _ <- runPipeline StopLn hsc_env (stub_c,Nothing) Nothing - (SpecificFile stub_o) Nothing{-no ModLocation-} +compileStub :: HscEnv -> FilePath -> IO FilePath +compileStub hsc_env stub_c = do + (_, stub_o) <- runPipeline StopLn hsc_env (stub_c,Nothing) Nothing + Temporary Nothing{-no ModLocation-} Nothing return stub_o - -- --------------------------------------------------------------------------- -- Link @@ -391,7 +384,30 @@ linkingNeeded dflags linkables pkg_deps = do let (lib_errs,lib_times) = splitEithers e_lib_times if not (null lib_errs) || any (t <) lib_times then return True - else return False + else checkLinkInfo dflags pkg_deps exe_file + +-- Returns 'False' if it was, and we can avoid linking, because the +-- previous binary was linked with "the same options". +checkLinkInfo :: DynFlags -> [PackageId] -> FilePath -> IO Bool +checkLinkInfo dflags pkg_deps exe_file + | isWindowsTarget || isDarwinTarget + -- ToDo: Windows and OS X do not use the ELF binary format, so + -- readelf does not work there. We need to find another way to do + -- this. + = return False -- conservatively we should return True, but not + -- linking in this case was the behaviour for a long + -- time so we leave it as-is. + | otherwise + = do + link_info <- getLinkInfo dflags pkg_deps + debugTraceMsg dflags 3 $ text ("Link info: " ++ link_info) + m_exe_link_info <- readElfSection dflags ghcLinkInfoSectionName exe_file + debugTraceMsg dflags 3 $ text ("Exe link info: " ++ show m_exe_link_info) + return (Just link_info /= m_exe_link_info) + +ghcLinkInfoSectionName :: String +ghcLinkInfoSectionName = ".debug-ghc-link-info" + -- if we use the ".debug" prefix, then strip will strip it by default findHSLib :: [String] -> String -> IO (Maybe FilePath) findHSLib dirs lib = do @@ -436,7 +452,7 @@ compileFile hsc_env stop_phase (src, mb_phase) = do ( _, out_file) <- runPipeline stop_phase' hsc_env (src, mb_phase) Nothing output - Nothing{-no ModLocation-} + Nothing{-no ModLocation-} Nothing return out_file @@ -482,9 +498,11 @@ runPipeline -> Maybe FilePath -- ^ original basename (if different from ^^^) -> PipelineOutput -- ^ Output filename -> Maybe ModLocation -- ^ A ModLocation, if this is a Haskell module + -> Maybe FilePath -- ^ stub object, if we have one -> IO (DynFlags, FilePath) -- ^ (final flags, output filename) -runPipeline stop_phase hsc_env0 (input_fn, mb_phase) mb_basename output maybe_loc +runPipeline stop_phase hsc_env0 (input_fn, mb_phase) + mb_basename output maybe_loc maybe_stub_o = do let dflags0 = hsc_dflags hsc_env0 (input_basename, suffix) = splitExtension input_fn @@ -516,9 +534,17 @@ runPipeline stop_phase hsc_env0 (input_fn, mb_phase) mb_basename output maybe_lo let get_output_fn = getOutputFilename stop_phase output basename -- Execute the pipeline... - (dflags', output_fn, maybe_loc) <- - pipeLoop hsc_env start_phase stop_phase input_fn - basename suffix' get_output_fn maybe_loc + let env = PipeEnv{ stop_phase, + src_basename = basename, + src_suffix = suffix', + output_spec = output } + + state = PipeState{ hsc_env, maybe_loc, maybe_stub_o = maybe_stub_o } + + (state', output_fn) <- unP (pipeLoop start_phase input_fn) env state + + let PipeState{ hsc_env=hsc_env', maybe_loc } = state' + dflags' = hsc_dflags hsc_env' -- Sometimes, a compilation phase doesn't actually generate any output -- (eg. the CPP phase when -fcpp is not turned on). If we end on this @@ -536,38 +562,102 @@ runPipeline stop_phase hsc_env0 (input_fn, mb_phase) mb_basename output maybe_lo copyWithHeader dflags msg line_prag output_fn final_fn return (dflags', final_fn) +-- ----------------------------------------------------------------------------- +-- The pipeline uses a monad to carry around various bits of information + +-- PipeEnv: invariant information passed down +data PipeEnv = PipeEnv { + stop_phase :: Phase, -- ^ Stop just before this phase + src_basename :: String, -- ^ basename of original input source + src_suffix :: String, -- ^ its extension + output_spec :: PipelineOutput -- ^ says where to put the pipeline output + } + +-- PipeState: information that might change during a pipeline run +data PipeState = PipeState { + hsc_env :: HscEnv, + -- ^ only the DynFlags change in the HscEnv. The DynFlags change + -- at various points, for example when we read the OPTIONS_GHC + -- pragmas in the Cpp phase. + maybe_loc :: Maybe ModLocation, + -- ^ the ModLocation. This is discovered during compilation, + -- in the Hsc phase where we read the module header. + maybe_stub_o :: Maybe FilePath + -- ^ the stub object. This is set by the Hsc phase if a stub + -- object was created. The stub object will be joined with + -- the main compilation object using "ld -r" at the end. + } + +getPipeEnv :: CompPipeline PipeEnv +getPipeEnv = P $ \env state -> return (state, env) + +getPipeState :: CompPipeline PipeState +getPipeState = P $ \_env state -> return (state, state) + +getDynFlags :: CompPipeline DynFlags +getDynFlags = P $ \_env state -> return (state, hsc_dflags (hsc_env state)) + +setDynFlags :: DynFlags -> CompPipeline () +setDynFlags dflags = P $ \_env state -> + return (state{hsc_env= (hsc_env state){ hsc_dflags = dflags }}, ()) + +setModLocation :: ModLocation -> CompPipeline () +setModLocation loc = P $ \_env state -> + return (state{ maybe_loc = Just loc }, ()) + +setStubO :: FilePath -> CompPipeline () +setStubO stub_o = P $ \_env state -> + return (state{ maybe_stub_o = Just stub_o }, ()) + +newtype CompPipeline a = P { unP :: PipeEnv -> PipeState -> IO (PipeState, a) } + +instance Monad CompPipeline where + return a = P $ \_env state -> return (state, a) + P m >>= k = P $ \env state -> do (state',a) <- m env state + unP (k a) env state' + +io :: IO a -> CompPipeline a +io m = P $ \_env state -> do a <- m; return (state, a) + +phaseOutputFilename :: Phase{-next phase-} -> CompPipeline FilePath +phaseOutputFilename next_phase = do + PipeEnv{stop_phase, src_basename, output_spec} <- getPipeEnv + PipeState{maybe_loc, hsc_env} <- getPipeState + let dflags = hsc_dflags hsc_env + io $ getOutputFilename stop_phase output_spec + src_basename dflags next_phase maybe_loc - -pipeLoop :: HscEnv -> Phase -> Phase - -> FilePath -> String -> Suffix - -> (DynFlags -> Phase -> Maybe ModLocation -> IO FilePath) - -> Maybe ModLocation - -> IO (DynFlags, FilePath, Maybe ModLocation) - -pipeLoop hsc_env phase stop_phase - input_fn orig_basename orig_suff - orig_get_output_fn maybe_loc - - | phase `eqPhase` stop_phase -- All done - = return (hsc_dflags hsc_env, input_fn, maybe_loc) - - | not (phase `happensBefore` stop_phase) +-- --------------------------------------------------------------------------- +-- outer pipeline loop + +-- | pipeLoop runs phases until we reach the stop phase +pipeLoop :: Phase -> FilePath -> CompPipeline FilePath +pipeLoop phase input_fn = do + PipeEnv{stop_phase} <- getPipeEnv + PipeState{hsc_env} <- getPipeState + case () of + _ | phase `eqPhase` stop_phase -- All done + -> return input_fn + + | not (phase `happensBefore` stop_phase) -- Something has gone wrong. We'll try to cover all the cases when -- this could happen, so if we reach here it is a panic. -- eg. it might happen if the -C flag is used on a source file that -- has {-# OPTIONS -fasm #-}. - = panic ("pipeLoop: at phase " ++ show phase ++ + -> panic ("pipeLoop: at phase " ++ show phase ++ " but I wanted to stop at phase " ++ show stop_phase) - | otherwise - = do debugTraceMsg (hsc_dflags hsc_env) 4 + | otherwise + -> do io $ debugTraceMsg (hsc_dflags hsc_env) 4 (ptext (sLit "Running phase") <+> ppr phase) - (next_phase, dflags', maybe_loc, output_fn) - <- runPhase phase stop_phase hsc_env orig_basename - orig_suff input_fn orig_get_output_fn maybe_loc - let hsc_env' = hsc_env {hsc_dflags = dflags'} - pipeLoop hsc_env' next_phase stop_phase output_fn - orig_basename orig_suff orig_get_output_fn maybe_loc + dflags <- getDynFlags + (next_phase, output_fn) <- runPhase phase input_fn dflags + pipeLoop next_phase output_fn + +-- ----------------------------------------------------------------------------- +-- In each phase, we need to know into what filename to generate the +-- output. All the logic about which filenames we generate output +-- into is embodied in the following function. getOutputFilename :: Phase -> PipelineOutput -> String @@ -585,21 +675,19 @@ getOutputFilename stop_phase output basename odir = objectDir dflags osuf = objectSuf dflags keep_hc = dopt Opt_KeepHcFiles dflags - keep_raw_s = dopt Opt_KeepRawSFiles dflags keep_s = dopt Opt_KeepSFiles dflags keep_bc = dopt Opt_KeepLlvmFiles dflags - myPhaseInputExt HCc = hcsuf - myPhaseInputExt StopLn = osuf - myPhaseInputExt other = phaseInputExt other + myPhaseInputExt HCc = hcsuf + myPhaseInputExt MergeStub = osuf + myPhaseInputExt StopLn = osuf + myPhaseInputExt other = phaseInputExt other is_last_phase = next_phase `eqPhase` stop_phase -- sometimes, we keep output from intermediate stages keep_this_output = case next_phase of - StopLn -> True - Mangle | keep_raw_s -> True As | keep_s -> True LlvmOpt | keep_bc -> True HCc | keep_hc -> True @@ -630,31 +718,23 @@ getOutputFilename stop_phase output basename -- of a source file can change the latter stages of the pipeline from -- taking the via-C route to using the native code generator. -- -runPhase :: Phase -- ^ Do this phase first - -> Phase -- ^ Stop just before this phase - -> HscEnv - -> String -- ^ basename of original input source - -> String -- ^ its extension - -> FilePath -- ^ name of file which contains the input to this phase. - -> (DynFlags -> Phase -> Maybe ModLocation -> IO FilePath) - -- ^ how to calculate the output filename - -> Maybe ModLocation -- ^ the ModLocation, if we have one - -> IO (Phase, -- next phase - DynFlags, -- new dynamic flags - Maybe ModLocation, -- the ModLocation, if we have one - FilePath) -- output filename +runPhase :: Phase -- ^ Run this phase + -> FilePath -- ^ name of the input file + -> DynFlags -- ^ for convenience, we pass the current dflags in + -> CompPipeline (Phase, -- next phase to run + FilePath) -- output filename -- Invariant: the output filename always contains the output -- Interesting case: Hsc when there is no recompilation to do -- Then the output filename is still a .o file + ------------------------------------------------------------------------------- -- Unlit phase -runPhase (Unlit sf) _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc +runPhase (Unlit sf) input_fn dflags = do - let dflags = hsc_dflags hsc_env - output_fn <- get_output_fn dflags (Cpp sf) maybe_loc + output_fn <- phaseOutputFilename (Cpp sf) let unlit_flags = getOpts dflags opt_L flags = map SysTools.Option unlit_flags ++ @@ -668,56 +748,60 @@ runPhase (Unlit sf) _stop hsc_env _basename _suff input_fn get_output_fn maybe_l , SysTools.FileOption "" output_fn ] - SysTools.runUnlit dflags flags + io $ SysTools.runUnlit dflags flags - return (Cpp sf, dflags, maybe_loc, output_fn) + return (Cpp sf, output_fn) ------------------------------------------------------------------------------- -- Cpp phase : (a) gets OPTIONS out of file -- (b) runs cpp if necessary -runPhase (Cpp sf) _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc - = do let dflags0 = hsc_dflags hsc_env - src_opts <- getOptionsFromFile dflags0 input_fn +runPhase (Cpp sf) input_fn dflags0 + = do + src_opts <- io $ getOptionsFromFile dflags0 input_fn (dflags1, unhandled_flags, warns) - <- parseDynamicNoPackageFlags dflags0 src_opts - checkProcessArgsResult unhandled_flags + <- io $ parseDynamicNoPackageFlags dflags0 src_opts + setDynFlags dflags1 + io $ checkProcessArgsResult unhandled_flags if not (xopt Opt_Cpp dflags1) then do -- we have to be careful to emit warnings only once. - unless (dopt Opt_Pp dflags1) $ handleFlagWarnings dflags1 warns + unless (dopt Opt_Pp dflags1) $ io $ handleFlagWarnings dflags1 warns -- no need to preprocess CPP, just pass input file along -- to the next phase of the pipeline. - return (HsPp sf, dflags1, maybe_loc, input_fn) + return (HsPp sf, input_fn) else do - output_fn <- get_output_fn dflags1 (HsPp sf) maybe_loc - doCpp dflags1 True{-raw-} False{-no CC opts-} input_fn output_fn + output_fn <- phaseOutputFilename (HsPp sf) + io $ doCpp dflags1 True{-raw-} False{-no CC opts-} input_fn output_fn -- re-read the pragmas now that we've preprocessed the file -- See #2464,#3457 - src_opts <- getOptionsFromFile dflags0 output_fn + src_opts <- io $ getOptionsFromFile dflags0 output_fn (dflags2, unhandled_flags, warns) - <- parseDynamicNoPackageFlags dflags0 src_opts - unless (dopt Opt_Pp dflags2) $ handleFlagWarnings dflags2 warns + <- io $ parseDynamicNoPackageFlags dflags0 src_opts + unless (dopt Opt_Pp dflags2) $ io $ handleFlagWarnings dflags2 warns -- the HsPp pass below will emit warnings - checkProcessArgsResult unhandled_flags + io $ checkProcessArgsResult unhandled_flags - return (HsPp sf, dflags2, maybe_loc, output_fn) + setDynFlags dflags2 + + return (HsPp sf, output_fn) ------------------------------------------------------------------------------- -- HsPp phase -runPhase (HsPp sf) _stop hsc_env basename suff input_fn get_output_fn maybe_loc - = do let dflags = hsc_dflags hsc_env +runPhase (HsPp sf) input_fn dflags + = do if not (dopt Opt_Pp dflags) then -- no need to preprocess, just pass input file along -- to the next phase of the pipeline. - return (Hsc sf, dflags, maybe_loc, input_fn) + return (Hsc sf, input_fn) else do let hspp_opts = getOpts dflags opt_F - let orig_fn = basename <.> suff - output_fn <- get_output_fn dflags (Hsc sf) maybe_loc - SysTools.runPp dflags + PipeEnv{src_basename, src_suffix} <- getPipeEnv + let orig_fn = src_basename <.> src_suffix + output_fn <- phaseOutputFilename (Hsc sf) + io $ SysTools.runPp dflags ( [ SysTools.Option orig_fn , SysTools.Option input_fn , SysTools.FileOption "" output_fn @@ -726,22 +810,26 @@ runPhase (HsPp sf) _stop hsc_env basename suff input_fn get_output_fn maybe_loc ) -- re-read pragmas now that we've parsed the file (see #3674) - src_opts <- getOptionsFromFile dflags output_fn + src_opts <- io $ getOptionsFromFile dflags output_fn (dflags1, unhandled_flags, warns) - <- parseDynamicNoPackageFlags dflags src_opts - handleFlagWarnings dflags1 warns - checkProcessArgsResult unhandled_flags + <- io $ parseDynamicNoPackageFlags dflags src_opts + setDynFlags dflags1 + io $ handleFlagWarnings dflags1 warns + io $ checkProcessArgsResult unhandled_flags - return (Hsc sf, dflags1, maybe_loc, output_fn) + return (Hsc sf, output_fn) ----------------------------------------------------------------------------- -- Hsc phase -- Compilation of a single module, in "legacy" mode (_not_ under -- the direction of the compilation manager). -runPhase (Hsc src_flavour) stop hsc_env basename suff input_fn get_output_fn _maybe_loc +runPhase (Hsc src_flavour) input_fn dflags0 = do -- normal Hsc mode, not mkdependHS - let dflags0 = hsc_dflags hsc_env + + PipeEnv{ stop_phase=stop, + src_basename=basename, + src_suffix=suff } <- getPipeEnv -- we add the current directory (i.e. the directory in which -- the .hs files resides) to the include path, since this is @@ -753,8 +841,10 @@ runPhase (Hsc src_flavour) stop hsc_env basename suff input_fn get_output_fn _ma paths = includePaths dflags0 dflags = dflags0 { includePaths = current_dir : paths } + setDynFlags dflags + -- gather the imports and module name - (hspp_buf,mod_name,imps,src_imps) <- + (hspp_buf,mod_name,imps,src_imps) <- io $ case src_flavour of ExtCoreFile -> do -- no explicit imports in ExtCore input. m <- getCoreModuleName input_fn @@ -771,7 +861,7 @@ runPhase (Hsc src_flavour) stop hsc_env basename suff input_fn get_output_fn _ma -- the .hi and .o filenames, and this is as good a way -- as any to generate them, and better than most. (e.g. takes -- into accout the -osuf flags) - location1 <- mkHomeModLocation2 dflags mod_name basename suff + location1 <- io $ mkHomeModLocation2 dflags mod_name basename suff -- Boot-ify it if necessary let location2 | isHsBoot src_flavour = addBootSuffixLocn location1 @@ -798,6 +888,7 @@ runPhase (Hsc src_flavour) stop hsc_env basename suff input_fn get_output_fn _ma o_file = ml_obj_file location4 -- The real object file + setModLocation location4 -- Figure out if the source has changed, for recompilation avoidance. -- @@ -806,11 +897,11 @@ runPhase (Hsc src_flavour) stop hsc_env basename suff input_fn get_output_fn _ma -- changed (which the compiler itself figures out). -- Setting source_unchanged to False tells the compiler that M.o is out of -- date wrt M.hs (or M.o doesn't exist) so we must recompile regardless. - src_timestamp <- getModificationTime (basename <.> suff) + src_timestamp <- io $ getModificationTime (basename <.> suff) let force_recomp = dopt Opt_ForceRecomp dflags - hsc_lang = hscMaybeAdjustTarget dflags stop src_flavour (hscTarget dflags) - source_unchanged <- + hsc_lang = hscTarget dflags + source_unchanged <- io $ if force_recomp || not (isStopLn stop) -- Set source_unchanged to False unconditionally if -- (a) recompilation checker is off, or @@ -827,16 +918,17 @@ runPhase (Hsc src_flavour) stop hsc_env basename suff input_fn get_output_fn _ma -- get the DynFlags let next_phase = hscNextPhase dflags src_flavour hsc_lang - output_fn <- get_output_fn dflags next_phase (Just location4) + output_fn <- phaseOutputFilename next_phase let dflags' = dflags { hscTarget = hsc_lang, hscOutName = output_fn, extCoreName = basename ++ ".hcr" } - let hsc_env' = hsc_env {hsc_dflags = dflags'} + setDynFlags dflags' + PipeState{hsc_env=hsc_env'} <- getPipeState -- Tell the finder cache about this module - mod <- addHomeModuleToFinder hsc_env' mod_name location4 + mod <- io $ addHomeModuleToFinder hsc_env' mod_name location4 -- Make the ModSummary to hand to hscMain let @@ -852,58 +944,64 @@ runPhase (Hsc src_flavour) stop hsc_env basename suff input_fn get_output_fn _ma ms_srcimps = src_imps } -- run the compiler! - result <- hscCompileOneShot hsc_env' + result <- io $ hscCompileOneShot hsc_env' mod_summary source_unchanged Nothing -- No iface Nothing -- No "module i of n" progress info case result of HscNoRecomp - -> do SysTools.touch dflags' "Touching object file" o_file + -> do io $ SysTools.touch dflags' "Touching object file" o_file -- The .o file must have a later modification date -- than the source file (else we wouldn't be in HscNoRecomp) -- but we touch it anyway, to keep 'make' happy (we think). - return (StopLn, dflags', Just location4, o_file) + return (StopLn, o_file) (HscRecomp hasStub _) - -> do when hasStub $ - do stub_o <- compileStub hsc_env' mod location4 - liftIO $ consIORef v_Ld_inputs stub_o + -> do case hasStub of + Nothing -> return () + Just stub_c -> + do stub_o <- io $ compileStub hsc_env' stub_c + setStubO stub_o -- In the case of hs-boot files, generate a dummy .o-boot -- stamp file for the benefit of Make when (isHsBoot src_flavour) $ - SysTools.touch dflags' "Touching object file" o_file - return (next_phase, dflags', Just location4, output_fn) + io $ SysTools.touch dflags' "Touching object file" o_file + return (next_phase, output_fn) ----------------------------------------------------------------------------- -- Cmm phase -runPhase CmmCpp _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc +runPhase CmmCpp input_fn dflags = do - let dflags = hsc_dflags hsc_env - output_fn <- get_output_fn dflags Cmm maybe_loc - doCpp dflags False{-not raw-} True{-include CC opts-} input_fn output_fn - return (Cmm, dflags, maybe_loc, output_fn) + output_fn <- phaseOutputFilename Cmm + io $ doCpp dflags False{-not raw-} True{-include CC opts-} + input_fn output_fn + return (Cmm, output_fn) -runPhase Cmm stop hsc_env basename _ input_fn get_output_fn maybe_loc +runPhase Cmm input_fn dflags = do - let dflags = hsc_dflags hsc_env - let hsc_lang = hscMaybeAdjustTarget dflags stop HsSrcFile (hscTarget dflags) + PipeEnv{src_basename} <- getPipeEnv + let hsc_lang = hscTarget dflags + let next_phase = hscNextPhase dflags HsSrcFile hsc_lang - output_fn <- get_output_fn dflags next_phase maybe_loc + + output_fn <- phaseOutputFilename next_phase let dflags' = dflags { hscTarget = hsc_lang, hscOutName = output_fn, - extCoreName = basename ++ ".hcr" } - let hsc_env' = hsc_env {hsc_dflags = dflags'} + extCoreName = src_basename ++ ".hcr" } - hscCompileCmmFile hsc_env' input_fn + setDynFlags dflags' + PipeState{hsc_env} <- getPipeState + + io $ hscCompileCmmFile hsc_env input_fn -- XXX: catch errors above and convert them into ghcError? Original -- code was: -- --when (not ok) $ ghcError (PhaseFailed "cmm" (ExitFailure 1)) - return (next_phase, dflags, maybe_loc, output_fn) + return (next_phase, output_fn) ----------------------------------------------------------------------------- -- Cc phase @@ -911,26 +1009,26 @@ runPhase Cmm stop hsc_env basename _ input_fn get_output_fn maybe_loc -- we don't support preprocessing .c files (with -E) now. Doing so introduces -- way too many hacks, and I can't say I've ever used it anyway. -runPhase cc_phase _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc - | cc_phase `eqPhase` Cc || cc_phase `eqPhase` Ccpp || cc_phase `eqPhase` HCc - = do let dflags = hsc_dflags hsc_env +runPhase cc_phase input_fn dflags + | cc_phase `eqPhase` Cc || cc_phase `eqPhase` Ccpp || cc_phase `eqPhase` HCc || cc_phase `eqPhase` Cobjc + = do let cc_opts = getOpts dflags opt_c hcc = cc_phase `eqPhase` HCc let cmdline_include_paths = includePaths dflags -- HC files have the dependent packages stamped into them - pkgs <- if hcc then getHCFilePackages input_fn else return [] + pkgs <- if hcc then io $ getHCFilePackages input_fn else return [] -- add package include paths even if we're just compiling .c -- files; this is the Value Add(TM) that using ghc instead of -- gcc gives you :) - pkg_include_dirs <- getPackageIncludePath dflags pkgs + pkg_include_dirs <- io $ getPackageIncludePath dflags pkgs let include_paths = foldr (\ x xs -> "-I" : x : xs) [] (cmdline_include_paths ++ pkg_include_dirs) - let (md_c_flags, md_regd_c_flags) = machdepCCOpts dflags - gcc_extra_viac_flags <- getExtraViaCOpts dflags + let md_c_flags = machdepCCOpts dflags + gcc_extra_viac_flags <- io $ getExtraViaCOpts dflags let pic_c_flags = picCCOpts dflags let verb = getVerbFlag dflags @@ -938,13 +1036,13 @@ runPhase cc_phase _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc -- cc-options are not passed when compiling .hc files. Our -- hc code doesn't not #include any header files anyway, so these -- options aren't necessary. - pkg_extra_cc_opts <- + pkg_extra_cc_opts <- io $ if cc_phase `eqPhase` HCc then return [] else getPackageExtraCcOpts dflags pkgs #ifdef darwin_TARGET_OS - pkg_framework_paths <- getPackageFrameworkPath dflags pkgs + pkg_framework_paths <- io $ getPackageFrameworkPath dflags pkgs let cmdline_framework_paths = frameworkPaths dflags let framework_paths = map ("-F"++) (cmdline_framework_paths ++ pkg_framework_paths) @@ -959,11 +1057,8 @@ runPhase cc_phase _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc -- Decide next phase - let mangle = dopt Opt_DoAsmMangling dflags - next_phase - | hcc && mangle = Mangle - | otherwise = As - output_fn <- get_output_fn dflags next_phase maybe_loc + let next_phase = As + output_fn <- phaseOutputFilename next_phase let more_hcc_opts = @@ -983,15 +1078,16 @@ runPhase cc_phase _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc -- very weakly typed, being derived from C--. ["-fno-strict-aliasing"] - SysTools.runCc dflags ( + let gcc_lang_opt | cc_phase `eqPhase` Ccpp = "c++" + | cc_phase `eqPhase` Cobjc = "objective-c" + | otherwise = "c" + io $ SysTools.runCc dflags ( -- force the C compiler to interpret this file as C when -- compiling .hc files, by adding the -x c option. -- Also useful for plain .c files, just in case GHC saw a -- -x c option. - [ SysTools.Option "-x", if cc_phase `eqPhase` Ccpp - then SysTools.Option "c++" - else SysTools.Option "c"] ++ - [ SysTools.FileOption "" input_fn + [ SysTools.Option "-x", SysTools.Option gcc_lang_opt + , SysTools.FileOption "" input_fn , SysTools.Option "-o" , SysTools.FileOption "" output_fn ] @@ -1019,18 +1115,8 @@ runPhase cc_phase _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc -- This is a temporary hack. ++ ["-mcpu=v9"] #endif - ++ (if hcc && mangle - then md_regd_c_flags - else []) - ++ (if hcc - then if mangle - then gcc_extra_viac_flags - else filter (=="-fwrapv") - gcc_extra_viac_flags - -- still want -fwrapv even for unreg'd - else []) ++ (if hcc - then more_hcc_opts + then gcc_extra_viac_flags ++ more_hcc_opts else []) ++ [ verb, "-S", "-Wimplicit", cc_opt ] ++ [ "-D__GLASGOW_HASKELL__="++cProjectVersionInt ] @@ -1043,81 +1129,56 @@ runPhase cc_phase _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc ++ pkg_extra_cc_opts )) - return (next_phase, dflags, maybe_loc, output_fn) + return (next_phase, output_fn) -- ToDo: postprocess the output from gcc ----------------------------------------------------------------------------- --- Mangle phase - -runPhase Mangle _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc - = do let dflags = hsc_dflags hsc_env - let mangler_opts = getOpts dflags opt_m - -#if i386_TARGET_ARCH - machdep_opts <- return [ show (stolen_x86_regs dflags) ] -#else - machdep_opts <- return [] -#endif - - let split = dopt Opt_SplitObjs dflags - next_phase - | split = SplitMangle - | otherwise = As - output_fn <- get_output_fn dflags next_phase maybe_loc - - SysTools.runMangle dflags (map SysTools.Option mangler_opts - ++ [ SysTools.FileOption "" input_fn - , SysTools.FileOption "" output_fn - ] - ++ map SysTools.Option machdep_opts) - - return (next_phase, dflags, maybe_loc, output_fn) - ------------------------------------------------------------------------------ -- Splitting phase -runPhase SplitMangle _stop hsc_env _basename _suff input_fn _get_output_fn maybe_loc +runPhase SplitMangle input_fn dflags = do -- tmp_pfx is the prefix used for the split .s files - -- We also use it as the file to contain the no. of split .s files (sigh) - let dflags = hsc_dflags hsc_env - split_s_prefix <- SysTools.newTempName dflags "split" + + split_s_prefix <- io $ SysTools.newTempName dflags "split" let n_files_fn = split_s_prefix - SysTools.runSplit dflags + io $ SysTools.runSplit dflags [ SysTools.FileOption "" input_fn , SysTools.FileOption "" split_s_prefix , SysTools.FileOption "" n_files_fn ] -- Save the number of split files for future references - s <- readFile n_files_fn + s <- io $ readFile n_files_fn let n_files = read s :: Int dflags' = dflags { splitInfo = Just (split_s_prefix, n_files) } + setDynFlags dflags' + -- Remember to delete all these files - addFilesToClean dflags' [ split_s_prefix ++ "__" ++ show n ++ ".s" - | n <- [1..n_files]] + io $ addFilesToClean dflags' [ split_s_prefix ++ "__" ++ show n ++ ".s" + | n <- [1..n_files]] - return (SplitAs, dflags', maybe_loc, "**splitmangle**") + return (SplitAs, "**splitmangle**") -- we don't use the filename ----------------------------------------------------------------------------- -- As phase -runPhase As _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc - = do let dflags = hsc_dflags hsc_env +runPhase As input_fn dflags + = do let as_opts = getOpts dflags opt_a let cmdline_include_paths = includePaths dflags - output_fn <- get_output_fn dflags StopLn maybe_loc + next_phase <- maybeMergeStub + output_fn <- phaseOutputFilename next_phase -- we create directories for the object file, because it -- might be a hierarchical module. - createDirectoryHierarchy (takeDirectory output_fn) + io $ createDirectoryHierarchy (takeDirectory output_fn) - let (md_c_flags, _) = machdepCCOpts dflags - SysTools.runAs dflags + let md_c_flags = machdepCCOpts dflags + io $ SysTools.runAs dflags (map SysTools.Option as_opts ++ [ SysTools.Option ("-I" ++ p) | p <- cmdline_include_paths ] #ifdef sparc_TARGET_ARCH @@ -1137,24 +1198,27 @@ runPhase As _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc ] ++ map SysTools.Option md_c_flags) - return (StopLn, dflags, maybe_loc, output_fn) + return (next_phase, output_fn) -runPhase SplitAs _stop hsc_env _basename _suff _input_fn get_output_fn maybe_loc +runPhase SplitAs _input_fn dflags = do - let dflags = hsc_dflags hsc_env - output_fn <- get_output_fn dflags StopLn maybe_loc + -- we'll handle the stub_o file in this phase, so don't MergeStub, + -- just jump straight to StopLn afterwards. + let next_phase = StopLn + output_fn <- phaseOutputFilename next_phase let base_o = dropExtension output_fn osuf = objectSuf dflags split_odir = base_o ++ "_" ++ osuf ++ "_split" - createDirectoryHierarchy split_odir + io $ createDirectoryHierarchy split_odir -- remove M_split/ *.o, because we're going to archive M_split/ *.o -- later and we don't want to pick up any old objects. - fs <- getDirectoryContents split_odir - mapM_ removeFile $ map (split_odir ) $ filter (osuf `isSuffixOf`) fs + fs <- io $ getDirectoryContents split_odir + io $ mapM_ removeFile $ + map (split_odir ) $ filter (osuf `isSuffixOf`) fs let as_opts = getOpts dflags opt_a @@ -1163,10 +1227,12 @@ runPhase SplitAs _stop hsc_env _basename _suff _input_fn get_output_fn maybe_loc Just x -> x let split_s n = split_s_prefix ++ "__" ++ show n <.> "s" + + split_obj :: Int -> FilePath split_obj n = split_odir takeFileName base_o ++ "__" ++ show n <.> osuf - let (md_c_flags, _) = machdepCCOpts dflags + let md_c_flags = machdepCCOpts dflags let assemble_file n = SysTools.runAs dflags (map SysTools.Option as_opts ++ @@ -1187,19 +1253,41 @@ runPhase SplitAs _stop hsc_env _basename _suff _input_fn get_output_fn maybe_loc ] ++ map SysTools.Option md_c_flags) - mapM_ assemble_file [1..n] + io $ mapM_ assemble_file [1..n] + + -- Note [pipeline-split-init] + -- If we have a stub file, it may contain constructor + -- functions for initialisation of this module. We can't + -- simply leave the stub as a separate object file, because it + -- will never be linked in: nothing refers to it. We need to + -- ensure that if we ever refer to the data in this module + -- that needs initialisation, then we also pull in the + -- initialisation routine. + -- + -- To that end, we make a DANGEROUS ASSUMPTION here: the data + -- that needs to be initialised is all in the FIRST split + -- object. See Note [codegen-split-init]. + + PipeState{maybe_stub_o} <- getPipeState + case maybe_stub_o of + Nothing -> return () + Just stub_o -> io $ do + tmp_split_1 <- newTempName dflags osuf + let split_1 = split_obj 1 + copyFile split_1 tmp_split_1 + removeFile split_1 + joinObjectFiles dflags [tmp_split_1, stub_o] split_1 -- join them into a single .o file - joinObjectFiles dflags (map split_obj [1..n]) output_fn + io $ joinObjectFiles dflags (map split_obj [1..n]) output_fn - return (StopLn, dflags, maybe_loc, output_fn) + return (next_phase, output_fn) ----------------------------------------------------------------------------- -- LlvmOpt phase -runPhase LlvmOpt _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc +runPhase LlvmOpt input_fn dflags = do - let dflags = hsc_dflags hsc_env let lo_opts = getOpts dflags opt_lo let opt_lvl = max 0 (min 2 $ optLevel dflags) -- don't specify anything if user has specified commands. We do this for @@ -1210,16 +1298,16 @@ runPhase LlvmOpt _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc then [SysTools.Option (llvmOpts !! opt_lvl)] else [] - output_fn <- get_output_fn dflags LlvmLlc maybe_loc + output_fn <- phaseOutputFilename LlvmLlc - SysTools.runLlvmOpt dflags + io $ SysTools.runLlvmOpt dflags ([ SysTools.FileOption "" input_fn, SysTools.Option "-o", SysTools.FileOption "" output_fn] ++ optFlag ++ map SysTools.Option lo_opts) - return (LlvmLlc, dflags, maybe_loc, output_fn) + return (LlvmLlc, output_fn) where -- we always (unless -optlo specified) run Opt since we rely on it to -- fix up some pretty big deficiencies in the code we generate @@ -1229,9 +1317,8 @@ runPhase LlvmOpt _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc ----------------------------------------------------------------------------- -- LlvmLlc phase -runPhase LlvmLlc _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc +runPhase LlvmLlc input_fn dflags = do - let dflags = hsc_dflags hsc_env let lc_opts = getOpts dflags opt_lc let opt_lvl = max 0 (min 2 $ optLevel dflags) #if darwin_TARGET_OS @@ -1243,16 +1330,16 @@ runPhase LlvmLlc _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc | not opt_Static = "dynamic-no-pic" | otherwise = "static" - output_fn <- get_output_fn dflags nphase maybe_loc + output_fn <- phaseOutputFilename nphase - SysTools.runLlvmLlc dflags + io $ SysTools.runLlvmLlc dflags ([ SysTools.Option (llvmOpts !! opt_lvl), SysTools.Option $ "-relocation-model=" ++ rmodel, SysTools.FileOption "" input_fn, SysTools.Option "-o", SysTools.FileOption "" output_fn] ++ map SysTools.Option lc_opts) - return (nphase, dflags, maybe_loc, output_fn) + return (nphase, output_fn) where #if darwin_TARGET_OS llvmOpts = ["-O1", "-O2", "-O2"] @@ -1264,17 +1351,36 @@ runPhase LlvmLlc _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc ----------------------------------------------------------------------------- -- LlvmMangle phase -runPhase LlvmMangle _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc +runPhase LlvmMangle input_fn _dflags = do - let dflags = hsc_dflags hsc_env - output_fn <- get_output_fn dflags As maybe_loc - llvmFixupAsm input_fn output_fn - return (As, dflags, maybe_loc, output_fn) + output_fn <- phaseOutputFilename As + io $ llvmFixupAsm input_fn output_fn + return (As, output_fn) + +----------------------------------------------------------------------------- +-- merge in stub objects +runPhase MergeStub input_fn dflags + = do + PipeState{maybe_stub_o} <- getPipeState + output_fn <- phaseOutputFilename StopLn + case maybe_stub_o of + Nothing -> + panic "runPhase(MergeStub): no stub" + Just stub_o -> do + io $ joinObjectFiles dflags [input_fn, stub_o] output_fn + return (StopLn, output_fn) -- warning suppression -runPhase other _stop _dflags _basename _suff _input_fn _get_output_fn _maybe_loc = +runPhase other _input_fn _dflags = panic ("runPhase: don't know how to run phase " ++ show other) + +maybeMergeStub :: CompPipeline Phase +maybeMergeStub + = do + PipeState{maybe_stub_o} <- getPipeState + if isJust maybe_stub_o then return MergeStub else return StopLn + ----------------------------------------------------------------------------- -- MoveBinary sort-of-phase -- After having produced a binary, move it somewhere else and generate a @@ -1306,13 +1412,13 @@ runPhase_MoveBinary dflags input_fn return True | otherwise = return True -mkExtraCObj :: DynFlags -> [String] -> IO FilePath +mkExtraCObj :: DynFlags -> String -> IO FilePath mkExtraCObj dflags xs = do cFile <- newTempName dflags "c" oFile <- newTempName dflags "o" - writeFile cFile $ unlines xs + writeFile cFile xs let rtsDetails = getPackageDetails (pkgState dflags) rtsPackageId - (md_c_flags, _) = machdepCCOpts dflags + md_c_flags = machdepCCOpts dflags SysTools.runCc dflags ([Option "-c", FileOption "" cFile, @@ -1322,19 +1428,69 @@ mkExtraCObj dflags xs map Option md_c_flags) return oFile -mkRtsOptionsLevelObj :: DynFlags -> IO [FilePath] -mkRtsOptionsLevelObj dflags - = do let mkRtsEnabledObj val - = do fn <- mkExtraCObj dflags - ["#include \"Rts.h\"", - "#include \"RtsOpts.h\"", - "const rtsOptsEnabledEnum rtsOptsEnabled = " - ++ val ++ ";"] - return [fn] - case rtsOptsEnabled dflags of - RtsOptsNone -> mkRtsEnabledObj "rtsOptsNone" - RtsOptsSafeOnly -> return [] -- The default - RtsOptsAll -> mkRtsEnabledObj "rtsOptsAll" +mkExtraObjToLinkIntoBinary :: DynFlags -> [PackageId] -> IO FilePath +mkExtraObjToLinkIntoBinary dflags dep_packages = do + link_info <- getLinkInfo dflags dep_packages + mkExtraCObj dflags (showSDoc (vcat [rts_opts_enabled, + extra_rts_opts, + link_opts link_info] + <> char '\n')) -- final newline, to + -- keep gcc happy + + where + mk_rts_opts_enabled val + = vcat [text "#include \"Rts.h\"", + text "#include \"RtsOpts.h\"", + text "const RtsOptsEnabledEnum rtsOptsEnabled = " <> + text val <> semi ] + + rts_opts_enabled = case rtsOptsEnabled dflags of + RtsOptsNone -> mk_rts_opts_enabled "RtsOptsNone" + RtsOptsSafeOnly -> empty -- The default + RtsOptsAll -> mk_rts_opts_enabled "RtsOptsAll" + + extra_rts_opts = case rtsOpts dflags of + Nothing -> empty + Just opts -> text "char *ghc_rts_opts = " <> text (show opts) <> semi + + link_opts info + | isDarwinTarget = empty + | isWindowsTarget = empty + | otherwise = hcat [ + text "__asm__(\"\\t.section ", text ghcLinkInfoSectionName, + text ",\\\"\\\",@note\\n", + text "\\t.ascii \\\"", info', text "\\\"\\n\");" ] + where + -- we need to escape twice: once because we're inside a C string, + -- and again because we're inside an asm string. + info' = text $ (escape.escape) info + + escape :: String -> String + escape = concatMap (charToC.fromIntegral.ord) + +-- The "link info" is a string representing the parameters of the +-- link. We save this information in the binary, and the next time we +-- link, if nothing else has changed, we use the link info stored in +-- the existing binary to decide whether to re-link or not. +getLinkInfo :: DynFlags -> [PackageId] -> IO String +getLinkInfo dflags dep_packages = do + package_link_opts <- getPackageLinkOpts dflags dep_packages +#ifdef darwin_TARGET_OS + pkg_frameworks <- getPackageFrameworks dflags dep_packages +#endif + extra_ld_inputs <- readIORef v_Ld_inputs + let + link_info = (package_link_opts, +#ifdef darwin_TARGET_OS + pkg_frameworks, +#endif + rtsOpts dflags, + rtsOptsEnabled dflags, + dopt Opt_NoHsMain dflags, + extra_ld_inputs, + getOpts dflags opt_l) + -- + return (show link_info) -- generates a Perl skript starting a parallel prg under PVM mk_pvm_wrapper_script :: String -> String -> String -> String @@ -1446,15 +1602,8 @@ linkBinary dflags o_files dep_packages = do let no_hs_main = dopt Opt_NoHsMain dflags let main_lib | no_hs_main = [] | otherwise = [ "-lHSrtsmain" ] - rtsEnabledObj <- mkRtsOptionsLevelObj dflags - rtsOptsObj <- case rtsOpts dflags of - Just opts -> - do fn <- mkExtraCObj dflags - -- We assume that the Haskell "show" does - -- the right thing here - ["char *ghc_rts_opts = " ++ show opts ++ ";"] - return [fn] - Nothing -> return [] + + extraLinkObj <- mkExtraObjToLinkIntoBinary dflags dep_packages pkg_link_opts <- getPackageLinkOpts dflags dep_packages @@ -1504,7 +1653,7 @@ linkBinary dflags o_files dep_packages = do rc_objs <- maybeCreateManifest dflags output_fn - let (md_c_flags, _) = machdepCCOpts dflags + let md_c_flags = machdepCCOpts dflags SysTools.runLink dflags ( [ SysTools.Option verb , SysTools.Option "-o" @@ -1529,8 +1678,7 @@ linkBinary dflags o_files dep_packages = do #endif ++ pkg_lib_path_opts ++ main_lib - ++ rtsEnabledObj - ++ rtsOptsObj + ++ [extraLinkObj] ++ pkg_link_opts #ifdef darwin_TARGET_OS ++ pkg_framework_path_opts @@ -1657,10 +1805,10 @@ linkDynLib dflags o_files dep_packages = do -- probably _stub.o files extra_ld_inputs <- readIORef v_Ld_inputs - let (md_c_flags, _) = machdepCCOpts dflags + let md_c_flags = machdepCCOpts dflags let extra_ld_opts = getOpts dflags opt_l - rtsEnabledObj <- mkRtsOptionsLevelObj dflags + extraLinkObj <- mkExtraObjToLinkIntoBinary dflags dep_packages #if defined(mingw32_HOST_OS) ----------------------------------------------------------------------------- @@ -1689,7 +1837,7 @@ linkDynLib dflags o_files dep_packages = do ++ lib_path_opts ++ extra_ld_opts ++ pkg_lib_path_opts - ++ rtsEnabledObj + ++ [extraLinkObj] ++ pkg_link_opts )) #elif defined(darwin_TARGET_OS) @@ -1738,12 +1886,15 @@ linkDynLib dflags o_files dep_packages = do md_c_flags ++ o_files ++ [ "-undefined", "dynamic_lookup", "-single_module", - "-Wl,-read_only_relocs,suppress", "-install_name", instName ] +#if !defined(x86_64_TARGET_ARCH) + "-Wl,-read_only_relocs,suppress", +#endif + "-install_name", instName ] ++ extra_ld_inputs ++ lib_path_opts ++ extra_ld_opts ++ pkg_lib_path_opts - ++ rtsEnabledObj + ++ [extraLinkObj] ++ pkg_link_opts )) #else @@ -1778,7 +1929,7 @@ linkDynLib dflags o_files dep_packages = do ++ lib_path_opts ++ extra_ld_opts ++ pkg_lib_path_opts - ++ rtsEnabledObj + ++ [extraLinkObj] ++ pkg_link_opts )) #endif @@ -1801,7 +1952,7 @@ doCpp dflags raw include_cc_opts input_fn output_fn = do | otherwise = (optc ++ md_c_flags) where optc = getOpts dflags opt_c - (md_c_flags, _) = machdepCCOpts dflags + md_c_flags = machdepCCOpts dflags let cpp_prog args | raw = SysTools.runCpp dflags args | otherwise = SysTools.runCc dflags (SysTools.Option "-E" : args) @@ -1849,15 +2000,23 @@ joinObjectFiles dflags o_files output_fn = do SysTools.Option "-nostdlib", SysTools.Option "-nodefaultlibs", SysTools.Option "-Wl,-r", + SysTools.Option ld_build_id, SysTools.Option ld_x_flag, SysTools.Option "-o", SysTools.FileOption "" output_fn ] ++ map SysTools.Option md_c_flags ++ args) + ld_x_flag | null cLD_X = "" | otherwise = "-Wl,-x" - (md_c_flags, _) = machdepCCOpts dflags + -- suppress the generation of the .note.gnu.build-id section, + -- which we don't need and sometimes causes ld to emit a + -- warning: + ld_build_id | cLdHasBuildId == "YES" = "-Wl,--build-id=none" + | otherwise = "" + + md_c_flags = machdepCCOpts dflags if cLdIsGNULd == "YES" then do @@ -1882,19 +2041,3 @@ hscNextPhase dflags _ hsc_lang = HscInterpreted -> StopLn _other -> StopLn - -hscMaybeAdjustTarget :: DynFlags -> Phase -> HscSource -> HscTarget -> HscTarget -hscMaybeAdjustTarget dflags stop _ current_hsc_lang - = hsc_lang - where - keep_hc = dopt Opt_KeepHcFiles dflags - hsc_lang - -- don't change the lang if we're interpreting - | current_hsc_lang == HscInterpreted = current_hsc_lang - - -- force -fvia-C if we are being asked for a .hc file - | HCc <- stop = HscC - | keep_hc = HscC - -- otherwise, stick to the plan - | otherwise = current_hsc_lang - diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 22df6a0..832f2d2 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -113,6 +113,7 @@ data DynFlag -- debugging flags = Opt_D_dump_cmm + | Opt_D_dump_raw_cmm | Opt_D_dump_cmmz | Opt_D_dump_cmmz_pretty | Opt_D_dump_cps_cmm @@ -127,6 +128,7 @@ data DynFlag | Opt_D_dump_asm_stats | Opt_D_dump_asm_expanded | Opt_D_dump_llvm + | Opt_D_dump_core_stats | Opt_D_dump_cpranal | Opt_D_dump_deriv | Opt_D_dump_ds @@ -254,7 +256,6 @@ data DynFlag | Opt_Pp | Opt_ForceRecomp | Opt_DryRun - | Opt_DoAsmMangling | Opt_ExcessPrecision | Opt_EagerBlackHoling | Opt_ReadUserPackageConf @@ -291,7 +292,6 @@ data DynFlag | Opt_KeepHiDiffs | Opt_KeepHcFiles | Opt_KeepSFiles - | Opt_KeepRawSFiles | Opt_KeepTmpFiles | Opt_KeepRawTokenStream | Opt_KeepLlvmFiles @@ -401,7 +401,6 @@ data DynFlags = DynFlags { #ifndef OMIT_NATIVE_CODEGEN targetPlatform :: Platform, -- ^ The platform we're compiling for. Used by the NCG. #endif - stolen_x86_regs :: Int, cmdlineHcIncludes :: [String], -- ^ @\-\#includes@ importPaths :: [FilePath], mainModIs :: Module, @@ -472,7 +471,6 @@ data DynFlags = DynFlags { pgm_P :: (String,[Option]), pgm_F :: String, pgm_c :: (String,[Option]), - pgm_m :: (String,[Option]), pgm_s :: (String,[Option]), pgm_a :: (String,[Option]), pgm_l :: (String,[Option]), @@ -630,6 +628,7 @@ data DynLibLoader deriving Eq data RtsOptsEnabled = RtsOptsNone | RtsOptsSafeOnly | RtsOptsAll + deriving (Show) -- | Used by 'GHC.newSession' to partially initialize a new 'DynFlags' value initDynFlags :: DynFlags -> IO DynFlags @@ -671,7 +670,6 @@ defaultDynFlags = #ifndef OMIT_NATIVE_CODEGEN targetPlatform = defaultTargetPlatform, #endif - stolen_x86_regs = 4, cmdlineHcIncludes = [], importPaths = ["."], mainModIs = mAIN, @@ -736,7 +734,6 @@ defaultDynFlags = pgm_P = panic "defaultDynFlags: No pgm_P", pgm_F = panic "defaultDynFlags: No pgm_F", pgm_c = panic "defaultDynFlags: No pgm_c", - pgm_m = panic "defaultDynFlags: No pgm_m", pgm_s = panic "defaultDynFlags: No pgm_s", pgm_a = panic "defaultDynFlags: No pgm_a", pgm_l = panic "defaultDynFlags: No pgm_l", @@ -898,7 +895,8 @@ setObjectDir f d = d{ objectDir = Just f} setHiDir f d = d{ hiDir = Just f} setStubDir f d = d{ stubDir = Just f, includePaths = f : includePaths d } -- -stubdir D adds an implicit -I D, so that gcc can find the _stub.h file - -- \#included from the .hc file when compiling with -fvia-C. + -- \#included from the .hc file when compiling via C (i.e. unregisterised + -- builds). setOutputDir f = setObjectDir f . setHiDir f . setStubDir f setDylibInstallName f d = d{ dylibInstallName = Just f} @@ -1059,16 +1057,7 @@ parseDynamicFlags_ dflags0 args pkg_flags = do = runCmdLine (processArgs flag_spec args') dflags0 when (not (null errs)) $ ghcError $ errorsToGhcException errs - -- Cannot use -fPIC with registerised -fvia-C, because the mangler - -- isn't up to the job. We know that if hscTarget == HscC, then the - -- user has explicitly used -fvia-C, because -fasm is the default, - -- unless there is no NCG on this platform. The latter case is - -- checked when the -fPIC flag is parsed. - -- let (pic_warns, dflags2) - | opt_PIC && hscTarget dflags1 == HscC && cGhcUnregisterised == "NO" - = ([L noSrcSpan $ "Warning: -fvia-C is incompatible with -fPIC; ignoring -fvia-C"], - dflags1{ hscTarget = HscAsm }) #if !(x86_64_TARGET_ARCH && linux_TARGET_OS) | (not opt_Static || opt_PIC) && hscTarget dflags1 == HscLlvm = ([L noSrcSpan $ "Warning: -fllvm is incompatible with -fPIC and -" @@ -1117,7 +1106,7 @@ dynamic_flags = [ , Flag "pgmP" (hasArg setPgmP) , Flag "pgmF" (hasArg (\f d -> d{ pgm_F = f})) , Flag "pgmc" (hasArg (\f d -> d{ pgm_c = (f,[])})) - , Flag "pgmm" (hasArg (\f d -> d{ pgm_m = (f,[])})) + , Flag "pgmm" (HasArg (\_ -> addWarn "The -keep-raw-s-files flag does nothing; it will be removed in a future GHC release")) , Flag "pgms" (hasArg (\f d -> d{ pgm_s = (f,[])})) , Flag "pgma" (hasArg (\f d -> d{ pgm_a = (f,[])})) , Flag "pgml" (hasArg (\f d -> d{ pgm_l = (f,[])})) @@ -1188,8 +1177,8 @@ dynamic_flags = [ , Flag "keep-hc-files" (NoArg (setDynFlag Opt_KeepHcFiles)) , Flag "keep-s-file" (NoArg (setDynFlag Opt_KeepSFiles)) , Flag "keep-s-files" (NoArg (setDynFlag Opt_KeepSFiles)) - , Flag "keep-raw-s-file" (NoArg (setDynFlag Opt_KeepRawSFiles)) - , Flag "keep-raw-s-files" (NoArg (setDynFlag Opt_KeepRawSFiles)) + , Flag "keep-raw-s-file" (NoArg (addWarn "The -keep-raw-s-file flag does nothing; it will be removed in a future GHC release")) + , Flag "keep-raw-s-files" (NoArg (addWarn "The -keep-raw-s-files flag does nothing; it will be removed in a future GHC release")) , Flag "keep-llvm-file" (NoArg (setDynFlag Opt_KeepLlvmFiles)) , Flag "keep-llvm-files" (NoArg (setDynFlag Opt_KeepLlvmFiles)) -- This only makes sense as plural @@ -1227,8 +1216,10 @@ dynamic_flags = [ , Flag "dstg-stats" (NoArg (setDynFlag Opt_StgStats)) , Flag "ddump-cmm" (setDumpFlag Opt_D_dump_cmm) + , Flag "ddump-raw-cmm" (setDumpFlag Opt_D_dump_raw_cmm) , Flag "ddump-cmmz" (setDumpFlag Opt_D_dump_cmmz) , Flag "ddump-cmmz-pretty" (setDumpFlag Opt_D_dump_cmmz_pretty) + , Flag "ddump-core-stats" (setDumpFlag Opt_D_dump_core_stats) , Flag "ddump-cps-cmm" (setDumpFlag Opt_D_dump_cps_cmm) , Flag "ddump-cvt-cmm" (setDumpFlag Opt_D_dump_cvt_cmm) , Flag "ddump-asm" (setDumpFlag Opt_D_dump_asm) @@ -1303,9 +1294,9 @@ dynamic_flags = [ ------ Machine dependant (-m) stuff --------------------------- - , Flag "monly-2-regs" (noArg (\s -> s{stolen_x86_regs = 2})) - , Flag "monly-3-regs" (noArg (\s -> s{stolen_x86_regs = 3})) - , Flag "monly-4-regs" (noArg (\s -> s{stolen_x86_regs = 4})) + , Flag "monly-2-regs" (NoArg (addWarn "The -monly-2-regs flag does nothing; it will be removed in a future GHC release")) + , Flag "monly-3-regs" (NoArg (addWarn "The -monly-3-regs flag does nothing; it will be removed in a future GHC release")) + , Flag "monly-4-regs" (NoArg (addWarn "The -monly-4-regs flag does nothing; it will be removed in a future GHC release")) , Flag "msse2" (NoArg (setDynFlag Opt_SSE2)) ------ Warning opts ------------------------------------------------- @@ -1362,10 +1353,10 @@ dynamic_flags = [ ------ Compiler flags ----------------------------------------------- , Flag "fasm" (NoArg (setObjTarget HscAsm)) - , Flag "fvia-c" (NoArg (setObjTarget HscC >> - (addWarn "The -fvia-c flag will be removed in a future GHC release"))) - , Flag "fvia-C" (NoArg (setObjTarget HscC >> - (addWarn "The -fvia-C flag will be removed in a future GHC release"))) + , Flag "fvia-c" (NoArg + (addWarn "The -fvia-c flag does nothing; it will be removed in a future GHC release")) + , Flag "fvia-C" (NoArg + (addWarn "The -fvia-C flag does nothing; it will be removed in a future GHC release")) , Flag "fllvm" (NoArg (setObjTarget HscLlvm)) , Flag "fno-code" (NoArg (do upd $ \d -> d{ ghcLink=NoLink } @@ -1492,7 +1483,6 @@ fFlags = [ ( "dicts-cheap", Opt_DictsCheap, nop ), ( "excess-precision", Opt_ExcessPrecision, nop ), ( "eager-blackholing", Opt_EagerBlackHoling, nop ), - ( "asm-mangling", Opt_DoAsmMangling, nop ), ( "print-bind-result", Opt_PrintBindResult, nop ), ( "force-recomp", Opt_ForceRecomp, nop ), ( "hpc-no-auto", Opt_Hpc_No_Auto, nop ), @@ -1665,10 +1655,12 @@ defaultFlags = [ Opt_AutoLinkPackages, Opt_ReadUserPackageConf, - Opt_DoAsmMangling, - Opt_SharedImplib, +#if GHC_DEFAULT_NEW_CODEGEN + Opt_TryNewCodeGen, +#endif + Opt_GenManifest, Opt_EmbedManifest, Opt_PrintBindContents, @@ -1690,6 +1682,7 @@ impliedFlags , (Opt_ExistentialQuantification, turnOn, Opt_ExplicitForAll) , (Opt_PolymorphicComponents, turnOn, Opt_ExplicitForAll) , (Opt_FlexibleInstances, turnOn, Opt_TypeSynonymInstances) + , (Opt_FunctionalDependencies, turnOn, Opt_MultiParamTypeClasses) , (Opt_ModalTypes, turnOn, Opt_RankNTypes) , (Opt_ModalTypes, turnOn, Opt_ExplicitForAll) @@ -1989,8 +1982,8 @@ setTarget l = upd set | otherwise = dfs -- Changes the target only if we're compiling object code. This is --- used by -fasm and -fvia-C, which switch from one to the other, but --- not from bytecode to object-code. The idea is that -fasm/-fvia-C +-- used by -fasm and -fllvm, which switch from one to the other, but +-- not from bytecode to object-code. The idea is that -fasm/-fllvm -- can be safely used in an OPTIONS_GHC pragma. setObjTarget :: HscTarget -> DynP () setObjTarget l = upd set @@ -2172,20 +2165,17 @@ setOptHpcDir arg = upd $ \ d -> d{hpcDir = arg} -- The options below are not dependent on the version of gcc, only the -- platform. -machdepCCOpts :: DynFlags -> ([String], -- flags for all C compilations - [String]) -- for registerised HC compilations -machdepCCOpts dflags = let (flagsAll, flagsRegHc) = machdepCCOpts' dflags - in (cCcOpts ++ flagsAll, flagsRegHc) +machdepCCOpts :: DynFlags -> [String] -- flags for all C compilations +machdepCCOpts dflags = cCcOpts ++ machdepCCOpts' -machdepCCOpts' :: DynFlags -> ([String], -- flags for all C compilations - [String]) -- for registerised HC compilations -machdepCCOpts' _dflags +machdepCCOpts' :: [String] -- flags for all C compilations +machdepCCOpts' #if alpha_TARGET_ARCH - = ( ["-w", "-mieee" + = ["-w", "-mieee" #ifdef HAVE_THREADED_RTS_SUPPORT , "-D_REENTRANT" #endif - ], [] ) + ] -- For now, to suppress the gcc warning "call-clobbered -- register used for global register variable", we simply -- disable all warnings altogether using the -w flag. Oh well. @@ -2193,71 +2183,17 @@ machdepCCOpts' _dflags #elif hppa_TARGET_ARCH -- ___HPUX_SOURCE, not _HPUX_SOURCE, is #defined if -ansi! -- (very nice, but too bad the HP /usr/include files don't agree.) - = ( ["-D_HPUX_SOURCE"], [] ) - -#elif m68k_TARGET_ARCH - -- -fno-defer-pop : for the .hc files, we want all the pushing/ - -- popping of args to routines to be explicit; if we let things - -- be deferred 'til after an STGJUMP, imminent death is certain! - -- - -- -fomit-frame-pointer : *don't* - -- It's better to have a6 completely tied up being a frame pointer - -- rather than let GCC pick random things to do with it. - -- (If we want to steal a6, then we would try to do things - -- as on iX86, where we *do* steal the frame pointer [%ebp].) - = ( [], ["-fno-defer-pop", "-fno-omit-frame-pointer"] ) + = ["-D_HPUX_SOURCE"] #elif i386_TARGET_ARCH -- -fno-defer-pop : basically the same game as for m68k -- -- -fomit-frame-pointer : *must* in .hc files; because we're stealing -- the fp (%ebp) for our register maps. - = let n_regs = stolen_x86_regs _dflags - in - ( - [ if opt_Static then "-DDONT_WANT_WIN32_DLL_SUPPORT" else "" - ], - [ "-fno-defer-pop", - "-fomit-frame-pointer", - -- we want -fno-builtin, because when gcc inlines - -- built-in functions like memcpy() it tends to - -- run out of registers, requiring -monly-n-regs - "-fno-builtin", - "-DSTOLEN_X86_REGS="++show n_regs ] - ) - -#elif ia64_TARGET_ARCH - = ( [], ["-fomit-frame-pointer", "-G0"] ) - -#elif x86_64_TARGET_ARCH - = ( - [], - ["-fomit-frame-pointer", - "-fno-asynchronous-unwind-tables", - -- the unwind tables are unnecessary for HC code, - -- and get in the way of -split-objs. Another option - -- would be to throw them away in the mangler, but this - -- is easier. - "-fno-builtin" - -- calling builtins like strlen() using the FFI can - -- cause gcc to run out of regs, so use the external - -- version. - ] ) - -#elif sparc_TARGET_ARCH - = ( [], ["-w"] ) - -- For now, to suppress the gcc warning "call-clobbered - -- register used for global register variable", we simply - -- disable all warnings altogether using the -w flag. Oh well. + = if opt_Static then ["-DDONT_WANT_WIN32_DLL_SUPPORT"] else [] -#elif powerpc_apple_darwin_TARGET - -- -no-cpp-precomp: - -- Disable Apple's precompiling preprocessor. It's a great thing - -- for "normal" programs, but it doesn't support register variable - -- declarations. - = ( [], ["-no-cpp-precomp"] ) #else - = ( [], [] ) + = [] #endif picCCOpts :: DynFlags -> [String] diff --git a/compiler/main/Finder.lhs b/compiler/main/Finder.lhs index d8a6271..3ac3a47 100644 --- a/compiler/main/Finder.lhs +++ b/compiler/main/Finder.lhs @@ -37,21 +37,21 @@ import PrelNames ( gHC_PRIM ) import DynFlags import Outputable import UniqFM -import Maybes ( expectJust ) +import Maybes ( expectJust ) import Exception ( evaluate ) import Distribution.Text import Distribution.Package hiding (PackageId) -import Data.IORef ( IORef, writeIORef, readIORef, atomicModifyIORef ) +import Data.IORef ( IORef, writeIORef, readIORef, atomicModifyIORef ) import System.Directory import System.FilePath import Control.Monad -import System.Time ( ClockTime ) +import System.Time ( ClockTime ) import Data.List ( partition ) -type FileExt = String -- Filename extension -type BaseName = String -- Basename of file +type FileExt = String -- Filename extension +type BaseName = String -- Basename of file -- ----------------------------------------------------------------------------- -- The Finder @@ -74,9 +74,9 @@ flushFinderCaches hsc_env = do writeIORef fc_ref emptyUFM flushModLocationCache this_pkg mlc_ref where - this_pkg = thisPackage (hsc_dflags hsc_env) - fc_ref = hsc_FC hsc_env - mlc_ref = hsc_MLC hsc_env + this_pkg = thisPackage (hsc_dflags hsc_env) + fc_ref = hsc_FC hsc_env + mlc_ref = hsc_MLC hsc_env flushModLocationCache :: PackageId -> IORef ModLocationCache -> IO () flushModLocationCache this_pkg ref = do @@ -84,7 +84,7 @@ flushModLocationCache this_pkg ref = do _ <- evaluate =<< readIORef ref return () where is_ext mod _ | modulePackageId mod /= this_pkg = True - | otherwise = False + | otherwise = False addToFinderCache :: IORef FinderCache -> ModuleName -> FindResult -> IO () addToFinderCache ref key val = @@ -103,7 +103,7 @@ removeFromModLocationCache ref key = atomicModifyIORef ref $ \c -> (delModuleEnv c key, ()) lookupFinderCache :: IORef FinderCache -> ModuleName -> IO (Maybe FindResult) -lookupFinderCache ref key = do +lookupFinderCache ref key = do c <- readIORef ref return $! lookupUFM c key @@ -125,30 +125,30 @@ lookupModLocationCache ref key = do findImportedModule :: HscEnv -> ModuleName -> Maybe FastString -> IO FindResult findImportedModule hsc_env mod_name mb_pkg = case mb_pkg of - Nothing -> unqual_import - Just pkg | pkg == fsLit "this" -> home_import -- "this" is special - | otherwise -> pkg_import + Nothing -> unqual_import + Just pkg | pkg == fsLit "this" -> home_import -- "this" is special + | otherwise -> pkg_import where home_import = findHomeModule hsc_env mod_name pkg_import = findExposedPackageModule hsc_env mod_name mb_pkg - unqual_import = home_import - `orIfNotFound` - findExposedPackageModule hsc_env mod_name Nothing + unqual_import = home_import + `orIfNotFound` + findExposedPackageModule hsc_env mod_name Nothing -- | Locate a specific 'Module'. The purpose of this function is to -- create a 'ModLocation' for a given 'Module', that is to find out -- where the files associated with this module live. It is used when --- reading the interface for a module mentioned by another interface, +-- reading the interface for a module mentioned by another interface, -- for example (a "system import"). findExactModule :: HscEnv -> Module -> IO FindResult findExactModule hsc_env mod = - let dflags = hsc_dflags hsc_env in - if modulePackageId mod == thisPackage dflags - then findHomeModule hsc_env (moduleName mod) - else findPackageModule hsc_env mod + let dflags = hsc_dflags hsc_env + in if modulePackageId mod == thisPackage dflags + then findHomeModule hsc_env (moduleName mod) + else findPackageModule hsc_env mod -- ----------------------------------------------------------------------------- -- Helpers @@ -175,15 +175,15 @@ orIfNotFound this or_this = do homeSearchCache :: HscEnv -> ModuleName -> IO FindResult -> IO FindResult homeSearchCache hsc_env mod_name do_this = do m <- lookupFinderCache (hsc_FC hsc_env) mod_name - case m of + case m of Just result -> return result Nothing -> do - result <- do_this - addToFinderCache (hsc_FC hsc_env) mod_name result - case result of - Found loc mod -> addToModLocationCache (hsc_MLC hsc_env) mod loc - _other -> return () - return result + result <- do_this + addToFinderCache (hsc_FC hsc_env) mod_name result + case result of + Found loc mod -> addToModLocationCache (hsc_MLC hsc_env) mod loc + _other -> return () + return result findExposedPackageModule :: HscEnv -> ModuleName -> Maybe FastString -> IO FindResult @@ -229,10 +229,10 @@ modLocationCache hsc_env mod do_this = do Just loc -> return (Found loc mod) Nothing -> do result <- do_this - case result of - Found loc mod -> addToModLocationCache (hsc_MLC hsc_env) mod loc - _other -> return () - return result + case result of + Found loc mod -> addToModLocationCache (hsc_MLC hsc_env) mod loc + _other -> return () + return result where mlc = hsc_MLC hsc_env @@ -250,7 +250,7 @@ uncacheModule hsc_env mod = do removeFromModLocationCache (hsc_MLC hsc_env) (mkModule this_pkg mod) -- ----------------------------------------------------------------------------- --- The internal workers +-- The internal workers -- | Search for a module in the home package only. findHomeModule :: HscEnv -> ModuleName -> IO FindResult @@ -262,60 +262,58 @@ findHomeModule hsc_env mod_name = hisuf = hiSuf dflags mod = mkModule (thisPackage dflags) mod_name - source_exts = + source_exts = [ ("hs", mkHomeModLocationSearched dflags mod_name "hs") , ("lhs", mkHomeModLocationSearched dflags mod_name "lhs") ] - - hi_exts = [ (hisuf, mkHiOnlyModLocation dflags hisuf) - , (addBootSuffix hisuf, mkHiOnlyModLocation dflags hisuf) - ] - - -- In compilation manager modes, we look for source files in the home - -- package because we can compile these automatically. In one-shot - -- compilation mode we look for .hi and .hi-boot files only. + + hi_exts = [ (hisuf, mkHiOnlyModLocation dflags hisuf) + , (addBootSuffix hisuf, mkHiOnlyModLocation dflags hisuf) + ] + + -- In compilation manager modes, we look for source files in the home + -- package because we can compile these automatically. In one-shot + -- compilation mode we look for .hi and .hi-boot files only. exts | isOneShot (ghcMode dflags) = hi_exts - | otherwise = source_exts + | otherwise = source_exts in -- special case for GHC.Prim; we won't find it in the filesystem. -- This is important only when compiling the base package (where GHC.Prim -- is a home module). - if mod == gHC_PRIM + if mod == gHC_PRIM then return (Found (error "GHC.Prim ModLocation") mod) - else - - searchPathExts home_path mod exts + else searchPathExts home_path mod exts -- | Search for a module in external packages only. findPackageModule :: HscEnv -> Module -> IO FindResult findPackageModule hsc_env mod = do let - dflags = hsc_dflags hsc_env - pkg_id = modulePackageId mod - pkg_map = pkgIdMap (pkgState dflags) + dflags = hsc_dflags hsc_env + pkg_id = modulePackageId mod + pkg_map = pkgIdMap (pkgState dflags) -- case lookupPackage pkg_map pkg_id of Nothing -> return (NoPackage pkg_id) Just pkg_conf -> findPackageModule_ hsc_env mod pkg_conf - + findPackageModule_ :: HscEnv -> Module -> PackageConfig -> IO FindResult -findPackageModule_ hsc_env mod pkg_conf = +findPackageModule_ hsc_env mod pkg_conf = modLocationCache hsc_env mod $ -- special case for GHC.Prim; we won't find it in the filesystem. - if mod == gHC_PRIM + if mod == gHC_PRIM then return (Found (error "GHC.Prim ModLocation") mod) - else + else let dflags = hsc_dflags hsc_env tag = buildTag dflags - -- hi-suffix for packages depends on the build tag. + -- hi-suffix for packages depends on the build tag. package_hisuf | null tag = "hi" - | otherwise = tag ++ "_hi" + | otherwise = tag ++ "_hi" mk_hi_loc = mkHiOnlyModLocation dflags package_hisuf @@ -337,38 +335,38 @@ findPackageModule_ hsc_env mod pkg_conf = -- General path searching searchPathExts - :: [FilePath] -- paths to search - -> Module -- module name + :: [FilePath] -- paths to search + -> Module -- module name -> [ ( - FileExt, -- suffix - FilePath -> BaseName -> IO ModLocation -- action + FileExt, -- suffix + FilePath -> BaseName -> IO ModLocation -- action ) - ] + ] -> IO FindResult -searchPathExts paths mod exts +searchPathExts paths mod exts = do result <- search to_search {- - hPutStrLn stderr (showSDoc $ - vcat [text "Search" <+> ppr mod <+> sep (map (text. fst) exts) - , nest 2 (vcat (map text paths)) - , case result of - Succeeded (loc, p) -> text "Found" <+> ppr loc - Failed fs -> text "not found"]) --} - return result + hPutStrLn stderr (showSDoc $ + vcat [text "Search" <+> ppr mod <+> sep (map (text. fst) exts) + , nest 2 (vcat (map text paths)) + , case result of + Succeeded (loc, p) -> text "Found" <+> ppr loc + Failed fs -> text "not found"]) +-} + return result where basename = moduleNameSlashes (moduleName mod) to_search :: [(FilePath, IO ModLocation)] to_search = [ (file, fn path basename) - | path <- paths, - (ext,fn) <- exts, - let base | path == "." = basename - | otherwise = path basename - file = base <.> ext - ] + | path <- paths, + (ext,fn) <- exts, + let base | path == "." = basename + | otherwise = path basename + file = base <.> ext + ] search [] = return (NotFound { fr_paths = map fst to_search , fr_pkg = Just (modulePackageId mod) @@ -377,12 +375,12 @@ searchPathExts paths mod exts search ((file, mk_result) : rest) = do b <- doesFileExist file - if b - then do { loc <- mk_result; return (Found loc mod) } - else search rest + if b + then do { loc <- mk_result; return (Found loc mod) } + else search rest mkHomeModLocationSearched :: DynFlags -> ModuleName -> FileExt - -> FilePath -> BaseName -> IO ModLocation + -> FilePath -> BaseName -> IO ModLocation mkHomeModLocationSearched dflags mod suff path basename = do mkHomeModLocation2 dflags mod (path basename) suff @@ -417,7 +415,7 @@ mkHomeModLocationSearched dflags mod suff path basename = do -- (b) and (c): The filename of the source file, minus its extension -- -- ext --- The filename extension of the source file (usually "hs" or "lhs"). +-- The filename extension of the source file (usually "hs" or "lhs"). mkHomeModLocation :: DynFlags -> ModuleName -> FilePath -> IO ModLocation mkHomeModLocation dflags mod src_filename = do @@ -425,10 +423,10 @@ mkHomeModLocation dflags mod src_filename = do mkHomeModLocation2 dflags mod basename extension mkHomeModLocation2 :: DynFlags - -> ModuleName - -> FilePath -- Of source module, without suffix - -> String -- Suffix - -> IO ModLocation + -> ModuleName + -> FilePath -- Of source module, without suffix + -> String -- Suffix + -> IO ModLocation mkHomeModLocation2 dflags mod src_basename ext = do let mod_basename = moduleNameSlashes mod @@ -436,37 +434,37 @@ mkHomeModLocation2 dflags mod src_basename ext = do hi_fn <- mkHiPath dflags src_basename mod_basename return (ModLocation{ ml_hs_file = Just (src_basename <.> ext), - ml_hi_file = hi_fn, - ml_obj_file = obj_fn }) + ml_hi_file = hi_fn, + ml_obj_file = obj_fn }) mkHiOnlyModLocation :: DynFlags -> Suffix -> FilePath -> String - -> IO ModLocation + -> IO ModLocation mkHiOnlyModLocation dflags hisuf path basename = do let full_basename = path basename obj_fn <- mkObjPath dflags full_basename basename return ModLocation{ ml_hs_file = Nothing, - ml_hi_file = full_basename <.> hisuf, - -- Remove the .hi-boot suffix from - -- hi_file, if it had one. We always - -- want the name of the real .hi file - -- in the ml_hi_file field. - ml_obj_file = obj_fn + ml_hi_file = full_basename <.> hisuf, + -- Remove the .hi-boot suffix from + -- hi_file, if it had one. We always + -- want the name of the real .hi file + -- in the ml_hi_file field. + ml_obj_file = obj_fn } -- | Constructs the filename of a .o file for a given source file. -- Does /not/ check whether the .o file exists mkObjPath :: DynFlags - -> FilePath -- the filename of the source file, minus the extension - -> String -- the module name with dots replaced by slashes + -> FilePath -- the filename of the source file, minus the extension + -> String -- the module name with dots replaced by slashes -> IO FilePath mkObjPath dflags basename mod_basename = do let - odir = objectDir dflags - osuf = objectSuf dflags - - obj_basename | Just dir <- odir = dir mod_basename - | otherwise = basename + odir = objectDir dflags + osuf = objectSuf dflags + + obj_basename | Just dir <- odir = dir mod_basename + | otherwise = basename return (obj_basename <.> osuf) @@ -474,16 +472,16 @@ mkObjPath dflags basename mod_basename -- Does /not/ check whether the .hi file exists mkHiPath :: DynFlags - -> FilePath -- the filename of the source file, minus the extension - -> String -- the module name with dots replaced by slashes + -> FilePath -- the filename of the source file, minus the extension + -> String -- the module name with dots replaced by slashes -> IO FilePath mkHiPath dflags basename mod_basename = do let - hidir = hiDir dflags - hisuf = hiSuf dflags + hidir = hiDir dflags + hisuf = hiSuf dflags - hi_basename | Just dir <- hidir = dir mod_basename - | otherwise = basename + hi_basename | Just dir <- hidir = dir mod_basename + | otherwise = basename return (hi_basename <.> hisuf) @@ -498,14 +496,14 @@ mkStubPaths :: DynFlags -> ModuleName -> ModLocation - -> (FilePath,FilePath,FilePath) + -> FilePath mkStubPaths dflags mod location = let stubdir = stubDir dflags mod_basename = moduleNameSlashes mod - src_basename = dropExtension $ expectJust "mkStubPaths" + src_basename = dropExtension $ expectJust "mkStubPaths" (ml_hs_file location) stub_basename0 @@ -513,37 +511,27 @@ mkStubPaths dflags mod location | otherwise = src_basename stub_basename = stub_basename0 ++ "_stub" - - obj = ml_obj_file location - osuf = objectSuf dflags - stub_obj_base = dropTail (length osuf + 1) obj ++ "_stub" - -- NB. not takeFileName, see #3093 in - (stub_basename <.> "c", - stub_basename <.> "h", - stub_obj_base <.> objectSuf dflags) + stub_basename <.> "h" -- ----------------------------------------------------------------------------- --- findLinkable isn't related to the other stuff in here, +-- findLinkable isn't related to the other stuff in here, -- but there's no other obvious place for it findObjectLinkableMaybe :: Module -> ModLocation -> IO (Maybe Linkable) findObjectLinkableMaybe mod locn = do let obj_fn = ml_obj_file locn - maybe_obj_time <- modificationTimeIfExists obj_fn - case maybe_obj_time of - Nothing -> return Nothing - Just obj_time -> liftM Just (findObjectLinkable mod obj_fn obj_time) + maybe_obj_time <- modificationTimeIfExists obj_fn + case maybe_obj_time of + Nothing -> return Nothing + Just obj_time -> liftM Just (findObjectLinkable mod obj_fn obj_time) -- Make an object linkable when we know the object file exists, and we know -- its modification time. findObjectLinkable :: Module -> FilePath -> ClockTime -> IO Linkable -findObjectLinkable mod obj_fn obj_time = do - let stub_fn = (dropExtension obj_fn ++ "_stub") <.> "o" - stub_exist <- doesFileExist stub_fn - if stub_exist - then return (LM obj_time mod [DotO obj_fn, DotO stub_fn]) - else return (LM obj_time mod [DotO obj_fn]) +findObjectLinkable mod obj_fn obj_time = return (LM obj_time mod [DotO obj_fn]) + -- We used to look for _stub.o files here, but that was a bug (#706) + -- Now GHC merges the stub.o into the main .o (#3687) -- ----------------------------------------------------------------------------- -- Error messages @@ -561,7 +549,7 @@ cantFindErr :: LitString -> LitString -> DynFlags -> ModuleName -> FindResult cantFindErr _ multiple_found _ mod_name (FoundMultiple pkgs) = hang (ptext multiple_found <+> quotes (ppr mod_name) <> colon) 2 ( sep [ptext (sLit "it was found in multiple packages:"), - hsep (map (text.packageIdString) pkgs)] + hsep (map (text.packageIdString) pkgs)] ) cantFindErr cannot_find _ dflags mod_name find_result = ptext cannot_find <+> quotes (ppr mod_name) @@ -572,15 +560,15 @@ cantFindErr cannot_find _ dflags mod_name find_result more_info = case find_result of - NoPackage pkg - -> ptext (sLit "no package matching") <+> quotes (ppr pkg) <+> - ptext (sLit "was found") + NoPackage pkg + -> ptext (sLit "no package matching") <+> quotes (ppr pkg) <+> + ptext (sLit "was found") NotFound { fr_paths = files, fr_pkg = mb_pkg , fr_mods_hidden = mod_hiddens, fr_pkgs_hidden = pkg_hiddens , fr_suggestions = suggest } - | Just pkg <- mb_pkg, pkg /= thisPackage dflags - -> not_found_in_package pkg files + | Just pkg <- mb_pkg, pkg /= thisPackage dflags + -> not_found_in_package pkg files | not (null suggest) -> pp_suggestions suggest $$ tried_these files @@ -588,8 +576,8 @@ cantFindErr cannot_find _ dflags mod_name find_result | null files && null mod_hiddens && null pkg_hiddens -> ptext (sLit "It is not a module in the current program, or in any known package.") - | otherwise - -> vcat (map pkg_hidden pkg_hiddens) $$ + | otherwise + -> vcat (map pkg_hidden pkg_hiddens) $$ vcat (map mod_hidden mod_hiddens) $$ tried_these files @@ -616,10 +604,10 @@ cantFindErr cannot_find _ dflags mod_name find_result tried_these files | null files = empty | verbosity dflags < 3 = - ptext (sLit "Use -v to see a list of the files searched for.") + ptext (sLit "Use -v to see a list of the files searched for.") | otherwise = hang (ptext (sLit "Locations searched:")) 2 $ vcat (map text files) - + pkg_hidden pkg = ptext (sLit "It is a member of the hidden package") <+> quotes (ppr pkg) <> dot $$ cabal_pkg_hidden_hint pkg diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 0d94ade..ca2e14c 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -756,9 +756,7 @@ data CoreModule -- | Type environment for types declared in this module cm_types :: !TypeEnv, -- | Declarations - cm_binds :: [CoreBind], - -- | Imports - cm_imports :: ![Module] + cm_binds :: [CoreBind] } instance Outputable CoreModule where @@ -857,11 +855,11 @@ compileCore simplify fn = do gutsToCoreModule :: Either (CgGuts, ModDetails) ModGuts -> CoreModule gutsToCoreModule (Left (cg, md)) = CoreModule { cm_module = cg_module cg, cm_types = md_types md, - cm_imports = cg_dir_imps cg, cm_binds = cg_binds cg + cm_binds = cg_binds cg } gutsToCoreModule (Right mg) = CoreModule { cm_module = mg_module mg, cm_types = mg_types mg, - cm_imports = moduleEnvKeys (mg_dir_imps mg), cm_binds = mg_binds mg + cm_binds = mg_binds mg } -- %************************************************************************ diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs index 5f9380a..0d41435 100644 --- a/compiler/main/GhcMake.hs +++ b/compiler/main/GhcMake.hs @@ -1,1463 +1,1478 @@ --- ----------------------------------------------------------------------------- --- --- (c) The University of Glasgow, 2005 --- --- This module deals with --make --- ----------------------------------------------------------------------------- - -module GhcMake( - depanal, - load, LoadHowMuch(..), - - topSortModuleGraph, - - noModError, cyclicModuleErr - ) where - -#include "HsVersions.h" - -#ifdef GHCI -import qualified Linker ( unload ) -#endif - -import DriverPipeline -import DriverPhases -import GhcMonad -import Module -import HscTypes -import ErrUtils -import DynFlags -import HsSyn hiding ((<.>)) -import Finder -import HeaderInfo -import TcIface ( typecheckIface ) -import TcRnMonad ( initIfaceCheck ) -import RdrName ( RdrName ) - -import Exception ( evaluate, tryIO ) -import Panic -import SysTools -import BasicTypes -import SrcLoc -import Util -import Digraph -import Bag ( listToBag ) -import Maybes ( expectJust, mapCatMaybes ) -import StringBuffer -import FastString -import Outputable -import UniqFM - -import qualified Data.Map as Map -import qualified FiniteMap as Map( insertListWith) - -import System.Directory ( doesFileExist, getModificationTime ) -import System.IO ( fixIO ) -import System.IO.Error ( isDoesNotExistError ) -import System.Time ( ClockTime ) -import System.FilePath -import Control.Monad -import Data.Maybe -import Data.List -import qualified Data.List as List - --- ----------------------------------------------------------------------------- --- Loading the program - --- | Perform a dependency analysis starting from the current targets --- and update the session with the new module graph. --- --- Dependency analysis entails parsing the @import@ directives and may --- therefore require running certain preprocessors. --- --- Note that each 'ModSummary' in the module graph caches its 'DynFlags'. --- These 'DynFlags' are determined by the /current/ session 'DynFlags' and the --- @OPTIONS@ and @LANGUAGE@ pragmas of the parsed module. Thus if you want to --- changes to the 'DynFlags' to take effect you need to call this function --- again. --- -depanal :: GhcMonad m => - [ModuleName] -- ^ excluded modules - -> Bool -- ^ allow duplicate roots - -> m ModuleGraph -depanal excluded_mods allow_dup_roots = do - hsc_env <- getSession - let - dflags = hsc_dflags hsc_env - targets = hsc_targets hsc_env - old_graph = hsc_mod_graph hsc_env - - liftIO $ showPass dflags "Chasing dependencies" - liftIO $ debugTraceMsg dflags 2 (hcat [ - text "Chasing modules from: ", - hcat (punctuate comma (map pprTarget targets))]) - - mod_graph <- liftIO $ downsweep hsc_env old_graph excluded_mods allow_dup_roots - modifySession $ \_ -> hsc_env { hsc_mod_graph = mod_graph } - return mod_graph - --- | Describes which modules of the module graph need to be loaded. -data LoadHowMuch - = LoadAllTargets - -- ^ Load all targets and its dependencies. - | LoadUpTo ModuleName - -- ^ Load only the given module and its dependencies. - | LoadDependenciesOf ModuleName - -- ^ Load only the dependencies of the given module, but not the module - -- itself. - --- | Try to load the program. See 'LoadHowMuch' for the different modes. --- --- This function implements the core of GHC's @--make@ mode. It preprocesses, --- compiles and loads the specified modules, avoiding re-compilation wherever --- possible. Depending on the target (see 'DynFlags.hscTarget') compilating --- and loading may result in files being created on disk. --- --- Calls the 'reportModuleCompilationResult' callback after each compiling --- each module, whether successful or not. --- --- Throw a 'SourceError' if errors are encountered before the actual --- compilation starts (e.g., during dependency analysis). All other errors --- are reported using the callback. --- -load :: GhcMonad m => LoadHowMuch -> m SuccessFlag -load how_much = do - mod_graph <- depanal [] False - load2 how_much mod_graph - -load2 :: GhcMonad m => LoadHowMuch -> [ModSummary] - -> m SuccessFlag -load2 how_much mod_graph = do - guessOutputFile - hsc_env <- getSession - - let hpt1 = hsc_HPT hsc_env - let dflags = hsc_dflags hsc_env - - -- The "bad" boot modules are the ones for which we have - -- B.hs-boot in the module graph, but no B.hs - -- The downsweep should have ensured this does not happen - -- (see msDeps) - let all_home_mods = [ms_mod_name s - | s <- mod_graph, not (isBootSummary s)] - bad_boot_mods = [s | s <- mod_graph, isBootSummary s, - not (ms_mod_name s `elem` all_home_mods)] - ASSERT( null bad_boot_mods ) return () - - -- check that the module given in HowMuch actually exists, otherwise - -- topSortModuleGraph will bomb later. - let checkHowMuch (LoadUpTo m) = checkMod m - checkHowMuch (LoadDependenciesOf m) = checkMod m - checkHowMuch _ = id - - checkMod m and_then - | m `elem` all_home_mods = and_then - | otherwise = do - liftIO $ errorMsg dflags (text "no such module:" <+> - quotes (ppr m)) - return Failed - - checkHowMuch how_much $ do - - -- mg2_with_srcimps drops the hi-boot nodes, returning a - -- graph with cycles. Among other things, it is used for - -- backing out partially complete cycles following a failed - -- upsweep, and for removing from hpt all the modules - -- not in strict downwards closure, during calls to compile. - let mg2_with_srcimps :: [SCC ModSummary] - mg2_with_srcimps = topSortModuleGraph True mod_graph Nothing - - -- If we can determine that any of the {-# SOURCE #-} imports - -- are definitely unnecessary, then emit a warning. - warnUnnecessarySourceImports mg2_with_srcimps - - let - -- check the stability property for each module. - stable_mods@(stable_obj,stable_bco) - = checkStability hpt1 mg2_with_srcimps all_home_mods - - -- prune bits of the HPT which are definitely redundant now, - -- to save space. - pruned_hpt = pruneHomePackageTable hpt1 - (flattenSCCs mg2_with_srcimps) - stable_mods - - _ <- liftIO $ evaluate pruned_hpt - - -- before we unload anything, make sure we don't leave an old - -- interactive context around pointing to dead bindings. Also, - -- write the pruned HPT to allow the old HPT to be GC'd. - modifySession $ \_ -> hsc_env{ hsc_IC = emptyInteractiveContext, - hsc_HPT = pruned_hpt } - - liftIO $ debugTraceMsg dflags 2 (text "Stable obj:" <+> ppr stable_obj $$ - text "Stable BCO:" <+> ppr stable_bco) - - -- Unload any modules which are going to be re-linked this time around. - let stable_linkables = [ linkable - | m <- stable_obj++stable_bco, - Just hmi <- [lookupUFM pruned_hpt m], - Just linkable <- [hm_linkable hmi] ] - liftIO $ unload hsc_env stable_linkables - - -- We could at this point detect cycles which aren't broken by - -- a source-import, and complain immediately, but it seems better - -- to let upsweep_mods do this, so at least some useful work gets - -- done before the upsweep is abandoned. - --hPutStrLn stderr "after tsort:\n" - --hPutStrLn stderr (showSDoc (vcat (map ppr mg2))) - - -- Now do the upsweep, calling compile for each module in - -- turn. Final result is version 3 of everything. - - -- Topologically sort the module graph, this time including hi-boot - -- nodes, and possibly just including the portion of the graph - -- reachable from the module specified in the 2nd argument to load. - -- This graph should be cycle-free. - -- If we're restricting the upsweep to a portion of the graph, we - -- also want to retain everything that is still stable. - let full_mg :: [SCC ModSummary] - full_mg = topSortModuleGraph False mod_graph Nothing - - maybe_top_mod = case how_much of - LoadUpTo m -> Just m - LoadDependenciesOf m -> Just m - _ -> Nothing - - partial_mg0 :: [SCC ModSummary] - partial_mg0 = topSortModuleGraph False mod_graph maybe_top_mod - - -- LoadDependenciesOf m: we want the upsweep to stop just - -- short of the specified module (unless the specified module - -- is stable). - partial_mg - | LoadDependenciesOf _mod <- how_much - = ASSERT( case last partial_mg0 of - AcyclicSCC ms -> ms_mod_name ms == _mod; _ -> False ) - List.init partial_mg0 - | otherwise - = partial_mg0 - - stable_mg = - [ AcyclicSCC ms - | AcyclicSCC ms <- full_mg, - ms_mod_name ms `elem` stable_obj++stable_bco, - ms_mod_name ms `notElem` [ ms_mod_name ms' | - AcyclicSCC ms' <- partial_mg ] ] - - mg = stable_mg ++ partial_mg - - -- clean up between compilations - let cleanup = cleanTempFilesExcept dflags - (ppFilesFromSummaries (flattenSCCs mg2_with_srcimps)) - - liftIO $ debugTraceMsg dflags 2 (hang (text "Ready for upsweep") - 2 (ppr mg)) - - setSession hsc_env{ hsc_HPT = emptyHomePackageTable } - (upsweep_ok, modsUpswept) - <- upsweep pruned_hpt stable_mods cleanup mg - - -- Make modsDone be the summaries for each home module now - -- available; this should equal the domain of hpt3. - -- Get in in a roughly top .. bottom order (hence reverse). - - let modsDone = reverse modsUpswept - - -- Try and do linking in some form, depending on whether the - -- upsweep was completely or only partially successful. - - if succeeded upsweep_ok - - then - -- Easy; just relink it all. - do liftIO $ debugTraceMsg dflags 2 (text "Upsweep completely successful.") - - -- Clean up after ourselves - liftIO $ cleanTempFilesExcept dflags (ppFilesFromSummaries modsDone) - - -- Issue a warning for the confusing case where the user - -- said '-o foo' but we're not going to do any linking. - -- We attempt linking if either (a) one of the modules is - -- called Main, or (b) the user said -no-hs-main, indicating - -- that main() is going to come from somewhere else. - -- - let ofile = outputFile dflags - let no_hs_main = dopt Opt_NoHsMain dflags - let - main_mod = mainModIs dflags - a_root_is_Main = any ((==main_mod).ms_mod) mod_graph - do_linking = a_root_is_Main || no_hs_main || ghcLink dflags == LinkDynLib - - when (ghcLink dflags == LinkBinary - && isJust ofile && not do_linking) $ - liftIO $ debugTraceMsg dflags 1 $ - text ("Warning: output was redirected with -o, " ++ - "but no output will be generated\n" ++ - "because there is no " ++ - moduleNameString (moduleName main_mod) ++ " module.") - - -- link everything together - hsc_env1 <- getSession - linkresult <- liftIO $ link (ghcLink dflags) dflags do_linking (hsc_HPT hsc_env1) - - loadFinish Succeeded linkresult - - else - -- Tricky. We need to back out the effects of compiling any - -- half-done cycles, both so as to clean up the top level envs - -- and to avoid telling the interactive linker to link them. - do liftIO $ debugTraceMsg dflags 2 (text "Upsweep partially successful.") - - let modsDone_names - = map ms_mod modsDone - let mods_to_zap_names - = findPartiallyCompletedCycles modsDone_names - mg2_with_srcimps - let mods_to_keep - = filter ((`notElem` mods_to_zap_names).ms_mod) - modsDone - - hsc_env1 <- getSession - let hpt4 = retainInTopLevelEnvs (map ms_mod_name mods_to_keep) - (hsc_HPT hsc_env1) - - -- Clean up after ourselves - liftIO $ cleanTempFilesExcept dflags (ppFilesFromSummaries mods_to_keep) - - -- there should be no Nothings where linkables should be, now - ASSERT(all (isJust.hm_linkable) - (eltsUFM (hsc_HPT hsc_env))) do - - -- Link everything together - linkresult <- liftIO $ link (ghcLink dflags) dflags False hpt4 - - modifySession $ \hsc_env -> hsc_env{ hsc_HPT = hpt4 } - loadFinish Failed linkresult - --- Finish up after a load. - --- If the link failed, unload everything and return. -loadFinish :: GhcMonad m => - SuccessFlag -> SuccessFlag - -> m SuccessFlag -loadFinish _all_ok Failed - = do hsc_env <- getSession - liftIO $ unload hsc_env [] - modifySession discardProg - return Failed - --- Empty the interactive context and set the module context to the topmost --- newly loaded module, or the Prelude if none were loaded. -loadFinish all_ok Succeeded - = do modifySession $ \hsc_env -> hsc_env{ hsc_IC = emptyInteractiveContext } - return all_ok - - --- Forget the current program, but retain the persistent info in HscEnv -discardProg :: HscEnv -> HscEnv -discardProg hsc_env - = hsc_env { hsc_mod_graph = emptyMG, - hsc_IC = emptyInteractiveContext, - hsc_HPT = emptyHomePackageTable } - --- used to fish out the preprocess output files for the purposes of --- cleaning up. The preprocessed file *might* be the same as the --- source file, but that doesn't do any harm. -ppFilesFromSummaries :: [ModSummary] -> [FilePath] -ppFilesFromSummaries summaries = map ms_hspp_file summaries - --- | If there is no -o option, guess the name of target executable --- by using top-level source file name as a base. -guessOutputFile :: GhcMonad m => m () -guessOutputFile = modifySession $ \env -> - let dflags = hsc_dflags env - mod_graph = hsc_mod_graph env - mainModuleSrcPath :: Maybe String - mainModuleSrcPath = do - let isMain = (== mainModIs dflags) . ms_mod - [ms] <- return (filter isMain mod_graph) - ml_hs_file (ms_location ms) - name = fmap dropExtension mainModuleSrcPath - -#if defined(mingw32_HOST_OS) - -- we must add the .exe extention unconditionally here, otherwise - -- when name has an extension of its own, the .exe extension will - -- not be added by DriverPipeline.exeFileName. See #2248 - name_exe = fmap (<.> "exe") name -#else - name_exe = name -#endif - in - case outputFile dflags of - Just _ -> env - Nothing -> env { hsc_dflags = dflags { outputFile = name_exe } } - --- ----------------------------------------------------------------------------- - --- | Prune the HomePackageTable --- --- Before doing an upsweep, we can throw away: --- --- - For non-stable modules: --- - all ModDetails, all linked code --- - all unlinked code that is out of date with respect to --- the source file --- --- This is VERY IMPORTANT otherwise we'll end up requiring 2x the --- space at the end of the upsweep, because the topmost ModDetails of the --- old HPT holds on to the entire type environment from the previous --- compilation. - -pruneHomePackageTable - :: HomePackageTable - -> [ModSummary] - -> ([ModuleName],[ModuleName]) - -> HomePackageTable - -pruneHomePackageTable hpt summ (stable_obj, stable_bco) - = mapUFM prune hpt - where prune hmi - | is_stable modl = hmi' - | otherwise = hmi'{ hm_details = emptyModDetails } - where - modl = moduleName (mi_module (hm_iface hmi)) - hmi' | Just l <- hm_linkable hmi, linkableTime l < ms_hs_date ms - = hmi{ hm_linkable = Nothing } - | otherwise - = hmi - where ms = expectJust "prune" (lookupUFM ms_map modl) - - ms_map = listToUFM [(ms_mod_name ms, ms) | ms <- summ] - - is_stable m = m `elem` stable_obj || m `elem` stable_bco - --- ----------------------------------------------------------------------------- - --- Return (names of) all those in modsDone who are part of a cycle --- as defined by theGraph. -findPartiallyCompletedCycles :: [Module] -> [SCC ModSummary] -> [Module] -findPartiallyCompletedCycles modsDone theGraph - = chew theGraph - where - chew [] = [] - chew ((AcyclicSCC _):rest) = chew rest -- acyclic? not interesting. - chew ((CyclicSCC vs):rest) - = let names_in_this_cycle = nub (map ms_mod vs) - mods_in_this_cycle - = nub ([done | done <- modsDone, - done `elem` names_in_this_cycle]) - chewed_rest = chew rest - in - if notNull mods_in_this_cycle - && length mods_in_this_cycle < length names_in_this_cycle - then mods_in_this_cycle ++ chewed_rest - else chewed_rest - - --- --------------------------------------------------------------------------- --- Unloading - -unload :: HscEnv -> [Linkable] -> IO () -unload hsc_env stable_linkables -- Unload everthing *except* 'stable_linkables' - = case ghcLink (hsc_dflags hsc_env) of -#ifdef GHCI - LinkInMemory -> Linker.unload (hsc_dflags hsc_env) stable_linkables -#else - LinkInMemory -> panic "unload: no interpreter" - -- urgh. avoid warnings: - hsc_env stable_linkables -#endif - _other -> return () - --- ----------------------------------------------------------------------------- - -{- | - - Stability tells us which modules definitely do not need to be recompiled. - There are two main reasons for having stability: - - - avoid doing a complete upsweep of the module graph in GHCi when - modules near the bottom of the tree have not changed. - - - to tell GHCi when it can load object code: we can only load object code - for a module when we also load object code fo all of the imports of the - module. So we need to know that we will definitely not be recompiling - any of these modules, and we can use the object code. - - The stability check is as follows. Both stableObject and - stableBCO are used during the upsweep phase later. - -@ - stable m = stableObject m || stableBCO m - - stableObject m = - all stableObject (imports m) - && old linkable does not exist, or is == on-disk .o - && date(on-disk .o) > date(.hs) - - stableBCO m = - all stable (imports m) - && date(BCO) > date(.hs) -@ - - These properties embody the following ideas: - - - if a module is stable, then: - - - if it has been compiled in a previous pass (present in HPT) - then it does not need to be compiled or re-linked. - - - if it has not been compiled in a previous pass, - then we only need to read its .hi file from disk and - link it to produce a 'ModDetails'. - - - if a modules is not stable, we will definitely be at least - re-linking, and possibly re-compiling it during the 'upsweep'. - All non-stable modules can (and should) therefore be unlinked - before the 'upsweep'. - - - Note that objects are only considered stable if they only depend - on other objects. We can't link object code against byte code. --} - -checkStability - :: HomePackageTable -- HPT from last compilation - -> [SCC ModSummary] -- current module graph (cyclic) - -> [ModuleName] -- all home modules - -> ([ModuleName], -- stableObject - [ModuleName]) -- stableBCO - -checkStability hpt sccs all_home_mods = foldl checkSCC ([],[]) sccs - where - checkSCC (stable_obj, stable_bco) scc0 - | stableObjects = (scc_mods ++ stable_obj, stable_bco) - | stableBCOs = (stable_obj, scc_mods ++ stable_bco) - | otherwise = (stable_obj, stable_bco) - where - scc = flattenSCC scc0 - scc_mods = map ms_mod_name scc - home_module m = m `elem` all_home_mods && m `notElem` scc_mods - - scc_allimps = nub (filter home_module (concatMap ms_home_allimps scc)) - -- all imports outside the current SCC, but in the home pkg - - stable_obj_imps = map (`elem` stable_obj) scc_allimps - stable_bco_imps = map (`elem` stable_bco) scc_allimps - - stableObjects = - and stable_obj_imps - && all object_ok scc - - stableBCOs = - and (zipWith (||) stable_obj_imps stable_bco_imps) - && all bco_ok scc - - object_ok ms - | Just t <- ms_obj_date ms = t >= ms_hs_date ms - && same_as_prev t - | otherwise = False - where - same_as_prev t = case lookupUFM hpt (ms_mod_name ms) of - Just hmi | Just l <- hm_linkable hmi - -> isObjectLinkable l && t == linkableTime l - _other -> True - -- why '>=' rather than '>' above? If the filesystem stores - -- times to the nearset second, we may occasionally find that - -- the object & source have the same modification time, - -- especially if the source was automatically generated - -- and compiled. Using >= is slightly unsafe, but it matches - -- make's behaviour. - - bco_ok ms - = case lookupUFM hpt (ms_mod_name ms) of - Just hmi | Just l <- hm_linkable hmi -> - not (isObjectLinkable l) && - linkableTime l >= ms_hs_date ms - _other -> False - --- ----------------------------------------------------------------------------- - --- | The upsweep --- --- This is where we compile each module in the module graph, in a pass --- from the bottom to the top of the graph. --- --- There better had not be any cyclic groups here -- we check for them. - -upsweep - :: GhcMonad m - => HomePackageTable -- ^ HPT from last time round (pruned) - -> ([ModuleName],[ModuleName]) -- ^ stable modules (see checkStability) - -> IO () -- ^ How to clean up unwanted tmp files - -> [SCC ModSummary] -- ^ Mods to do (the worklist) - -> m (SuccessFlag, - [ModSummary]) - -- ^ Returns: - -- - -- 1. A flag whether the complete upsweep was successful. - -- 2. The 'HscEnv' in the monad has an updated HPT - -- 3. A list of modules which succeeded loading. - -upsweep old_hpt stable_mods cleanup sccs = do - (res, done) <- upsweep' old_hpt [] sccs 1 (length sccs) - return (res, reverse done) - where - - upsweep' _old_hpt done - [] _ _ - = return (Succeeded, done) - - upsweep' _old_hpt done - (CyclicSCC ms:_) _ _ - = do dflags <- getSessionDynFlags - liftIO $ fatalErrorMsg dflags (cyclicModuleErr ms) - return (Failed, done) - - upsweep' old_hpt done - (AcyclicSCC mod:mods) mod_index nmods - = do -- putStrLn ("UPSWEEP_MOD: hpt = " ++ - -- show (map (moduleUserString.moduleName.mi_module.hm_iface) - -- (moduleEnvElts (hsc_HPT hsc_env))) - let logger _mod = defaultWarnErrLogger - - hsc_env <- getSession - mb_mod_info - <- handleSourceError - (\err -> do logger mod (Just err); return Nothing) $ do - mod_info <- liftIO $ upsweep_mod hsc_env old_hpt stable_mods - mod mod_index nmods - logger mod Nothing -- log warnings - return (Just mod_info) - - liftIO cleanup -- Remove unwanted tmp files between compilations - - case mb_mod_info of - Nothing -> return (Failed, done) - Just mod_info -> do - let this_mod = ms_mod_name mod - - -- Add new info to hsc_env - hpt1 = addToUFM (hsc_HPT hsc_env) this_mod mod_info - hsc_env1 = hsc_env { hsc_HPT = hpt1 } - - -- Space-saving: delete the old HPT entry - -- for mod BUT if mod is a hs-boot - -- node, don't delete it. For the - -- interface, the HPT entry is probaby for the - -- main Haskell source file. Deleting it - -- would force the real module to be recompiled - -- every time. - old_hpt1 | isBootSummary mod = old_hpt - | otherwise = delFromUFM old_hpt this_mod - - done' = mod:done - - -- fixup our HomePackageTable after we've finished compiling - -- a mutually-recursive loop. See reTypecheckLoop, below. - hsc_env2 <- liftIO $ reTypecheckLoop hsc_env1 mod done' - setSession hsc_env2 - - upsweep' old_hpt1 done' mods (mod_index+1) nmods - --- | Compile a single module. Always produce a Linkable for it if --- successful. If no compilation happened, return the old Linkable. -upsweep_mod :: HscEnv - -> HomePackageTable - -> ([ModuleName],[ModuleName]) - -> ModSummary - -> Int -- index of module - -> Int -- total number of modules - -> IO HomeModInfo - -upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods - = let - this_mod_name = ms_mod_name summary - this_mod = ms_mod summary - mb_obj_date = ms_obj_date summary - obj_fn = ml_obj_file (ms_location summary) - hs_date = ms_hs_date summary - - is_stable_obj = this_mod_name `elem` stable_obj - is_stable_bco = this_mod_name `elem` stable_bco - - old_hmi = lookupUFM old_hpt this_mod_name - - -- We're using the dflags for this module now, obtained by - -- applying any options in its LANGUAGE & OPTIONS_GHC pragmas. - dflags = ms_hspp_opts summary - prevailing_target = hscTarget (hsc_dflags hsc_env) - local_target = hscTarget dflags - - -- If OPTIONS_GHC contains -fasm or -fvia-C, be careful that - -- we don't do anything dodgy: these should only work to change - -- from -fvia-C to -fasm and vice-versa, otherwise we could - -- end up trying to link object code to byte code. - target = if prevailing_target /= local_target - && (not (isObjectTarget prevailing_target) - || not (isObjectTarget local_target)) - then prevailing_target - else local_target - - -- store the corrected hscTarget into the summary - summary' = summary{ ms_hspp_opts = dflags { hscTarget = target } } - - -- The old interface is ok if - -- a) we're compiling a source file, and the old HPT - -- entry is for a source file - -- b) we're compiling a hs-boot file - -- Case (b) allows an hs-boot file to get the interface of its - -- real source file on the second iteration of the compilation - -- manager, but that does no harm. Otherwise the hs-boot file - -- will always be recompiled - - mb_old_iface - = case old_hmi of - Nothing -> Nothing - Just hm_info | isBootSummary summary -> Just iface - | not (mi_boot iface) -> Just iface - | otherwise -> Nothing - where - iface = hm_iface hm_info - - compile_it :: Maybe Linkable -> IO HomeModInfo - compile_it mb_linkable = - compile hsc_env summary' mod_index nmods - mb_old_iface mb_linkable - - compile_it_discard_iface :: Maybe Linkable -> IO HomeModInfo - compile_it_discard_iface mb_linkable = - compile hsc_env summary' mod_index nmods - Nothing mb_linkable - - -- With the HscNothing target we create empty linkables to avoid - -- recompilation. We have to detect these to recompile anyway if - -- the target changed since the last compile. - is_fake_linkable - | Just hmi <- old_hmi, Just l <- hm_linkable hmi = - null (linkableUnlinked l) - | otherwise = - -- we have no linkable, so it cannot be fake - False - - implies False _ = True - implies True x = x - - in - case () of - _ - -- Regardless of whether we're generating object code or - -- byte code, we can always use an existing object file - -- if it is *stable* (see checkStability). - | is_stable_obj, Just hmi <- old_hmi -> do - liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 - (text "skipping stable obj mod:" <+> ppr this_mod_name) - return hmi - -- object is stable, and we have an entry in the - -- old HPT: nothing to do - - | is_stable_obj, isNothing old_hmi -> do - liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 - (text "compiling stable on-disk mod:" <+> ppr this_mod_name) - linkable <- liftIO $ findObjectLinkable this_mod obj_fn - (expectJust "upsweep1" mb_obj_date) - compile_it (Just linkable) - -- object is stable, but we need to load the interface - -- off disk to make a HMI. - - | not (isObjectTarget target), is_stable_bco, - (target /= HscNothing) `implies` not is_fake_linkable -> - ASSERT(isJust old_hmi) -- must be in the old_hpt - let Just hmi = old_hmi in do - liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 - (text "skipping stable BCO mod:" <+> ppr this_mod_name) - return hmi - -- BCO is stable: nothing to do - - | not (isObjectTarget target), - Just hmi <- old_hmi, - Just l <- hm_linkable hmi, - not (isObjectLinkable l), - (target /= HscNothing) `implies` not is_fake_linkable, - linkableTime l >= ms_hs_date summary -> do - liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 - (text "compiling non-stable BCO mod:" <+> ppr this_mod_name) - compile_it (Just l) - -- we have an old BCO that is up to date with respect - -- to the source: do a recompilation check as normal. - - -- When generating object code, if there's an up-to-date - -- object file on the disk, then we can use it. - -- However, if the object file is new (compared to any - -- linkable we had from a previous compilation), then we - -- must discard any in-memory interface, because this - -- means the user has compiled the source file - -- separately and generated a new interface, that we must - -- read from the disk. - -- - | isObjectTarget target, - Just obj_date <- mb_obj_date, - obj_date >= hs_date -> do - case old_hmi of - Just hmi - | Just l <- hm_linkable hmi, - isObjectLinkable l && linkableTime l == obj_date -> do - liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 - (text "compiling mod with new on-disk obj:" <+> ppr this_mod_name) - compile_it (Just l) - _otherwise -> do - liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 - (text "compiling mod with new on-disk obj2:" <+> ppr this_mod_name) - linkable <- liftIO $ findObjectLinkable this_mod obj_fn obj_date - compile_it_discard_iface (Just linkable) - - _otherwise -> do - liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 - (text "compiling mod:" <+> ppr this_mod_name) - compile_it Nothing - - - --- Filter modules in the HPT -retainInTopLevelEnvs :: [ModuleName] -> HomePackageTable -> HomePackageTable -retainInTopLevelEnvs keep_these hpt - = listToUFM [ (mod, expectJust "retain" mb_mod_info) - | mod <- keep_these - , let mb_mod_info = lookupUFM hpt mod - , isJust mb_mod_info ] - --- --------------------------------------------------------------------------- --- Typecheck module loops - -{- -See bug #930. This code fixes a long-standing bug in --make. The -problem is that when compiling the modules *inside* a loop, a data -type that is only defined at the top of the loop looks opaque; but -after the loop is done, the structure of the data type becomes -apparent. - -The difficulty is then that two different bits of code have -different notions of what the data type looks like. - -The idea is that after we compile a module which also has an .hs-boot -file, we re-generate the ModDetails for each of the modules that -depends on the .hs-boot file, so that everyone points to the proper -TyCons, Ids etc. defined by the real module, not the boot module. -Fortunately re-generating a ModDetails from a ModIface is easy: the -function TcIface.typecheckIface does exactly that. - -Picking the modules to re-typecheck is slightly tricky. Starting from -the module graph consisting of the modules that have already been -compiled, we reverse the edges (so they point from the imported module -to the importing module), and depth-first-search from the .hs-boot -node. This gives us all the modules that depend transitively on the -.hs-boot module, and those are exactly the modules that we need to -re-typecheck. - -Following this fix, GHC can compile itself with --make -O2. --} - -reTypecheckLoop :: HscEnv -> ModSummary -> ModuleGraph -> IO HscEnv -reTypecheckLoop hsc_env ms graph - | not (isBootSummary ms) && - any (\m -> ms_mod m == this_mod && isBootSummary m) graph - = do - let mss = reachableBackwards (ms_mod_name ms) graph - non_boot = filter (not.isBootSummary) mss - debugTraceMsg (hsc_dflags hsc_env) 2 $ - text "Re-typechecking loop: " <> ppr (map ms_mod_name non_boot) - typecheckLoop hsc_env (map ms_mod_name non_boot) - | otherwise - = return hsc_env - where - this_mod = ms_mod ms - -typecheckLoop :: HscEnv -> [ModuleName] -> IO HscEnv -typecheckLoop hsc_env mods = do - new_hpt <- - fixIO $ \new_hpt -> do - let new_hsc_env = hsc_env{ hsc_HPT = new_hpt } - mds <- initIfaceCheck new_hsc_env $ - mapM (typecheckIface . hm_iface) hmis - let new_hpt = addListToUFM old_hpt - (zip mods [ hmi{ hm_details = details } - | (hmi,details) <- zip hmis mds ]) - return new_hpt - return hsc_env{ hsc_HPT = new_hpt } - where - old_hpt = hsc_HPT hsc_env - hmis = map (expectJust "typecheckLoop" . lookupUFM old_hpt) mods - -reachableBackwards :: ModuleName -> [ModSummary] -> [ModSummary] -reachableBackwards mod summaries - = [ ms | (ms,_,_) <- reachableG (transposeG graph) root ] - where -- the rest just sets up the graph: - (graph, lookup_node) = moduleGraphNodes False summaries - root = expectJust "reachableBackwards" (lookup_node HsBootFile mod) - --- --------------------------------------------------------------------------- --- Topological sort of the module graph - -type SummaryNode = (ModSummary, Int, [Int]) - -topSortModuleGraph - :: Bool - -- ^ Drop hi-boot nodes? (see below) - -> [ModSummary] - -> Maybe ModuleName - -- ^ Root module name. If @Nothing@, use the full graph. - -> [SCC ModSummary] --- ^ Calculate SCCs of the module graph, possibly dropping the hi-boot nodes --- The resulting list of strongly-connected-components is in topologically --- sorted order, starting with the module(s) at the bottom of the --- dependency graph (ie compile them first) and ending with the ones at --- the top. --- --- Drop hi-boot nodes (first boolean arg)? --- --- - @False@: treat the hi-boot summaries as nodes of the graph, --- so the graph must be acyclic --- --- - @True@: eliminate the hi-boot nodes, and instead pretend --- the a source-import of Foo is an import of Foo --- The resulting graph has no hi-boot nodes, but can be cyclic - -topSortModuleGraph drop_hs_boot_nodes summaries mb_root_mod - = map (fmap summaryNodeSummary) $ stronglyConnCompG initial_graph - where - (graph, lookup_node) = moduleGraphNodes drop_hs_boot_nodes summaries - - initial_graph = case mb_root_mod of - Nothing -> graph - Just root_mod -> - -- restrict the graph to just those modules reachable from - -- the specified module. We do this by building a graph with - -- the full set of nodes, and determining the reachable set from - -- the specified node. - let root | Just node <- lookup_node HsSrcFile root_mod, graph `hasVertexG` node = node - | otherwise = ghcError (ProgramError "module does not exist") - in graphFromEdgedVertices (seq root (reachableG graph root)) - -summaryNodeKey :: SummaryNode -> Int -summaryNodeKey (_, k, _) = k - -summaryNodeSummary :: SummaryNode -> ModSummary -summaryNodeSummary (s, _, _) = s - -moduleGraphNodes :: Bool -> [ModSummary] - -> (Graph SummaryNode, HscSource -> ModuleName -> Maybe SummaryNode) -moduleGraphNodes drop_hs_boot_nodes summaries = (graphFromEdgedVertices nodes, lookup_node) - where - numbered_summaries = zip summaries [1..] - - lookup_node :: HscSource -> ModuleName -> Maybe SummaryNode - lookup_node hs_src mod = Map.lookup (mod, hs_src) node_map - - lookup_key :: HscSource -> ModuleName -> Maybe Int - lookup_key hs_src mod = fmap summaryNodeKey (lookup_node hs_src mod) - - node_map :: NodeMap SummaryNode - node_map = Map.fromList [ ((moduleName (ms_mod s), ms_hsc_src s), node) - | node@(s, _, _) <- nodes ] - - -- We use integers as the keys for the SCC algorithm - nodes :: [SummaryNode] - nodes = [ (s, key, out_keys) - | (s, key) <- numbered_summaries - -- Drop the hi-boot ones if told to do so - , not (isBootSummary s && drop_hs_boot_nodes) - , let out_keys = out_edge_keys hs_boot_key (map unLoc (ms_home_srcimps s)) ++ - out_edge_keys HsSrcFile (map unLoc (ms_home_imps s)) ++ - (-- see [boot-edges] below - if drop_hs_boot_nodes || ms_hsc_src s == HsBootFile - then [] - else case lookup_key HsBootFile (ms_mod_name s) of - Nothing -> [] - Just k -> [k]) ] - - -- [boot-edges] if this is a .hs and there is an equivalent - -- .hs-boot, add a link from the former to the latter. This - -- has the effect of detecting bogus cases where the .hs-boot - -- depends on the .hs, by introducing a cycle. Additionally, - -- it ensures that we will always process the .hs-boot before - -- the .hs, and so the HomePackageTable will always have the - -- most up to date information. - - -- Drop hs-boot nodes by using HsSrcFile as the key - hs_boot_key | drop_hs_boot_nodes = HsSrcFile - | otherwise = HsBootFile - - out_edge_keys :: HscSource -> [ModuleName] -> [Int] - out_edge_keys hi_boot ms = mapCatMaybes (lookup_key hi_boot) ms - -- If we want keep_hi_boot_nodes, then we do lookup_key with - -- the IsBootInterface parameter True; else False - - -type NodeKey = (ModuleName, HscSource) -- The nodes of the graph are -type NodeMap a = Map.Map NodeKey a -- keyed by (mod, src_file_type) pairs - -msKey :: ModSummary -> NodeKey -msKey (ModSummary { ms_mod = mod, ms_hsc_src = boot }) = (moduleName mod,boot) - -mkNodeMap :: [ModSummary] -> NodeMap ModSummary -mkNodeMap summaries = Map.fromList [ (msKey s, s) | s <- summaries] - -nodeMapElts :: NodeMap a -> [a] -nodeMapElts = Map.elems - --- | If there are {-# SOURCE #-} imports between strongly connected --- components in the topological sort, then those imports can --- definitely be replaced by ordinary non-SOURCE imports: if SOURCE --- were necessary, then the edge would be part of a cycle. -warnUnnecessarySourceImports :: GhcMonad m => [SCC ModSummary] -> m () -warnUnnecessarySourceImports sccs = do - logWarnings (listToBag (concatMap (check.flattenSCC) sccs)) - where check ms = - let mods_in_this_cycle = map ms_mod_name ms in - [ warn i | m <- ms, i <- ms_home_srcimps m, - unLoc i `notElem` mods_in_this_cycle ] - - warn :: Located ModuleName -> WarnMsg - warn (L loc mod) = - mkPlainErrMsg loc - (ptext (sLit "Warning: {-# SOURCE #-} unnecessary in import of ") - <+> quotes (ppr mod)) - ------------------------------------------------------------------------------ --- Downsweep (dependency analysis) - --- Chase downwards from the specified root set, returning summaries --- for all home modules encountered. Only follow source-import --- links. - --- We pass in the previous collection of summaries, which is used as a --- cache to avoid recalculating a module summary if the source is --- unchanged. --- --- The returned list of [ModSummary] nodes has one node for each home-package --- module, plus one for any hs-boot files. The imports of these nodes --- are all there, including the imports of non-home-package modules. - -downsweep :: HscEnv - -> [ModSummary] -- Old summaries - -> [ModuleName] -- Ignore dependencies on these; treat - -- them as if they were package modules - -> Bool -- True <=> allow multiple targets to have - -- the same module name; this is - -- very useful for ghc -M - -> IO [ModSummary] - -- The elts of [ModSummary] all have distinct - -- (Modules, IsBoot) identifiers, unless the Bool is true - -- in which case there can be repeats -downsweep hsc_env old_summaries excl_mods allow_dup_roots - = do - rootSummaries <- mapM getRootSummary roots - let root_map = mkRootMap rootSummaries - checkDuplicates root_map - summs <- loop (concatMap msDeps rootSummaries) root_map - return summs - where - roots = hsc_targets hsc_env - - old_summary_map :: NodeMap ModSummary - old_summary_map = mkNodeMap old_summaries - - getRootSummary :: Target -> IO ModSummary - getRootSummary (Target (TargetFile file mb_phase) obj_allowed maybe_buf) - = do exists <- liftIO $ doesFileExist file - if exists - then summariseFile hsc_env old_summaries file mb_phase - obj_allowed maybe_buf - else throwOneError $ mkPlainErrMsg noSrcSpan $ - text "can't find file:" <+> text file - getRootSummary (Target (TargetModule modl) obj_allowed maybe_buf) - = do maybe_summary <- summariseModule hsc_env old_summary_map False - (L rootLoc modl) obj_allowed - maybe_buf excl_mods - case maybe_summary of - Nothing -> packageModErr modl - Just s -> return s - - rootLoc = mkGeneralSrcSpan (fsLit "") - - -- In a root module, the filename is allowed to diverge from the module - -- name, so we have to check that there aren't multiple root files - -- defining the same module (otherwise the duplicates will be silently - -- ignored, leading to confusing behaviour). - checkDuplicates :: NodeMap [ModSummary] -> IO () - checkDuplicates root_map - | allow_dup_roots = return () - | null dup_roots = return () - | otherwise = liftIO $ multiRootsErr (head dup_roots) - where - dup_roots :: [[ModSummary]] -- Each at least of length 2 - dup_roots = filterOut isSingleton (nodeMapElts root_map) - - loop :: [(Located ModuleName,IsBootInterface)] - -- Work list: process these modules - -> NodeMap [ModSummary] - -- Visited set; the range is a list because - -- the roots can have the same module names - -- if allow_dup_roots is True - -> IO [ModSummary] - -- The result includes the worklist, except - -- for those mentioned in the visited set - loop [] done = return (concat (nodeMapElts done)) - loop ((wanted_mod, is_boot) : ss) done - | Just summs <- Map.lookup key done - = if isSingleton summs then - loop ss done - else - do { multiRootsErr summs; return [] } - | otherwise - = do mb_s <- summariseModule hsc_env old_summary_map - is_boot wanted_mod True - Nothing excl_mods - case mb_s of - Nothing -> loop ss done - Just s -> loop (msDeps s ++ ss) (Map.insert key [s] done) - where - key = (unLoc wanted_mod, if is_boot then HsBootFile else HsSrcFile) - --- XXX Does the (++) here need to be flipped? -mkRootMap :: [ModSummary] -> NodeMap [ModSummary] -mkRootMap summaries = Map.insertListWith (flip (++)) - [ (msKey s, [s]) | s <- summaries ] - Map.empty - -msDeps :: ModSummary -> [(Located ModuleName, IsBootInterface)] --- (msDeps s) returns the dependencies of the ModSummary s. --- A wrinkle is that for a {-# SOURCE #-} import we return --- *both* the hs-boot file --- *and* the source file --- as "dependencies". That ensures that the list of all relevant --- modules always contains B.hs if it contains B.hs-boot. --- Remember, this pass isn't doing the topological sort. It's --- just gathering the list of all relevant ModSummaries -msDeps s = - concat [ [(m,True), (m,False)] | m <- ms_home_srcimps s ] - ++ [ (m,False) | m <- ms_home_imps s ] - -home_imps :: [Located (ImportDecl RdrName)] -> [Located ModuleName] -home_imps imps = [ ideclName i | L _ i <- imps, isLocal (ideclPkgQual i) ] - where isLocal Nothing = True - isLocal (Just pkg) | pkg == fsLit "this" = True -- "this" is special - isLocal _ = False - -ms_home_allimps :: ModSummary -> [ModuleName] -ms_home_allimps ms = map unLoc (ms_home_srcimps ms ++ ms_home_imps ms) - -ms_home_srcimps :: ModSummary -> [Located ModuleName] -ms_home_srcimps = home_imps . ms_srcimps - -ms_home_imps :: ModSummary -> [Located ModuleName] -ms_home_imps = home_imps . ms_imps - ------------------------------------------------------------------------------ --- Summarising modules - --- We have two types of summarisation: --- --- * Summarise a file. This is used for the root module(s) passed to --- cmLoadModules. The file is read, and used to determine the root --- module name. The module name may differ from the filename. --- --- * Summarise a module. We are given a module name, and must provide --- a summary. The finder is used to locate the file in which the module --- resides. - -summariseFile - :: HscEnv - -> [ModSummary] -- old summaries - -> FilePath -- source file name - -> Maybe Phase -- start phase - -> Bool -- object code allowed? - -> Maybe (StringBuffer,ClockTime) - -> IO ModSummary - -summariseFile hsc_env old_summaries file mb_phase obj_allowed maybe_buf - -- we can use a cached summary if one is available and the - -- source file hasn't changed, But we have to look up the summary - -- by source file, rather than module name as we do in summarise. - | Just old_summary <- findSummaryBySourceFile old_summaries file - = do - let location = ms_location old_summary - - -- return the cached summary if the source didn't change - src_timestamp <- case maybe_buf of - Just (_,t) -> return t - Nothing -> liftIO $ getModificationTime file - -- The file exists; we checked in getRootSummary above. - -- If it gets removed subsequently, then this - -- getModificationTime may fail, but that's the right - -- behaviour. - - if ms_hs_date old_summary == src_timestamp - then do -- update the object-file timestamp - obj_timestamp <- - if isObjectTarget (hscTarget (hsc_dflags hsc_env)) - || obj_allowed -- bug #1205 - then liftIO $ getObjTimestamp location False - else return Nothing - return old_summary{ ms_obj_date = obj_timestamp } - else - new_summary - - | otherwise - = new_summary - where - new_summary = do - let dflags = hsc_dflags hsc_env - - (dflags', hspp_fn, buf) - <- preprocessFile hsc_env file mb_phase maybe_buf - - (srcimps,the_imps, L _ mod_name) <- getImports dflags' buf hspp_fn file - - -- Make a ModLocation for this file - location <- liftIO $ mkHomeModLocation dflags mod_name file - - -- Tell the Finder cache where it is, so that subsequent calls - -- to findModule will find it, even if it's not on any search path - mod <- liftIO $ addHomeModuleToFinder hsc_env mod_name location - - src_timestamp <- case maybe_buf of - Just (_,t) -> return t - Nothing -> liftIO $ getModificationTime file - -- getMofificationTime may fail - - -- when the user asks to load a source file by name, we only - -- use an object file if -fobject-code is on. See #1205. - obj_timestamp <- - if isObjectTarget (hscTarget (hsc_dflags hsc_env)) - || obj_allowed -- bug #1205 - then liftIO $ modificationTimeIfExists (ml_obj_file location) - else return Nothing - - return (ModSummary { ms_mod = mod, ms_hsc_src = HsSrcFile, - ms_location = location, - ms_hspp_file = hspp_fn, - ms_hspp_opts = dflags', - ms_hspp_buf = Just buf, - ms_srcimps = srcimps, ms_imps = the_imps, - ms_hs_date = src_timestamp, - ms_obj_date = obj_timestamp }) - -findSummaryBySourceFile :: [ModSummary] -> FilePath -> Maybe ModSummary -findSummaryBySourceFile summaries file - = case [ ms | ms <- summaries, HsSrcFile <- [ms_hsc_src ms], - expectJust "findSummaryBySourceFile" (ml_hs_file (ms_location ms)) == file ] of - [] -> Nothing - (x:_) -> Just x - --- Summarise a module, and pick up source and timestamp. -summariseModule - :: HscEnv - -> NodeMap ModSummary -- Map of old summaries - -> IsBootInterface -- True <=> a {-# SOURCE #-} import - -> Located ModuleName -- Imported module to be summarised - -> Bool -- object code allowed? - -> Maybe (StringBuffer, ClockTime) - -> [ModuleName] -- Modules to exclude - -> IO (Maybe ModSummary) -- Its new summary - -summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) - obj_allowed maybe_buf excl_mods - | wanted_mod `elem` excl_mods - = return Nothing - - | Just old_summary <- Map.lookup (wanted_mod, hsc_src) old_summary_map - = do -- Find its new timestamp; all the - -- ModSummaries in the old map have valid ml_hs_files - let location = ms_location old_summary - src_fn = expectJust "summariseModule" (ml_hs_file location) - - -- check the modification time on the source file, and - -- return the cached summary if it hasn't changed. If the - -- file has disappeared, we need to call the Finder again. - case maybe_buf of - Just (_,t) -> check_timestamp old_summary location src_fn t - Nothing -> do - m <- tryIO (getModificationTime src_fn) - case m of - Right t -> check_timestamp old_summary location src_fn t - Left e | isDoesNotExistError e -> find_it - | otherwise -> ioError e - - | otherwise = find_it - where - dflags = hsc_dflags hsc_env - - hsc_src = if is_boot then HsBootFile else HsSrcFile - - check_timestamp old_summary location src_fn src_timestamp - | ms_hs_date old_summary == src_timestamp = do - -- update the object-file timestamp - obj_timestamp <- - if isObjectTarget (hscTarget (hsc_dflags hsc_env)) - || obj_allowed -- bug #1205 - then getObjTimestamp location is_boot - else return Nothing - return (Just old_summary{ ms_obj_date = obj_timestamp }) - | otherwise = - -- source changed: re-summarise. - new_summary location (ms_mod old_summary) src_fn src_timestamp - - find_it = do - -- Don't use the Finder's cache this time. If the module was - -- previously a package module, it may have now appeared on the - -- search path, so we want to consider it to be a home module. If - -- the module was previously a home module, it may have moved. - uncacheModule hsc_env wanted_mod - found <- findImportedModule hsc_env wanted_mod Nothing - case found of - Found location mod - | isJust (ml_hs_file location) -> - -- Home package - just_found location mod - | otherwise -> - -- Drop external-pkg - ASSERT(modulePackageId mod /= thisPackage dflags) - return Nothing - - err -> noModError dflags loc wanted_mod err - -- Not found - - just_found location mod = do - -- Adjust location to point to the hs-boot source file, - -- hi file, object file, when is_boot says so - let location' | is_boot = addBootSuffixLocn location - | otherwise = location - src_fn = expectJust "summarise2" (ml_hs_file location') - - -- Check that it exists - -- It might have been deleted since the Finder last found it - maybe_t <- modificationTimeIfExists src_fn - case maybe_t of - Nothing -> noHsFileErr loc src_fn - Just t -> new_summary location' mod src_fn t - - - new_summary location mod src_fn src_timestamp - = do - -- Preprocess the source file and get its imports - -- The dflags' contains the OPTIONS pragmas - (dflags', hspp_fn, buf) <- preprocessFile hsc_env src_fn Nothing maybe_buf - (srcimps, the_imps, L mod_loc mod_name) <- getImports dflags' buf hspp_fn src_fn - - when (mod_name /= wanted_mod) $ - throwOneError $ mkPlainErrMsg mod_loc $ - text "File name does not match module name:" - $$ text "Saw:" <+> quotes (ppr mod_name) - $$ text "Expected:" <+> quotes (ppr wanted_mod) - - -- Find the object timestamp, and return the summary - obj_timestamp <- - if isObjectTarget (hscTarget (hsc_dflags hsc_env)) - || obj_allowed -- bug #1205 - then getObjTimestamp location is_boot - else return Nothing - - return (Just (ModSummary { ms_mod = mod, - ms_hsc_src = hsc_src, - ms_location = location, - ms_hspp_file = hspp_fn, - ms_hspp_opts = dflags', - ms_hspp_buf = Just buf, - ms_srcimps = srcimps, - ms_imps = the_imps, - ms_hs_date = src_timestamp, - ms_obj_date = obj_timestamp })) - - -getObjTimestamp :: ModLocation -> Bool -> IO (Maybe ClockTime) -getObjTimestamp location is_boot - = if is_boot then return Nothing - else modificationTimeIfExists (ml_obj_file location) - - -preprocessFile :: HscEnv - -> FilePath - -> Maybe Phase -- ^ Starting phase - -> Maybe (StringBuffer,ClockTime) - -> IO (DynFlags, FilePath, StringBuffer) -preprocessFile hsc_env src_fn mb_phase Nothing - = do - (dflags', hspp_fn) <- preprocess hsc_env (src_fn, mb_phase) - buf <- hGetStringBuffer hspp_fn - return (dflags', hspp_fn, buf) - -preprocessFile hsc_env src_fn mb_phase (Just (buf, _time)) - = do - let dflags = hsc_dflags hsc_env - -- case we bypass the preprocessing stage? - let - local_opts = getOptions dflags buf src_fn - -- - (dflags', leftovers, warns) - <- parseDynamicNoPackageFlags dflags local_opts - checkProcessArgsResult leftovers - handleFlagWarnings dflags' warns - - let - needs_preprocessing - | Just (Unlit _) <- mb_phase = True - | Nothing <- mb_phase, Unlit _ <- startPhase src_fn = True - -- note: local_opts is only required if there's no Unlit phase - | xopt Opt_Cpp dflags' = True - | dopt Opt_Pp dflags' = True - | otherwise = False - - when needs_preprocessing $ - ghcError (ProgramError "buffer needs preprocesing; interactive check disabled") - - return (dflags', src_fn, buf) - - ------------------------------------------------------------------------------ --- Error messages ------------------------------------------------------------------------------ - -noModError :: DynFlags -> SrcSpan -> ModuleName -> FindResult -> IO ab --- ToDo: we don't have a proper line number for this error -noModError dflags loc wanted_mod err - = throwOneError $ mkPlainErrMsg loc $ cannotFindModule dflags wanted_mod err - -noHsFileErr :: SrcSpan -> String -> IO a -noHsFileErr loc path - = throwOneError $ mkPlainErrMsg loc $ text "Can't find" <+> text path - -packageModErr :: ModuleName -> IO a -packageModErr mod - = throwOneError $ mkPlainErrMsg noSrcSpan $ - text "module" <+> quotes (ppr mod) <+> text "is a package module" - -multiRootsErr :: [ModSummary] -> IO () -multiRootsErr [] = panic "multiRootsErr" -multiRootsErr summs@(summ1:_) - = throwOneError $ mkPlainErrMsg noSrcSpan $ - text "module" <+> quotes (ppr mod) <+> - text "is defined in multiple files:" <+> - sep (map text files) - where - mod = ms_mod summ1 - files = map (expectJust "checkDup" . ml_hs_file . ms_location) summs - -cyclicModuleErr :: [ModSummary] -> SDoc -cyclicModuleErr ms - = hang (ptext (sLit "Module imports form a cycle for modules:")) - 2 (vcat (map show_one ms)) - where - mods_in_cycle = map ms_mod_name ms - imp_modname = unLoc . ideclName . unLoc - just_in_cycle = filter ((`elem` mods_in_cycle) . imp_modname) - - show_one ms = - vcat [ show_mod (ms_hsc_src ms) (ms_mod_name ms) <+> - maybe empty (parens . text) (ml_hs_file (ms_location ms)), - nest 2 $ ptext (sLit "imports:") <+> vcat [ - pp_imps HsBootFile (just_in_cycle $ ms_srcimps ms), - pp_imps HsSrcFile (just_in_cycle $ ms_imps ms) ] - ] - show_mod hsc_src mod = ppr mod <> text (hscSourceString hsc_src) - pp_imps src imps = fsep (map (show_mod src . unLoc . ideclName . unLoc) imps) +-- ----------------------------------------------------------------------------- +-- +-- (c) The University of Glasgow, 2011 +-- +-- This module implements multi-module compilation, and is used +-- by --make and GHCi. +-- +-- ----------------------------------------------------------------------------- + +module GhcMake( + depanal, + load, LoadHowMuch(..), + + topSortModuleGraph, + + noModError, cyclicModuleErr + ) where + +#include "HsVersions.h" + +#ifdef GHCI +import qualified Linker ( unload ) +#endif + +import DriverPipeline +import DriverPhases +import GhcMonad +import Module +import HscTypes +import ErrUtils +import DynFlags +import HsSyn hiding ((<.>)) +import Finder +import HeaderInfo +import TcIface ( typecheckIface ) +import TcRnMonad ( initIfaceCheck ) +import RdrName ( RdrName ) + +import Exception ( evaluate, tryIO ) +import Panic +import SysTools +import BasicTypes +import SrcLoc +import Util +import Digraph +import Bag ( listToBag ) +import Maybes ( expectJust, mapCatMaybes ) +import StringBuffer +import FastString +import Outputable +import UniqFM + +import qualified Data.Map as Map +import qualified FiniteMap as Map( insertListWith) + +import System.Directory ( doesFileExist, getModificationTime ) +import System.IO ( fixIO ) +import System.IO.Error ( isDoesNotExistError ) +import System.Time ( ClockTime ) +import System.FilePath +import Control.Monad +import Data.Maybe +import Data.List +import qualified Data.List as List + +-- ----------------------------------------------------------------------------- +-- Loading the program + +-- | Perform a dependency analysis starting from the current targets +-- and update the session with the new module graph. +-- +-- Dependency analysis entails parsing the @import@ directives and may +-- therefore require running certain preprocessors. +-- +-- Note that each 'ModSummary' in the module graph caches its 'DynFlags'. +-- These 'DynFlags' are determined by the /current/ session 'DynFlags' and the +-- @OPTIONS@ and @LANGUAGE@ pragmas of the parsed module. Thus if you want to +-- changes to the 'DynFlags' to take effect you need to call this function +-- again. +-- +depanal :: GhcMonad m => + [ModuleName] -- ^ excluded modules + -> Bool -- ^ allow duplicate roots + -> m ModuleGraph +depanal excluded_mods allow_dup_roots = do + hsc_env <- getSession + let + dflags = hsc_dflags hsc_env + targets = hsc_targets hsc_env + old_graph = hsc_mod_graph hsc_env + + liftIO $ showPass dflags "Chasing dependencies" + liftIO $ debugTraceMsg dflags 2 (hcat [ + text "Chasing modules from: ", + hcat (punctuate comma (map pprTarget targets))]) + + mod_graph <- liftIO $ downsweep hsc_env old_graph excluded_mods allow_dup_roots + modifySession $ \_ -> hsc_env { hsc_mod_graph = mod_graph } + return mod_graph + +-- | Describes which modules of the module graph need to be loaded. +data LoadHowMuch + = LoadAllTargets + -- ^ Load all targets and its dependencies. + | LoadUpTo ModuleName + -- ^ Load only the given module and its dependencies. + | LoadDependenciesOf ModuleName + -- ^ Load only the dependencies of the given module, but not the module + -- itself. + +-- | Try to load the program. See 'LoadHowMuch' for the different modes. +-- +-- This function implements the core of GHC's @--make@ mode. It preprocesses, +-- compiles and loads the specified modules, avoiding re-compilation wherever +-- possible. Depending on the target (see 'DynFlags.hscTarget') compilating +-- and loading may result in files being created on disk. +-- +-- Calls the 'reportModuleCompilationResult' callback after each compiling +-- each module, whether successful or not. +-- +-- Throw a 'SourceError' if errors are encountered before the actual +-- compilation starts (e.g., during dependency analysis). All other errors +-- are reported using the callback. +-- +load :: GhcMonad m => LoadHowMuch -> m SuccessFlag +load how_much = do + mod_graph <- depanal [] False + load2 how_much mod_graph + +load2 :: GhcMonad m => LoadHowMuch -> [ModSummary] + -> m SuccessFlag +load2 how_much mod_graph = do + guessOutputFile + hsc_env <- getSession + + let hpt1 = hsc_HPT hsc_env + let dflags = hsc_dflags hsc_env + + -- The "bad" boot modules are the ones for which we have + -- B.hs-boot in the module graph, but no B.hs + -- The downsweep should have ensured this does not happen + -- (see msDeps) + let all_home_mods = [ms_mod_name s + | s <- mod_graph, not (isBootSummary s)] + bad_boot_mods = [s | s <- mod_graph, isBootSummary s, + not (ms_mod_name s `elem` all_home_mods)] + ASSERT( null bad_boot_mods ) return () + + -- check that the module given in HowMuch actually exists, otherwise + -- topSortModuleGraph will bomb later. + let checkHowMuch (LoadUpTo m) = checkMod m + checkHowMuch (LoadDependenciesOf m) = checkMod m + checkHowMuch _ = id + + checkMod m and_then + | m `elem` all_home_mods = and_then + | otherwise = do + liftIO $ errorMsg dflags (text "no such module:" <+> + quotes (ppr m)) + return Failed + + checkHowMuch how_much $ do + + -- mg2_with_srcimps drops the hi-boot nodes, returning a + -- graph with cycles. Among other things, it is used for + -- backing out partially complete cycles following a failed + -- upsweep, and for removing from hpt all the modules + -- not in strict downwards closure, during calls to compile. + let mg2_with_srcimps :: [SCC ModSummary] + mg2_with_srcimps = topSortModuleGraph True mod_graph Nothing + + -- If we can determine that any of the {-# SOURCE #-} imports + -- are definitely unnecessary, then emit a warning. + warnUnnecessarySourceImports mg2_with_srcimps + + let + -- check the stability property for each module. + stable_mods@(stable_obj,stable_bco) + = checkStability hpt1 mg2_with_srcimps all_home_mods + + -- prune bits of the HPT which are definitely redundant now, + -- to save space. + pruned_hpt = pruneHomePackageTable hpt1 + (flattenSCCs mg2_with_srcimps) + stable_mods + + _ <- liftIO $ evaluate pruned_hpt + + -- before we unload anything, make sure we don't leave an old + -- interactive context around pointing to dead bindings. Also, + -- write the pruned HPT to allow the old HPT to be GC'd. + modifySession $ \_ -> hsc_env{ hsc_IC = emptyInteractiveContext, + hsc_HPT = pruned_hpt } + + liftIO $ debugTraceMsg dflags 2 (text "Stable obj:" <+> ppr stable_obj $$ + text "Stable BCO:" <+> ppr stable_bco) + + -- Unload any modules which are going to be re-linked this time around. + let stable_linkables = [ linkable + | m <- stable_obj++stable_bco, + Just hmi <- [lookupUFM pruned_hpt m], + Just linkable <- [hm_linkable hmi] ] + liftIO $ unload hsc_env stable_linkables + + -- We could at this point detect cycles which aren't broken by + -- a source-import, and complain immediately, but it seems better + -- to let upsweep_mods do this, so at least some useful work gets + -- done before the upsweep is abandoned. + --hPutStrLn stderr "after tsort:\n" + --hPutStrLn stderr (showSDoc (vcat (map ppr mg2))) + + -- Now do the upsweep, calling compile for each module in + -- turn. Final result is version 3 of everything. + + -- Topologically sort the module graph, this time including hi-boot + -- nodes, and possibly just including the portion of the graph + -- reachable from the module specified in the 2nd argument to load. + -- This graph should be cycle-free. + -- If we're restricting the upsweep to a portion of the graph, we + -- also want to retain everything that is still stable. + let full_mg :: [SCC ModSummary] + full_mg = topSortModuleGraph False mod_graph Nothing + + maybe_top_mod = case how_much of + LoadUpTo m -> Just m + LoadDependenciesOf m -> Just m + _ -> Nothing + + partial_mg0 :: [SCC ModSummary] + partial_mg0 = topSortModuleGraph False mod_graph maybe_top_mod + + -- LoadDependenciesOf m: we want the upsweep to stop just + -- short of the specified module (unless the specified module + -- is stable). + partial_mg + | LoadDependenciesOf _mod <- how_much + = ASSERT( case last partial_mg0 of + AcyclicSCC ms -> ms_mod_name ms == _mod; _ -> False ) + List.init partial_mg0 + | otherwise + = partial_mg0 + + stable_mg = + [ AcyclicSCC ms + | AcyclicSCC ms <- full_mg, + ms_mod_name ms `elem` stable_obj++stable_bco, + ms_mod_name ms `notElem` [ ms_mod_name ms' | + AcyclicSCC ms' <- partial_mg ] ] + + mg = stable_mg ++ partial_mg + + -- clean up between compilations + let cleanup hsc_env = intermediateCleanTempFiles dflags + (flattenSCCs mg2_with_srcimps) + hsc_env + + liftIO $ debugTraceMsg dflags 2 (hang (text "Ready for upsweep") + 2 (ppr mg)) + + setSession hsc_env{ hsc_HPT = emptyHomePackageTable } + (upsweep_ok, modsUpswept) + <- upsweep pruned_hpt stable_mods cleanup mg + + -- Make modsDone be the summaries for each home module now + -- available; this should equal the domain of hpt3. + -- Get in in a roughly top .. bottom order (hence reverse). + + let modsDone = reverse modsUpswept + + -- Try and do linking in some form, depending on whether the + -- upsweep was completely or only partially successful. + + if succeeded upsweep_ok + + then + -- Easy; just relink it all. + do liftIO $ debugTraceMsg dflags 2 (text "Upsweep completely successful.") + + -- Clean up after ourselves + hsc_env1 <- getSession + liftIO $ intermediateCleanTempFiles dflags modsDone hsc_env1 + + -- Issue a warning for the confusing case where the user + -- said '-o foo' but we're not going to do any linking. + -- We attempt linking if either (a) one of the modules is + -- called Main, or (b) the user said -no-hs-main, indicating + -- that main() is going to come from somewhere else. + -- + let ofile = outputFile dflags + let no_hs_main = dopt Opt_NoHsMain dflags + let + main_mod = mainModIs dflags + a_root_is_Main = any ((==main_mod).ms_mod) mod_graph + do_linking = a_root_is_Main || no_hs_main || ghcLink dflags == LinkDynLib + + when (ghcLink dflags == LinkBinary + && isJust ofile && not do_linking) $ + liftIO $ debugTraceMsg dflags 1 $ + text ("Warning: output was redirected with -o, " ++ + "but no output will be generated\n" ++ + "because there is no " ++ + moduleNameString (moduleName main_mod) ++ " module.") + + -- link everything together + linkresult <- liftIO $ link (ghcLink dflags) dflags do_linking (hsc_HPT hsc_env1) + + loadFinish Succeeded linkresult + + else + -- Tricky. We need to back out the effects of compiling any + -- half-done cycles, both so as to clean up the top level envs + -- and to avoid telling the interactive linker to link them. + do liftIO $ debugTraceMsg dflags 2 (text "Upsweep partially successful.") + + let modsDone_names + = map ms_mod modsDone + let mods_to_zap_names + = findPartiallyCompletedCycles modsDone_names + mg2_with_srcimps + let mods_to_keep + = filter ((`notElem` mods_to_zap_names).ms_mod) + modsDone + + hsc_env1 <- getSession + let hpt4 = retainInTopLevelEnvs (map ms_mod_name mods_to_keep) + (hsc_HPT hsc_env1) + + -- Clean up after ourselves + liftIO $ intermediateCleanTempFiles dflags mods_to_keep hsc_env1 + + -- there should be no Nothings where linkables should be, now + ASSERT(all (isJust.hm_linkable) + (eltsUFM (hsc_HPT hsc_env))) do + + -- Link everything together + linkresult <- liftIO $ link (ghcLink dflags) dflags False hpt4 + + modifySession $ \hsc_env -> hsc_env{ hsc_HPT = hpt4 } + loadFinish Failed linkresult + +-- Finish up after a load. + +-- If the link failed, unload everything and return. +loadFinish :: GhcMonad m => + SuccessFlag -> SuccessFlag + -> m SuccessFlag +loadFinish _all_ok Failed + = do hsc_env <- getSession + liftIO $ unload hsc_env [] + modifySession discardProg + return Failed + +-- Empty the interactive context and set the module context to the topmost +-- newly loaded module, or the Prelude if none were loaded. +loadFinish all_ok Succeeded + = do modifySession $ \hsc_env -> hsc_env{ hsc_IC = emptyInteractiveContext } + return all_ok + + +-- Forget the current program, but retain the persistent info in HscEnv +discardProg :: HscEnv -> HscEnv +discardProg hsc_env + = hsc_env { hsc_mod_graph = emptyMG, + hsc_IC = emptyInteractiveContext, + hsc_HPT = emptyHomePackageTable } + +intermediateCleanTempFiles :: DynFlags -> [ModSummary] -> HscEnv -> IO () +intermediateCleanTempFiles dflags summaries hsc_env + = cleanTempFilesExcept dflags except + where + except = + -- Save preprocessed files. The preprocessed file *might* be + -- the same as the source file, but that doesn't do any + -- harm. + map ms_hspp_file summaries ++ + -- Save object files for loaded modules. The point of this + -- is that we might have generated and compiled a stub C + -- file, and in the case of GHCi the object file will be a + -- temporary file which we must not remove because we need + -- to load/link it later. + hptObjs (hsc_HPT hsc_env) + +-- | If there is no -o option, guess the name of target executable +-- by using top-level source file name as a base. +guessOutputFile :: GhcMonad m => m () +guessOutputFile = modifySession $ \env -> + let dflags = hsc_dflags env + mod_graph = hsc_mod_graph env + mainModuleSrcPath :: Maybe String + mainModuleSrcPath = do + let isMain = (== mainModIs dflags) . ms_mod + [ms] <- return (filter isMain mod_graph) + ml_hs_file (ms_location ms) + name = fmap dropExtension mainModuleSrcPath + +#if defined(mingw32_HOST_OS) + -- we must add the .exe extention unconditionally here, otherwise + -- when name has an extension of its own, the .exe extension will + -- not be added by DriverPipeline.exeFileName. See #2248 + name_exe = fmap (<.> "exe") name +#else + name_exe = name +#endif + in + case outputFile dflags of + Just _ -> env + Nothing -> env { hsc_dflags = dflags { outputFile = name_exe } } + +-- ----------------------------------------------------------------------------- + +-- | Prune the HomePackageTable +-- +-- Before doing an upsweep, we can throw away: +-- +-- - For non-stable modules: +-- - all ModDetails, all linked code +-- - all unlinked code that is out of date with respect to +-- the source file +-- +-- This is VERY IMPORTANT otherwise we'll end up requiring 2x the +-- space at the end of the upsweep, because the topmost ModDetails of the +-- old HPT holds on to the entire type environment from the previous +-- compilation. + +pruneHomePackageTable + :: HomePackageTable + -> [ModSummary] + -> ([ModuleName],[ModuleName]) + -> HomePackageTable + +pruneHomePackageTable hpt summ (stable_obj, stable_bco) + = mapUFM prune hpt + where prune hmi + | is_stable modl = hmi' + | otherwise = hmi'{ hm_details = emptyModDetails } + where + modl = moduleName (mi_module (hm_iface hmi)) + hmi' | Just l <- hm_linkable hmi, linkableTime l < ms_hs_date ms + = hmi{ hm_linkable = Nothing } + | otherwise + = hmi + where ms = expectJust "prune" (lookupUFM ms_map modl) + + ms_map = listToUFM [(ms_mod_name ms, ms) | ms <- summ] + + is_stable m = m `elem` stable_obj || m `elem` stable_bco + +-- ----------------------------------------------------------------------------- + +-- Return (names of) all those in modsDone who are part of a cycle +-- as defined by theGraph. +findPartiallyCompletedCycles :: [Module] -> [SCC ModSummary] -> [Module] +findPartiallyCompletedCycles modsDone theGraph + = chew theGraph + where + chew [] = [] + chew ((AcyclicSCC _):rest) = chew rest -- acyclic? not interesting. + chew ((CyclicSCC vs):rest) + = let names_in_this_cycle = nub (map ms_mod vs) + mods_in_this_cycle + = nub ([done | done <- modsDone, + done `elem` names_in_this_cycle]) + chewed_rest = chew rest + in + if notNull mods_in_this_cycle + && length mods_in_this_cycle < length names_in_this_cycle + then mods_in_this_cycle ++ chewed_rest + else chewed_rest + + +-- --------------------------------------------------------------------------- +-- Unloading + +unload :: HscEnv -> [Linkable] -> IO () +unload hsc_env stable_linkables -- Unload everthing *except* 'stable_linkables' + = case ghcLink (hsc_dflags hsc_env) of +#ifdef GHCI + LinkInMemory -> Linker.unload (hsc_dflags hsc_env) stable_linkables +#else + LinkInMemory -> panic "unload: no interpreter" + -- urgh. avoid warnings: + hsc_env stable_linkables +#endif + _other -> return () + +-- ----------------------------------------------------------------------------- + +{- | + + Stability tells us which modules definitely do not need to be recompiled. + There are two main reasons for having stability: + + - avoid doing a complete upsweep of the module graph in GHCi when + modules near the bottom of the tree have not changed. + + - to tell GHCi when it can load object code: we can only load object code + for a module when we also load object code fo all of the imports of the + module. So we need to know that we will definitely not be recompiling + any of these modules, and we can use the object code. + + The stability check is as follows. Both stableObject and + stableBCO are used during the upsweep phase later. + +@ + stable m = stableObject m || stableBCO m + + stableObject m = + all stableObject (imports m) + && old linkable does not exist, or is == on-disk .o + && date(on-disk .o) > date(.hs) + + stableBCO m = + all stable (imports m) + && date(BCO) > date(.hs) +@ + + These properties embody the following ideas: + + - if a module is stable, then: + + - if it has been compiled in a previous pass (present in HPT) + then it does not need to be compiled or re-linked. + + - if it has not been compiled in a previous pass, + then we only need to read its .hi file from disk and + link it to produce a 'ModDetails'. + + - if a modules is not stable, we will definitely be at least + re-linking, and possibly re-compiling it during the 'upsweep'. + All non-stable modules can (and should) therefore be unlinked + before the 'upsweep'. + + - Note that objects are only considered stable if they only depend + on other objects. We can't link object code against byte code. +-} + +checkStability + :: HomePackageTable -- HPT from last compilation + -> [SCC ModSummary] -- current module graph (cyclic) + -> [ModuleName] -- all home modules + -> ([ModuleName], -- stableObject + [ModuleName]) -- stableBCO + +checkStability hpt sccs all_home_mods = foldl checkSCC ([],[]) sccs + where + checkSCC (stable_obj, stable_bco) scc0 + | stableObjects = (scc_mods ++ stable_obj, stable_bco) + | stableBCOs = (stable_obj, scc_mods ++ stable_bco) + | otherwise = (stable_obj, stable_bco) + where + scc = flattenSCC scc0 + scc_mods = map ms_mod_name scc + home_module m = m `elem` all_home_mods && m `notElem` scc_mods + + scc_allimps = nub (filter home_module (concatMap ms_home_allimps scc)) + -- all imports outside the current SCC, but in the home pkg + + stable_obj_imps = map (`elem` stable_obj) scc_allimps + stable_bco_imps = map (`elem` stable_bco) scc_allimps + + stableObjects = + and stable_obj_imps + && all object_ok scc + + stableBCOs = + and (zipWith (||) stable_obj_imps stable_bco_imps) + && all bco_ok scc + + object_ok ms + | Just t <- ms_obj_date ms = t >= ms_hs_date ms + && same_as_prev t + | otherwise = False + where + same_as_prev t = case lookupUFM hpt (ms_mod_name ms) of + Just hmi | Just l <- hm_linkable hmi + -> isObjectLinkable l && t == linkableTime l + _other -> True + -- why '>=' rather than '>' above? If the filesystem stores + -- times to the nearset second, we may occasionally find that + -- the object & source have the same modification time, + -- especially if the source was automatically generated + -- and compiled. Using >= is slightly unsafe, but it matches + -- make's behaviour. + + bco_ok ms + = case lookupUFM hpt (ms_mod_name ms) of + Just hmi | Just l <- hm_linkable hmi -> + not (isObjectLinkable l) && + linkableTime l >= ms_hs_date ms + _other -> False + +-- ----------------------------------------------------------------------------- + +-- | The upsweep +-- +-- This is where we compile each module in the module graph, in a pass +-- from the bottom to the top of the graph. +-- +-- There better had not be any cyclic groups here -- we check for them. + +upsweep + :: GhcMonad m + => HomePackageTable -- ^ HPT from last time round (pruned) + -> ([ModuleName],[ModuleName]) -- ^ stable modules (see checkStability) + -> (HscEnv -> IO ()) -- ^ How to clean up unwanted tmp files + -> [SCC ModSummary] -- ^ Mods to do (the worklist) + -> m (SuccessFlag, + [ModSummary]) + -- ^ Returns: + -- + -- 1. A flag whether the complete upsweep was successful. + -- 2. The 'HscEnv' in the monad has an updated HPT + -- 3. A list of modules which succeeded loading. + +upsweep old_hpt stable_mods cleanup sccs = do + (res, done) <- upsweep' old_hpt [] sccs 1 (length sccs) + return (res, reverse done) + where + + upsweep' _old_hpt done + [] _ _ + = return (Succeeded, done) + + upsweep' _old_hpt done + (CyclicSCC ms:_) _ _ + = do dflags <- getSessionDynFlags + liftIO $ fatalErrorMsg dflags (cyclicModuleErr ms) + return (Failed, done) + + upsweep' old_hpt done + (AcyclicSCC mod:mods) mod_index nmods + = do -- putStrLn ("UPSWEEP_MOD: hpt = " ++ + -- show (map (moduleUserString.moduleName.mi_module.hm_iface) + -- (moduleEnvElts (hsc_HPT hsc_env))) + let logger _mod = defaultWarnErrLogger + + hsc_env <- getSession + + -- Remove unwanted tmp files between compilations + liftIO (cleanup hsc_env) + + mb_mod_info + <- handleSourceError + (\err -> do logger mod (Just err); return Nothing) $ do + mod_info <- liftIO $ upsweep_mod hsc_env old_hpt stable_mods + mod mod_index nmods + logger mod Nothing -- log warnings + return (Just mod_info) + + case mb_mod_info of + Nothing -> return (Failed, done) + Just mod_info -> do + let this_mod = ms_mod_name mod + + -- Add new info to hsc_env + hpt1 = addToUFM (hsc_HPT hsc_env) this_mod mod_info + hsc_env1 = hsc_env { hsc_HPT = hpt1 } + + -- Space-saving: delete the old HPT entry + -- for mod BUT if mod is a hs-boot + -- node, don't delete it. For the + -- interface, the HPT entry is probaby for the + -- main Haskell source file. Deleting it + -- would force the real module to be recompiled + -- every time. + old_hpt1 | isBootSummary mod = old_hpt + | otherwise = delFromUFM old_hpt this_mod + + done' = mod:done + + -- fixup our HomePackageTable after we've finished compiling + -- a mutually-recursive loop. See reTypecheckLoop, below. + hsc_env2 <- liftIO $ reTypecheckLoop hsc_env1 mod done' + setSession hsc_env2 + + upsweep' old_hpt1 done' mods (mod_index+1) nmods + +-- | Compile a single module. Always produce a Linkable for it if +-- successful. If no compilation happened, return the old Linkable. +upsweep_mod :: HscEnv + -> HomePackageTable + -> ([ModuleName],[ModuleName]) + -> ModSummary + -> Int -- index of module + -> Int -- total number of modules + -> IO HomeModInfo + +upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods + = let + this_mod_name = ms_mod_name summary + this_mod = ms_mod summary + mb_obj_date = ms_obj_date summary + obj_fn = ml_obj_file (ms_location summary) + hs_date = ms_hs_date summary + + is_stable_obj = this_mod_name `elem` stable_obj + is_stable_bco = this_mod_name `elem` stable_bco + + old_hmi = lookupUFM old_hpt this_mod_name + + -- We're using the dflags for this module now, obtained by + -- applying any options in its LANGUAGE & OPTIONS_GHC pragmas. + dflags = ms_hspp_opts summary + prevailing_target = hscTarget (hsc_dflags hsc_env) + local_target = hscTarget dflags + + -- If OPTIONS_GHC contains -fasm or -fvia-C, be careful that + -- we don't do anything dodgy: these should only work to change + -- from -fvia-C to -fasm and vice-versa, otherwise we could + -- end up trying to link object code to byte code. + target = if prevailing_target /= local_target + && (not (isObjectTarget prevailing_target) + || not (isObjectTarget local_target)) + then prevailing_target + else local_target + + -- store the corrected hscTarget into the summary + summary' = summary{ ms_hspp_opts = dflags { hscTarget = target } } + + -- The old interface is ok if + -- a) we're compiling a source file, and the old HPT + -- entry is for a source file + -- b) we're compiling a hs-boot file + -- Case (b) allows an hs-boot file to get the interface of its + -- real source file on the second iteration of the compilation + -- manager, but that does no harm. Otherwise the hs-boot file + -- will always be recompiled + + mb_old_iface + = case old_hmi of + Nothing -> Nothing + Just hm_info | isBootSummary summary -> Just iface + | not (mi_boot iface) -> Just iface + | otherwise -> Nothing + where + iface = hm_iface hm_info + + compile_it :: Maybe Linkable -> IO HomeModInfo + compile_it mb_linkable = + compile hsc_env summary' mod_index nmods + mb_old_iface mb_linkable + + compile_it_discard_iface :: Maybe Linkable -> IO HomeModInfo + compile_it_discard_iface mb_linkable = + compile hsc_env summary' mod_index nmods + Nothing mb_linkable + + -- With the HscNothing target we create empty linkables to avoid + -- recompilation. We have to detect these to recompile anyway if + -- the target changed since the last compile. + is_fake_linkable + | Just hmi <- old_hmi, Just l <- hm_linkable hmi = + null (linkableUnlinked l) + | otherwise = + -- we have no linkable, so it cannot be fake + False + + implies False _ = True + implies True x = x + + in + case () of + _ + -- Regardless of whether we're generating object code or + -- byte code, we can always use an existing object file + -- if it is *stable* (see checkStability). + | is_stable_obj, Just hmi <- old_hmi -> do + liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 + (text "skipping stable obj mod:" <+> ppr this_mod_name) + return hmi + -- object is stable, and we have an entry in the + -- old HPT: nothing to do + + | is_stable_obj, isNothing old_hmi -> do + liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 + (text "compiling stable on-disk mod:" <+> ppr this_mod_name) + linkable <- liftIO $ findObjectLinkable this_mod obj_fn + (expectJust "upsweep1" mb_obj_date) + compile_it (Just linkable) + -- object is stable, but we need to load the interface + -- off disk to make a HMI. + + | not (isObjectTarget target), is_stable_bco, + (target /= HscNothing) `implies` not is_fake_linkable -> + ASSERT(isJust old_hmi) -- must be in the old_hpt + let Just hmi = old_hmi in do + liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 + (text "skipping stable BCO mod:" <+> ppr this_mod_name) + return hmi + -- BCO is stable: nothing to do + + | not (isObjectTarget target), + Just hmi <- old_hmi, + Just l <- hm_linkable hmi, + not (isObjectLinkable l), + (target /= HscNothing) `implies` not is_fake_linkable, + linkableTime l >= ms_hs_date summary -> do + liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 + (text "compiling non-stable BCO mod:" <+> ppr this_mod_name) + compile_it (Just l) + -- we have an old BCO that is up to date with respect + -- to the source: do a recompilation check as normal. + + -- When generating object code, if there's an up-to-date + -- object file on the disk, then we can use it. + -- However, if the object file is new (compared to any + -- linkable we had from a previous compilation), then we + -- must discard any in-memory interface, because this + -- means the user has compiled the source file + -- separately and generated a new interface, that we must + -- read from the disk. + -- + | isObjectTarget target, + Just obj_date <- mb_obj_date, + obj_date >= hs_date -> do + case old_hmi of + Just hmi + | Just l <- hm_linkable hmi, + isObjectLinkable l && linkableTime l == obj_date -> do + liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 + (text "compiling mod with new on-disk obj:" <+> ppr this_mod_name) + compile_it (Just l) + _otherwise -> do + liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 + (text "compiling mod with new on-disk obj2:" <+> ppr this_mod_name) + linkable <- liftIO $ findObjectLinkable this_mod obj_fn obj_date + compile_it_discard_iface (Just linkable) + + _otherwise -> do + liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 + (text "compiling mod:" <+> ppr this_mod_name) + compile_it Nothing + + + +-- Filter modules in the HPT +retainInTopLevelEnvs :: [ModuleName] -> HomePackageTable -> HomePackageTable +retainInTopLevelEnvs keep_these hpt + = listToUFM [ (mod, expectJust "retain" mb_mod_info) + | mod <- keep_these + , let mb_mod_info = lookupUFM hpt mod + , isJust mb_mod_info ] + +-- --------------------------------------------------------------------------- +-- Typecheck module loops + +{- +See bug #930. This code fixes a long-standing bug in --make. The +problem is that when compiling the modules *inside* a loop, a data +type that is only defined at the top of the loop looks opaque; but +after the loop is done, the structure of the data type becomes +apparent. + +The difficulty is then that two different bits of code have +different notions of what the data type looks like. + +The idea is that after we compile a module which also has an .hs-boot +file, we re-generate the ModDetails for each of the modules that +depends on the .hs-boot file, so that everyone points to the proper +TyCons, Ids etc. defined by the real module, not the boot module. +Fortunately re-generating a ModDetails from a ModIface is easy: the +function TcIface.typecheckIface does exactly that. + +Picking the modules to re-typecheck is slightly tricky. Starting from +the module graph consisting of the modules that have already been +compiled, we reverse the edges (so they point from the imported module +to the importing module), and depth-first-search from the .hs-boot +node. This gives us all the modules that depend transitively on the +.hs-boot module, and those are exactly the modules that we need to +re-typecheck. + +Following this fix, GHC can compile itself with --make -O2. +-} + +reTypecheckLoop :: HscEnv -> ModSummary -> ModuleGraph -> IO HscEnv +reTypecheckLoop hsc_env ms graph + | not (isBootSummary ms) && + any (\m -> ms_mod m == this_mod && isBootSummary m) graph + = do + let mss = reachableBackwards (ms_mod_name ms) graph + non_boot = filter (not.isBootSummary) mss + debugTraceMsg (hsc_dflags hsc_env) 2 $ + text "Re-typechecking loop: " <> ppr (map ms_mod_name non_boot) + typecheckLoop hsc_env (map ms_mod_name non_boot) + | otherwise + = return hsc_env + where + this_mod = ms_mod ms + +typecheckLoop :: HscEnv -> [ModuleName] -> IO HscEnv +typecheckLoop hsc_env mods = do + new_hpt <- + fixIO $ \new_hpt -> do + let new_hsc_env = hsc_env{ hsc_HPT = new_hpt } + mds <- initIfaceCheck new_hsc_env $ + mapM (typecheckIface . hm_iface) hmis + let new_hpt = addListToUFM old_hpt + (zip mods [ hmi{ hm_details = details } + | (hmi,details) <- zip hmis mds ]) + return new_hpt + return hsc_env{ hsc_HPT = new_hpt } + where + old_hpt = hsc_HPT hsc_env + hmis = map (expectJust "typecheckLoop" . lookupUFM old_hpt) mods + +reachableBackwards :: ModuleName -> [ModSummary] -> [ModSummary] +reachableBackwards mod summaries + = [ ms | (ms,_,_) <- reachableG (transposeG graph) root ] + where -- the rest just sets up the graph: + (graph, lookup_node) = moduleGraphNodes False summaries + root = expectJust "reachableBackwards" (lookup_node HsBootFile mod) + +-- --------------------------------------------------------------------------- +-- Topological sort of the module graph + +type SummaryNode = (ModSummary, Int, [Int]) + +topSortModuleGraph + :: Bool + -- ^ Drop hi-boot nodes? (see below) + -> [ModSummary] + -> Maybe ModuleName + -- ^ Root module name. If @Nothing@, use the full graph. + -> [SCC ModSummary] +-- ^ Calculate SCCs of the module graph, possibly dropping the hi-boot nodes +-- The resulting list of strongly-connected-components is in topologically +-- sorted order, starting with the module(s) at the bottom of the +-- dependency graph (ie compile them first) and ending with the ones at +-- the top. +-- +-- Drop hi-boot nodes (first boolean arg)? +-- +-- - @False@: treat the hi-boot summaries as nodes of the graph, +-- so the graph must be acyclic +-- +-- - @True@: eliminate the hi-boot nodes, and instead pretend +-- the a source-import of Foo is an import of Foo +-- The resulting graph has no hi-boot nodes, but can be cyclic + +topSortModuleGraph drop_hs_boot_nodes summaries mb_root_mod + = map (fmap summaryNodeSummary) $ stronglyConnCompG initial_graph + where + (graph, lookup_node) = moduleGraphNodes drop_hs_boot_nodes summaries + + initial_graph = case mb_root_mod of + Nothing -> graph + Just root_mod -> + -- restrict the graph to just those modules reachable from + -- the specified module. We do this by building a graph with + -- the full set of nodes, and determining the reachable set from + -- the specified node. + let root | Just node <- lookup_node HsSrcFile root_mod, graph `hasVertexG` node = node + | otherwise = ghcError (ProgramError "module does not exist") + in graphFromEdgedVertices (seq root (reachableG graph root)) + +summaryNodeKey :: SummaryNode -> Int +summaryNodeKey (_, k, _) = k + +summaryNodeSummary :: SummaryNode -> ModSummary +summaryNodeSummary (s, _, _) = s + +moduleGraphNodes :: Bool -> [ModSummary] + -> (Graph SummaryNode, HscSource -> ModuleName -> Maybe SummaryNode) +moduleGraphNodes drop_hs_boot_nodes summaries = (graphFromEdgedVertices nodes, lookup_node) + where + numbered_summaries = zip summaries [1..] + + lookup_node :: HscSource -> ModuleName -> Maybe SummaryNode + lookup_node hs_src mod = Map.lookup (mod, hs_src) node_map + + lookup_key :: HscSource -> ModuleName -> Maybe Int + lookup_key hs_src mod = fmap summaryNodeKey (lookup_node hs_src mod) + + node_map :: NodeMap SummaryNode + node_map = Map.fromList [ ((moduleName (ms_mod s), ms_hsc_src s), node) + | node@(s, _, _) <- nodes ] + + -- We use integers as the keys for the SCC algorithm + nodes :: [SummaryNode] + nodes = [ (s, key, out_keys) + | (s, key) <- numbered_summaries + -- Drop the hi-boot ones if told to do so + , not (isBootSummary s && drop_hs_boot_nodes) + , let out_keys = out_edge_keys hs_boot_key (map unLoc (ms_home_srcimps s)) ++ + out_edge_keys HsSrcFile (map unLoc (ms_home_imps s)) ++ + (-- see [boot-edges] below + if drop_hs_boot_nodes || ms_hsc_src s == HsBootFile + then [] + else case lookup_key HsBootFile (ms_mod_name s) of + Nothing -> [] + Just k -> [k]) ] + + -- [boot-edges] if this is a .hs and there is an equivalent + -- .hs-boot, add a link from the former to the latter. This + -- has the effect of detecting bogus cases where the .hs-boot + -- depends on the .hs, by introducing a cycle. Additionally, + -- it ensures that we will always process the .hs-boot before + -- the .hs, and so the HomePackageTable will always have the + -- most up to date information. + + -- Drop hs-boot nodes by using HsSrcFile as the key + hs_boot_key | drop_hs_boot_nodes = HsSrcFile + | otherwise = HsBootFile + + out_edge_keys :: HscSource -> [ModuleName] -> [Int] + out_edge_keys hi_boot ms = mapCatMaybes (lookup_key hi_boot) ms + -- If we want keep_hi_boot_nodes, then we do lookup_key with + -- the IsBootInterface parameter True; else False + + +type NodeKey = (ModuleName, HscSource) -- The nodes of the graph are +type NodeMap a = Map.Map NodeKey a -- keyed by (mod, src_file_type) pairs + +msKey :: ModSummary -> NodeKey +msKey (ModSummary { ms_mod = mod, ms_hsc_src = boot }) = (moduleName mod,boot) + +mkNodeMap :: [ModSummary] -> NodeMap ModSummary +mkNodeMap summaries = Map.fromList [ (msKey s, s) | s <- summaries] + +nodeMapElts :: NodeMap a -> [a] +nodeMapElts = Map.elems + +-- | If there are {-# SOURCE #-} imports between strongly connected +-- components in the topological sort, then those imports can +-- definitely be replaced by ordinary non-SOURCE imports: if SOURCE +-- were necessary, then the edge would be part of a cycle. +warnUnnecessarySourceImports :: GhcMonad m => [SCC ModSummary] -> m () +warnUnnecessarySourceImports sccs = do + logWarnings (listToBag (concatMap (check.flattenSCC) sccs)) + where check ms = + let mods_in_this_cycle = map ms_mod_name ms in + [ warn i | m <- ms, i <- ms_home_srcimps m, + unLoc i `notElem` mods_in_this_cycle ] + + warn :: Located ModuleName -> WarnMsg + warn (L loc mod) = + mkPlainErrMsg loc + (ptext (sLit "Warning: {-# SOURCE #-} unnecessary in import of ") + <+> quotes (ppr mod)) + +----------------------------------------------------------------------------- +-- Downsweep (dependency analysis) + +-- Chase downwards from the specified root set, returning summaries +-- for all home modules encountered. Only follow source-import +-- links. + +-- We pass in the previous collection of summaries, which is used as a +-- cache to avoid recalculating a module summary if the source is +-- unchanged. +-- +-- The returned list of [ModSummary] nodes has one node for each home-package +-- module, plus one for any hs-boot files. The imports of these nodes +-- are all there, including the imports of non-home-package modules. + +downsweep :: HscEnv + -> [ModSummary] -- Old summaries + -> [ModuleName] -- Ignore dependencies on these; treat + -- them as if they were package modules + -> Bool -- True <=> allow multiple targets to have + -- the same module name; this is + -- very useful for ghc -M + -> IO [ModSummary] + -- The elts of [ModSummary] all have distinct + -- (Modules, IsBoot) identifiers, unless the Bool is true + -- in which case there can be repeats +downsweep hsc_env old_summaries excl_mods allow_dup_roots + = do + rootSummaries <- mapM getRootSummary roots + let root_map = mkRootMap rootSummaries + checkDuplicates root_map + summs <- loop (concatMap msDeps rootSummaries) root_map + return summs + where + roots = hsc_targets hsc_env + + old_summary_map :: NodeMap ModSummary + old_summary_map = mkNodeMap old_summaries + + getRootSummary :: Target -> IO ModSummary + getRootSummary (Target (TargetFile file mb_phase) obj_allowed maybe_buf) + = do exists <- liftIO $ doesFileExist file + if exists + then summariseFile hsc_env old_summaries file mb_phase + obj_allowed maybe_buf + else throwOneError $ mkPlainErrMsg noSrcSpan $ + text "can't find file:" <+> text file + getRootSummary (Target (TargetModule modl) obj_allowed maybe_buf) + = do maybe_summary <- summariseModule hsc_env old_summary_map False + (L rootLoc modl) obj_allowed + maybe_buf excl_mods + case maybe_summary of + Nothing -> packageModErr modl + Just s -> return s + + rootLoc = mkGeneralSrcSpan (fsLit "") + + -- In a root module, the filename is allowed to diverge from the module + -- name, so we have to check that there aren't multiple root files + -- defining the same module (otherwise the duplicates will be silently + -- ignored, leading to confusing behaviour). + checkDuplicates :: NodeMap [ModSummary] -> IO () + checkDuplicates root_map + | allow_dup_roots = return () + | null dup_roots = return () + | otherwise = liftIO $ multiRootsErr (head dup_roots) + where + dup_roots :: [[ModSummary]] -- Each at least of length 2 + dup_roots = filterOut isSingleton (nodeMapElts root_map) + + loop :: [(Located ModuleName,IsBootInterface)] + -- Work list: process these modules + -> NodeMap [ModSummary] + -- Visited set; the range is a list because + -- the roots can have the same module names + -- if allow_dup_roots is True + -> IO [ModSummary] + -- The result includes the worklist, except + -- for those mentioned in the visited set + loop [] done = return (concat (nodeMapElts done)) + loop ((wanted_mod, is_boot) : ss) done + | Just summs <- Map.lookup key done + = if isSingleton summs then + loop ss done + else + do { multiRootsErr summs; return [] } + | otherwise + = do mb_s <- summariseModule hsc_env old_summary_map + is_boot wanted_mod True + Nothing excl_mods + case mb_s of + Nothing -> loop ss done + Just s -> loop (msDeps s ++ ss) (Map.insert key [s] done) + where + key = (unLoc wanted_mod, if is_boot then HsBootFile else HsSrcFile) + +-- XXX Does the (++) here need to be flipped? +mkRootMap :: [ModSummary] -> NodeMap [ModSummary] +mkRootMap summaries = Map.insertListWith (flip (++)) + [ (msKey s, [s]) | s <- summaries ] + Map.empty + +msDeps :: ModSummary -> [(Located ModuleName, IsBootInterface)] +-- (msDeps s) returns the dependencies of the ModSummary s. +-- A wrinkle is that for a {-# SOURCE #-} import we return +-- *both* the hs-boot file +-- *and* the source file +-- as "dependencies". That ensures that the list of all relevant +-- modules always contains B.hs if it contains B.hs-boot. +-- Remember, this pass isn't doing the topological sort. It's +-- just gathering the list of all relevant ModSummaries +msDeps s = + concat [ [(m,True), (m,False)] | m <- ms_home_srcimps s ] + ++ [ (m,False) | m <- ms_home_imps s ] + +home_imps :: [Located (ImportDecl RdrName)] -> [Located ModuleName] +home_imps imps = [ ideclName i | L _ i <- imps, isLocal (ideclPkgQual i) ] + where isLocal Nothing = True + isLocal (Just pkg) | pkg == fsLit "this" = True -- "this" is special + isLocal _ = False + +ms_home_allimps :: ModSummary -> [ModuleName] +ms_home_allimps ms = map unLoc (ms_home_srcimps ms ++ ms_home_imps ms) + +ms_home_srcimps :: ModSummary -> [Located ModuleName] +ms_home_srcimps = home_imps . ms_srcimps + +ms_home_imps :: ModSummary -> [Located ModuleName] +ms_home_imps = home_imps . ms_imps + +----------------------------------------------------------------------------- +-- Summarising modules + +-- We have two types of summarisation: +-- +-- * Summarise a file. This is used for the root module(s) passed to +-- cmLoadModules. The file is read, and used to determine the root +-- module name. The module name may differ from the filename. +-- +-- * Summarise a module. We are given a module name, and must provide +-- a summary. The finder is used to locate the file in which the module +-- resides. + +summariseFile + :: HscEnv + -> [ModSummary] -- old summaries + -> FilePath -- source file name + -> Maybe Phase -- start phase + -> Bool -- object code allowed? + -> Maybe (StringBuffer,ClockTime) + -> IO ModSummary + +summariseFile hsc_env old_summaries file mb_phase obj_allowed maybe_buf + -- we can use a cached summary if one is available and the + -- source file hasn't changed, But we have to look up the summary + -- by source file, rather than module name as we do in summarise. + | Just old_summary <- findSummaryBySourceFile old_summaries file + = do + let location = ms_location old_summary + + -- return the cached summary if the source didn't change + src_timestamp <- case maybe_buf of + Just (_,t) -> return t + Nothing -> liftIO $ getModificationTime file + -- The file exists; we checked in getRootSummary above. + -- If it gets removed subsequently, then this + -- getModificationTime may fail, but that's the right + -- behaviour. + + if ms_hs_date old_summary == src_timestamp + then do -- update the object-file timestamp + obj_timestamp <- + if isObjectTarget (hscTarget (hsc_dflags hsc_env)) + || obj_allowed -- bug #1205 + then liftIO $ getObjTimestamp location False + else return Nothing + return old_summary{ ms_obj_date = obj_timestamp } + else + new_summary + + | otherwise + = new_summary + where + new_summary = do + let dflags = hsc_dflags hsc_env + + (dflags', hspp_fn, buf) + <- preprocessFile hsc_env file mb_phase maybe_buf + + (srcimps,the_imps, L _ mod_name) <- getImports dflags' buf hspp_fn file + + -- Make a ModLocation for this file + location <- liftIO $ mkHomeModLocation dflags mod_name file + + -- Tell the Finder cache where it is, so that subsequent calls + -- to findModule will find it, even if it's not on any search path + mod <- liftIO $ addHomeModuleToFinder hsc_env mod_name location + + src_timestamp <- case maybe_buf of + Just (_,t) -> return t + Nothing -> liftIO $ getModificationTime file + -- getMofificationTime may fail + + -- when the user asks to load a source file by name, we only + -- use an object file if -fobject-code is on. See #1205. + obj_timestamp <- + if isObjectTarget (hscTarget (hsc_dflags hsc_env)) + || obj_allowed -- bug #1205 + then liftIO $ modificationTimeIfExists (ml_obj_file location) + else return Nothing + + return (ModSummary { ms_mod = mod, ms_hsc_src = HsSrcFile, + ms_location = location, + ms_hspp_file = hspp_fn, + ms_hspp_opts = dflags', + ms_hspp_buf = Just buf, + ms_srcimps = srcimps, ms_imps = the_imps, + ms_hs_date = src_timestamp, + ms_obj_date = obj_timestamp }) + +findSummaryBySourceFile :: [ModSummary] -> FilePath -> Maybe ModSummary +findSummaryBySourceFile summaries file + = case [ ms | ms <- summaries, HsSrcFile <- [ms_hsc_src ms], + expectJust "findSummaryBySourceFile" (ml_hs_file (ms_location ms)) == file ] of + [] -> Nothing + (x:_) -> Just x + +-- Summarise a module, and pick up source and timestamp. +summariseModule + :: HscEnv + -> NodeMap ModSummary -- Map of old summaries + -> IsBootInterface -- True <=> a {-# SOURCE #-} import + -> Located ModuleName -- Imported module to be summarised + -> Bool -- object code allowed? + -> Maybe (StringBuffer, ClockTime) + -> [ModuleName] -- Modules to exclude + -> IO (Maybe ModSummary) -- Its new summary + +summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) + obj_allowed maybe_buf excl_mods + | wanted_mod `elem` excl_mods + = return Nothing + + | Just old_summary <- Map.lookup (wanted_mod, hsc_src) old_summary_map + = do -- Find its new timestamp; all the + -- ModSummaries in the old map have valid ml_hs_files + let location = ms_location old_summary + src_fn = expectJust "summariseModule" (ml_hs_file location) + + -- check the modification time on the source file, and + -- return the cached summary if it hasn't changed. If the + -- file has disappeared, we need to call the Finder again. + case maybe_buf of + Just (_,t) -> check_timestamp old_summary location src_fn t + Nothing -> do + m <- tryIO (getModificationTime src_fn) + case m of + Right t -> check_timestamp old_summary location src_fn t + Left e | isDoesNotExistError e -> find_it + | otherwise -> ioError e + + | otherwise = find_it + where + dflags = hsc_dflags hsc_env + + hsc_src = if is_boot then HsBootFile else HsSrcFile + + check_timestamp old_summary location src_fn src_timestamp + | ms_hs_date old_summary == src_timestamp = do + -- update the object-file timestamp + obj_timestamp <- + if isObjectTarget (hscTarget (hsc_dflags hsc_env)) + || obj_allowed -- bug #1205 + then getObjTimestamp location is_boot + else return Nothing + return (Just old_summary{ ms_obj_date = obj_timestamp }) + | otherwise = + -- source changed: re-summarise. + new_summary location (ms_mod old_summary) src_fn src_timestamp + + find_it = do + -- Don't use the Finder's cache this time. If the module was + -- previously a package module, it may have now appeared on the + -- search path, so we want to consider it to be a home module. If + -- the module was previously a home module, it may have moved. + uncacheModule hsc_env wanted_mod + found <- findImportedModule hsc_env wanted_mod Nothing + case found of + Found location mod + | isJust (ml_hs_file location) -> + -- Home package + just_found location mod + | otherwise -> + -- Drop external-pkg + ASSERT(modulePackageId mod /= thisPackage dflags) + return Nothing + + err -> noModError dflags loc wanted_mod err + -- Not found + + just_found location mod = do + -- Adjust location to point to the hs-boot source file, + -- hi file, object file, when is_boot says so + let location' | is_boot = addBootSuffixLocn location + | otherwise = location + src_fn = expectJust "summarise2" (ml_hs_file location') + + -- Check that it exists + -- It might have been deleted since the Finder last found it + maybe_t <- modificationTimeIfExists src_fn + case maybe_t of + Nothing -> noHsFileErr loc src_fn + Just t -> new_summary location' mod src_fn t + + + new_summary location mod src_fn src_timestamp + = do + -- Preprocess the source file and get its imports + -- The dflags' contains the OPTIONS pragmas + (dflags', hspp_fn, buf) <- preprocessFile hsc_env src_fn Nothing maybe_buf + (srcimps, the_imps, L mod_loc mod_name) <- getImports dflags' buf hspp_fn src_fn + + when (mod_name /= wanted_mod) $ + throwOneError $ mkPlainErrMsg mod_loc $ + text "File name does not match module name:" + $$ text "Saw:" <+> quotes (ppr mod_name) + $$ text "Expected:" <+> quotes (ppr wanted_mod) + + -- Find the object timestamp, and return the summary + obj_timestamp <- + if isObjectTarget (hscTarget (hsc_dflags hsc_env)) + || obj_allowed -- bug #1205 + then getObjTimestamp location is_boot + else return Nothing + + return (Just (ModSummary { ms_mod = mod, + ms_hsc_src = hsc_src, + ms_location = location, + ms_hspp_file = hspp_fn, + ms_hspp_opts = dflags', + ms_hspp_buf = Just buf, + ms_srcimps = srcimps, + ms_imps = the_imps, + ms_hs_date = src_timestamp, + ms_obj_date = obj_timestamp })) + + +getObjTimestamp :: ModLocation -> Bool -> IO (Maybe ClockTime) +getObjTimestamp location is_boot + = if is_boot then return Nothing + else modificationTimeIfExists (ml_obj_file location) + + +preprocessFile :: HscEnv + -> FilePath + -> Maybe Phase -- ^ Starting phase + -> Maybe (StringBuffer,ClockTime) + -> IO (DynFlags, FilePath, StringBuffer) +preprocessFile hsc_env src_fn mb_phase Nothing + = do + (dflags', hspp_fn) <- preprocess hsc_env (src_fn, mb_phase) + buf <- hGetStringBuffer hspp_fn + return (dflags', hspp_fn, buf) + +preprocessFile hsc_env src_fn mb_phase (Just (buf, _time)) + = do + let dflags = hsc_dflags hsc_env + -- case we bypass the preprocessing stage? + let + local_opts = getOptions dflags buf src_fn + -- + (dflags', leftovers, warns) + <- parseDynamicNoPackageFlags dflags local_opts + checkProcessArgsResult leftovers + handleFlagWarnings dflags' warns + + let + needs_preprocessing + | Just (Unlit _) <- mb_phase = True + | Nothing <- mb_phase, Unlit _ <- startPhase src_fn = True + -- note: local_opts is only required if there's no Unlit phase + | xopt Opt_Cpp dflags' = True + | dopt Opt_Pp dflags' = True + | otherwise = False + + when needs_preprocessing $ + ghcError (ProgramError "buffer needs preprocesing; interactive check disabled") + + return (dflags', src_fn, buf) + + +----------------------------------------------------------------------------- +-- Error messages +----------------------------------------------------------------------------- + +noModError :: DynFlags -> SrcSpan -> ModuleName -> FindResult -> IO ab +-- ToDo: we don't have a proper line number for this error +noModError dflags loc wanted_mod err + = throwOneError $ mkPlainErrMsg loc $ cannotFindModule dflags wanted_mod err + +noHsFileErr :: SrcSpan -> String -> IO a +noHsFileErr loc path + = throwOneError $ mkPlainErrMsg loc $ text "Can't find" <+> text path + +packageModErr :: ModuleName -> IO a +packageModErr mod + = throwOneError $ mkPlainErrMsg noSrcSpan $ + text "module" <+> quotes (ppr mod) <+> text "is a package module" + +multiRootsErr :: [ModSummary] -> IO () +multiRootsErr [] = panic "multiRootsErr" +multiRootsErr summs@(summ1:_) + = throwOneError $ mkPlainErrMsg noSrcSpan $ + text "module" <+> quotes (ppr mod) <+> + text "is defined in multiple files:" <+> + sep (map text files) + where + mod = ms_mod summ1 + files = map (expectJust "checkDup" . ml_hs_file . ms_location) summs + +cyclicModuleErr :: [ModSummary] -> SDoc +cyclicModuleErr ms + = hang (ptext (sLit "Module imports form a cycle for modules:")) + 2 (vcat (map show_one ms)) + where + mods_in_cycle = map ms_mod_name ms + imp_modname = unLoc . ideclName . unLoc + just_in_cycle = filter ((`elem` mods_in_cycle) . imp_modname) + + show_one ms = + vcat [ show_mod (ms_hsc_src ms) (ms_mod_name ms) <+> + maybe empty (parens . text) (ml_hs_file (ms_location ms)), + nest 2 $ ptext (sLit "imports:") <+> vcat [ + pp_imps HsBootFile (just_in_cycle $ ms_srcimps ms), + pp_imps HsSrcFile (just_in_cycle $ ms_imps ms) ] + ] + show_mod hsc_src mod = ppr mod <> text (hscSourceString hsc_src) + pp_imps src imps = fsep (map (show_mod src . unLoc . ideclName . unLoc) imps) diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs index 47bde96..70ddd6a 100644 --- a/compiler/main/HscMain.lhs +++ b/compiler/main/HscMain.lhs @@ -58,8 +58,8 @@ module HscMain , hscParseIdentifier , hscTcRcLookupName , hscTcRnGetInfo - , hscRnImportDecls #ifdef GHCI + , hscRnImportDecls , hscGetModuleExports , hscTcRnLookupRdrName , hscStmt, hscStmtWithLocation @@ -97,7 +97,6 @@ import SrcLoc import TcRnDriver import TcIface ( typecheckIface ) import TcRnMonad -import RnNames ( rnImports ) import IfaceEnv ( initNameCache ) import LoadIface ( ifaceStats, initExternalPackageState ) import PrelInfo ( wiredInThings, basicKnownKeyNames ) @@ -110,7 +109,8 @@ import CoreToStg ( coreToStg ) import qualified StgCmm ( codeGen ) import StgSyn import CostCentre -import TyCon ( TyCon, isDataTyCon ) +import ProfInit +import TyCon ( TyCon, isDataTyCon ) import Name ( Name, NamedThing(..) ) import SimplStg ( stg2stg ) import CodeGen ( codeGen ) @@ -295,7 +295,6 @@ hscTcRnGetInfo hsc_env name = hscGetModuleExports :: HscEnv -> Module -> IO (Maybe [AvailInfo]) hscGetModuleExports hsc_env mdl = runHsc hsc_env $ ioMsgMaybe' $ getModuleExports hsc_env mdl -#endif -- ----------------------------------------------------------------------------- -- | Rename some import declarations @@ -306,11 +305,14 @@ hscRnImportDecls -> [LImportDecl RdrName] -> IO GlobalRdrEnv -hscRnImportDecls hsc_env this_mod import_decls = runHsc hsc_env $ do - (_, r, _, _) <- - ioMsgMaybe $ initTc hsc_env HsSrcFile False this_mod $ - rnImports import_decls - return r +-- It is important that we use tcRnImports instead of calling rnImports directly +-- because tcRnImports will force-load any orphan modules necessary, making extra +-- instances/family instances visible (GHC #4832) +hscRnImportDecls hsc_env this_mod import_decls + = runHsc hsc_env $ ioMsgMaybe $ initTc hsc_env HsSrcFile False this_mod $ + fmap tcg_rdr_env $ tcRnImports hsc_env this_mod import_decls + +#endif -- ----------------------------------------------------------------------------- -- | parse a file, returning the abstract syntax @@ -459,7 +461,8 @@ error. This is the only thing that isn't caught by the type-system. data HscStatus' a = HscNoRecomp | HscRecomp - Bool -- Has stub files. This is a hack. We can't compile C files here + (Maybe FilePath) + -- Has stub files. This is a hack. We can't compile C files here -- since it's done in DriverPipeline. For now we just return True -- if we want the caller to compile them for us. a @@ -595,14 +598,14 @@ hscOneShotCompiler = , hscBackend = \ tc_result mod_summary mb_old_hash -> do dflags <- getDynFlags case hscTarget dflags of - HscNothing -> return (HscRecomp False ()) + HscNothing -> return (HscRecomp Nothing ()) _otherw -> genericHscBackend hscOneShotCompiler tc_result mod_summary mb_old_hash , hscGenBootOutput = \tc_result mod_summary mb_old_iface -> do (iface, changed, _) <- hscSimpleIface tc_result mb_old_iface hscWriteIface iface changed mod_summary - return (HscRecomp False ()) + return (HscRecomp Nothing ()) , hscGenOutput = \guts0 mod_summary mb_old_iface -> do guts <- hscSimplify' guts0 @@ -648,7 +651,7 @@ hscBatchCompiler = , hscGenBootOutput = \tc_result mod_summary mb_old_iface -> do (iface, changed, details) <- hscSimpleIface tc_result mb_old_iface hscWriteIface iface changed mod_summary - return (HscRecomp False (), iface, details) + return (HscRecomp Nothing (), iface, details) , hscGenOutput = \guts0 mod_summary mb_old_iface -> do guts <- hscSimplify' guts0 @@ -680,7 +683,7 @@ hscInteractiveCompiler = , hscGenBootOutput = \tc_result _mod_summary mb_old_iface -> do (iface, _changed, details) <- hscSimpleIface tc_result mb_old_iface - return (HscRecomp False Nothing, iface, details) + return (HscRecomp Nothing Nothing, iface, details) , hscGenOutput = \guts0 mod_summary mb_old_iface -> do guts <- hscSimplify' guts0 @@ -709,7 +712,7 @@ hscNothingCompiler = , hscBackend = \tc_result _mod_summary mb_old_iface -> do handleWarnings (iface, _changed, details) <- hscSimpleIface tc_result mb_old_iface - return (HscRecomp False (), iface, details) + return (HscRecomp Nothing (), iface, details) , hscGenBootOutput = \_ _ _ -> panic "hscCompileNothing: hscGenBootOutput should not be called" @@ -851,7 +854,7 @@ hscWriteIface iface no_change mod_summary -- | Compile to hard-code. hscGenHardCode :: CgGuts -> ModSummary - -> Hsc Bool -- ^ @True@ <=> stub.c exists + -> Hsc (Maybe FilePath) -- ^ @Just f@ <=> _stub.c is f hscGenHardCode cgguts mod_summary = do hsc_env <- getHscEnv @@ -861,8 +864,7 @@ hscGenHardCode cgguts mod_summary cg_module = this_mod, cg_binds = core_binds, cg_tycons = tycons, - cg_dir_imps = dir_imps, - cg_foreign = foreign_stubs, + cg_foreign = foreign_stubs0, cg_dep_pkgs = dependencies, cg_hpc_info = hpc_info } = cgguts dflags = hsc_dflags hsc_env @@ -881,16 +883,19 @@ hscGenHardCode cgguts mod_summary <- {-# SCC "CoreToStg" #-} myCoreToStg dflags this_mod prepd_binds + let prof_init = profilingInitCode this_mod cost_centre_info + foreign_stubs = foreign_stubs0 `appendStubC` prof_init + ------------------ Code generation ------------------ cmms <- if dopt Opt_TryNewCodeGen dflags then do cmms <- tryNewCodeGen hsc_env this_mod data_tycons - dir_imps cost_centre_info + cost_centre_info stg_binds hpc_info return cmms else {-# SCC "CodeGen" #-} codeGen dflags this_mod data_tycons - dir_imps cost_centre_info + cost_centre_info stg_binds hpc_info --- Optionally run experimental Cmm transformations --- @@ -898,7 +903,7 @@ hscGenHardCode cgguts mod_summary -- unless certain dflags are on, the identity function ------------------ Code output ----------------------- rawcmms <- cmmToRawCmm cmms - dumpIfSet_dyn dflags Opt_D_dump_cmmz "Raw Cmm" (ppr rawcmms) + dumpIfSet_dyn dflags Opt_D_dump_raw_cmm "Raw Cmm" (ppr rawcmms) (_stub_h_exists, stub_c_exists) <- codeOutput dflags this_mod location foreign_stubs dependencies rawcmms @@ -961,15 +966,15 @@ hscCompileCmmFile hsc_env filename -------------------- Stuff for new code gen --------------------- -tryNewCodeGen :: HscEnv -> Module -> [TyCon] -> [Module] +tryNewCodeGen :: HscEnv -> Module -> [TyCon] -> CollectedCCs -> [(StgBinding,[(Id,[Id])])] -> HpcInfo -> IO [Cmm] -tryNewCodeGen hsc_env this_mod data_tycons imported_mods +tryNewCodeGen hsc_env this_mod data_tycons cost_centre_info stg_binds hpc_info = do { let dflags = hsc_dflags hsc_env - ; prog <- StgCmm.codeGen dflags this_mod data_tycons imported_mods + ; prog <- StgCmm.codeGen dflags this_mod data_tycons cost_centre_info stg_binds hpc_info ; dumpIfSet_dyn dflags Opt_D_dump_cmmz "Cmm produced by new codegen" (pprCmms prog) diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index 3673b3e..e59c223 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -14,7 +14,7 @@ module HscTypes ( -- * Information about modules ModDetails(..), emptyModDetails, - ModGuts(..), CgGuts(..), ForeignStubs(..), + ModGuts(..), CgGuts(..), ForeignStubs(..), appendStubC, ImportedMods, ModSummary(..), ms_mod_name, showModMsg, isBootSummary, @@ -25,8 +25,9 @@ module HscTypes ( -- * State relating to modules in this package HomePackageTable, HomeModInfo(..), emptyHomePackageTable, - hptInstances, hptRules, hptVectInfo, - + hptInstances, hptRules, hptVectInfo, + hptObjs, + -- * State relating to known packages ExternalPackageState(..), EpsStats(..), addEpsInStats, PackageTypeEnv, PackageIfaceTable, emptyPackageIfaceTable, @@ -76,7 +77,7 @@ module HscTypes ( Warnings(..), WarningTxt(..), plusWarns, -- * Linker stuff - Linkable(..), isObjectLinkable, + Linkable(..), isObjectLinkable, linkableObjs, Unlinked(..), CompiledByteCode, isObject, nameOfObject, isInterpretable, byteCodeOfObject, @@ -494,6 +495,9 @@ hptSomeThingsBelowUs extract include_hi_boot hsc_env deps -- And get its dfuns , thing <- things ] + +hptObjs :: HomePackageTable -> [FilePath] +hptObjs hpt = concat (map (maybe [] linkableObjs . hm_linkable) (eltsUFM hpt)) \end{code} %************************************************************************ @@ -795,11 +799,7 @@ data CgGuts -- data constructor workers; reason: we we regard them -- as part of the code-gen of tycons - cg_dir_imps :: ![Module], - -- ^ Directly-imported modules; used to generate - -- initialisation code - - cg_foreign :: !ForeignStubs, -- ^ Foreign export stubs + cg_foreign :: !ForeignStubs, -- ^ Foreign export stubs cg_dep_pkgs :: ![PackageId], -- ^ Dependent packages, used to -- generate #includes for C code gen cg_hpc_info :: !HpcInfo, -- ^ Program coverage tick box information @@ -819,6 +819,10 @@ data ForeignStubs = NoStubs -- ^ We don't have any stubs -- -- 2) C stubs to use when calling -- "foreign exported" functions + +appendStubC :: ForeignStubs -> SDoc -> ForeignStubs +appendStubC NoStubs c_code = ForeignStubs empty c_code +appendStubC (ForeignStubs h c) c_code = ForeignStubs h (c $$ c_code) \end{code} \begin{code} @@ -1790,6 +1794,9 @@ isObjectLinkable l = not (null unlinked) && all isObject unlinked -- compiling a module in HscNothing mode, and this choice -- happens to work well with checkStability in module GHC. +linkableObjs :: Linkable -> [FilePath] +linkableObjs l = [ f | DotO f <- linkableUnlinked l ] + instance Outputable Linkable where ppr (LM when_made mod unlinkeds) = (text "LinkableM" <+> parens (text (show when_made)) <+> ppr mod) diff --git a/compiler/main/StaticFlagParser.hs b/compiler/main/StaticFlagParser.hs index 803baba..54f0a92 100644 --- a/compiler/main/StaticFlagParser.hs +++ b/compiler/main/StaticFlagParser.hs @@ -185,6 +185,7 @@ isStaticFlag f = "fsimple-list-literals", "fruntime-types", "fno-pre-inlining", + "fno-opt-coercion", "fexcess-precision", "static", "fhardwire-lib-paths", diff --git a/compiler/main/StaticFlags.hs b/compiler/main/StaticFlags.hs index 96f8b4b..049b61f 100644 --- a/compiler/main/StaticFlags.hs +++ b/compiler/main/StaticFlags.hs @@ -24,7 +24,7 @@ module StaticFlags ( opt_PprCols, opt_PprCaseAsLet, opt_PprStyle_Debug, opt_TraceLevel, - opt_NoDebugOutput, + opt_NoDebugOutput, -- Suppressing boring aspects of core dumps opt_SuppressAll, @@ -52,6 +52,7 @@ module StaticFlags ( opt_CprOff, opt_SimplNoPreInlining, opt_SimplExcessPrecision, + opt_NoOptCoercion, opt_MaxWorkerArgs, -- Unfolding control @@ -266,7 +267,6 @@ opt_Fuel = lookup_def_int "-dopt-fuel" maxBound opt_NoDebugOutput :: Bool opt_NoDebugOutput = lookUp (fsLit "-dno-debug-output") - -- profiling opts opt_SccProfilingOn :: Bool opt_SccProfilingOn = lookUp (fsLit "-fscc-profiling") @@ -320,6 +320,9 @@ opt_SimplNoPreInlining = lookUp (fsLit "-fno-pre-inlining") opt_SimplExcessPrecision :: Bool opt_SimplExcessPrecision = lookUp (fsLit "-fexcess-precision") +opt_NoOptCoercion :: Bool +opt_NoOptCoercion = lookUp (fsLit "-fno-opt-coercion") + -- Unfolding control -- See Note [Discounts and thresholds] in CoreUnfold diff --git a/compiler/main/SysTools.lhs b/compiler/main/SysTools.lhs index d33fd6c..5c64a34 100644 --- a/compiler/main/SysTools.lhs +++ b/compiler/main/SysTools.lhs @@ -7,6 +7,7 @@ ----------------------------------------------------------------------------- \begin{code} +{-# OPTIONS -fno-warn-unused-do-bind #-} module SysTools ( -- Initialisation initSysTools, @@ -14,12 +15,13 @@ module SysTools ( -- Interface to system tools runUnlit, runCpp, runCc, -- [Option] -> IO () runPp, -- [Option] -> IO () - runMangle, runSplit, -- [Option] -> IO () + runSplit, -- [Option] -> IO () runAs, runLink, -- [Option] -> IO () runMkDLL, runWindres, runLlvmOpt, runLlvmLlc, + readElfSection, touch, -- String -> String -> IO () copy, @@ -58,6 +60,8 @@ import System.Directory import Data.Char import Data.List import qualified Data.Map as Map +import Text.ParserCombinators.ReadP hiding (char) +import qualified Text.ParserCombinators.ReadP as R #ifndef mingw32_HOST_OS import qualified System.Posix.Internals @@ -171,9 +175,8 @@ initSysTools mbMinusB dflags0 -- architecture-specific stuff is done when building Config.hs unlit_path = installed cGHC_UNLIT_PGM - -- split and mangle are Perl scripts + -- split is a Perl script split_script = installed cGHC_SPLIT_PGM - mangle_script = installed cGHC_MANGLER_PGM windres_path = installed_mingw_bin "windres" @@ -194,7 +197,7 @@ initSysTools mbMinusB dflags0 | isWindowsHost = installed cGHC_TOUCHY_PGM | otherwise = "touch" -- On Win32 we don't want to rely on #!/bin/perl, so we prepend - -- a call to Perl to get the invocation of split and mangle. + -- a call to Perl to get the invocation of split. -- On Unix, scripts are invoked using the '#!' method. Binary -- installations of GHC on Unix place the correct line on the -- front of the script at installation time, so we don't want @@ -202,9 +205,6 @@ initSysTools mbMinusB dflags0 (split_prog, split_args) | isWindowsHost = (perl_path, [Option split_script]) | otherwise = (split_script, []) - (mangle_prog, mangle_args) - | isWindowsHost = (perl_path, [Option mangle_script]) - | otherwise = (mangle_script, []) (mkdll_prog, mkdll_args) | not isWindowsHost = panic "Can't build DLLs on a non-Win32 system" @@ -234,7 +234,6 @@ initSysTools mbMinusB dflags0 pgm_P = cpp_path, pgm_F = "", pgm_c = (gcc_prog,[]), - pgm_m = (mangle_prog,mangle_args), pgm_s = (split_prog,split_args), pgm_a = (as_prog,[]), pgm_l = (ld_prog,[]), @@ -372,11 +371,6 @@ getGccEnv opts = = (path, '\"' : head b_dirs ++ "\";" ++ paths) mangle_path other = other -runMangle :: DynFlags -> [Option] -> IO () -runMangle dflags args = do - let (p,args0) = pgm_m dflags - runSomething dflags "Mangler" p (args0++args) - runSplit :: DynFlags -> [Option] -> IO () runSplit dflags args = do let (p,args0) = pgm_s dflags @@ -458,6 +452,27 @@ getExtraViaCOpts :: DynFlags -> IO [String] getExtraViaCOpts dflags = do f <- readFile (topDir dflags "extra-gcc-opts") return (words f) + +-- | read the contents of the named section in an ELF object as a +-- String. +readElfSection :: DynFlags -> String -> FilePath -> IO (Maybe String) +readElfSection _dflags section exe = do + let + prog = "readelf" + args = [Option "-p", Option section, FileOption "" exe] + -- + r <- readProcessWithExitCode prog (filter notNull (map showOpt args)) "" + case r of + (ExitSuccess, out, _err) -> return (doFilter (lines out)) + _ -> return Nothing + where + doFilter [] = Nothing + doFilter (s:r) = case readP_to_S parse s of + [(p,"")] -> Just p + _r -> doFilter r + where parse = do + skipSpaces; R.char '['; skipSpaces; string "0]"; skipSpaces; + munch (const True) \end{code} %************************************************************************ @@ -489,8 +504,8 @@ cleanTempFilesExcept dflags dont_delete $ do let ref = filesToClean dflags files <- readIORef ref let (to_keep, to_delete) = partition (`elem` dont_delete) files - removeTmpFiles dflags to_delete writeIORef ref to_keep + removeTmpFiles dflags to_delete -- find a temporary name that doesn't already exist. diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs index 98fbeb3..f23280b 100644 --- a/compiler/main/TidyPgm.lhs +++ b/compiler/main/TidyPgm.lhs @@ -46,6 +46,7 @@ import FastBool hiding ( fastOr ) import Util import FastString +import Control.Monad ( when ) import Data.List ( sortBy ) import Data.IORef ( IORef, readIORef, writeIORef ) \end{code} @@ -291,8 +292,7 @@ tidyProgram hsc_env (ModGuts { mg_module = mod, mg_exports = exports, mg_binds = binds, mg_rules = imp_rules, mg_vect_info = vect_info, - mg_dir_imps = dir_imps, - mg_anns = anns, + mg_anns = anns, mg_deps = deps, mg_foreign = foreign_stubs, mg_hpc_info = hpc_info, @@ -353,13 +353,19 @@ tidyProgram hsc_env (ModGuts { mg_module = mod, mg_exports = exports, (ptext (sLit "rules")) (pprRulesForUser tidy_rules) - ; let dir_imp_mods = moduleEnvKeys dir_imps - - ; return (CgGuts { cg_module = mod, - cg_tycons = alg_tycons, - cg_binds = all_tidy_binds, - cg_dir_imps = dir_imp_mods, - cg_foreign = foreign_stubs, + -- Print one-line size info + ; let cs = coreBindsStats tidy_binds + ; when (dopt Opt_D_dump_core_stats dflags) + (printDump (ptext (sLit "Tidy size (terms,types,coercions)") + <+> ppr (moduleName mod) <> colon + <+> int (cs_tm cs) + <+> int (cs_ty cs) + <+> int (cs_co cs) )) + + ; return (CgGuts { cg_module = mod, + cg_tycons = alg_tycons, + cg_binds = all_tidy_binds, + cg_foreign = foreign_stubs, cg_dep_pkgs = dep_pkgs deps, cg_hpc_info = hpc_info, cg_modBreaks = modBreaks }, diff --git a/compiler/nativeGen/RegAlloc/Linear/Main.hs b/compiler/nativeGen/RegAlloc/Linear/Main.hs index 5fab944..473b549 100644 --- a/compiler/nativeGen/RegAlloc/Linear/Main.hs +++ b/compiler/nativeGen/RegAlloc/Linear/Main.hs @@ -48,7 +48,7 @@ The algorithm is roughly: (c) Update the current assignment - (d) If the intstruction is a branch: + (d) If the instruction is a branch: if the destination block already has a register assignment, Generate a new block with fixup code and redirect the jump to the new block. @@ -331,7 +331,7 @@ raInsn block_live new_instrs id (LiveInstr (Instr instr) (Just live)) -- register does not already have an assignment, -- and the source register is assigned to a register, not to a spill slot, -- then we can eliminate the instruction. - -- (we can't eliminitate it if the source register is on the stack, because + -- (we can't eliminate it if the source register is on the stack, because -- we do not want to use one spill slot for different virtual registers) case takeRegRegMoveInstr instr of Just (src,dst) | src `elementOfUniqSet` (liveDieRead live), @@ -497,7 +497,7 @@ releaseRegs regs = do saveClobberedTemps - :: Instruction instr + :: (Outputable instr, Instruction instr) => [RealReg] -- real registers clobbered by this instruction -> [Reg] -- registers which are no longer live after this insn -> RegM [instr] -- return: instructions to spill any temps that will @@ -536,7 +536,7 @@ saveClobberedTemps clobbered dying --- | Mark all these regal regs as allocated, +-- | Mark all these real regs as allocated, -- and kick out their vreg assignments. -- clobberRegs :: [RealReg] -> RegM () @@ -571,6 +571,16 @@ clobberRegs clobbered -- ----------------------------------------------------------------------------- -- allocateRegsAndSpill +-- Why are we performing a spill? +data SpillLoc = ReadMem StackSlot -- reading from register only in memory + | WriteNew -- writing to a new variable + | WriteMem -- writing to register only in memory +-- Note that ReadNew is not valid, since you don't want to be reading +-- from an uninitialized register. We also don't need the location of +-- the register in memory, since that will be invalidated by the write. +-- Technically, we could coalesce WriteNew and WriteMem into a single +-- entry as well. -- EZY + -- This function does several things: -- For each temporary referred to by this instruction, -- we allocate a real register (spilling another temporary if necessary). @@ -579,7 +589,7 @@ clobberRegs clobbered -- the list of free registers and free stack slots. allocateRegsAndSpill - :: Instruction instr + :: (Outputable instr, Instruction instr) => Bool -- True <=> reading (load up spilled regs) -> [VirtualReg] -- don't push these out -> [instr] -- spill insns @@ -593,13 +603,14 @@ allocateRegsAndSpill _ _ spills alloc [] allocateRegsAndSpill reading keep spills alloc (r:rs) = do assig <- getAssigR + let doSpill = allocRegsAndSpill_spill reading keep spills alloc r rs assig case lookupUFM assig r of -- case (1a): already in a register Just (InReg my_reg) -> allocateRegsAndSpill reading keep spills (my_reg:alloc) rs -- case (1b): already in a register (and memory) - -- NB1. if we're writing this register, update its assignemnt to be + -- NB1. if we're writing this register, update its assignment to be -- InReg, because the memory value is no longer valid. -- NB2. This is why we must process written registers here, even if they -- are also read by the same instruction. @@ -608,10 +619,22 @@ allocateRegsAndSpill reading keep spills alloc (r:rs) allocateRegsAndSpill reading keep spills (my_reg:alloc) rs -- Not already in a register, so we need to find a free one... - loc -> allocRegsAndSpill_spill reading keep spills alloc r rs loc assig + Just (InMem slot) | reading -> doSpill (ReadMem slot) + | otherwise -> doSpill WriteMem + Nothing | reading -> + -- pprPanic "allocateRegsAndSpill: Cannot read from uninitialized register" (ppr r) + -- ToDo: This case should be a panic, but we + -- sometimes see an unreachable basic block which + -- triggers this because the register allocator + -- will start with an empty assignment. + doSpill WriteNew + + | otherwise -> doSpill WriteNew -allocRegsAndSpill_spill reading keep spills alloc r rs loc assig +-- reading is redundant with reason, but we keep it around because it's +-- convenient and it maintains the recursive structure of the allocator. -- EZY +allocRegsAndSpill_spill reading keep spills alloc r rs assig spill_loc = do freeRegs <- getFreeRegsR let freeRegs_thisClass = getFreeRegs (classOfVirtualReg r) freeRegs @@ -620,19 +643,9 @@ allocRegsAndSpill_spill reading keep spills alloc r rs loc assig -- case (2): we have a free register (my_reg : _) -> - do spills' <- loadTemp reading r loc my_reg spills - - let new_loc - -- if the tmp was in a slot, then now its in a reg as well - | Just (InMem slot) <- loc - , reading - = InBoth my_reg slot + do spills' <- loadTemp r spill_loc my_reg spills - -- tmp has been loaded into a reg - | otherwise - = InReg my_reg - - setAssigR (addToUFM assig r $! new_loc) + setAssigR (addToUFM assig r $! newLocation spill_loc my_reg) setFreeRegsR $ allocateReg my_reg freeRegs allocateRegsAndSpill reading keep spills' (my_reg : alloc) rs @@ -662,9 +675,9 @@ allocRegsAndSpill_spill reading keep spills alloc r rs loc assig -- we have a temporary that is in both register and mem, -- just free up its register for use. | (temp, my_reg, slot) : _ <- candidates_inBoth - = do spills' <- loadTemp reading r loc my_reg spills + = do spills' <- loadTemp r spill_loc my_reg spills let assig1 = addToUFM assig temp (InMem slot) - let assig2 = addToUFM assig1 r (InReg my_reg) + let assig2 = addToUFM assig1 r $! newLocation spill_loc my_reg setAssigR assig2 allocateRegsAndSpill reading keep spills' (my_reg:alloc) rs @@ -684,11 +697,11 @@ allocRegsAndSpill_spill reading keep spills alloc r rs loc assig -- update the register assignment let assig1 = addToUFM assig temp_to_push_out (InMem slot) - let assig2 = addToUFM assig1 r (InReg my_reg) + let assig2 = addToUFM assig1 r $! newLocation spill_loc my_reg setAssigR assig2 -- if need be, load up a spilled temp into the reg we've just freed up. - spills' <- loadTemp reading r loc my_reg spills + spills' <- loadTemp r spill_loc my_reg spills allocateRegsAndSpill reading keep (spill_store ++ spills') @@ -707,22 +720,28 @@ allocRegsAndSpill_spill reading keep spills alloc r rs loc assig result --- | Load up a spilled temporary if we need to. +-- | Calculate a new location after a register has been loaded. +newLocation :: SpillLoc -> RealReg -> Loc +-- if the tmp was read from a slot, then now its in a reg as well +newLocation (ReadMem slot) my_reg = InBoth my_reg slot +-- writes will always result in only the register being available +newLocation _ my_reg = InReg my_reg + +-- | Load up a spilled temporary if we need to (read from memory). loadTemp - :: Instruction instr - => Bool - -> VirtualReg -- the temp being loaded - -> Maybe Loc -- the current location of this temp + :: (Outputable instr, Instruction instr) + => VirtualReg -- the temp being loaded + -> SpillLoc -- the current location of this temp -> RealReg -- the hreg to load the temp into -> [instr] -> RegM [instr] -loadTemp True vreg (Just (InMem slot)) hreg spills +loadTemp vreg (ReadMem slot) hreg spills = do insn <- loadR (RegReal hreg) slot recordSpill (SpillLoad $ getUnique vreg) return $ {- COMMENT (fsLit "spill load") : -} insn : spills -loadTemp _ _ _ _ spills = +loadTemp _ _ _ spills = return spills diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs index 44311a4..5df8f77 100644 --- a/compiler/nativeGen/X86/CodeGen.hs +++ b/compiler/nativeGen/X86/CodeGen.hs @@ -431,7 +431,7 @@ getRegister (CmmReg reg) size | not use_sse2 && isFloatSize sz = FF80 | otherwise = sz -- - return (Fixed sz (getRegisterReg use_sse2 reg) nilOL) + return (Fixed size (getRegisterReg use_sse2 reg) nilOL) getRegister tree@(CmmRegOff _ _) @@ -605,9 +605,7 @@ getRegister (CmmMachOp mop [x]) = do -- unary MachOps | sse2 -> coerceFP2FP W64 x | otherwise -> conversionNop FF80 x - MO_FF_Conv W64 W32 - | sse2 -> coerceFP2FP W32 x - | otherwise -> conversionNop FF80 x + MO_FF_Conv W64 W32 -> coerceFP2FP W32 x MO_FS_Conv from to -> coerceFP2Int from to x MO_SF_Conv from to -> coerceInt2FP from to x @@ -1589,12 +1587,24 @@ genCCall target dest_regs args = do | otherwise #endif = concatOL push_codes + + -- Deallocate parameters after call for ccall; + -- but not for stdcall (callee does it) + -- + -- We have to pop any stack padding we added + -- on Darwin even if we are doing stdcall, though (#5052) + pop_size | cconv /= StdCallConv = tot_arg_size + | otherwise +#if darwin_TARGET_OS + = arg_pad_size +#else + = 0 +#endif + call = callinsns `appOL` toOL ( - -- Deallocate parameters after call for ccall; - -- but not for stdcall (callee does it) - (if cconv == StdCallConv || tot_arg_size==0 then [] else - [ADD II32 (OpImm (ImmInt tot_arg_size)) (OpReg esp)]) + (if pop_size==0 then [] else + [ADD II32 (OpImm (ImmInt pop_size)) (OpReg esp)]) ++ [DELTA (delta + tot_arg_size)] ) @@ -2257,12 +2267,14 @@ coerceFP2Int from to x = if_sse2 coerceFP2Int_sse2 coerceFP2Int_x87 -------------------------------------------------------------------------------- coerceFP2FP :: Width -> CmmExpr -> NatM Register coerceFP2FP to x = do + use_sse2 <- sse2Enabled (x_reg, x_code) <- getSomeReg x let - opc = case to of W32 -> CVTSD2SS; W64 -> CVTSS2SD + opc | use_sse2 = case to of W32 -> CVTSD2SS; W64 -> CVTSS2SD + | otherwise = GDTOF code dst = x_code `snocOL` opc x_reg dst -- in - return (Any (floatSize to) code) + return (Any (if use_sse2 then floatSize to else FF80) code) -------------------------------------------------------------------------------- diff --git a/compiler/nativeGen/X86/Instr.hs b/compiler/nativeGen/X86/Instr.hs index 28b7997..a96452b 100644 --- a/compiler/nativeGen/X86/Instr.hs +++ b/compiler/nativeGen/X86/Instr.hs @@ -228,6 +228,8 @@ data Instr | GITOF Reg Reg -- src(intreg), dst(fpreg) | GITOD Reg Reg -- src(intreg), dst(fpreg) + | GDTOF Reg Reg -- src(fpreg), dst(fpreg) + | GADD Size Reg Reg Reg -- src1, src2, dst | GDIV Size Reg Reg Reg -- src1, src2, dst | GSUB Size Reg Reg Reg -- src1, src2, dst @@ -367,6 +369,8 @@ x86_regUsageOfInstr instr GITOF src dst -> mkRU [src] [dst] GITOD src dst -> mkRU [src] [dst] + GDTOF src dst -> mkRU [src] [dst] + GADD _ s1 s2 dst -> mkRU [s1,s2] [dst] GSUB _ s1 s2 dst -> mkRU [s1,s2] [dst] GMUL _ s1 s2 dst -> mkRU [s1,s2] [dst] @@ -493,6 +497,8 @@ x86_patchRegsOfInstr instr env GITOF src dst -> GITOF (env src) (env dst) GITOD src dst -> GITOD (env src) (env dst) + GDTOF src dst -> GDTOF (env src) (env dst) + GADD sz s1 s2 dst -> GADD sz (env s1) (env s2) (env dst) GSUB sz s1 s2 dst -> GSUB sz (env s1) (env s2) (env dst) GMUL sz s1 s2 dst -> GMUL sz (env s1) (env s2) (env dst) @@ -735,6 +741,7 @@ i386_insert_ffrees blocks where p insn r = case insn of CALL _ _ -> GFREE : insn : r JMP _ -> GFREE : insn : r + JXX_GBL _ _ -> GFREE : insn : r _ -> insn : r -- if you ever add a new FP insn to the fake x86 FP insn set, @@ -749,8 +756,9 @@ is_G_instr instr GLD1{} -> True GFTOI{} -> True GDTOI{} -> True - GITOF{} -> True - GITOD{} -> True + GITOF{} -> True + GITOD{} -> True + GDTOF{} -> True GADD{} -> True GDIV{} -> True GSUB{} -> True diff --git a/compiler/nativeGen/X86/Ppr.hs b/compiler/nativeGen/X86/Ppr.hs index 7944a38..5fe78e1 100644 --- a/compiler/nativeGen/X86/Ppr.hs +++ b/compiler/nativeGen/X86/Ppr.hs @@ -720,6 +720,11 @@ pprInstr g@(GITOD src dst) text " ; fildl (%esp) ; ", gpop dst 1, text " ; addl $4,%esp"]) +pprInstr g@(GDTOF src dst) + = pprG g (vcat [gtab <> gpush src 0, + gtab <> text "subl $4,%esp ; fstps (%esp) ; flds (%esp) ; addl $4,%esp ;", + gtab <> gpop dst 1]) + {- Gruesome swamp follows. If you're unfortunate enough to have ventured this far into the jungle AND you give a Rat's Ass (tm) what's going on, here's the deal. Generate code to do a floating point comparison @@ -975,6 +980,7 @@ pprGInstr (GDTOI src dst) = pprSizeSizeRegReg (sLit "gdtoi") FF64 II32 src dst pprGInstr (GITOF src dst) = pprSizeSizeRegReg (sLit "gitof") II32 FF32 src dst pprGInstr (GITOD src dst) = pprSizeSizeRegReg (sLit "gitod") II32 FF64 src dst +pprGInstr (GDTOF src dst) = pprSizeSizeRegReg (sLit "gdtof") FF64 FF32 src dst pprGInstr (GCMP co src dst) = pprCondRegReg (sLit "gcmp_") FF64 co src dst pprGInstr (GABS sz src dst) = pprSizeRegReg (sLit "gabs") sz src dst diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs index b43373e..f4d4329 100644 --- a/compiler/prelude/PrelNames.lhs +++ b/compiler/prelude/PrelNames.lhs @@ -1108,7 +1108,7 @@ hetMetCodeTypeTyConKey :: Unique hetMetCodeTypeTyConKey = mkPreludeTyConUnique 135 ---------------- Template Haskell ------------------- --- USES TyConUniques 100-129 +-- USES TyConUniques 200-299 ----------------------------------------------------- unitTyConKey :: Unique @@ -1361,7 +1361,7 @@ hetmet_guest_string_literal_key = mkPreludeMiscIdUnique 135 hetmet_guest_char_literal_key = mkPreludeMiscIdUnique 136 ---------------- Template Haskell ------------------- --- USES IdUniques 200-399 +-- USES IdUniques 200-499 ----------------------------------------------------- \end{code} diff --git a/compiler/prelude/PrelRules.lhs b/compiler/prelude/PrelRules.lhs index 5e43ad4..b37556b 100644 --- a/compiler/prelude/PrelRules.lhs +++ b/compiler/prelude/PrelRules.lhs @@ -39,7 +39,8 @@ import StaticFlags ( opt_SimplExcessPrecision ) import Constants import Data.Bits as Bits -import Data.Word ( Word ) +import Data.Int ( Int64 ) +import Data.Word ( Word, Word64 ) \end{code} @@ -142,15 +143,15 @@ primOpRules op op_name = primop_rule op primop_rule CharEqOp = relop (==) ++ litEq op_name True primop_rule CharNeOp = relop (/=) ++ litEq op_name False - primop_rule IntGtOp = relop (>) - primop_rule IntGeOp = relop (>=) - primop_rule IntLeOp = relop (<=) - primop_rule IntLtOp = relop (<) + primop_rule IntGtOp = relop (>) ++ boundsCmp op_name Gt + primop_rule IntGeOp = relop (>=) ++ boundsCmp op_name Ge + primop_rule IntLeOp = relop (<=) ++ boundsCmp op_name Le + primop_rule IntLtOp = relop (<) ++ boundsCmp op_name Lt - primop_rule CharGtOp = relop (>) - primop_rule CharGeOp = relop (>=) - primop_rule CharLeOp = relop (<=) - primop_rule CharLtOp = relop (<) + primop_rule CharGtOp = relop (>) ++ boundsCmp op_name Gt + primop_rule CharGeOp = relop (>=) ++ boundsCmp op_name Ge + primop_rule CharLeOp = relop (<=) ++ boundsCmp op_name Le + primop_rule CharLtOp = relop (<) ++ boundsCmp op_name Lt primop_rule FloatGtOp = relop (>) primop_rule FloatGeOp = relop (>=) @@ -166,10 +167,10 @@ primOpRules op op_name = primop_rule op primop_rule DoubleEqOp = relop (==) primop_rule DoubleNeOp = relop (/=) - primop_rule WordGtOp = relop (>) - primop_rule WordGeOp = relop (>=) - primop_rule WordLeOp = relop (<=) - primop_rule WordLtOp = relop (<) + primop_rule WordGtOp = relop (>) ++ boundsCmp op_name Gt + primop_rule WordGeOp = relop (>=) ++ boundsCmp op_name Ge + primop_rule WordLeOp = relop (<=) ++ boundsCmp op_name Le + primop_rule WordLtOp = relop (<) ++ boundsCmp op_name Lt primop_rule WordEqOp = relop (==) primop_rule WordNeOp = relop (/=) @@ -350,6 +351,53 @@ litEq op_name is_eq val_if_neq | is_eq = falseVal | otherwise = trueVal + +-- | Check if there is comparison with minBound or maxBound, that is +-- always true or false. For instance, an Int cannot be smaller than its +-- minBound, so we can replace such comparison with False. +boundsCmp :: Name -> Comparison -> [CoreRule] +boundsCmp op_name op = [ rule ] + where + rule = BuiltinRule + { ru_name = occNameFS (nameOccName op_name) + `appendFS` (fsLit "min/maxBound") + , ru_fn = op_name + , ru_nargs = 2 + , ru_try = rule_fn + } + rule_fn _ [a, b] = mkRuleFn op a b + rule_fn _ _ = Nothing + +data Comparison = Gt | Ge | Lt | Le + +mkRuleFn :: Comparison -> CoreExpr -> CoreExpr -> Maybe CoreExpr +mkRuleFn Gt (Lit lit) _ | isMinBound lit = Just falseVal +mkRuleFn Le (Lit lit) _ | isMinBound lit = Just trueVal +mkRuleFn Ge _ (Lit lit) | isMinBound lit = Just trueVal +mkRuleFn Lt _ (Lit lit) | isMinBound lit = Just falseVal +mkRuleFn Ge (Lit lit) _ | isMaxBound lit = Just trueVal +mkRuleFn Lt (Lit lit) _ | isMaxBound lit = Just falseVal +mkRuleFn Gt _ (Lit lit) | isMaxBound lit = Just falseVal +mkRuleFn Le _ (Lit lit) | isMaxBound lit = Just trueVal +mkRuleFn _ _ _ = Nothing + +isMinBound :: Literal -> Bool +isMinBound (MachChar c) = c == minBound +isMinBound (MachInt i) = i == toInteger (minBound :: Int) +isMinBound (MachInt64 i) = i == toInteger (minBound :: Int64) +isMinBound (MachWord i) = i == toInteger (minBound :: Word) +isMinBound (MachWord64 i) = i == toInteger (minBound :: Word64) +isMinBound _ = False + +isMaxBound :: Literal -> Bool +isMaxBound (MachChar c) = c == maxBound +isMaxBound (MachInt i) = i == toInteger (maxBound :: Int) +isMaxBound (MachInt64 i) = i == toInteger (maxBound :: Int64) +isMaxBound (MachWord i) = i == toInteger (maxBound :: Word) +isMaxBound (MachWord64 i) = i == toInteger (maxBound :: Word64) +isMaxBound _ = False + + -- Note that we *don't* warn the user about overflow. It's not done at -- runtime either, and compilation of completely harmless things like -- ((124076834 :: Word32) + (2147483647 :: Word32)) diff --git a/compiler/prelude/primops.txt.pp b/compiler/prelude/primops.txt.pp index 777e83f..7d80db4 100644 --- a/compiler/prelude/primops.txt.pp +++ b/compiler/prelude/primops.txt.pp @@ -1121,6 +1121,12 @@ primop AtomicModifyMutVarOp "atomicModifyMutVar#" GenPrimOp out_of_line = True has_side_effects = True +primop CasMutVarOp "casMutVar#" GenPrimOp + MutVar# s a -> a -> a -> State# s -> (# State# s, Int#, a #) + with + out_of_line = True + has_side_effects = True + ------------------------------------------------------------------------ section "Exceptions" ------------------------------------------------------------------------ diff --git a/compiler/profiling/ProfInit.hs b/compiler/profiling/ProfInit.hs new file mode 100644 index 0000000..7e223f8 --- /dev/null +++ b/compiler/profiling/ProfInit.hs @@ -0,0 +1,45 @@ +-- ----------------------------------------------------------------------------- +-- +-- (c) The University of Glasgow, 2011 +-- +-- Generate code to initialise cost centres +-- +-- ----------------------------------------------------------------------------- + +module ProfInit (profilingInitCode) where + +import CLabel +import CostCentre +import Outputable +import StaticFlags +import FastString +import Module + +-- ----------------------------------------------------------------------------- +-- Initialising cost centres + +-- We must produce declarations for the cost-centres defined in this +-- module; + +profilingInitCode :: Module -> CollectedCCs -> SDoc +profilingInitCode this_mod (local_CCs, ___extern_CCs, singleton_CCSs) + | not opt_SccProfilingOn = empty + | otherwise + = vcat + [ text "static void prof_init_" <> ppr this_mod + <> text "(void) __attribute__((constructor));" + , text "static void prof_init_" <> ppr this_mod <> text "(void)" + , braces (vcat ( + map emitRegisterCC local_CCs ++ + map emitRegisterCCS singleton_CCSs + )) + ] + where + emitRegisterCC cc = + ptext (sLit "extern CostCentre ") <> cc_lbl <> ptext (sLit "[];") $$ + ptext (sLit "REGISTER_CC(") <> cc_lbl <> char ')' <> semi + where cc_lbl = ppr (mkCCLabel cc) + emitRegisterCCS ccs = + ptext (sLit "extern CostCentreStack ") <> ccs_lbl <> ptext (sLit "[];") $$ + ptext (sLit "REGISTER_CCS(") <> ccs_lbl <> char ')' <> semi + where ccs_lbl = ppr (mkCCSLabel ccs) diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs index 0b10764..6c57cb2 100644 --- a/compiler/rename/RnBinds.lhs +++ b/compiler/rename/RnBinds.lhs @@ -357,7 +357,9 @@ rnLocalValBindsAndThen binds@(ValBindsIn _ sigs) thing_inside -- let x = x in 3 -- should report 'x' unused ; let real_uses = findUses dus result_fvs - ; warnUnusedLocalBinds bound_names real_uses + -- Insert fake uses for variables introduced implicitly by wildcards (#4404) + implicit_uses = hsValBindsImplicits binds' + ; warnUnusedLocalBinds bound_names (real_uses `unionNameSets` implicit_uses) ; let -- The variables "used" in the val binds are: diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs index 3a288bb..f71b17c 100644 --- a/compiler/rename/RnExpr.lhs +++ b/compiler/rename/RnExpr.lhs @@ -899,13 +899,15 @@ rnRecStmtsAndThen s cont -- ...bring them and their fixities into scope ; let bound_names = collectLStmtsBinders (map fst new_lhs_and_fv) + -- Fake uses of variables introduced implicitly (warning suppression, see #4404) + implicit_uses = lStmtsImplicits (map fst new_lhs_and_fv) ; bindLocalNamesFV bound_names $ addLocalFixities fix_env bound_names $ do -- (C) do the right-hand-sides and thing-inside { segs <- rn_rec_stmts bound_names new_lhs_and_fv ; (res, fvs) <- cont segs - ; warnUnusedLocalBinds bound_names fvs + ; warnUnusedLocalBinds bound_names (fvs `unionNameSets` implicit_uses) ; return (res, fvs) }} -- get all the fixity decls in any Let stmt diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs index a756c7f..3a20ac4 100644 --- a/compiler/rename/RnNames.lhs +++ b/compiler/rename/RnNames.lhs @@ -112,8 +112,9 @@ rnImportDecl this_mod implicit_prelude -- (Opt_WarnMissingImportList also checks for T(..) items -- but that is done in checkDodgyImport below) case imp_details of - Just (False, _) -> return () + Just (False, _) -> return () -- Explicit import list _ | implicit_prelude -> return () + | qual_only -> return () | otherwise -> ifDOptM Opt_WarnMissingImportList $ addWarn (missingImportListWarn imp_mod_name) @@ -586,6 +587,7 @@ filterImports iface decl_spec (Just (want_hiding, import_items)) all_avails = ifDOptM Opt_WarnDodgyImports (addWarn (dodgyImportWarn n)) -- NB. use the RdrName for reporting the warning | IEThingAll {} <- ieRdr + , not (is_qual decl_spec) = ifDOptM Opt_WarnMissingImportList $ addWarn (missingImportListItem ieRdr) checkDodgyImport _ diff --git a/compiler/simplCore/CoreMonad.lhs b/compiler/simplCore/CoreMonad.lhs index bb598c6..c527d82 100644 --- a/compiler/simplCore/CoreMonad.lhs +++ b/compiler/simplCore/CoreMonad.lhs @@ -401,7 +401,7 @@ getCoreToDo dflags simpl_gently = CoreDoSimplify max_iter (base_mode { sm_phase = InitialPhase , sm_names = ["Gentle"] - , sm_rules = True -- Note [RULEs enabled in SimplGently] + , sm_rules = rules_on -- Note [RULEs enabled in SimplGently] , sm_inline = False , sm_case_case = False }) -- Don't do case-of-case transformations. @@ -568,9 +568,6 @@ RULES are enabled when doing "gentle" simplification. Two reasons: But watch out: list fusion can prevent floating. So use phase control to switch off those rules until after floating. -Currently (Oct10) I think that sm_rules is always True, so we -could remove it. - %************************************************************************ %* * diff --git a/compiler/simplCore/OccurAnal.lhs b/compiler/simplCore/OccurAnal.lhs index 0bc6296..7692b62 100644 --- a/compiler/simplCore/OccurAnal.lhs +++ b/compiler/simplCore/OccurAnal.lhs @@ -1146,7 +1146,7 @@ wrapProxy (bndr, rhs_var, co) (body_usg, body) where (body_usg', tagged_bndr) = tagBinder body_usg bndr rhs_usg = unitVarEnv rhs_var NoOccInfo -- We don't need exact info - rhs = mkCoerceI co (Var rhs_var) + rhs = mkCoerceI co (Var (zapIdOccInfo rhs_var)) -- See Note [Zap case binders in proxy bindings] \end{code} @@ -1352,9 +1352,11 @@ extendFvs env s %************************************************************************ \begin{code} -data ProxyEnv - = PE (IdEnv (Id, [(Id,CoercionI)])) VarSet - -- Main env, and its free variables (of both range and domain) +data ProxyEnv -- See Note [ProxyEnv] + = PE (IdEnv -- Domain = scrutinee variables + (Id, -- The scrutinee variable again + [(Id,CoercionI)])) -- The case binders that it maps to + VarSet -- Free variables of both range and domain \end{code} Note [ProxyEnv] @@ -1497,6 +1499,17 @@ From this we want to extract the bindings Notice that later bindings may mention earlier ones, and that we need to go "both ways". +Note [Zap case binders in proxy bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +From the original + case x of cb(dead) { p -> ...x... } +we will get + case x of cb(live) { p -> let x = cb in ...x... } + +Core Lint never expects to find an *occurence* of an Id marked +as Dead, so we must zap the OccInfo on cb before making the +binding x = cb. See Trac #5028. + Historical note [no-case-of-case] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We *used* to suppress the binder-swap in case expressions when @@ -1580,10 +1593,11 @@ extendProxyEnv pe scrut co case_bndr -- Localise the scrut_var before shadowing it; we're making a -- new binding for it, and it might have an External Name, or -- even be a GlobalId; Note [Binder swap on GlobalId scrutinees] - -- Also we don't want any INLILNE or NOINLINE pragmas! + -- Also we don't want any INLINE or NOINLINE pragmas! ----------- type ProxyBind = (Id, Id, CoercionI) + -- (scrut variable, case-binder variable, coercion) getProxies :: OccEnv -> Id -> Bag ProxyBind -- Return a bunch of bindings [...(xi,ei)...] diff --git a/compiler/simplCore/SimplCore.lhs b/compiler/simplCore/SimplCore.lhs index 1a634d5..ea81317 100644 --- a/compiler/simplCore/SimplCore.lhs +++ b/compiler/simplCore/SimplCore.lhs @@ -211,7 +211,7 @@ simplifyExpr dflags expr ; us <- mkSplitUniqSupply 's' ; let (expr', _counts) = initSmpl dflags emptyRuleBase emptyFamInstEnvs us $ - simplExprGently simplEnvForGHCi expr + simplExprGently (simplEnvForGHCi dflags) expr ; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression" (pprCoreExpr expr') diff --git a/compiler/simplCore/SimplUtils.lhs b/compiler/simplCore/SimplUtils.lhs index 99a63e4..7e9a010 100644 --- a/compiler/simplCore/SimplUtils.lhs +++ b/compiler/simplCore/SimplUtils.lhs @@ -468,12 +468,17 @@ CoreMonad sm_eta_expand :: Bool -- Whether eta-expansion is enabled \begin{code} -simplEnvForGHCi :: SimplEnv -simplEnvForGHCi = mkSimplEnv $ - SimplMode { sm_names = ["GHCi"] - , sm_phase = InitialPhase - , sm_rules = True, sm_inline = False - , sm_eta_expand = False, sm_case_case = True } +simplEnvForGHCi :: DynFlags -> SimplEnv +simplEnvForGHCi dflags + = mkSimplEnv $ SimplMode { sm_names = ["GHCi"] + , sm_phase = InitialPhase + , sm_rules = rules_on + , sm_inline = False + , sm_eta_expand = eta_expand_on + , sm_case_case = True } + where + rules_on = dopt Opt_EnableRewriteRules dflags + eta_expand_on = dopt Opt_DoLambdaEtaExpansion dflags -- Do not do any inlining, in case we expose some unboxed -- tuple stuff that confuses the bytecode interpreter @@ -481,9 +486,10 @@ updModeForInlineRules :: Activation -> SimplifierMode -> SimplifierMode -- See Note [Simplifying inside InlineRules] updModeForInlineRules inline_rule_act current_mode = current_mode { sm_phase = phaseFromActivation inline_rule_act - , sm_rules = True , sm_inline = True , sm_eta_expand = False } + -- For sm_rules, just inherit; sm_rules might be "off" + -- becuase of -fno-enable-rewrite-rules where phaseFromActivation (ActiveAfter n) = Phase n phaseFromActivation _ = InitialPhase diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs index b82dd31..8249c89 100644 --- a/compiler/simplCore/Simplify.lhs +++ b/compiler/simplCore/Simplify.lhs @@ -1391,9 +1391,10 @@ tryRules env rules fn args call_cont trace_dump dflags rule rule_rhs stuff | not (dopt Opt_D_dump_rule_firings dflags) , not (dopt Opt_D_dump_rule_rewrites dflags) = stuff - | not (dopt Opt_D_dump_rule_rewrites dflags) + | not (dopt Opt_D_dump_rule_rewrites dflags) = pprTrace "Rule fired:" (ftext (ru_name rule)) stuff + | otherwise = pprTrace "Rule fired" (vcat [text "Rule:" <+> ftext (ru_name rule), diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs index 0da6cdb..8a6a3b7 100644 --- a/compiler/typecheck/TcBinds.lhs +++ b/compiler/typecheck/TcBinds.lhs @@ -325,11 +325,13 @@ tcPolyBinds :: TopLevelFlag -> SigFun -> PragFun tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc bind_list = setSrcSpan loc $ recoverM (recoveryCode binder_names sig_fn) $ do - -- Set up main recoer; take advantage of any type sigs + -- Set up main recover; take advantage of any type sigs { traceTc "------------------------------------------------" empty ; traceTc "Bindings for" (ppr binder_names) + -- Instantiate the polytypes of any binders that have signatures + -- (as determined by sig_fn), returning a TcSigInfo for each ; tc_sig_fn <- tcInstSigs sig_fn binder_names ; dflags <- getDOpts @@ -348,9 +350,10 @@ tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc bind_list ; return (binds, poly_ids) } where binder_names = collectHsBindListBinders bind_list - loc = getLoc (head bind_list) - -- TODO: location a bit awkward, but the mbinds have been - -- dependency analysed and may no longer be adjacent + loc = foldr1 combineSrcSpans (map getLoc bind_list) + -- The mbinds have been dependency analysed and + -- may no longer be adjacent; so find the narrowest + -- span that includes them all ------------------ tcPolyNoGen @@ -388,7 +391,7 @@ tcPolyCheck :: TcSigInfo -> PragFun -- it binds a single variable, -- it has a signature, tcPolyCheck sig@(TcSigInfo { sig_id = id, sig_tvs = tvs, sig_scoped = scoped - , sig_theta = theta, sig_tau = tau, sig_loc = loc }) + , sig_theta = theta, sig_tau = tau }) prag_fn rec_tc bind_list = do { ev_vars <- newEvVars theta ; let skol_info = SigSkol (FunSigCtxt (idName id)) (mkPhiTy theta tau) @@ -399,6 +402,7 @@ tcPolyCheck sig@(TcSigInfo { sig_id = id, sig_tvs = tvs, sig_scoped = scoped ; export <- mkExport prag_fn tvs theta mono_info + ; loc <- getSrcSpanM ; let (_, poly_id, _, _) = export abs_bind = L loc $ AbsBinds { abs_tvs = tvs @@ -415,10 +419,10 @@ tcPolyInfer -- dependencies based on type signatures -> [LHsBind Name] -> TcM (LHsBinds TcId, [TcId]) -tcPolyInfer top_lvl mono sig_fn prag_fn rec_tc bind_list +tcPolyInfer top_lvl mono tc_sig_fn prag_fn rec_tc bind_list = do { ((binds', mono_infos), wanted) <- captureConstraints $ - tcMonoBinds sig_fn LetLclBndr rec_tc bind_list + tcMonoBinds tc_sig_fn LetLclBndr rec_tc bind_list ; unifyCtxts [sig | (_, Just sig, _) <- mono_infos] diff --git a/compiler/typecheck/TcCanonical.lhs b/compiler/typecheck/TcCanonical.lhs index 59d221e..59cc736 100644 --- a/compiler/typecheck/TcCanonical.lhs +++ b/compiler/typecheck/TcCanonical.lhs @@ -1,7 +1,7 @@ \begin{code} module TcCanonical( - mkCanonical, mkCanonicals, mkCanonicalFEV, canWanteds, canGivens, - canOccursCheck, canEq, + mkCanonical, mkCanonicals, mkCanonicalFEV, mkCanonicalFEVs, canWanteds, canGivens, + canOccursCheck, canEqToWorkList, rewriteWithFunDeps ) where @@ -218,28 +218,35 @@ flattenPred ctxt (EqPred ty1 ty2) %************************************************************************ \begin{code} -canWanteds :: [WantedEvVar] -> TcS CanonicalCts -canWanteds = fmap andCCans . mapM (\(EvVarX ev loc) -> mkCanonical (Wanted loc) ev) +canWanteds :: [WantedEvVar] -> TcS WorkList +canWanteds = fmap unionWorkLists . mapM (\(EvVarX ev loc) -> mkCanonical (Wanted loc) ev) -canGivens :: GivenLoc -> [EvVar] -> TcS CanonicalCts +canGivens :: GivenLoc -> [EvVar] -> TcS WorkList canGivens loc givens = do { ccs <- mapM (mkCanonical (Given loc)) givens - ; return (andCCans ccs) } + ; return (unionWorkLists ccs) } -mkCanonicals :: CtFlavor -> [EvVar] -> TcS CanonicalCts -mkCanonicals fl vs = fmap andCCans (mapM (mkCanonical fl) vs) +mkCanonicals :: CtFlavor -> [EvVar] -> TcS WorkList +mkCanonicals fl vs = fmap unionWorkLists (mapM (mkCanonical fl) vs) -mkCanonicalFEV :: FlavoredEvVar -> TcS CanonicalCts +mkCanonicalFEV :: FlavoredEvVar -> TcS WorkList mkCanonicalFEV (EvVarX ev fl) = mkCanonical fl ev -mkCanonical :: CtFlavor -> EvVar -> TcS CanonicalCts +mkCanonicalFEVs :: Bag FlavoredEvVar -> TcS WorkList +mkCanonicalFEVs = foldrBagM canon_one emptyWorkList + where -- Preserves order (shouldn't be important, but curently + -- is important for the vectoriser) + canon_one fev wl = do { wl' <- mkCanonicalFEV fev + ; return (unionWorkList wl' wl) } + +mkCanonical :: CtFlavor -> EvVar -> TcS WorkList mkCanonical fl ev = case evVarPred ev of - ClassP clas tys -> canClass fl ev clas tys - IParam ip ty -> canIP fl ev ip ty - EqPred ty1 ty2 -> canEq fl ev ty1 ty2 + ClassP clas tys -> canClassToWorkList fl ev clas tys + IParam ip ty -> canIPToWorkList fl ev ip ty + EqPred ty1 ty2 -> canEqToWorkList fl ev ty1 ty2 -canClass :: CtFlavor -> EvVar -> Class -> [TcType] -> TcS CanonicalCts -canClass fl v cn tys +canClassToWorkList :: CtFlavor -> EvVar -> Class -> [TcType] -> TcS WorkList +canClassToWorkList fl v cn tys = do { (xis,cos,ccs) <- flattenMany fl tys -- cos :: xis ~ tys ; let no_flattening_happened = isEmptyCCan ccs dict_co = mkTyConCoercion (classTyCon cn) cos @@ -256,13 +263,15 @@ canClass fl v cn tys -- Add the superclasses of this one here, See Note [Adding superclasses]. -- But only if we are not simplifying the LHS of a rule. ; sctx <- getTcSContext - ; sc_cts <- if simplEqsOnly sctx then return emptyCCan + ; sc_cts <- if simplEqsOnly sctx then return emptyWorkList else newSCWorkFromFlavored v_new fl cn xis - ; return (sc_cts `andCCan` ccs `extendCCans` CDictCan { cc_id = v_new - , cc_flavor = fl - , cc_class = cn - , cc_tyargs = xis }) } + ; return (sc_cts `unionWorkList` + workListFromEqs ccs `unionWorkList` + workListFromNonEq CDictCan { cc_id = v_new + , cc_flavor = fl + , cc_class = cn + , cc_tyargs = xis }) } \end{code} Note [Adding superclasses] @@ -330,12 +339,12 @@ happen. \begin{code} -newSCWorkFromFlavored :: EvVar -> CtFlavor -> Class -> [Xi] -> TcS CanonicalCts +newSCWorkFromFlavored :: EvVar -> CtFlavor -> Class -> [Xi] -> TcS WorkList -- Returns superclasses, see Note [Adding superclasses] newSCWorkFromFlavored ev orig_flavor cls xis | isDerived orig_flavor - = return emptyCCan -- Deriveds don't yield more superclasses because we will - -- add them transitively in the case of wanteds. + = return emptyWorkList -- Deriveds don't yield more superclasses because we will + -- add them transitively in the case of wanteds. | isGiven orig_flavor = do { let sc_theta = immSuperClasses cls xis @@ -345,8 +354,8 @@ newSCWorkFromFlavored ev orig_flavor cls xis ; mkCanonicals flavor sc_vars } | isEmptyVarSet (tyVarsOfTypes xis) - = return emptyCCan -- Wanteds with no variables yield no deriveds. - -- See Note [Improvement from Ground Wanteds] + = return emptyWorkList -- Wanteds with no variables yield no deriveds. + -- See Note [Improvement from Ground Wanteds] | otherwise -- Wanted case, just add those SC that can lead to improvement. = do { let sc_rec_theta = transSuperClasses cls xis @@ -366,16 +375,20 @@ is_improvement_pty _ = False -canIP :: CtFlavor -> EvVar -> IPName Name -> TcType -> TcS CanonicalCts +canIPToWorkList :: CtFlavor -> EvVar -> IPName Name -> TcType -> TcS WorkList -- See Note [Canonical implicit parameter constraints] to see why we don't -- immediately canonicalize (flatten) IP constraints. -canIP fl v nm ty - = return $ singleCCan $ CIPCan { cc_id = v - , cc_flavor = fl - , cc_ip_nm = nm - , cc_ip_ty = ty } +canIPToWorkList fl v nm ty + = return $ workListFromNonEq (CIPCan { cc_id = v + , cc_flavor = fl + , cc_ip_nm = nm + , cc_ip_ty = ty }) ----------------- +canEqToWorkList :: CtFlavor -> EvVar -> Type -> Type -> TcS WorkList +canEqToWorkList fl cv ty1 ty2 = do { cts <- canEq fl cv ty1 ty2 + ; return $ workListFromEqs cts } + canEq :: CtFlavor -> EvVar -> Type -> Type -> TcS CanonicalCts canEq fl cv ty1 ty2 | tcEqType ty1 ty2 -- Dealing with equality here avoids @@ -1020,15 +1033,15 @@ now!). \begin{code} rewriteWithFunDeps :: [Equation] -> [Xi] -> CtFlavor - -> TcS (Maybe ([Xi], [Coercion], CanonicalCts)) + -> TcS (Maybe ([Xi], [Coercion], WorkList)) rewriteWithFunDeps eqn_pred_locs xis fl = do { fd_ev_poss <- mapM (instFunDepEqn fl) eqn_pred_locs ; let fd_ev_pos :: [(Int,FlavoredEvVar)] fd_ev_pos = concat fd_ev_poss (rewritten_xis, cos) = unzip (rewriteDictParams fd_ev_pos xis) ; fds <- mapM (\(_,fev) -> mkCanonicalFEV fev) fd_ev_pos - ; let fd_work = unionManyBags fds - ; if isEmptyBag fd_work + ; let fd_work = unionWorkLists fds + ; if isEmptyWorkList fd_work then return Nothing else return (Just (rewritten_xis, cos, fd_work)) } diff --git a/compiler/typecheck/TcInteract.lhs b/compiler/typecheck/TcInteract.lhs index c8b0114..4a049aa 100644 --- a/compiler/typecheck/TcInteract.lhs +++ b/compiler/typecheck/TcInteract.lhs @@ -225,22 +225,6 @@ Note [Basic plan] type AtomicInert = CanonicalCt -- constraint pulled from InertSet type WorkItem = CanonicalCt -- constraint pulled from WorkList --- A mixture of Given, Wanted, and Derived constraints. --- We split between equalities and the rest to process equalities first. -type WorkList = CanonicalCts - -unionWorkLists :: WorkList -> WorkList -> WorkList -unionWorkLists = andCCan - -isEmptyWorkList :: WorkList -> Bool -isEmptyWorkList = isEmptyCCan - -emptyWorkList :: WorkList -emptyWorkList = emptyCCan - -workListFromCCan :: CanonicalCt -> WorkList -workListFromCCan = singleCCan - ------------------------ data StopOrContinue = Stop -- Work item is consumed @@ -305,7 +289,7 @@ runSolverPipeline depth pipeline inerts workItem , sr_stop = ContinueWith work_item }) = do { itr <- stage depth work_item inerts ; traceTcS ("Stage result (" ++ name ++ ")") (ppr itr) - ; let itr' = itr { sr_new_work = accum_work `unionWorkLists` sr_new_work itr } + ; let itr' = itr { sr_new_work = accum_work `unionWorkList` sr_new_work itr } ; run_pipeline stages itr' } \end{code} @@ -365,8 +349,10 @@ solveInteract inert ws -> (ct,evVarPred ev)) ws) , text "inert = " <+> ppr inert ] - ; (flag, inert_ret) <- foldrBagM (tryPreSolveAndInteract sctx dyn_flags) (True,inert) ws - -- use foldr to preserve the order + ; can_ws <- mkCanonicalFEVs ws + + ; (flag, inert_ret) + <- foldrWorkListM (tryPreSolveAndInteract sctx dyn_flags) (True,inert) can_ws ; traceTcS "solveInteract, after clever canonicalization (and interaction):" $ vcat [ text "No interaction happened = " <+> ppr flag @@ -374,27 +360,32 @@ solveInteract inert ws ; return (flag, inert_ret) } - tryPreSolveAndInteract :: SimplContext -> DynFlags - -> FlavoredEvVar + -> CanonicalCt -> (Bool, InertSet) -> TcS (Bool, InertSet) -- Returns: True if it was able to discharge this constraint AND all previous ones -tryPreSolveAndInteract sctx dyn_flags flavev@(EvVarX ev_var fl) (all_previous_discharged, inert) +tryPreSolveAndInteract sctx dyn_flags ct (all_previous_discharged, inert) = do { let inert_cts = get_inert_cts (evVarPred ev_var) - ; this_one_discharged <- dischargeFromCCans inert_cts flavev + ; this_one_discharged <- + if isCFrozenErr ct then + return False + else + dischargeFromCCans inert_cts ev_var fl ; if this_one_discharged then return (all_previous_discharged, inert) else do - { extra_cts <- mkCanonical fl ev_var - ; inert_ret <- solveInteractWithDepth (ctxtStkDepth dyn_flags,0,[]) extra_cts inert + { inert_ret <- solveOneWithDepth (ctxtStkDepth dyn_flags,0,[]) ct inert ; return (False, inert_ret) } } where + ev_var = cc_id ct + fl = cc_flavor ct + get_inert_cts (ClassP clas _) | simplEqsOnly sctx = emptyCCan | otherwise = fst (getRelevantCts clas (inert_dicts inert)) @@ -405,12 +396,12 @@ tryPreSolveAndInteract sctx dyn_flags flavev@(EvVarX ev_var fl) (all_previous_di get_inert_cts (EqPred {}) = inert_eqs inert `unionBags` cCanMapToBag (inert_funeqs inert) -dischargeFromCCans :: CanonicalCts -> FlavoredEvVar -> TcS Bool +dischargeFromCCans :: CanonicalCts -> EvVar -> CtFlavor -> TcS Bool -- See if this (pre-canonicalised) work-item is identical to a -- one already in the inert set. Reasons: -- a) Avoid creating superclass constraints for millions of incoming (Num a) constraints -- b) Termination for improve_eqs in TcSimplify.simpl_loop -dischargeFromCCans cans (EvVarX ev fl) +dischargeFromCCans cans ev fl = Bag.foldrBag discharge_ct (return False) cans where the_pred = evVarPred ev @@ -469,11 +460,9 @@ solveInteractWithDepth ctxt@(max_depth,n,stack) ws inert , text "Max depth =" <+> ppr max_depth , text "ws =" <+> ppr ws ] - -- Solve equalities first - ; let (eqs, non_eqs) = Bag.partitionBag isCTyEqCan ws - ; is_from_eqs <- Bag.foldrBagM (solveOneWithDepth ctxt) inert eqs - ; Bag.foldrBagM (solveOneWithDepth ctxt) is_from_eqs non_eqs } - -- use foldr to preserve the order + + ; foldrWorkListM (solveOneWithDepth ctxt) inert ws } + -- use foldr to preserve the order ------------------ -- Fully interact the given work item with an inert set, and return a @@ -834,7 +823,7 @@ data WhichComesFromInert = LeftComesFromInert | RightComesFromInert interactWithInertEqsStage :: SimplifierStage interactWithInertEqsStage depth workItem inert = Bag.foldrBagM (interactNext depth) initITR (inert_eqs inert) - -- use foldr to preserve the order + -- use foldr to preserve the order where initITR = SR { sr_inerts = inert { inert_eqs = emptyCCan } , sr_new_work = emptyWorkList @@ -893,7 +882,7 @@ interactNext depth inert it = text rule <+> keep_doc <+> vcat [ ptext (sLit "Inert =") <+> ppr inert , ptext (sLit "Work =") <+> ppr work_item - , ppUnless (isEmptyBag new_work) $ + , ppUnless (isEmptyWorkList new_work) $ ptext (sLit "New =") <+> ppr new_work ] keep_doc = case inert_action of KeepInert -> ptext (sLit "[keep]") @@ -909,7 +898,7 @@ interactNext depth inert it DropInert -> inerts ; return $ SR { sr_inerts = inerts_new - , sr_new_work = sr_new_work it `unionWorkLists` new_work + , sr_new_work = sr_new_work it `unionWorkList` new_work , sr_stop = stop } } | otherwise = return $ it { sr_inerts = (sr_inerts it) `updInertSet` inert } @@ -971,8 +960,8 @@ doInteractWithInert -- and put it back into the work-list -- Maybe rather than starting again, we could *replace* the -- inert item, but its safe and simple to restart - ; mkIRStopD "Cls/Cls fundep (solved)" (inert_w `consBag` fd_work) } - + ; mkIRStopD "Cls/Cls fundep (solved)" $ + workListFromNonEq inert_w `unionWorkList` fd_work } | otherwise -> do { setDictBind d2 (EvCast d1 dict_co) ; mkIRStopK "Cls/Cls fundep (solved)" fd_work } @@ -998,7 +987,8 @@ doInteractWithInert Wanted {} -> setDictBind d2 (EvCast d2' dict_co) Derived {} -> return () ; let workItem' = workItem { cc_id = d2', cc_tyargs = rewritten_tys2 } - ; mkIRStopK "Cls/Cls fundep (partial)" (workItem' `consBag` fd_work) } + ; mkIRStopK "Cls/Cls fundep (partial)" $ + workListFromNonEq workItem' `unionWorkList` fd_work } where dict_co = mkTyConCoercion (classTyCon cls1) cos2 @@ -1020,7 +1010,7 @@ doInteractWithInert (CDictCan { cc_id = dv, cc_flavor = ifl, cc_class = cl, cc_t | wfl `canRewrite` ifl , tv `elemVarSet` tyVarsOfTypes xis = do { rewritten_dict <- rewriteDict (cv,tv,xi) (dv,ifl,cl,xis) - ; mkIRContinue "Cls/Eq" workItem DropInert (workListFromCCan rewritten_dict) } + ; mkIRContinue "Cls/Eq" workItem DropInert (workListFromNonEq rewritten_dict) } -- Class constraint and given equality: use the equality to rewrite -- the class constraint. @@ -1036,7 +1026,7 @@ doInteractWithInert (CIPCan { cc_id = ipid, cc_flavor = ifl, cc_ip_nm = nm, cc_i | wfl `canRewrite` ifl , tv `elemVarSet` tyVarsOfType ty = do { rewritten_ip <- rewriteIP (cv,tv,xi) (ipid,ifl,nm,ty) - ; mkIRContinue "IP/Eq" workItem DropInert (workListFromCCan rewritten_ip) } + ; mkIRContinue "IP/Eq" workItem DropInert (workListFromNonEq rewritten_ip) } -- Two implicit parameter constraints. If the names are the same, -- but their types are not, we generate a wanted type equality @@ -1075,7 +1065,7 @@ doInteractWithInert (CTyEqCan { cc_id = cv1, cc_flavor = ifl, cc_tyvar = tv, cc_ | ifl `canRewrite` wfl , tv `elemVarSet` tyVarsOfTypes (xi2:args) -- Rewrite RHS as well = do { rewritten_funeq <- rewriteFunEq (cv1,tv,xi1) (cv2,wfl,tc,args,xi2) - ; mkIRStopK "Eq/FunEq" (workListFromCCan rewritten_funeq) } + ; mkIRStopK "Eq/FunEq" (workListFromEq rewritten_funeq) } -- Must Stop here, because we may no longer be inert after the rewritting. -- Inert: function equality, work item: equality @@ -1085,7 +1075,7 @@ doInteractWithInert (CFunEqCan {cc_id = cv1, cc_flavor = ifl, cc_fun = tc | wfl `canRewrite` ifl , tv `elemVarSet` tyVarsOfTypes (xi1:args) -- Rewrite RHS as well = do { rewritten_funeq <- rewriteFunEq (cv2,tv,xi2) (cv1,ifl,tc,args,xi1) - ; mkIRContinue "FunEq/Eq" workItem DropInert (workListFromCCan rewritten_funeq) } + ; mkIRContinue "FunEq/Eq" workItem DropInert (workListFromEq rewritten_funeq) } -- One may think that we could (KeepTransformedInert rewritten_funeq) -- but that is wrong, because it may end up not being inert with respect -- to future inerts. Example: @@ -1214,7 +1204,7 @@ rewriteEqRHS (cv1,tv1,xi1) (cv2,gw,tv2,xi2) | Just tv2' <- tcGetTyVar_maybe xi2' , tv2 == tv2' -- In this case xi2[xi1/tv1] = tv2, so we have tv2~tv2 = do { when (isWanted gw) (setCoBind cv2 (mkSymCoercion co2')) - ; return emptyCCan } + ; return emptyWorkList } | otherwise = do { cv2' <- newCoVar (mkTyVarTy tv2) xi2' ; case gw of @@ -1223,7 +1213,7 @@ rewriteEqRHS (cv1,tv1,xi1) (cv2,gw,tv2,xi2) Given {} -> setCoBind cv2' $ mkCoVarCoercion cv2 `mkTransCoercion` co2' Derived {} -> return () - ; canEq gw cv2' (mkTyVarTy tv2) xi2' } + ; canEqToWorkList gw cv2' (mkTyVarTy tv2) xi2' } where xi2' = substTyWith [tv1] [xi1] xi2 co2' = substTyWith [tv1] [mkCoVarCoercion cv1] xi2 -- xi2 ~ xi2[xi1/tv1] @@ -1269,7 +1259,7 @@ rewriteFrozen (cv1, tv1, xi1) (cv2, fl2) Derived {} -> return () - ; return (singleCCan $ CFrozenErr { cc_id = cv2', cc_flavor = fl2 }) } + ; return (workListFromNonEq $ CFrozenErr { cc_id = cv2', cc_flavor = fl2 }) } where (ty2a, ty2b) = coVarKind cv2 -- cv2 : ty2a ~ ty2b ty2a' = substTyWith [tv1] [xi1] ty2a @@ -1750,7 +1740,7 @@ doTopReact workItem@(CDictCan { cc_id = dv, cc_flavor = fl@(Wanted loc) ; let workItem' = CDictCan { cc_id = dv', cc_flavor = fl, cc_class = cls, cc_tyargs = xis' } ; return $ - SomeTopInt { tir_new_work = singleCCan workItem' `andCCan` fd_work + SomeTopInt { tir_new_work = workListFromNonEq workItem' `unionWorkList` fd_work , tir_new_inert = Stop } } } GenInst wtvs ev_term -- Solved diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs index 9d74ff8..7453334 100644 --- a/compiler/typecheck/TcMType.lhs +++ b/compiler/typecheck/TcMType.lhs @@ -364,8 +364,8 @@ writeMetaTyVarRef tyvar ref ty | otherwise = do { meta_details <- readMutVar ref; - ; WARN( not (isFlexi meta_details), - hang (text "Double update of meta tyvar") + ; ASSERT2( isFlexi meta_details, + hang (text "Double update of meta tyvar") 2 (ppr tyvar $$ ppr meta_details) ) traceTc "writeMetaTyVar" (ppr tyvar <+> text ":=" <+> ppr ty) diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 3de19ed..23c2e67 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -9,8 +9,9 @@ module TcRnDriver ( #ifdef GHCI tcRnStmt, tcRnExpr, tcRnType, tcRnLookupRdrName, - getModuleExports, + getModuleExports, #endif + tcRnImports, tcRnLookupName, tcRnGetInfo, tcRnModule, diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs index bf3ab32..87cd5eb 100644 --- a/compiler/typecheck/TcSMonad.lhs +++ b/compiler/typecheck/TcSMonad.lhs @@ -8,6 +8,10 @@ module TcSMonad ( isCDictCan_Maybe, isCIPCan_Maybe, isCFunEqCan_Maybe, isCFrozenErr, + WorkList, unionWorkList, unionWorkLists, isEmptyWorkList, emptyWorkList, + workListFromEq, workListFromNonEq, + workListFromEqs, workListFromNonEqs, foldrWorkListM, + CanonicalCt(..), Xi, tyVarsOfCanonical, tyVarsOfCanonicals, tyVarsOfCDicts, deCanonicalise, mkFrozenError, @@ -257,8 +261,58 @@ isCFunEqCan_Maybe _ = Nothing isCFrozenErr :: CanonicalCt -> Bool isCFrozenErr (CFrozenErr {}) = True isCFrozenErr _ = False + + +-- A mixture of Given, Wanted, and Derived constraints. +-- We split between equalities and the rest to process equalities first. +data WorkList = WorkList { weqs :: CanonicalCts + -- NB: weqs includes equalities /and/ family equalities + , wrest :: CanonicalCts } + +unionWorkList :: WorkList -> WorkList -> WorkList +unionWorkList wl1 wl2 + = WorkList { weqs = weqs wl1 `andCCan` weqs wl2 + , wrest = wrest wl1 `andCCan` wrest wl2 } + +unionWorkLists :: [WorkList] -> WorkList +unionWorkLists = foldr unionWorkList emptyWorkList + +isEmptyWorkList :: WorkList -> Bool +isEmptyWorkList wl = isEmptyCCan (weqs wl) && isEmptyCCan (wrest wl) + +emptyWorkList :: WorkList +emptyWorkList + = WorkList { weqs = emptyBag, wrest = emptyBag } + +workListFromEq :: CanonicalCt -> WorkList +workListFromEq = workListFromEqs . singleCCan + +workListFromNonEq :: CanonicalCt -> WorkList +workListFromNonEq = workListFromNonEqs . singleCCan + +workListFromNonEqs :: CanonicalCts -> WorkList +workListFromNonEqs cts + = WorkList { weqs = emptyCCan, wrest = cts } + +workListFromEqs :: CanonicalCts -> WorkList +workListFromEqs cts + = WorkList { weqs = cts, wrest = emptyCCan } + +foldrWorkListM :: (Monad m) => (CanonicalCt -> r -> m r) + -> r -> WorkList -> m r +-- Prioritizes equalities +foldrWorkListM on_ct r (WorkList {weqs = eqs, wrest = rest }) + = do { r1 <- foldrBagM on_ct r eqs + ; foldrBagM on_ct r1 rest } + +instance Outputable WorkList where + ppr wl = vcat [ text "WorkList (Equalities) = " <+> ppr (weqs wl) + , text "WorkList (Other) = " <+> ppr (wrest wl) ] + \end{code} + + %************************************************************************ %* * CtFlavor diff --git a/compiler/types/OptCoercion.lhs b/compiler/types/OptCoercion.lhs index 0fff7ab..26f3295 100644 --- a/compiler/types/OptCoercion.lhs +++ b/compiler/types/OptCoercion.lhs @@ -19,6 +19,7 @@ import Var import VarSet import VarEnv import PrelNames +import StaticFlags ( opt_NoOptCoercion ) import Util import Outputable \end{code} @@ -50,7 +51,9 @@ mkCoPredTy in the ForAll case, where this note appears. optCoercion :: TvSubst -> Coercion -> NormalCo -- ^ optCoercion applies a substitution to a coercion, -- *and* optimises it to reduce its size -optCoercion env co = opt_co env False co +optCoercion env co + | opt_NoOptCoercion = substTy env co + | otherwise = opt_co env False co type NormalCo = Coercion -- Invariants: diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs index 2958107..adb0470 100644 --- a/compiler/types/TyCon.lhs +++ b/compiler/types/TyCon.lhs @@ -129,15 +129,28 @@ Note [Type synonym families] * Translation of type instance decl: type instance F [a] = Maybe a - translates to - A SynTyCon 'R:FList a', whose + translates to a "representation TyCon", 'R:FList', where + R:FList is a SynTyCon, whose SynTyConRhs is (SynonymTyCon (Maybe a)) TyConParent is (FamInstTyCon F [a] co) where co :: F [a] ~ R:FList a - Notice that we introduce a gratuitous vanilla type synonym + + It's very much as if the user had written + type instance F [a] = R:FList a type R:FList a = Maybe a - solely so that type and data families can be treated more - uniformly, via a single FamInstTyCon descriptor + Indeed, in GHC's internal representation, the RHS of every + 'type instance' is simply an application of the representation + TyCon to the quantified varaibles. + + The intermediate representation TyCon is a bit gratuitous, but + it means that: + + each 'type instance' decls is in 1-1 correspondance + with its representation TyCon + + So the result of typechecking a 'type instance' decl is just a + TyCon. In turn this means that type and data families can be + treated uniformly. * In the future we might want to support * closed type families (esp when we have proper kinds) diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs index 8ff78fb..5f348ef 100644 --- a/compiler/types/Type.lhs +++ b/compiler/types/Type.lhs @@ -74,7 +74,8 @@ module Type ( -- * Type free variables tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta, - expandTypeSynonyms, + expandTypeSynonyms, + typeSize, -- * Type comparison coreEqType, coreEqType2, @@ -857,6 +858,28 @@ tyVarsOfTheta = foldr (unionVarSet . tyVarsOfPred) emptyVarSet %************************************************************************ %* * + Size +%* * +%************************************************************************ + +\begin{code} +typeSize :: Type -> Int +typeSize (TyVarTy _) = 1 +typeSize (AppTy t1 t2) = typeSize t1 + typeSize t2 +typeSize (FunTy t1 t2) = typeSize t1 + typeSize t2 +typeSize (PredTy p) = predSize p +typeSize (ForAllTy _ t) = 1 + typeSize t +typeSize (TyConApp _ ts) = 1 + sum (map typeSize ts) + +predSize :: PredType -> Int +predSize (IParam _ t) = 1 + typeSize t +predSize (ClassP _ ts) = 1 + sum (map typeSize ts) +predSize (EqPred t1 t2) = typeSize t1 + typeSize t2 +\end{code} + + +%************************************************************************ +%* * \subsection{Type families} %* * %************************************************************************ diff --git a/compiler/utils/GraphOps.hs b/compiler/utils/GraphOps.hs index 388b968..1fa4199 100644 --- a/compiler/utils/GraphOps.hs +++ b/compiler/utils/GraphOps.hs @@ -61,14 +61,14 @@ addNode k node graph -- add back conflict edges from other nodes to this one map_conflict = foldUniqSet - (adjustUFM (\n -> n { nodeConflicts = addOneToUniqSet (nodeConflicts n) k})) + (adjustUFM_C (\n -> n { nodeConflicts = addOneToUniqSet (nodeConflicts n) k})) (graphMap graph) (nodeConflicts node) -- add back coalesce edges from other nodes to this one map_coalesce = foldUniqSet - (adjustUFM (\n -> n { nodeCoalesce = addOneToUniqSet (nodeCoalesce n) k})) + (adjustUFM_C (\n -> n { nodeCoalesce = addOneToUniqSet (nodeCoalesce n) k})) map_conflict (nodeCoalesce node) @@ -434,7 +434,7 @@ freezeNode k else node -- panic "GraphOps.freezeNode: edge to freeze wasn't in the coalesce set" -- If the edge isn't actually in the coelesce set then just ignore it. - fm2 = foldUniqSet (adjustUFM (freezeEdge k)) fm1 + fm2 = foldUniqSet (adjustUFM_C (freezeEdge k)) fm1 $ nodeCoalesce node in fm2 @@ -604,7 +604,7 @@ setColor setColor u color = graphMapModify - $ adjustUFM + $ adjustUFM_C (\n -> n { nodeColor = Just color }) u @@ -621,13 +621,14 @@ adjustWithDefaultUFM f def k map map k def -{-# INLINE adjustUFM #-} -adjustUFM +-- Argument order different from UniqFM's adjustUFM +{-# INLINE adjustUFM_C #-} +adjustUFM_C :: Uniquable k => (a -> a) -> k -> UniqFM a -> UniqFM a -adjustUFM f k map +adjustUFM_C f k map = case lookupUFM map k of Nothing -> map Just a -> addToUFM map k (f a) diff --git a/compiler/utils/UniqFM.lhs b/compiler/utils/UniqFM.lhs index 293e48e..7302b02 100644 --- a/compiler/utils/UniqFM.lhs +++ b/compiler/utils/UniqFM.lhs @@ -36,6 +36,8 @@ module UniqFM ( addListToUFM,addListToUFM_C, addToUFM_Directly, addListToUFM_Directly, + adjustUFM, + adjustUFM_Directly, delFromUFM, delFromUFM_Directly, delListFromUFM, @@ -45,7 +47,7 @@ module UniqFM ( intersectUFM, intersectUFM_C, foldUFM, foldUFM_Directly, - mapUFM, + mapUFM, mapUFM_Directly, elemUFM, elemUFM_Directly, filterUFM, filterUFM_Directly, sizeUFM, @@ -53,12 +55,15 @@ module UniqFM ( lookupUFM, lookupUFM_Directly, lookupWithDefaultUFM, lookupWithDefaultUFM_Directly, eltsUFM, keysUFM, splitUFM, - ufmToList + ufmToList, + joinUFM ) where import Unique ( Uniquable(..), Unique, getKey ) import Outputable +import Compiler.Hoopl hiding (Unique) + import qualified Data.IntMap as M \end{code} @@ -103,6 +108,9 @@ addListToUFM_C :: Uniquable key => (elt -> elt -> elt) -> UniqFM elt -> [(key,elt)] -> UniqFM elt +adjustUFM :: Uniquable key => (elt -> elt) -> UniqFM elt -> key -> UniqFM elt +adjustUFM_Directly :: (elt -> elt) -> UniqFM elt -> Unique -> UniqFM elt + delFromUFM :: Uniquable key => UniqFM elt -> key -> UniqFM elt delListFromUFM :: Uniquable key => UniqFM elt -> [key] -> UniqFM elt delFromUFM_Directly :: UniqFM elt -> Unique -> UniqFM elt @@ -122,6 +130,7 @@ intersectUFM_C :: (elt1 -> elt2 -> elt3) foldUFM :: (elt -> a -> a) -> a -> UniqFM elt -> a foldUFM_Directly:: (Unique -> elt -> a -> a) -> a -> UniqFM elt -> a mapUFM :: (elt1 -> elt2) -> UniqFM elt1 -> UniqFM elt2 +mapUFM_Directly :: (Unique -> elt1 -> elt2) -> UniqFM elt1 -> UniqFM elt2 filterUFM :: (elt -> Bool) -> UniqFM elt -> UniqFM elt filterUFM_Directly :: (Unique -> elt -> Bool) -> UniqFM elt -> UniqFM elt @@ -174,6 +183,9 @@ addToUFM_Acc exi new (UFM m) k v = UFM (M.insertWith (\_new old -> exi v old) (getKey $ getUnique k) (new v) m) addListToUFM_C f = foldl (\m (k, v) -> addToUFM_C f m k v) +adjustUFM f (UFM m) k = UFM (M.adjust f (getKey $ getUnique k) m) +adjustUFM_Directly f (UFM m) u = UFM (M.adjust f (getKey u) m) + delFromUFM (UFM m) k = UFM (M.delete (getKey $ getUnique k) m) delListFromUFM = foldl delFromUFM delFromUFM_Directly (UFM m) u = UFM (M.delete (getKey u) m) @@ -188,6 +200,7 @@ intersectUFM_C f (UFM x) (UFM y) = UFM (M.intersectionWith f x y) foldUFM k z (UFM m) = M.fold k z m foldUFM_Directly k z (UFM m) = M.foldWithKey (k . getUnique) z m mapUFM f (UFM m) = UFM (M.map f m) +mapUFM_Directly f (UFM m) = UFM (M.mapWithKey (f . getUnique) m) filterUFM p (UFM m) = UFM (M.filter p m) filterUFM_Directly p (UFM m) = UFM (M.filterWithKey (p . getUnique) m) @@ -205,6 +218,16 @@ keysUFM (UFM m) = map getUnique $ M.keys m eltsUFM (UFM m) = M.elems m ufmToList (UFM m) = map (\(k, v) -> (getUnique k, v)) $ M.toList m +-- Hoopl +joinUFM :: JoinFun v -> JoinFun (UniqFM v) +joinUFM eltJoin l (OldFact old) (NewFact new) = foldUFM_Directly add (NoChange, old) new + where add k new_v (ch, joinmap) = + case lookupUFM_Directly joinmap k of + Nothing -> (SomeChange, addToUFM_Directly joinmap k new_v) + Just old_v -> case eltJoin l (OldFact old_v) (NewFact new_v) of + (SomeChange, v') -> (SomeChange, addToUFM_Directly joinmap k v') + (NoChange, _) -> (ch, joinmap) + \end{code} %************************************************************************ diff --git a/compiler/utils/Util.lhs b/compiler/utils/Util.lhs index 6b17a28..0e46889 100644 --- a/compiler/utils/Util.lhs +++ b/compiler/utils/Util.lhs @@ -81,7 +81,10 @@ module Util ( Direction(..), reslash, -- * Utils for defining Data instances - abstractConstr, abstractDataType, mkNoRepType + abstractConstr, abstractDataType, mkNoRepType, + + -- * Utils for printing C code + charToC ) where #include "HsVersions.h" @@ -106,7 +109,7 @@ import System.Directory ( doesDirectoryExist, createDirectory, import System.FilePath import System.Time ( ClockTime ) -import Data.Char ( isUpper, isAlphaNum, isSpace, ord, isDigit ) +import Data.Char ( isUpper, isAlphaNum, isSpace, chr, ord, isDigit ) import Data.Ratio ( (%) ) import Data.Ord ( comparing ) import Data.Bits @@ -1066,3 +1069,22 @@ abstractDataType :: String -> DataType abstractDataType n = mkDataType n [abstractConstr n] \end{code} +%************************************************************************ +%* * +\subsection[Utils-C]{Utils for printing C code} +%* * +%************************************************************************ + +\begin{code} +charToC :: Word8 -> String +charToC w = + case chr (fromIntegral w) of + '\"' -> "\\\"" + '\'' -> "\\\'" + '\\' -> "\\\\" + c | c >= ' ' && c <= '~' -> [c] + | otherwise -> ['\\', + chr (ord '0' + ord c `div` 64), + chr (ord '0' + ord c `div` 8 `mod` 8), + chr (ord '0' + ord c `mod` 8)] +\end{code} diff --git a/compiler/vectorise/Vectorise.hs b/compiler/vectorise/Vectorise.hs index 72cca6e..ca6766a 100644 --- a/compiler/vectorise/Vectorise.hs +++ b/compiler/vectorise/Vectorise.hs @@ -1,4 +1,4 @@ -{-# OPTIONS -fno-warn-missing-signatures #-} +{-# OPTIONS -fno-warn-missing-signatures -fno-warn-unused-do-bind #-} module Vectorise ( vectorise ) where @@ -121,44 +121,53 @@ vectModule guts@(ModGuts { mg_types = types -- vectTopBind :: CoreBind -> VM CoreBind vectTopBind b@(NonRec var expr) - = do - (inline, _, expr') <- vectTopRhs [] var expr - var' <- vectTopBinder var inline expr' + = do { -- Vectorise the right-hand side, create an appropriate top-level binding and add it to + -- the vectorisation map. + ; (inline, isScalar, expr') <- vectTopRhs [] var expr + ; var' <- vectTopBinder var inline expr' + ; when isScalar $ + addGlobalScalar var - -- Vectorising the body may create other top-level bindings. - hs <- takeHoisted - - -- To get the same functionality as the original body we project - -- out its vectorised version from the closure. - cexpr <- tryConvert var var' expr - - return . Rec $ (var, cexpr) : (var', expr') : hs + -- We replace the original top-level binding by a value projected from the vectorised + -- closure and add any newly created hoisted top-level bindings. + ; cexpr <- tryConvert var var' expr + ; hs <- takeHoisted + ; return . Rec $ (var, cexpr) : (var', expr') : hs + } `orElseV` return b - vectTopBind b@(Rec bs) - = do - (vars', _, exprs') - <- fixV $ \ ~(_, inlines, rhss) -> - do vars' <- sequence [vectTopBinder var inline rhs - | (var, ~(inline, rhs)) <- zipLazy vars (zip inlines rhss)] - (inlines', areScalars', exprs') - <- mapAndUnzip3M (uncurry $ vectTopRhs vars) bs - if (and areScalars') || (length bs <= 1) - then do - return (vars', inlines', exprs') - else do - _ <- mapM deleteGlobalScalar vars - (inlines'', _, exprs'') <- mapAndUnzip3M (uncurry $ vectTopRhs []) bs - return (vars', inlines'', exprs'') + = let (vars, exprs) = unzip bs + in + do { (vars', _, exprs', hs) <- fixV $ + \ ~(_, inlines, rhss, _) -> + do { -- Vectorise the right-hand sides, create an appropriate top-level bindings and + -- add them to the vectorisation map. + ; vars' <- sequence [vectTopBinder var inline rhs + | (var, ~(inline, rhs)) <- zipLazy vars (zip inlines rhss)] + ; (inlines, areScalars, exprs') <- mapAndUnzip3M (uncurry $ vectTopRhs vars) bs + ; hs <- takeHoisted + ; if and areScalars + then -- (1) Entire recursive group is scalar + -- => add all variables to the global set of scalars + do { mapM addGlobalScalar vars + ; return (vars', inlines, exprs', hs) + } + else -- (2) At least one binding is not scalar + -- => vectorise again with empty set of local scalars + do { (inlines, _, exprs') <- mapAndUnzip3M (uncurry $ vectTopRhs []) bs + ; hs <- takeHoisted + ; return (vars', inlines, exprs', hs) + } + } - hs <- takeHoisted - cexprs <- sequence $ zipWith3 tryConvert vars vars' exprs - return . Rec $ zip vars cexprs ++ zip vars' exprs' ++ hs + -- Replace the original top-level bindings by a values projected from the vectorised + -- closures and add any newly created hoisted top-level bindings to the group. + ; cexprs <- sequence $ zipWith3 tryConvert vars vars' exprs + ; return . Rec $ zip vars cexprs ++ zip vars' exprs' ++ hs + } `orElseV` - return b - where - (vars, exprs) = unzip bs + return b -- | Make the vectorised version of this top level binder, and add the mapping -- between it and the original to the state. For some binder @foo@ the vectorised @@ -233,22 +242,16 @@ vectTopRhs recFs var expr where rhs _globalScalar (Just (_, expr')) -- Case (1) = return (inlineMe, False, expr') - rhs True _vectDecl -- Case (2) - = return (inlineMe, True, scalarRHS) - -- FIXME: that True is not enough to register scalarness - rhs False _vectDecl -- Case (3) + rhs True Nothing -- Case (2) + = do { expr' <- vectScalarFun True recFs expr + ; return (inlineMe, True, vectorised expr') + } + rhs False Nothing -- Case (3) = do { let fvs = freeVars expr ; (inline, isScalar, vexpr) <- inBind var $ vectPolyExpr (isLoopBreaker $ idOccInfo var) recFs fvs - ; if isScalar - then addGlobalScalar var - else deleteGlobalScalar var ; return (inline, isScalar, vectorised vexpr) } - - -- For scalar right-hand sides, we know that the original binding will remain unaltered - -- (hence, we can refer to it without risk of cycles) - cf, 'tryConvert'. - scalarRHS = panic "Vectorise.scalarRHS: not implemented yet" -- | Project out the vectorised version of a binding from some closure, -- or return the original body if that doesn't work or the binding is scalar. diff --git a/compiler/vectorise/Vectorise/Env.hs b/compiler/vectorise/Vectorise/Env.hs index 9a1fd44..5014fd6 100644 --- a/compiler/vectorise/Vectorise/Env.hs +++ b/compiler/vectorise/Vectorise/Env.hs @@ -75,7 +75,8 @@ emptyLocalEnv = LocalEnv { -- These are things the exist at top-level. data GlobalEnv = GlobalEnv { - -- | Mapping from global variables to their vectorised versions. + -- | Mapping from global variables to their vectorised versions — aka the /vectorisation + -- map/. global_vars :: VarEnv Var -- | Mapping from global variables that have a vectorisation declaration to the right-hand diff --git a/compiler/vectorise/Vectorise/Exp.hs b/compiler/vectorise/Vectorise/Exp.hs index 569057e..dbdf6e1 100644 --- a/compiler/vectorise/Vectorise/Exp.hs +++ b/compiler/vectorise/Vectorise/Exp.hs @@ -1,15 +1,23 @@ -- | Vectorisation of expressions. -module Vectorise.Exp - (vectPolyExpr) -where -import Vectorise.Utils +module Vectorise.Exp ( + + -- Vectorise a polymorphic expression + vectPolyExpr, + + -- Vectorise a scalar expression of functional type + vectScalarFun +) where + +#include "HsVersions.h" + import Vectorise.Type.Type import Vectorise.Var import Vectorise.Vect import Vectorise.Env import Vectorise.Monad import Vectorise.Builtins +import Vectorise.Utils import CoreSyn import CoreUtils @@ -148,134 +156,141 @@ vectExpr e = cantVectorise "Can't vectorise expression (vectExpr)" (ppr $ deAnno -- | Vectorise an expression with an outer lambda abstraction. -- -vectFnExpr :: Bool -- ^ When the RHS of a binding, whether that binding should be inlined. - -> Bool -- ^ Whether the binding is a loop breaker. - -> [Var] - -> CoreExprWithFVs -- ^ Expression to vectorise. Must have an outer `AnnLam`. +vectFnExpr :: Bool -- ^ If we process the RHS of a binding, whether that binding should + -- be inlined + -> Bool -- ^ Whether the binding is a loop breaker + -> [Var] -- ^ Names of function in same recursive binding group + -> CoreExprWithFVs -- ^ Expression to vectorise; must have an outer `AnnLam` -> VM (Inline, Bool, VExpr) -vectFnExpr inline loop_breaker recFns e@(fvs, AnnLam bndr _) - | isId bndr = onlyIfV True -- (isEmptyVarSet fvs) -- we check for free variables later. TODO: clean up - (mark DontInline True . vectScalarLam bs recFns $ deAnnotate body) - `orElseV` mark inlineMe False (vectLam inline loop_breaker fvs bs body) - where - (bs,body) = collectAnnValBinders e +vectFnExpr inline loop_breaker recFns expr@(_fvs, AnnLam bndr _) + | isId bndr = mark DontInline True (vectScalarFun False recFns (deAnnotate expr)) + `orElseV` + mark inlineMe False (vectLam inline loop_breaker expr) vectFnExpr _ _ _ e = mark DontInline False $ vectExpr e mark :: Inline -> Bool -> VM a -> VM (Inline, Bool, a) mark b isScalarFn p = do { x <- p; return (b, isScalarFn, x) } - --- | Vectorise a function where are the args have scalar type, --- that is Int, Float, Double etc. -vectScalarLam - :: [Var] -- ^ Bound variables of function - -> [Var] - -> CoreExpr -- ^ Function body. - -> VM VExpr - -vectScalarLam args recFns body - = do scalars' <- globalScalars - let scalars = unionVarSet (mkVarSet recFns) scalars' - onlyIfV (all is_prim_ty arg_tys - && is_prim_ty res_ty - && is_scalar (extendVarSetList scalars args) body - && uses scalars body) - $ do - fn_var <- hoistExpr (fsLit "fn") (mkLams args body) DontInline - zipf <- zipScalars arg_tys res_ty - clo <- scalarClosure arg_tys res_ty (Var fn_var) - (zipf `App` Var fn_var) - clo_var <- hoistExpr (fsLit "clo") clo DontInline - lclo <- liftPD (Var clo_var) - return (Var clo_var, lclo) +-- |Vectorise an expression of functional type, where all arguments and the result are of scalar +-- type (i.e., 'Int', 'Float', 'Double' etc.) and which does not contain any subcomputations that +-- involve parallel arrays. Such functionals do not requires the full blown vectorisation +-- transformation; instead, they can be lifted by application of a member of the zipWith family +-- (i.e., 'map', 'zipWith', zipWith3', etc.) +-- +vectScalarFun :: Bool -- ^ Was the function marked as scalar by the user? + -> [Var] -- ^ Functions names in same recursive binding group + -> CoreExpr -- ^ Expression to be vectorised + -> VM VExpr +vectScalarFun forceScalar recFns expr + = do { gscalars <- globalScalars + ; let scalars = gscalars `extendVarSetList` recFns + (arg_tys, res_ty) = splitFunTys (exprType expr) + ; MASSERT( not $ null arg_tys ) + ; onlyIfV (forceScalar -- user asserts the functions is scalar + || + all is_prim_ty arg_tys -- check whether the function is scalar + && is_prim_ty res_ty + && is_scalar scalars expr + && uses scalars expr) + $ mkScalarFun arg_tys res_ty expr + } where - arg_tys = map idType args - res_ty = exprType body - + -- FIXME: This is woefully insufficient!!! We need a scalar pragma for types!!! is_prim_ty ty | Just (tycon, []) <- splitTyConApp_maybe ty = tycon == intTyCon || tycon == floatTyCon || tycon == doubleTyCon - | otherwise = False - - cantbe_parr_expr expr = not $ maybe_parr_ty $ exprType expr - - maybe_parr_ty ty = maybe_parr_ty' [] ty - - maybe_parr_ty' _ ty | Nothing <- splitTyConApp_maybe ty = False -- TODO: is this really what we want to do with polym. types? - maybe_parr_ty' alreadySeen ty - | isPArrTyCon tycon = True - | isPrimTyCon tycon = False - | isAbstractTyCon tycon = True - | isFunTyCon tycon || isProductTyCon tycon || isTupleTyCon tycon = any (maybe_parr_ty' alreadySeen) args - | isDataTyCon tycon = any (maybe_parr_ty' alreadySeen) args || - hasParrDataCon alreadySeen tycon - | otherwise = True - where - Just (tycon, args) = splitTyConApp_maybe ty - - - hasParrDataCon alreadySeen tycon - | tycon `elem` alreadySeen = False - | otherwise = - any (maybe_parr_ty' $ tycon : alreadySeen) $ concat $ map dataConOrigArgTys $ tyConDataCons tycon - - -- checks to make sure expression can't contain a non-scalar subexpression. Might err on the side of caution whenever - -- an external (non data constructor) variable is used, or anonymous data constructor - is_scalar vs e@(Var v) - | Just _ <- isDataConId_maybe v = cantbe_parr_expr e - | otherwise = cantbe_parr_expr e && (v `elemVarSet` vs) - is_scalar _ e@(Lit _) = cantbe_parr_expr e - - is_scalar vs e@(App e1 e2) = cantbe_parr_expr e && - is_scalar vs e1 && is_scalar vs e2 - is_scalar vs e@(Let (NonRec b letExpr) body) - = cantbe_parr_expr e && - is_scalar vs letExpr && is_scalar (extendVarSet vs b) body - is_scalar vs e@(Let (Rec bnds) body) - = let vs' = extendVarSetList vs (map fst bnds) - in cantbe_parr_expr e && - all (is_scalar vs') (map snd bnds) && is_scalar vs' body - is_scalar vs e@(Case eC eId ty alts) - = let vs' = extendVarSet vs eId - in cantbe_parr_expr e && - is_prim_ty ty && - is_scalar vs' eC && - (all (is_scalar_alt vs') alts) - - is_scalar _ _ = False - - is_scalar_alt vs (_, bs, e) - = is_scalar (extendVarSetList vs bs) e + -- Checks whether an expression contain a non-scalar subexpression. + -- + -- Precodition: The variables in the first argument are scalar. + -- + -- In case of a recursive binding group, we /assume/ that all bindings are scalar (by adding + -- them to the list of scalar variables) and then check them. If one of them turns out not to + -- be scalar, the entire group is regarded as not being scalar. + -- + -- FIXME: Currently, doesn't regard external (non-data constructor) variable and anonymous + -- data constructor as scalar. Should be changed once scalar types are passed + -- through VectInfo. + -- + is_scalar :: VarSet -> CoreExpr -> Bool + is_scalar scalars (Var v) = v `elemVarSet` scalars + is_scalar _scalars (Lit _) = True + is_scalar scalars e@(App e1 e2) + | maybe_parr_ty (exprType e) = False + | otherwise = is_scalar scalars e1 && is_scalar scalars e2 + is_scalar scalars (Lam var body) + | maybe_parr_ty (varType var) = False + | otherwise = is_scalar (scalars `extendVarSet` var) body + is_scalar scalars (Let bind body) = bindsAreScalar && is_scalar scalars' body + where + (bindsAreScalar, scalars') = is_scalar_bind scalars bind + is_scalar scalars (Case e var ty alts) + | is_prim_ty ty = is_scalar scalars' e && all (is_scalar_alt scalars') alts + | otherwise = False + where + scalars' = scalars `extendVarSet` var + is_scalar scalars (Cast e _coe) = is_scalar scalars e + is_scalar scalars (Note _ e ) = is_scalar scalars e + is_scalar _scalars (Type _) = True + + -- Result: (, scalars ++ variables bound in this group) + is_scalar_bind scalars (NonRec var e) = (is_scalar scalars e, scalars `extendVarSet` var) + is_scalar_bind scalars (Rec bnds) = (all (is_scalar scalars') es, scalars') + where + (vars, es) = unzip bnds + scalars' = scalars `extendVarSetList` vars + + is_scalar_alt scalars (_, vars, e) = is_scalar (scalars `extendVarSetList ` vars) e + + -- Checks whether the type might be a parallel array type. In particular, if the outermost + -- constructor is a type family, we conservatively assume that it may be a parallel array type. + maybe_parr_ty :: Type -> Bool + maybe_parr_ty ty + | Just ty' <- coreView ty = maybe_parr_ty ty' + | Just (tyCon, _) <- splitTyConApp_maybe ty = isPArrTyCon tyCon || isSynFamilyTyCon tyCon + maybe_parr_ty _ = False + + -- FIXME: I'm not convinced that this reasoning is (always) sound. If the identify functions + -- is called by some other function that is otherwise scalar, it would be very bad + -- that just this call to the identity makes it not be scalar. -- A scalar function has to actually compute something. Without the check, -- we would treat (\(x :: Int) -> x) as a scalar function and lift it to -- (map (\x -> x)) which is very bad. Normal lifting transforms it to -- (\n# x -> x) which is what we want. - uses funs (Var v) = v `elemVarSet` funs - uses funs (App e1 e2) = uses funs e1 || uses funs e2 + uses funs (Var v) = v `elemVarSet` funs + uses funs (App e1 e2) = uses funs e1 || uses funs e2 + uses funs (Lam b body) = uses (funs `extendVarSet` b) body uses funs (Let (NonRec _b letExpr) body) - = uses funs letExpr || uses funs body + = uses funs letExpr || uses funs body uses funs (Case e _eId _ty alts) - = uses funs e || any (uses_alt funs) alts - uses _ _ = False + = uses funs e || any (uses_alt funs) alts + uses _ _ = False - uses_alt funs (_, _bs, e) - = uses funs e + uses_alt funs (_, _bs, e) = uses funs e + +mkScalarFun :: [Type] -> Type -> CoreExpr -> VM VExpr +mkScalarFun arg_tys res_ty expr + = do { fn_var <- hoistExpr (fsLit "fn") expr DontInline + ; zipf <- zipScalars arg_tys res_ty + ; clo <- scalarClosure arg_tys res_ty (Var fn_var) (zipf `App` Var fn_var) + ; clo_var <- hoistExpr (fsLit "clo") clo DontInline + ; lclo <- liftPD (Var clo_var) + ; return (Var clo_var, lclo) + } -- | Vectorise a lambda abstraction. -vectLam - :: Bool -- ^ When the RHS of a binding, whether that binding should be inlined. - -> Bool -- ^ Whether the binding is a loop breaker. - -> VarSet -- ^ The free variables in the body. - -> [Var] -- ^ Binding variables. - -> CoreExprWithFVs -- ^ Body of abstraction. - -> VM VExpr - -vectLam inline loop_breaker fvs bs body - = do tyvars <- localTyVars +-- +vectLam :: Bool -- ^ When the RHS of a binding, whether that binding should be inlined. + -> Bool -- ^ Whether the binding is a loop breaker. + -> CoreExprWithFVs -- ^ Body of abstraction. + -> VM VExpr +vectLam inline loop_breaker expr@(fvs, AnnLam _ _) + = do let (bs, body) = collectAnnValBinders expr + + tyvars <- localTyVars (vs, vvs) <- readLEnv $ \env -> unzip [(var, vv) | var <- varSetElems fvs , Just vv <- [lookupVarEnv (local_vars env) var]] @@ -305,6 +320,7 @@ vectLam inline loop_breaker fvs bs body (LitAlt (mkMachInt 0), [], empty)]) | otherwise = return (ve, le) +vectLam _ _ _ = panic "vectLam" vectTyAppExpr :: CoreExprWithFVs -> [Type] -> VM VExpr diff --git a/configure.ac b/configure.ac index 967fd6f..7baa3dd 100644 --- a/configure.ac +++ b/configure.ac @@ -222,6 +222,21 @@ x86_64-apple-darwin) ;; esac +# Testing if we shall enable shared libs support on Solaris. +# Anything older than SunOS 5.11 aka Solaris 11 (Express) is broken. + +SOLARIS_BROKEN_SHLD=NO + +case $host in + i386-*-solaris2) + # here we go with the test + MINOR=`uname -r|cut -d '.' -f 2-` + if test "$MINOR" -lt "11"; then + SOLARIS_BROKEN_SHLD=YES + fi + ;; +esac + # Sync this with cTargetArch in compiler/ghc.mk checkArch() { case $1 in @@ -288,7 +303,7 @@ checkOS "$TargetOS" # Verify that the installed (bootstrap) GHC is capable of generating # code for the requested build platform. -if test "$build" != "$bootstrap_target" +if test "$BuildPlatform" != "$bootstrap_target" then echo "This GHC (${WithGhc}) does not generate code for the build platform" echo " GHC target platform : $bootstrap_target" @@ -296,6 +311,10 @@ then exit 1 fi +echo "GHC build : $BuildPlatform" +echo "GHC host : $HostPlatform" +echo "GHC target : $TargetPlatform" + AC_SUBST(BuildPlatform) AC_SUBST(HostPlatform) AC_SUBST(TargetPlatform) @@ -318,6 +337,8 @@ AC_SUBST(TargetVendor_CPP) AC_SUBST(exeext) AC_SUBST(soext) +AC_SUBST(SOLARIS_BROKEN_SHLD) + AC_ARG_WITH(hc, [AC_HELP_STRING([--with-hc=ARG], [Use ARG as the path to the compiler for compiling ordinary @@ -417,22 +438,34 @@ AC_SUBST([NmCmd]) SplitObjsBroken=NO if test "$TargetOS_CPP" = "darwin" then + AC_MSG_CHECKING(XCode version) XCodeVersion=`xcodebuild -version | grep Xcode | sed "s/Xcode //"` - XCodeVersion1=`echo "$XCodeVersion" | sed 's/\..*//'` - XCodeVersion2=`echo "$XCodeVersion" | sed 's/.*\.//'` # Old XCode versions don't actually give the XCode version if test "$XCodeVersion" = "" then + AC_MSG_RESULT(not found (too old?)) SplitObjsBroken=YES - fi - # Split objects is broken (#4013) with XCode < 3.2 - if test "$XCodeVersion1" -lt 3 - then - SplitObjsBroken=YES - fi - if test "$XCodeVersion1" -eq 3 && test "$XCodeVersion2" -lt 2 - then - SplitObjsBroken=YES + else + AC_MSG_RESULT($XCodeVersion) + XCodeVersion1=`echo "$XCodeVersion" | sed 's/\..*//'` +changequote(, )dnl + XCodeVersion2=`echo "$XCodeVersion" | sed 's/[^.]*\.\([^.]*\).*/\1/'` +changequote([, ])dnl + AC_MSG_NOTICE(XCode version component 1: $XCodeVersion1) + AC_MSG_NOTICE(XCode version component 2: $XCodeVersion2) + # Split objects is broken (#4013) with XCode < 3.2 + if test "$XCodeVersion1" -lt 3 + then + SplitObjsBroken=YES + else + if test "$XCodeVersion1" -eq 3 + then + if test "$XCodeVersion2" -lt 2 + then + SplitObjsBroken=YES + fi + fi + fi fi fi AC_SUBST([SplitObjsBroken]) @@ -783,6 +816,7 @@ FP_LEADING_UNDERSCORE dnl ** check for ld, whether it has an -x option, and if it is GNU ld FP_PROG_LD_X FP_PROG_LD_IS_GNU +FP_PROG_LD_BUILD_ID dnl ** check for Apple-style dead-stripping support dnl (.subsections-via-symbols assembler directive) diff --git a/darcs-all b/darcs-all deleted file mode 100644 index 106eb8f..0000000 --- a/darcs-all +++ /dev/null @@ -1,437 +0,0 @@ -#!/usr/bin/perl -w - -use strict; - -# Usage: -# -# ./darcs-all [-q] [-s] [-i] [-r repo] -# [--nofib] [--testsuite] [--checked-out] cmd [darcs flags] -# -# Applies the darcs command "cmd" to each repository in the tree. -# -# e.g. -# ./darcs-all -r http://darcs.haskell.org/ghc get -# To get any repos which do not exist in the local tree -# -# ./darcs-all -r ~/ghc-validate push -# To push all your repos to the ~/ghc-validate tree -# -# ./darcs-all pull -a -# To pull everything from the default repos -# -# ./darc-all push --dry-run -# To see what local patches you have relative to the main repos -# -# -------------- Flags ------------------- -# -q says to be quite, and -s to be silent. -# -# -i says to ignore darcs errors and move on to the next repository -# -# -r repo says to use repo as the location of package repositories -# -# --checked-out says that the remote repo is in checked-out layout, as -# opposed to the layout used for the main repo. By default a repo on -# the local filesystem is assumed to be checked-out, and repos accessed -# via HTTP or SSH are assumed to be in the main repo layout; use -# --checked-out to override the latter. -# -# --nofib, --testsuite also get the nofib and testsuite repos respectively -# -# The darcs get flag you are most likely to want is --complete. By -# default we pass darcs the --partial flag. -# -# ------------ Which repos to use ------------- -# darcs-all uses the following algorithm to decide which remote repos to use -# -# It always computes the remote repos from a single base, $repo_base -# How is $repo_base set? -# If you say "-r repo", then that's $repo_base -# othewise $repo_base is set thus: -# look in _darcs/prefs/defaultrepo, -# and remove the trailing 'ghc' -# -# Then darcs-all iterates over the package found in the file -# ./packages, which has entries like: -# libraries/array packages/array darcs -# or, in general -# -# -# If $repo_base looks like a local filesystem path, or if you give -# the --checked-out flag, darcs-all works on repos of form -# $repo_base/ -# otherwise darcs-all works on repos of form -# $repo_base/ -# This logic lets you say -# both darcs-all -r http://darcs.haskell.org/ghc-6.12 pull -# and darcs-all -r ../HEAD pull -# The latter is called a "checked-out tree". - -# NB: darcs-all *ignores* the defaultrepo of all repos other than the -# root one. So the remote repos must be laid out in one of the two -# formats given by and in the file 'packages'. - - -$| = 1; # autoflush stdout after each print, to avoid output after die - -my $defaultrepo; - -my $verbose = 2; -my $ignore_failure = 0; -my $want_remote_repo = 0; -my $checked_out_flag = 0; - -my %tags; - -my @packages; - -# Figure out where to get the other repositories from. -sub getrepo { - my $basedir = "."; - my $repo = $defaultrepo || `cat $basedir/_darcs/prefs/defaultrepo`; - chomp $repo; - - my $repo_base; - my $checked_out_tree; - - if ($repo =~ /^...*:/) { - # HTTP or SSH - # Above regex says "at least two chars before the :", to avoid - # catching Win32 drives ("C:\"). - $repo_base = $repo; - - # --checked-out is needed if you want to use a checked-out repo - # over SSH or HTTP - if ($checked_out_flag) { - $checked_out_tree = 1; - } else { - $checked_out_tree = 0; - } - - # Don't drop the last part of the path if specified with -r, as - # it expects repos of the form: - # - # http://darcs.haskell.org - # - # rather than - # - # http://darcs.haskell.org/ghc - # - if (!$defaultrepo) { - $repo_base =~ s#/[^/]+/?$##; - } - } - elsif ($repo =~ /^\/|\.\.\/|.:(\/|\\)/) { - # Local filesystem, either absolute or relative path - # (assumes a checked-out tree): - $repo_base = $repo; - $checked_out_tree = 1; - } - else { - die "Couldn't work out repo"; - } - - return $repo_base, $checked_out_tree; -} - -sub message { - if ($verbose >= 2) { - print "@_\n"; - } -} - -sub warning { - if ($verbose >= 1) { - print "warning: @_\n"; - } -} - -sub darcs { - message "== running darcs @_"; - system ("darcs", @_) == 0 - or $ignore_failure - or die "darcs failed: $?"; -} - -sub parsePackages { - my @repos; - my $lineNum; - - my ($repo_base, $checked_out_tree) = getrepo(); - - open IN, "< packages" or die "Can't open packages file"; - @repos = ; - close IN; - - @packages = (); - $lineNum = 0; - foreach (@repos) { - chomp; - $lineNum++; - if (/^([^# ]+) +([^ ]+) +([^ ]+) +([^ ]+) +([^ ]+)$/) { - my %line; - $line{"localpath"} = $1; - $line{"tag"} = $2; - $line{"remotepath"} = $3; - $line{"vcs"} = $4; - $line{"upstream"} = $5; - push @packages, \%line; - } - elsif (! /^(#.*)?$/) { - die "Bad content on line $lineNum of packages file: $_"; - } - } -} - -sub darcsall { - my $localpath; - my $remotepath; - my $path; - my $tag; - my @repos; - my $command = $_[0]; - my $line; - - my ($repo_base, $checked_out_tree) = getrepo(); - - for $line (@packages) { - $localpath = $$line{"localpath"}; - $tag = $$line{"tag"}; - $remotepath = $$line{"remotepath"}; - - if ($checked_out_tree) { - $path = "$repo_base/$localpath"; - } - else { - $path = "$repo_base/$remotepath"; - } - - if (-d "$localpath/_darcs") { - if ($want_remote_repo) { - if ($command =~ /^opt/) { - # Allows ./darcs-all optimize --relink - darcs (@_, "--repodir", $localpath, "--sibling=$path"); - } else { - darcs (@_, "--repodir", $localpath, $path); - } - } else { - darcs (@_, "--repodir", $localpath); - } - } - elsif ($tag eq "-") { - message "== Required repo $localpath is missing! Skipping"; - } - else { - message "== $localpath repo not present; skipping"; - } - } -} - -sub darcsget { - my $r_flags; - my $localpath; - my $remotepath; - my $path; - my $tag; - my @repos; - my $line; - - my ($repo_base, $checked_out_tree) = getrepo(); - - if (! grep /(?:--complete|--partial|--lazy)/, @_) { - warning("adding --partial, to override use --complete"); - $r_flags = [@_, "--partial"]; - } - else { - $r_flags = \@_; - } - - for $line (@packages) { - $localpath = $$line{"localpath"}; - $tag = $$line{"tag"}; - $remotepath = $$line{"remotepath"}; - - if ($checked_out_tree) { - $path = "$repo_base/$localpath"; - } - else { - $path = "$repo_base/$remotepath"; - } - - if ($tags{$tag} eq 1) { - if (-d $localpath) { - warning("$localpath already present; omitting"); - } - else { - darcs (@$r_flags, $path, $localpath); - } - } - } -} - -sub darcsupstreampull { - my $localpath; - my $upstream; - my $line; - - for $line (@packages) { - $localpath = $$line{"localpath"}; - $upstream = $$line{"upstream"}; - - if ($upstream ne "-") { - if (-d $localpath) { - darcs ("pull", @_, "--repodir", $localpath, $upstream); - } - } - } -} - -sub main { - if (! -d "compiler") { - die "error: darcs-all must be run from the top level of the ghc tree." - } - - $tags{"-"} = 1; - $tags{"dph"} = 1; - $tags{"nofib"} = 0; - $tags{"testsuite"} = 0; - $tags{"extra"} = 0; - - while ($#_ ne -1) { - my $arg = shift; - # We handle -q here as well as lower down as we need to skip over it - # if it comes before the darcs command - if ($arg eq "-q") { - $verbose = 1; - } - elsif ($arg eq "-s") { - $verbose = 0; - } - elsif ($arg eq "-r") { - $defaultrepo = shift; - } - elsif ($arg eq "-i") { - $ignore_failure = 1; - } - # --nofib tells get to also grab the nofib repo. - # It has no effect on the other commands. - elsif ($arg eq "--nofib") { - $tags{"nofib"} = 1; - } - elsif ($arg eq "--no-nofib") { - $tags{"nofib"} = 0; - } - # --testsuite tells get to also grab the testsuite repo. - # It has no effect on the other commands. - elsif ($arg eq "--testsuite") { - $tags{"testsuite"} = 1; - } - elsif ($arg eq "--no-testsuite") { - $tags{"testsuite"} = 0; - } - # --dph tells get to also grab the dph repo. - # It has no effect on the other commands. - elsif ($arg eq "--dph") { - $tags{"dph"} = 1; - } - elsif ($arg eq "--no-dph") { - $tags{"dph"} = 0; - } - # --extralibs tells get to also grab the extra repos. - # It has no effect on the other commands. - elsif ($arg eq "--extra") { - $tags{"extra"} = 1; - } - elsif ($arg eq "--no-extra") { - $tags{"extra"} = 0; - } - # Use --checked-out if the remote repos are a checked-out tree, - # rather than the master trees. - elsif ($arg eq "--checked-out") { - $checked_out_flag = 1; - } - else { - unshift @_, $arg; - if (grep /^-q$/, @_) { - $verbose = 1; - } - last; - } - } - - if ($#_ eq -1) { - die "What do you want to do?"; - } - my $command = $_[0]; - parsePackages; - if ($command eq "get") { - darcsget @_; - } - elsif ($command eq "upstreampull") { - shift; - darcsupstreampull @_; - } - else { - if ($command =~ /^(?:w|wh|wha|what|whats|whatsn|whatsne|whatsnew)$/) { - # Hack around whatsnew failing if there are no changes - $ignore_failure = 1; - } - if ($command =~ /^(pul|pus|sen|put|opt)/) { - $want_remote_repo = 1; - } - darcsall @_; - } -} - -END { - my $ec = $?; - - message "== Checking for old bytestring repo"; - if (-d "libraries/bytestring/_darcs") { - if ((system "darcs annotate --repodir libraries/bytestring --match 'hash 20080118173113-3fd76-d5b74c04372a297b585ebea4e16d524551ce5035' > /dev/null 2> /dev/null") == 0) { - print < /dev/null 2> /dev/null") == 0) { - print < we have ".depend-v-p-dyn.haskell" files +type Ways = [String] + +emptyBuildInfo :: Maybe Ways -> BuildInfo +emptyBuildInfo mWays = BuildInfo { + biThingVersionMap = [], + biThingHashMap = [], + biMaybeWays = mWays + } + +addThingMap :: ThingMap -> String -> String -> Maybe ThingMap +addThingMap mapping thing str + = case lookup thing mapping of + Just str' -> + if str == str' + then Just mapping + else Nothing + Nothing -> + Just ((thing, str) : mapping) + +getMaybeWays :: BIMonad (Maybe Ways) +getMaybeWays = do st <- get + return $ biMaybeWays st + +haveThingVersion :: String -> String -> BIMonad () +haveThingVersion thing thingVersion + = do st <- get + case addThingMap (biThingVersionMap st) thing thingVersion of + Nothing -> fail "Inconsistent version" + Just tvm -> put $ st { biThingVersionMap = tvm } + +haveThingHash :: String -> String -> BIMonad () +haveThingHash thing thingHash + = do st <- get + case addThingMap (biThingHashMap st) thing thingHash of + Nothing -> fail "Inconsistent hash" + Just thm -> put $ st { biThingHashMap = thm } + diff --git a/distrib/compare/Change.hs b/distrib/compare/Change.hs new file mode 100644 index 0000000..a89517c --- /dev/null +++ b/distrib/compare/Change.hs @@ -0,0 +1,43 @@ + +module Change where + +data FileChange = First Change + | Second Change + | Change Change + +data Change = DuplicateFile FilePath + | ExtraFile FilePath + | ExtraWay String + | ExtraThing String + | ThingVersionChanged String String String + | PermissionsChanged FilePath FilePath String String + | FileSizeChanged FilePath FilePath Integer Integer + +isSizeChange :: FileChange -> Bool +isSizeChange (Change (FileSizeChanged {})) = True +isSizeChange _ = False + +pprFileChange :: FileChange -> String +pprFileChange (First p) = "First " ++ pprChange p +pprFileChange (Second p) = "Second " ++ pprChange p +pprFileChange (Change p) = "Change " ++ pprChange p + +pprChange :: Change -> String +pprChange (DuplicateFile fp) = "Duplicate file: " ++ show fp +pprChange (ExtraFile fp) = "Extra file: " ++ show fp +pprChange (ExtraWay w) = "Extra way: " ++ show w +pprChange (ExtraThing t) = "Extra thing: " ++ show t +pprChange (ThingVersionChanged t v1 v2) + = "Version changed for " ++ show t ++ ":\n" + ++ " " ++ v1 ++ " -> " ++ v2 +pprChange (PermissionsChanged fp1 fp2 p1 p2) + = "Permissions changed:\n" + ++ " " ++ show fp1 + ++ " " ++ show fp2 + ++ " " ++ p1 ++ " -> " ++ p2 +pprChange (FileSizeChanged fp1 fp2 s1 s2) + = "Size changed:\n" + ++ " " ++ show fp1 ++ "\n" + ++ " " ++ show fp2 ++ "\n" + ++ " " ++ show s1 ++ " -> " ++ show s2 + diff --git a/distrib/compare/FilenameDescr.hs b/distrib/compare/FilenameDescr.hs new file mode 100644 index 0000000..d21745c --- /dev/null +++ b/distrib/compare/FilenameDescr.hs @@ -0,0 +1,56 @@ + +module FilenameDescr where + +import Data.Either +import Data.List + +import BuildInfo +import Utils +import Tar + +-- We can't just compare plain filenames, because versions numbers of GHC +-- and the libaries will vary. So we use FilenameDescr instead, which +-- abstracts out the version numbers. +type FilenameDescr = [FilenameDescrBit] +data FilenameDescrBit = VersionOf String + | HashOf String + | FP String + | Ways + deriving (Show, Eq, Ord) + +normalise :: FilenameDescr -> FilenameDescr +normalise [] = [] +normalise [x] = [x] +normalise (FP x1 : FP x2 : xs) = normalise (FP (x1 ++ x2) : xs) +normalise (x : xs) = x : normalise xs + +-- Sanity check that the FilenameDescr matches the filename in the tar line +checkContent :: BuildInfo -> (FilenameDescr, TarLine) -> Errors +checkContent buildInfo (fd, tl) + = let fn = tlFileName tl + in case flattenFilenameDescr buildInfo fd of + Right fn' -> + if fn' == fn + then [] + else ["checkContent: Can't happen: filename mismatch: " ++ show fn] + Left errs -> + errs + +flattenFilenameDescr :: BuildInfo -> FilenameDescr + -> Either Errors FilePath +flattenFilenameDescr buildInfo fd = case partitionEithers (map f fd) of + ([], strs) -> Right (concat strs) + (errs, _) -> Left (concat errs) + where f (FP fp) = Right fp + f (VersionOf thing) + = case lookup thing (biThingVersionMap buildInfo) of + Just v -> Right v + Nothing -> Left ["Can't happen: thing has no version in mapping"] + f (HashOf thing) + = case lookup thing (biThingHashMap buildInfo) of + Just v -> Right v + Nothing -> Left ["Can't happen: thing has no hash in mapping"] + f Ways = case biMaybeWays buildInfo of + Just ways -> Right $ intercalate "-" ways + Nothing -> Left ["Can't happen: No ways, but Ways is used"] + diff --git a/distrib/compare/Makefile b/distrib/compare/Makefile new file mode 100644 index 0000000..f65c041 --- /dev/null +++ b/distrib/compare/Makefile @@ -0,0 +1,12 @@ + +GHC = ghc + +compare: *.hs + "$(GHC)" -O --make -Wall -Werror $@ + +.PHONY: clean +clean: + rm -f *.o + rm -f *.hi + rm -f compare compare.exe + diff --git a/distrib/compare/Tar.hs b/distrib/compare/Tar.hs new file mode 100644 index 0000000..50b238a --- /dev/null +++ b/distrib/compare/Tar.hs @@ -0,0 +1,58 @@ + +module Tar where + +import Data.Either +import Data.List +import System.Exit +import System.Process + +import Utils + +readTarLines :: FilePath -> IO [TarLine] +readTarLines fp + = do (ec, out, err) <- readProcessWithExitCode "tar" ["-jtvf", fp] "" + case (ec, err) of + (ExitSuccess, []) -> + case parseTarLines fp out of + Left errs -> die errs + Right tls -> return tls + _ -> + die ["Failed running tar -jtvf " ++ show fp, + "Exit code: " ++ show ec, + "Stderr: " ++ show err] + +parseTarLines :: FilePath -> String -> Either Errors [TarLine] +parseTarLines fp xs + = case partitionEithers (zipWith (parseTarLine fp) [1..] (lines xs)) of + ([], tls) -> Right tls + (errss, _) -> Left (intercalate [""] errss) + +data TarLine = TarLine { + tlPermissions :: String, + tlUser :: String, + tlGroup :: String, + tlSize :: Integer, + tlDateTime :: String, + tlFileName :: FilePath + } + +parseTarLine :: FilePath -> Int -> String -> Either Errors TarLine +parseTarLine fp line str + = case re "^([^ ]+) ([^ ]+)/([^ ]+) +([0-9]+) ([^ ]+ [^ ]+) ([^ ]+)$" + str of + Just [perms, user, grp, sizeStr, dateTime, filename] -> + case maybeRead sizeStr of + Just size -> + Right $ TarLine { + tlPermissions = perms, + tlUser = user, + tlGroup = grp, + tlSize = size, + tlDateTime = dateTime, + tlFileName = filename + } + _ -> error "Can't happen: Can't parse size" + _ -> + Left ["In " ++ show fp ++ ", at line " ++ show line, + "Tar line doesn't parse: " ++ show str] + diff --git a/distrib/compare/Utils.hs b/distrib/compare/Utils.hs new file mode 100644 index 0000000..e2da6b5 --- /dev/null +++ b/distrib/compare/Utils.hs @@ -0,0 +1,40 @@ + +module Utils where + +import Data.Function +import Data.List +import System.Exit +import System.IO +import Text.Regex.Posix + +die :: Errors -> IO a +die errs = do mapM_ (hPutStrLn stderr) errs + exitFailure + +dieOnErrors :: Either Errors a -> IO a +dieOnErrors (Left errs) = die errs +dieOnErrors (Right x) = return x + +type Errors = [String] + +maybeRead :: Read a => String -> Maybe a +maybeRead str = case reads str of + [(x, "")] -> Just x + _ -> Nothing + +re :: String -> String -> Maybe [String] +re r str = case matchM r' str :: Maybe (String, String, String, [String]) of + Just (_, _, _, ms) -> Just ms + Nothing -> Nothing + where r' = makeRegex r :: Regex + +unSepList :: Eq a => a -> [a] -> [[a]] +unSepList x xs = case break (x ==) xs of + (this, _ : xs') -> + this : unSepList x xs' + (this, []) -> + [this] + +sortByFst :: Ord a => [(a, b)] -> [(a, b)] +sortByFst = sortBy (compare `on` fst) + diff --git a/distrib/compare/compare.hs b/distrib/compare/compare.hs new file mode 100644 index 0000000..0e0e9f8 --- /dev/null +++ b/distrib/compare/compare.hs @@ -0,0 +1,269 @@ +{-# LANGUAGE PatternGuards #-} + +module Main (main) where + +import Control.Monad.State +import Data.List +import System.Environment + +import BuildInfo +import FilenameDescr +import Change +import Utils +import Tar + +-- TODO: +-- * Check installed trees too +-- * Check hashbangs + +-- Only size changes > sizeAbs are considered an issue +sizeAbs :: Integer +sizeAbs = 1000 + +-- Only a size change of sizePercentage% or more is considered an issue +sizePercentage :: Integer +sizePercentage = 150 + +main :: IO () +main = do args <- getArgs + case args of + [bd1, bd2] -> doit False bd1 bd2 + ["--ignore-size-changes", bd1, bd2] -> doit True bd1 bd2 + _ -> die ["Bad args. Need 2 bindists."] + +doit :: Bool -> FilePath -> FilePath -> IO () +doit ignoreSizeChanges bd1 bd2 + = do tls1 <- readTarLines bd1 + tls2 <- readTarLines bd2 + let mWays1 = findWays tls1 + mWays2 = findWays tls2 + wayDifferences <- case (mWays1, mWays2) of + (Nothing, Nothing) -> + return [] + (Just ways1, Just ways2) -> + return $ diffWays ways1 ways2 + _ -> + die ["One input has ways, but the other doesn't"] + (content1, tvm1) <- dieOnErrors $ mkContents mWays1 tls1 + (content2, tvm2) <- dieOnErrors $ mkContents mWays2 tls2 + let sortedContent1 = sortByFst content1 + sortedContent2 = sortByFst content2 + (nubProbs1, nubbedContent1) = nubContents sortedContent1 + (nubProbs2, nubbedContent2) = nubContents sortedContent2 + differences = compareContent mWays1 nubbedContent1 + mWays2 nubbedContent2 + allProbs = map First nubProbs1 ++ map Second nubProbs2 + ++ diffThingVersionMap tvm1 tvm2 + ++ wayDifferences + ++ differences + wantedProbs = if ignoreSizeChanges + then filter (not . isSizeChange) allProbs + else allProbs + mapM_ (putStrLn . pprFileChange) wantedProbs + +-- *nix bindists have ways. +-- Windows "bindists", install trees, and testsuites don't. +findWays :: [TarLine] -> Maybe Ways +findWays tls = msum $ map f tls + where f tl = case re regex (tlFileName tl) of + Just [dashedWays] -> Just (unSepList '-' dashedWays) + _ -> Nothing + regex = "/libraries/base/dist-install/build/\\.depend-(.*)\\.haskell" + +diffWays :: Ways -> Ways -> [FileChange] +diffWays ws1 ws2 = f (sort ws1) (sort ws2) + where f [] [] = [] + f xs [] = map (First . ExtraWay) xs + f [] ys = map (Second . ExtraWay) ys + f xs@(x : xs') ys@(y : ys') + = case x `compare` y of + LT -> First (ExtraWay x) : f xs' ys + GT -> Second (ExtraWay y) : f xs ys' + EQ -> f xs' ys' + +diffThingVersionMap :: ThingVersionMap -> ThingVersionMap -> [FileChange] +diffThingVersionMap tvm1 tvm2 = f (sortByFst tvm1) (sortByFst tvm2) + where f [] [] = [] + f xs [] = map (First . ExtraThing . fst) xs + f [] ys = map (Second . ExtraThing . fst) ys + f xs@((xt, xv) : xs') ys@((yt, yv) : ys') + = case xt `compare` yt of + LT -> First (ExtraThing xt) : f xs' ys + GT -> Second (ExtraThing yt) : f xs ys' + EQ -> let this = if xv == yv + then [] + else [Change (ThingVersionChanged xt xv yv)] + in this ++ f xs' ys' + +mkContents :: Maybe Ways -> [TarLine] + -> Either Errors ([(FilenameDescr, TarLine)], ThingVersionMap) +mkContents mWays tls + = case runStateT (mapM f tls) (emptyBuildInfo mWays) of + Nothing -> Left ["Can't happen: mkContents: Nothing"] + Just (xs, finalBuildInfo) -> + case concat $ map (checkContent finalBuildInfo) xs of + [] -> Right (xs, biThingVersionMap finalBuildInfo) + errs -> Left errs + where f tl = do fnd <- mkFilePathDescr (tlFileName tl) + return (fnd, tl) + +nubContents :: [(FilenameDescr, TarLine)] + -> ([Change], [(FilenameDescr, TarLine)]) +nubContents [] = ([], []) +nubContents [x] = ([], [x]) +nubContents (x1@(fd1, tl1) : xs@((fd2, _) : _)) + | fd1 == fd2 = (DuplicateFile (tlFileName tl1) : ps, xs') + | otherwise = (ps, x1 : xs') + where (ps, xs') = nubContents xs + +mkFilePathDescr :: FilePath -> BIMonad FilenameDescr +mkFilePathDescr fp + | Just [ghcVersion, _, middle, filename] + <- re ("^ghc-" ++ versionRE ++ "(/.*)?/([^/]*)$") fp + = do haveThingVersion "ghc" ghcVersion + middle' <- mkMiddleDescr middle + filename' <- mkFileNameDescr filename + let fd = FP "ghc-" : VersionOf "ghc" : middle' ++ FP "/" : filename' + return $ normalise fd + | otherwise = return [FP fp] + +mkMiddleDescr :: FilePath -> BIMonad FilenameDescr +mkMiddleDescr middle + -- haddock docs in a Windows installed tree + | Just [thing, thingVersion, _, src] + <- re ("^/doc/html/libraries/([^/]*)-" ++ versionRE ++ "(/src)?$") + middle + = do haveThingVersion thing thingVersion + return [FP "/doc/html/libraries/", + FP thing, FP "-", VersionOf thing, FP src] + `mplus` unchanged + -- libraries in a Windows installed tree + | Just [thing, thingVersion, _, rest] + <- re ("^/lib/([^/]*)-" ++ versionRE ++ "(/.*)?$") + middle + = do haveThingVersion thing thingVersion + return [FP "/lib/", FP thing, FP "-", VersionOf thing, FP rest] + `mplus` unchanged + -- Windows in-tree gcc + | Just [prefix, _, _, gccVersion, _, rest] + <- re ("^(/mingw/(lib(exec)?/gcc/mingw32/|share/gcc-))" ++ versionRE ++ "(/.*)?$") + middle + = do haveThingVersion "gcc" gccVersion + return [FP prefix, VersionOf "gcc", FP rest] + `mplus` unchanged + | otherwise = unchanged + where unchanged = return [FP middle] + +mkFileNameDescr :: FilePath -> BIMonad FilenameDescr +mkFileNameDescr filename + | Just [prog, ghcVersion, _, exe] + <- re ("^(ghc|ghci|ghcii|haddock)-" ++ versionRE ++ "(\\.exe|\\.sh|)$") + filename + = do haveThingVersion "ghc" ghcVersion + return [FP prog, FP "-", VersionOf "ghc", FP exe] + `mplus` unchanged + | Just [thing, thingVersion, _, ghcVersion, _, soDll] + <- re ("^libHS(.*)-" ++ versionRE ++ "-ghc" ++ versionRE ++ "\\.(so|dll|dylib)$") + filename + = do haveThingVersion "ghc" ghcVersion + haveThingVersion thing thingVersion + return [FP "libHS", FP thing, FP "-", VersionOf thing, + FP "-ghc", VersionOf "ghc", FP ".", FP soDll] + `mplus` unchanged + | Just [way, thingVersion, _, soDll] + <- re ("^libHSrts(_.*)?-ghc" ++ versionRE ++ "\\.(so|dll|dylib)$") + filename + = do haveThingVersion "ghc" thingVersion + return [FP "libHSrts", FP way, FP "-ghc", VersionOf "ghc", + FP ".", FP soDll] + `mplus` unchanged + | Just [thingVersion, _, soDll] + <- re ("^libHSffi-ghc" ++ versionRE ++ "\\.(so|dll|dylib)$") + filename + = do haveThingVersion "ghc" thingVersion + return [FP "libHSffi-ghc", VersionOf "ghc", FP ".", FP soDll] + `mplus` unchanged + | Just [thing, thingVersion, _, way] + <- re ("^libHS(.*)-" ++ versionRE ++ "(_.*)?\\.a$") + filename + = do haveThingVersion thing thingVersion + return [FP "libHS", FP thing, FP "-", VersionOf thing, + FP way, FP ".a"] + `mplus` unchanged + | Just [thing, thingVersion, _] + <- re ("^HS(.*)-" ++ versionRE ++ "\\.o$") + filename + = do haveThingVersion thing thingVersion + return [FP "HS", FP thing, FP "-", VersionOf thing, FP ".o"] + `mplus` unchanged + | Just [thing, thingVersion, _, thingHash] + <- re ("^(.*)-" ++ versionRE ++ "-([0-9a-f]{32})\\.conf$") + filename + = do haveThingVersion thing thingVersion + haveThingHash thing thingHash + return [FP thing, FP "-", VersionOf thing, FP "-", HashOf thing, + FP ".conf"] + `mplus` unchanged + | Just [thingVersion, _] + <- re ("^mingw32-gcc-" ++ versionRE ++ "\\.exe$") + filename + = do haveThingVersion "gcc" thingVersion + return [FP "mingw32-gcc-", VersionOf "gcc", FP ".exe"] + `mplus` unchanged + | Just [dashedWays, depType] + <- re "^\\.depend-(.*)\\.(haskell|c_asm)" + filename + = do mWays <- getMaybeWays + if Just (unSepList '-' dashedWays) == mWays + then return [FP ".depend-", Ways, FP ".", FP depType] + else unchanged + | otherwise = unchanged + where unchanged = return [FP filename] + +compareContent :: Maybe Ways -> [(FilenameDescr, TarLine)] + -> Maybe Ways -> [(FilenameDescr, TarLine)] + -> [FileChange] +compareContent mWays1 xs1all mWays2 xs2all + = f xs1all xs2all + where f [] [] = [] + f xs [] = concatMap (mkExtraFile mWays1 mWays2 First . tlFileName . snd) xs + f [] ys = concatMap (mkExtraFile mWays2 mWays1 Second . tlFileName . snd) ys + f xs1@((fd1, tl1) : xs1') xs2@((fd2, tl2) : xs2') + = case fd1 `compare` fd2 of + EQ -> map Change (compareTarLine tl1 tl2) + ++ f xs1' xs2' + LT -> mkExtraFile mWays1 mWays2 First (tlFileName tl1) + ++ f xs1' xs2 + GT -> mkExtraFile mWays2 mWays1 Second (tlFileName tl2) + ++ f xs1 xs2' + mkExtraFile mWaysMe mWaysThem mkFileChange filename + = case (findFileWay filename, mWaysMe, mWaysThem) of + (Just way, Just waysMe, Just waysThem) + | (way `elem` waysMe) && not (way `elem` waysThem) -> [] + _ -> [mkFileChange (ExtraFile filename)] + +findFileWay :: FilePath -> Maybe String +findFileWay fp + | Just [way] <- re "\\.([a-z_]+)_hi$" fp + = Just way + | Just [_, _, way] <- re ("libHS.*-" ++ versionRE ++ "_([a-z_]+).a$") fp + = Just way + | otherwise = Nothing + +compareTarLine :: TarLine -> TarLine -> [Change] +compareTarLine tl1 tl2 + = [ PermissionsChanged fn1 fn2 perms1 perms2 | perms1 /= perms2 ] + ++ [ FileSizeChanged fn1 fn2 size1 size2 | sizeChanged ] + where fn1 = tlFileName tl1 + fn2 = tlFileName tl2 + perms1 = tlPermissions tl1 + perms2 = tlPermissions tl2 + size1 = tlSize tl1 + size2 = tlSize tl2 + sizeChanged = abs (size1 - size2) > sizeAbs + && (((100 * size1) `div` size2) > sizePercentage || + ((100 * size2) `div` size1) > sizePercentage) + +versionRE :: String +versionRE = "([0-9]+(\\.[0-9]+)*)" + diff --git a/distrib/mkDocs/mkDocs b/distrib/mkDocs/mkDocs new file mode 100644 index 0000000..07faa3d --- /dev/null +++ b/distrib/mkDocs/mkDocs @@ -0,0 +1,34 @@ +#!/bin/sh + +set -e + +die () { + echo "$1" >&2 + exit 1 +} + +[ "$#" -eq 2 ] || die "Bad args. Usage: $0 " + +LINUX_BINDIST=`realpath "$1"` +WINDOWS_BINDIST=`realpath "$2"` + +mkdir docs +cd docs +tar -jxf "$LINUX_BINDIST" +mv ghc* linux +tar -jxf "$WINDOWS_BINDIST" +mv ghc* windows +cd linux +./configure --prefix=`pwd`/inst +make install +cd inst/share/doc/ghc/html/libraries +mv ../../../../../../../windows/doc/html/libraries/Win32-* . +sh gen_contents_index +cd .. +for i in Cabal haddock libraries users_guide +do + tar -jcf ../../../../../../$i.html.tar.bz2 $i +done +cd .. +mv *.pdf *.ps ../../../../.. + diff --git a/docs/users_guide/debugging.xml b/docs/users_guide/debugging.xml index 4db79af..6fc1413 100644 --- a/docs/users_guide/debugging.xml +++ b/docs/users_guide/debugging.xml @@ -437,6 +437,17 @@ + + + + + Print a one-line summary of the size of the Core program + at the end of the optimisation pipeline. + + + + + diff --git a/docs/users_guide/ffi-chap.xml b/docs/users_guide/ffi-chap.xml index 47c0f01..97a2378 100644 --- a/docs/users_guide/ffi-chap.xml +++ b/docs/users_guide/ffi-chap.xml @@ -245,18 +245,11 @@ extern HsInt foo(HsInt a0); #include "foo_stub.h" #endif -#ifdef __GLASGOW_HASKELL__ -extern void __stginit_Foo ( void ); -#endif - int main(int argc, char *argv[]) { int i; hs_init(&argc, &argv); -#ifdef __GLASGOW_HASKELL__ - hs_add_root(__stginit_Foo); -#endif for (i = 0; i < 5; i++) { printf("%d\n", foo(2500)); @@ -283,26 +276,6 @@ int main(int argc, char *argv[]) (i.e. those arguments between +RTS...-RTS). - Next, we call - hs_add_rooths_add_root - , a GHC-specific interface which is required to - initialise the Haskell modules in the program. The argument - to hs_add_root should be the name of the - initialization function for the "root" module in your program - - in other words, the module which directly or indirectly - imports all the other Haskell modules in the program. In a - standalone Haskell program the root module is normally - Main, but when you are using Haskell code - from a library it may not be. If your program has multiple - root modules, then you can call - hs_add_root multiple times, one for each - root. The name of the initialization function for module - M is - __stginit_M, and - it may be declared as an external function symbol as in the - code above. Note that the symbol name should be transformed - according to the Z-encoding: - @@ -380,9 +353,6 @@ int main(int argc, char *argv[]) // Initialize Haskell runtime hs_init(&argc, &argv); - // Tell Haskell about all root modules - hs_add_root(__stginit_Foo); - // do any other initialization here and // return false if there was a problem return HS_BOOL_TRUE; @@ -394,7 +364,7 @@ int main(int argc, char *argv[]) The initialisation routine, mylib_init, calls - hs_init() and hs_add_root() as + hs_init() as normal to initialise the Haskell runtime, and the corresponding deinitialisation function mylib_end() calls hs_exit() to shut down the runtime. @@ -599,8 +569,7 @@ int main(int argc, char *argv[]) invoke foreign exported functions from multiple OS threads concurrently. The runtime system must be initialised as usual by - calling hs_init() - and hs_add_root, and these calls must + calling hs_init(), and this call must complete before invoking any foreign exported functions. diff --git a/docs/users_guide/flags.xml b/docs/users_guide/flags.xml index 3920c8e..e0940ae 100644 --- a/docs/users_guide/flags.xml +++ b/docs/users_guide/flags.xml @@ -325,13 +325,6 @@ - - or - - retain intermediate .raw_s files - dynamic - - - - retain all intermediate temporary files dynamic @@ -567,7 +560,7 @@ P Compile to be part of package P - dynamic + static - @@ -1551,6 +1544,13 @@ phase n + + Turn off the coercion optimiser + static + - + + + Turn on eager blackholing dynamic @@ -1743,13 +1743,7 @@ phase n Use the native code generator dynamic - -fvia-C - - - - Compile via C - dynamic - -fasm + -fllvm @@ -1998,12 +1992,6 @@ phase n - cmd - Use cmd as the mangler - dynamic - - - - cmd Use cmd as the splitter dynamic @@ -2250,6 +2238,13 @@ phase n - + + Print a one-line summary of the size of the Core program + at the end of the optimisation pipeline + dynamic + - + + Dump output from CPR analysis dynamic @@ -2587,12 +2582,6 @@ phase n - - - Turn off assembly mangling (use instead) - dynamic - - - - Turn off the GHCi sandbox. Means computations are run in teh main thread, rather than a forked thread. dynamic diff --git a/docs/users_guide/glasgow_exts.xml b/docs/users_guide/glasgow_exts.xml index f7b66d9..9ea3332 100644 --- a/docs/users_guide/glasgow_exts.xml +++ b/docs/users_guide/glasgow_exts.xml @@ -5726,9 +5726,6 @@ for rank-2 types. Impredicative polymorphism -NOTE: the impredicative-polymorphism feature is deprecated in GHC 6.12, and -will be removed or replaced in GHC 6.14. - GHC supports impredicative polymorphism, enabled with . This means @@ -5851,7 +5848,7 @@ signature is explicit. For example: g (x:xs) = xs ++ [ x :: a ] This program will be rejected, because "a" does not scope -over the definition of "f", so "x::a" +over the definition of "g", so "x::a" means "x::forall a. a" by Haskell's usual implicit quantification rules. @@ -5887,7 +5884,7 @@ type variables, in the annotated expression. For example: f = runST ( (op >>= \(x :: STRef s Int) -> g x) :: forall s. ST s Bool ) -Here, the type signature forall a. ST s Bool brings the +Here, the type signature forall s. ST s Bool brings the type variable s into scope, in the annotated expression (op >>= \(x :: STRef s Int) -> g x). diff --git a/docs/users_guide/packages.xml b/docs/users_guide/packages.xml index 5915046..86df594 100644 --- a/docs/users_guide/packages.xml +++ b/docs/users_guide/packages.xml @@ -279,7 +279,6 @@ exposed-modules: Network.BSD, /usr/bin/ld: Undefined symbols: _ZCMain_main_closure -___stginit_ZCMain diff --git a/docs/users_guide/phases.xml b/docs/users_guide/phases.xml index b48ebe8..dfa10a5 100644 --- a/docs/users_guide/phases.xml +++ b/docs/users_guide/phases.xml @@ -71,17 +71,6 @@ - cmd - - - - Use cmd as the - mangler. - - - - - cmd @@ -543,21 +532,8 @@ $ cat foo.hspp Use GHC's native code generator rather than - compiling via C. This will compile faster (up to twice as - fast), but may produce code that is slightly slower than - compiling via C. is the default. - - - - - - - - - - Compile via C instead of using the native code - generator. This is the default on architectures for which GHC - doesn't have a native code generator. + compiling via LLVM. + is the default. @@ -569,8 +545,8 @@ $ cat foo.hspp Compile via LLVM instead of using the native code generator. This will generally take slightly longer than the - native code generator to compile but quicker than compiling - via C. Produced code is generally the same speed or faster + native code generator to compile. + Produced code is generally the same speed or faster than the other two code generators. Compiling via LLVM requires LLVM version 2.7 or later to be on the path. diff --git a/docs/users_guide/runtime_control.xml b/docs/users_guide/runtime_control.xml index 045ea07..be341b2 100644 --- a/docs/users_guide/runtime_control.xml +++ b/docs/users_guide/runtime_control.xml @@ -1,5 +1,5 @@ -
+ Running a compiled program runtime control of Haskell programs @@ -21,7 +21,7 @@ options themselves. -
+ Setting RTS options RTS options, setting @@ -53,7 +53,7 @@ -
+ Setting RTS options on the command line @@ -127,9 +127,9 @@ $ ./prog -f +RTS -H32m -S -RTS -h foo bar +RTS -M128m -RTS to the command line. -
+ -
+ Setting RTS options at compile time @@ -139,9 +139,9 @@ $ ./prog -f +RTS -H32m -S -RTS -h foo bar set -H128m -K64m, link with -with-rtsopts="-H128m -K64m". -
+ -
+ Setting RTS options with the <envar>GHCRTS</envar> environment variable @@ -178,9 +178,9 @@ $ ./prog -f +RTS -H32m -S -RTS -h foo bar a crawl until the OS decides to kill the process (and you hope it kills the right one). -
+ -
+ “Hooks” to change RTS behaviour hooksRTS @@ -259,11 +259,11 @@ char *ghc_rts_opts = "-H128m -K1m"; versions in the file ghc/compiler/parser/hschooks.c in a GHC source tree. -
+ -
+ -
+ Miscellaneous RTS options @@ -347,9 +347,9 @@ char *ghc_rts_opts = "-H128m -K1m"; -
+ -
+ RTS options to control the garbage collector garbage collectoroptions @@ -1032,17 +1032,17 @@ char *ghc_rts_opts = "-H128m -K1m"; -
+ -
+ RTS options for concurrency and parallelism The RTS options related to concurrency are described in , and those for parallelism in . -
+ -
+ RTS options for profiling Most profiling runtime options are only available when you @@ -1073,9 +1073,9 @@ char *ghc_rts_opts = "-H128m -K1m"; -
+ -
+ Tracing tracing @@ -1166,9 +1166,9 @@ char *ghc_rts_opts = "-H128m -K1m"; the binary eventlog file by using the option. -
+ -
+ RTS options for hackers, debuggers, and over-interested souls @@ -1301,9 +1301,9 @@ char *ghc_rts_opts = "-H128m -K1m"; -
+ -
+ Getting information about the RTS RTS @@ -1443,8 +1443,8 @@ $ ./a.out +RTS --info -
-
+ +