diff options
| author | Dimitrios Vytiniotis <dimitris@microsoft.com> | 2012-03-28 10:56:29 +0200 |
|---|---|---|
| committer | Dimitrios Vytiniotis <dimitris@microsoft.com> | 2012-03-28 10:56:29 +0200 |
| commit | b4b7647fedf0feab41d417c4e980bd08445ce559 (patch) | |
| tree | 004f4e966e1a1e3a5457b11c57cb7f9abf43a108 | |
| parent | cc2d2e1d44405630fb34311dc3f5e42eadc5c6b1 (diff) | |
| parent | 9606231dd203163c8ca839b3f58c6e40a3805fa8 (diff) | |
| download | haskell-b4b7647fedf0feab41d417c4e980bd08445ce559.tar.gz | |
Merge branch 'master' of http://darcs.haskell.org/ghc into ghc-new-flavor
134 files changed, 6051 insertions, 5271 deletions
diff --git a/.authorspellings b/.authorspellings deleted file mode 100644 index dcbc16361d..0000000000 --- a/.authorspellings +++ /dev/null @@ -1,29 +0,0 @@ -Simon Marlow <marlowsd@gmail.com>, simonmar, simonmar@microsoft.com, simonm -Ross Paterson <ross@soi.city.ac.uk>, ross -Sven Panne <sven.panne@aedion.de>, panne -Malcolm Wallace <Malcolm.Wallace@cs.york.ac.uk>, malcolm -Simon Peyton Jones <simonpj@microsoft.com>, simonpj -Don Stewart <dons@galois.com>, dons -Tim Harris <tharris@microsoft.com>, tharris -Lennart Augustsson <lennart@augustsson.net>, lennart.augustsson@credit-suisse.com -Duncan Coutts <duncan@haskell.org>, duncan.coutts@worc.ox.ac.uk, duncan@well-typed.com -Ben Lippmeier <benl@ouroborus.net>, benl@cse.unsw.edu.au, Ben.Lippmeier@anu.edu.au, Ben.Lippmeier.anu.edu.au -Manuel M T Chakravarty <chak@cse.unsw.edu.au>, chak -Jose Pedro Magalhaes <jpm@cs.uu.nl>, jpm@cs.uu.nl -Sigbjorn Finne <sof@galois.com>, sof -Wolfgang Thaller <wolfgang.thaller@gmx.net>, wolfgang -Julian Seward <jseward@acm.org>, sewardj -Ian Lynagh <igloo@earth.li>, igloo -Roman Leshchinskiy <rl@cse.unsw.edu.au>, rl@cse.unsw.edu.au -John Dias <dias@cs.tufts.edu>, dias@eecs.tufts.edu, dias@eecs.harvard.edu -Norman Ramsey <nr@eecs.harvard.edu>, nr@eecs.harvard.edu -Andy Gill <andygill@ku.edu>, andy -Will Partain <partain@dcs.gla.ac.uk>, partain -Don Syme <dsyme@microsoft.com>, dsyme -Pepe Iborra <mnislaih@gmail.com>, pepe -Neil Mitchell <ndmitchell@gmail.com>, Neil Mitchell -Gabriele Keller <keller@cse.unsw.edu.au>, keller -Daan Leijen <daan@microsoft.com>, daan -Audrey Tang <audreyt@audreyt.org>, audreyt@audreyt.org -Hans-Wolfgang Loidl <hwloidl@macs.hw.ac.uk>, hwloidl -Bernie Pope <bjpop@csse.unimelb.edu.au>, bjpop@csse.unimelb.edu.au diff --git a/.darcs-boring b/.darcs-boring deleted file mode 100644 index a1a64456b8..0000000000 --- a/.darcs-boring +++ /dev/null @@ -1,256 +0,0 @@ -#Top-level dirs: -^alex/ -^common-rts/ -^CONTRIB/ -^dll/ -^greencard/ -^green-card/ -^haddock/ -^haggis/ -^happy/ -^hdirect/ -^hood/ -^hslibs/ -^hws/ -^hx/ -^literate/ -^mhms/ -^mkworld/ -^nofib(/|$) -^lib/ -^misc/ -^mkworld/ -^runtime/ -^testsuite(/|$) -# bindists -^ghc- -^bin-manifest- -#Packages: -^libraries/Cabal(/|$) -^libraries/ALUT(/|$) -^libraries/GLUT(/|$) -^libraries/HGL(/|$) -^libraries/HUnit(/|$) -^libraries/HaXml(/|$) -^libraries/Japi(/|$) -^libraries/OpenAL(/|$) -^libraries/OpenGL(/|$) -^libraries/QuickCheck(/|$) -^libraries/Win32(/|$) -^libraries/X11(/|$) -^libraries/array(/|$) -^libraries/arrows(/|$) -^libraries/base(/|$) -^libraries/base3-compat(/|$) -^libraries/binary(/|$) -^libraries/bytestring(/|$) -^libraries/cgi(/|$) -^libraries/concurrent(/|$) -^libraries/containers(/|$) -^libraries/directory(/|$) -^libraries/editline(/|$) -^libraries/fgl(/|$) -^libraries/filepath(/|$) -^libraries/getopt(/|$) -^libraries/ghc-prim(/|$) -^libraries/haskell-src(/|$) -^libraries/haskell98(/|$) -^libraries/hpc(/|$) -^libraries/html(/|$) -^libraries/integer-.*(/|$) -^libraries/old-locale(/|$) -^libraries/old-time(/|$) -^libraries/monads(/|$) -^libraries/mtl(/|$) -^libraries/ndp(/|$) -^libraries/network(/|$) -^libraries/packedstring(/|$) -^libraries/parsec(/|$) -^libraries/parallel(/|$) -^libraries/pretty(/|$) -^libraries/process(/|$) -^libraries/random(/|$) -^libraries/readline(/|$) -^libraries/regex-base(/|$) -^libraries/regex-compat(/|$) -^libraries/regex-posix(/|$) -^libraries/st(/|$) -^libraries/stm(/|$) -^libraries/syb(/|$) -^libraries/template-haskell(/|$) -^libraries/time(/|$) -^libraries/timeout(/|$) -^libraries/unique(/|$) -^libraries/unix(/|$) -^libraries/xhtml(/|$) -^libraries/dph(/|$) -^libraries/utf8-string(/|$) -^libraries/terminfo(/|$) -^libraries/haskeline(/|$) -^libraries/extensible-exceptions(/|$) -# Other library bits that get generated: -^libraries/bootstrapping/ -^libraries/stamp/ -^libraries/ifBuildable(/|$) -^libraries/installPackage(/|$) -^libraries/index.html -^libraries/doc-index.*\.html -^libraries/haddock-util.js -^libraries/haddock.css -^libraries/haskell_icon.gif -^libraries/minus.gif -^libraries/plus.gif -^libraries/libraries.txt -# It's often useful to have somewhere in the build tree to install to -^inst(/|$) -# Boring file regexps: -\.hi$ -\.hi-boot$ -\.o-boot$ -\.p_o$ -\.t_o$ -\.debug_o$ -\.thr_o$ -\.thr_p_o$ -\.thr_debug_o$ -\.o$ -\.a$ -\.o\.cmd$ -# *.ko files aren't boring by default because they might -# be Korean translations rather than kernel modules. -# \.ko$ -\.ko\.cmd$ -\.mod\.c$ -(^|/)\.tmp_versions($|/) -(^|/)CVS($|/) -(^|/)RCS($|/) -~$ -#(^|/)\.[^/] -(^|/)_darcs($|/) -\.bak$ -\.BAK$ -\.orig$ -(^|/)vssver\.scc$ -\.swp$ -(^|/)MT($|/) -(^|/)\{arch\}($|/) -(^|/).arch-ids($|/) -(^|/), -\.class$ -\.prof$ -(^|/)\.DS_Store$ -(^|/)BitKeeper($|/) -(^|/)ChangeSet($|/) -(^|/)\.svn($|/) -(^|/)\.git($|/) -\.git-ignore$ -\.py[co]$ -\# -\.cvsignore$ -(^|/)Thumbs\.db$ -\.depend$ -\.depend-.*$ -^compiler/primop- -^compiler/cmm/CmmLex.hs$ -^compiler/cmm/CmmParse.hs$ -^compiler/ghci/LibFFI.hs$ -^compiler/ghci/LibFFI_hsc.c$ -^compiler/main/Config.hs$ -^compiler/main/ParsePkgConf.hs$ -^compiler/parser/Parser.y$ -^compiler/parser/Parser.hs$ -^compiler/parser/Lexer.hs$ -^compiler/parser/ParserCore.hs$ -^compiler/parser/HaddockLex.hs -^compiler/parser/HaddockParse.hs -^compiler/prelude/primops.txt$ -^compiler/stage1($|/) -^compiler/stage2($|/) -^compiler/stage3($|/) -^compiler/utils/Fingerprint.hs$ -^compiler/utils/Fingerprint_hsc.c$ -^mk/build.mk$ -^mk/validate.mk$ -^mk/are-validating.mk$ -^mk/config.h.in$ -^mk/config.h$ -^mk/config.mk$ -^mk/stamp-h$ -^stage3.package.conf$ -^inplace-datadir(/|$) -(^|/)autom4te.cache($|/) -^rts/AutoApply.*cmm$ -^rts/sm/Evac_thr.c$ -^rts/sm/Scav_thr.c$ -package.conf.inplace$ -package.conf.installed$ -(^|/)config.log$ -(^|/)config.status$ -(^|/)configure$ -^ghc.spec$ -^docs/users_guide/ug-book.xml$ -^docs/man/flags.xml$ -^docs/man/flags.xsl$ -^docs/man/ghc.1$ -^extra-gcc-opts$ -# ignore scripts like push-monk -^push- -^pull- -# Common log file names; testlog is made by validate -^testlog -^log -^utils/[a-zA-Z0-9-]+/dist-install(/|$) -^utils/[a-zA-Z0-9-]+/dist-inplace(/|$) -^utils/[a-zA-Z0-9-]+/install-inplace(/|$) -^compiler/Makefile-stage[1-3](/|$) -^compiler/dist-stage[1-3](/|$) -^ghc/dist-stage[1-3](/|$) -^ghc/stage[1-3]-inplace(/|$) -^utils/ext-core/Driver$ -^utils/ext-core/PrimEnv.hs$ -^utils/genapply/genapply$ -^utils/genprimopcode/Lexer.hs$ -^utils/genprimopcode/Parser.hs$ -^utils/genprimopcode/genprimopcode$ -^utils/ghc-pkg/Version.hs$ -^utils/ghc-pkg/ghc-pkg-inplace$ -^utils/ghc-pkg/ghc-pkg-inplace.bin$ -^utils/ghc-pkg/ghc-pkg-inplace.hs$ -^utils/ghc-pkg/ghc-pkg.bin$ -^utils/hasktags/hasktags$ -^utils/hasktags/hasktags-inplace$ -^utils/hp2ps/hp2ps$ -^utils/hpc/HpcParser.hs$ -^utils/hsc2hs(/|$) -^utils/haddock(/|$) -^utils/lndir/lndir$ -^utils/mkdependC/mkdependC$ -^utils/mkdirhier/mkdirhier$ -^utils/prof/cgprof/cgprof$ -^utils/prof/ghcprof-inplace$ -^utils/pwd/pwd$ -^utils/pwd/pwd-inplace$ -^utils/runghc/runghc$ -^utils/runghc/runghc-inplace$ -^utils/runghc/runhaskell$ -^utils/runstdtest/runstdtest$ -^utils/unlit/unlit$ -^driver/ghci/ghc-pkg-inplace$ -^driver/ghci/ghci-inplace$ -^driver/mangler/ghc-asm$ -^driver/mangler/ghc-asm.prl$ -^driver/package.conf$ -^driver/package.conf.inplace.old$ -^driver/split/ghc-split$ -^driver/split/ghc-split.prl$ -^driver/stamp-pkg-conf-rts$ -^includes/DerivedConstants.h$ -^includes/GHCConstants.h$ -^includes/ghcautoconf.h$ -^includes/ghcplatform.h$ -^includes/mkDerivedConstantsHdr$ -^includes/mkGHCConstants$ -^libffi/build($|/) -^libffi/ffi.h$ -^libffi/stamp.ffi.static$ - diff --git a/aclocal.m4 b/aclocal.m4 index 6d80ad3759..5652185b5e 100644 --- a/aclocal.m4 +++ b/aclocal.m4 @@ -363,12 +363,18 @@ AC_DEFUN([FP_SETTINGS], [ if test "$windows" = YES then - SettingsCCompilerCommand='$topdir/../mingw/bin/gcc.exe' + if test "$HostArch" = "x86_64" + then + mingw_bin_prefix=x86_64-w64-mingw32- + else + mingw_bin_prefix= + fi + SettingsCCompilerCommand="\$topdir/../mingw/bin/${mingw_bin_prefix}gcc.exe" SettingsCCompilerFlags="$CONF_CC_OPTS_STAGE2 $CONF_GCC_LINKER_OPTS_STAGE2" - SettingsArCommand='$topdir/../mingw/bin/ar.exe' + SettingsArCommand="\$topdir/../mingw/bin/${mingw_bin_prefix}ar.exe" SettingsPerlCommand='$topdir/../perl/perl.exe' - SettingsDllWrapCommand='$topdir/../mingw/bin/dllwrap.exe' - SettingsWindresCommand='$topdir/../mingw/bin/windres.exe' + SettingsDllWrapCommand="\$topdir/../mingw/bin/${mingw_bin_prefix}dllwrap.exe" + SettingsWindresCommand="\$topdir/../mingw/bin/${mingw_bin_prefix}windres.exe" SettingsTouchCommand='$topdir/touchy.exe' else SettingsCCompilerCommand="$WhatGccIsCalled" @@ -686,7 +692,8 @@ case $HostPlatform in esac ;; alpha-dec-osf*) fptools_cv_leading_underscore=no;; *cygwin32) fptools_cv_leading_underscore=yes;; -*mingw32) fptools_cv_leading_underscore=yes;; +i386-unknown-mingw32) fptools_cv_leading_underscore=yes;; +x86_64-unknown-mingw32) fptools_cv_leading_underscore=no;; # HACK: Apple doesn't seem to provide nlist in the 64-bit-libraries x86_64-apple-darwin*) fptools_cv_leading_underscore=yes;; @@ -776,9 +783,9 @@ dnl AC_DEFUN([FPTOOLS_HAPPY], [AC_PATH_PROG(HappyCmd,happy,) # Happy is passed to Cabal, so we need a native path -if test "x$HostPlatform" = "xi386-unknown-mingw32" && \ - test "${OSTYPE}" != "msys" && \ - test "${HappyCmd}" != "" +if test "$HostOS" = "mingw32" && \ + test "${OSTYPE}" != "msys" && \ + test "${HappyCmd}" != "" then # Canonicalise to <drive>:/path/to/gcc HappyCmd=`cygpath -m "${HappyCmd}"` @@ -812,9 +819,9 @@ AC_DEFUN([FPTOOLS_ALEX], [ AC_PATH_PROG(AlexCmd,alex,) # Alex is passed to Cabal, so we need a native path -if test "x$HostPlatform" = "xi386-unknown-mingw32" && \ - test "${OSTYPE}" != "msys" && \ - test "${AlexCmd}" != "" +if test "$HostOS" = "mingw32" && \ + test "${OSTYPE}" != "msys" && \ + test "${AlexCmd}" != "" then # Canonicalise to <drive>:/path/to/gcc AlexCmd=`cygpath -m "${AlexCmd}"` diff --git a/compiler/basicTypes/Name.lhs b/compiler/basicTypes/Name.lhs index e4a9c7d82a..a26729f4b5 100644 --- a/compiler/basicTypes/Name.lhs +++ b/compiler/basicTypes/Name.lhs @@ -168,6 +168,9 @@ Wired-in thing => The thing (Id, TyCon) is fully known to the compiler, All built-in syntax is for wired-in things. \begin{code} +instance HasOccName Name where + occName = nameOccName + nameUnique :: Name -> Unique nameOccName :: Name -> OccName nameModule :: Name -> Module diff --git a/compiler/basicTypes/OccName.lhs b/compiler/basicTypes/OccName.lhs index ff1f71dc5c..27e995a839 100644 --- a/compiler/basicTypes/OccName.lhs +++ b/compiler/basicTypes/OccName.lhs @@ -54,6 +54,7 @@ module OccName ( mkTupleOcc, setOccNameSpace, demoteOccName, + HasOccName(..), -- ** Derived 'OccName's isDerivedOccName, @@ -334,6 +335,11 @@ demoteOccName :: OccName -> Maybe OccName demoteOccName (OccName space name) = do space' <- demoteNameSpace space return $ OccName space' name + +{- | Other names in the compiler add aditional information to an OccName. +This class provides a consistent way to access the underlying OccName. -} +class HasOccName name where + occName :: name -> OccName \end{code} @@ -492,7 +498,7 @@ isDataSymOcc _ = False -- it is a data constructor or variable or whatever) isSymOcc :: OccName -> Bool isSymOcc (OccName DataName s) = isLexConSym s -isSymOcc (OccName TcClsName s) = isLexConSym s +isSymOcc (OccName TcClsName s) = isLexConSym s || isLexVarSym s isSymOcc (OccName VarName s) = isLexSym s isSymOcc (OccName TvName s) = isLexSym s -- Pretty inefficient! diff --git a/compiler/basicTypes/RdrName.lhs b/compiler/basicTypes/RdrName.lhs index de0ff56222..22bd41f7d6 100644 --- a/compiler/basicTypes/RdrName.lhs +++ b/compiler/basicTypes/RdrName.lhs @@ -130,6 +130,10 @@ data RdrName %************************************************************************ \begin{code} + +instance HasOccName RdrName where + occName = rdrNameOcc + rdrNameOcc :: RdrName -> OccName rdrNameOcc (Qual _ occ) = occ rdrNameOcc (Unqual occ) = occ diff --git a/compiler/cmm/Cmm.hs b/compiler/cmm/Cmm.hs index 63c3a9080a..f1318c1dc9 100644 --- a/compiler/cmm/Cmm.hs +++ b/compiler/cmm/Cmm.hs @@ -1,14 +1,6 @@ -- Cmm representations using Hoopl's Graph CmmNode e x. {-# LANGUAGE GADTs #-} {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} - -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - {-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} #if __GLASGOW_HASKELL__ >= 703 -- GHC 7.0.1 improved incomplete pattern warnings with GADTs diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs index 9da00590c2..346b108fa4 100644 --- a/compiler/cmm/PprC.hs +++ b/compiler/cmm/PprC.hs @@ -1107,10 +1107,11 @@ pprHexVal w rep -- times values are unsigned. This also helps eliminate occasional -- warnings about integer overflow from gcc. - -- on 32-bit platforms, add "ULL" to 64-bit literals - repsuffix W64 | wORD_SIZE == 4 = ptext (sLit "ULL") - -- on 64-bit platforms with 32-bit int, add "L" to 64-bit literals - repsuffix W64 | cINT_SIZE == 4 = ptext (sLit "UL") + repsuffix W64 + | cINT_SIZE == 8 = char 'U' + | cLONG_SIZE == 8 = ptext (sLit "UL") + | cLONG_LONG_SIZE == 8 = ptext (sLit "ULL") + | otherwise = panic "pprHexVal: Can't find a 64-bit type" repsuffix _ = char 'U' go 0 = empty diff --git a/compiler/codeGen/ClosureInfo.lhs b/compiler/codeGen/ClosureInfo.lhs index 34746984c2..d8fd07fead 100644 --- a/compiler/codeGen/ClosureInfo.lhs +++ b/compiler/codeGen/ClosureInfo.lhs @@ -1097,8 +1097,16 @@ getTyDescription ty FunTy _ res -> '-' : '>' : fun_result res TyConApp tycon _ -> getOccString tycon ForAllTy _ ty -> getTyDescription ty + LitTy n -> getTyLitDescription n } where fun_result (FunTy _ res) = '>' : fun_result res fun_result other = getTyDescription other + + +getTyLitDescription :: TyLit -> String +getTyLitDescription l = + case l of + NumTyLit n -> show n + StrTyLit n -> show n \end{code} diff --git a/compiler/codeGen/StgCmmClosure.hs b/compiler/codeGen/StgCmmClosure.hs index 5c0741a65e..d4ba62c6ca 100644 --- a/compiler/codeGen/StgCmmClosure.hs +++ b/compiler/codeGen/StgCmmClosure.hs @@ -864,11 +864,18 @@ getTyDescription ty FunTy _ res -> '-' : '>' : fun_result res TyConApp tycon _ -> getOccString tycon ForAllTy _ ty -> getTyDescription ty + LitTy n -> getTyLitDescription n } where fun_result (FunTy _ res) = '>' : fun_result res fun_result other = getTyDescription other +getTyLitDescription :: TyLit -> String +getTyLitDescription l = + case l of + NumTyLit n -> show n + StrTyLit n -> show n + -------------------------------------- -- CmmInfoTable-related things -------------------------------------- diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs index 4a5143bcb9..b9054f43db 100644 --- a/compiler/coreSyn/CoreLint.lhs +++ b/compiler/coreSyn/CoreLint.lhs @@ -190,6 +190,12 @@ lintSingleBinding top_lvl_flag rec_flag (binder,rhs) ; checkL (not (isStrictId binder) || (isNonRec rec_flag && not (isTopLevel top_lvl_flag))) (mkStrictMsg binder) + -- Check that if the binder is local, it is not marked as exported + ; checkL (not (isExportedId binder) || isTopLevel top_lvl_flag) + (mkNonTopExportedMsg binder) + -- Check that if the binder is local, it does not have an external name + ; checkL (not (isExternalName (Var.varName binder)) || isTopLevel top_lvl_flag) + (mkNonTopExternalNameMsg binder) -- Check whether binder's specialisations contain any out-of-scope variables ; mapM_ (checkBndrIdInScope binder) bndr_vars @@ -673,6 +679,9 @@ lintType ty@(TyConApp tc tys) lintType (ForAllTy tv ty) = do { lintTyBndrKind tv ; addInScopeVar tv (lintType ty) } + +lintType ty@(LitTy l) = lintTyLit l >> return (typeKind ty) + \end{code} @@ -711,6 +720,13 @@ lint_co_app ty k tys = lint_app (ptext (sLit "coercion") <+> quotes (ppr ty)) k tys ---------------- +lintTyLit :: TyLit -> LintM () +lintTyLit (NumTyLit n) + | n >= 0 = return () + | otherwise = failWithL msg + where msg = ptext (sLit "Negative type literal:") <+> integer n +lintTyLit (StrTyLit _) = return () + lint_app :: SDoc -> LintedKind -> [(LintedType,LintedKind)] -> LintM Kind -- (lint_app d fun_kind arg_tys) -- We have an application (f arg_ty1 .. arg_tyn), @@ -1020,7 +1036,7 @@ lookupIdInScope id Nothing -> do { addErrL out_of_scope ; return id } } where - out_of_scope = ppr id <+> ptext (sLit "is out of scope") + out_of_scope = pprBndr LetBind id <+> ptext (sLit "is out of scope") oneTupleDataConId :: Id -- Should not happen @@ -1040,7 +1056,7 @@ checkInScope :: SDoc -> Var -> LintM () checkInScope loc_msg var = do { subst <- getTvSubst ; checkL (not (mustHaveLocalBinding var) || (var `isInScope` subst)) - (hsep [ppr var, loc_msg]) } + (hsep [pprBndr LetBind var, loc_msg]) } checkTys :: OutType -> OutType -> MsgDoc -> LintM () -- check ty2 is subtype of ty1 (ie, has same structure but usage @@ -1220,6 +1236,13 @@ mkStrictMsg binder hsep [ptext (sLit "Binder's demand info:"), ppr (idDemandInfo binder)] ] +mkNonTopExportedMsg :: Id -> MsgDoc +mkNonTopExportedMsg binder + = hsep [ptext (sLit "Non-top-level binder is marked as exported:"), ppr binder] + +mkNonTopExternalNameMsg :: Id -> MsgDoc +mkNonTopExternalNameMsg binder + = hsep [ptext (sLit "Non-top-level binder has an external name:"), ppr binder] mkKindErrMsg :: TyVar -> Type -> MsgDoc mkKindErrMsg tyvar arg_ty diff --git a/compiler/coreSyn/CorePrep.lhs b/compiler/coreSyn/CorePrep.lhs index ed288096f7..7f107137b6 100644 --- a/compiler/coreSyn/CorePrep.lhs +++ b/compiler/coreSyn/CorePrep.lhs @@ -870,10 +870,12 @@ get to a partial application: \begin{code} tryEtaReducePrep :: [CoreBndr] -> CoreExpr -> Maybe CoreExpr tryEtaReducePrep bndrs expr@(App _ _) - | ok_to_eta_reduce f && - n_remaining >= 0 && - and (zipWith ok bndrs last_args) && - not (any (`elemVarSet` fvs_remaining) bndrs) + | ok_to_eta_reduce f + , n_remaining >= 0 + , and (zipWith ok bndrs last_args) + , not (any (`elemVarSet` fvs_remaining) bndrs) + , exprIsHNF remaining_expr -- Don't turn value into a non-value + -- else the behaviour with 'seq' changes = Just remaining_expr where (f, args) = collectArgs expr @@ -885,9 +887,9 @@ tryEtaReducePrep bndrs expr@(App _ _) ok bndr (Var arg) = bndr == arg ok _ _ = False - -- we can't eta reduce something which must be saturated. + -- We can't eta reduce something which must be saturated. ok_to_eta_reduce (Var f) = not (hasNoBinding f) - ok_to_eta_reduce _ = False --safe. ToDo: generalise + ok_to_eta_reduce _ = False -- Safe. ToDo: generalise tryEtaReducePrep bndrs (Let bind@(NonRec _ r) body) | not (any (`elemVarSet` fvs) bndrs) diff --git a/compiler/coreSyn/CoreSyn.lhs b/compiler/coreSyn/CoreSyn.lhs index d7296e3e25..4faad7fc25 100644 --- a/compiler/coreSyn/CoreSyn.lhs +++ b/compiler/coreSyn/CoreSyn.lhs @@ -917,10 +917,10 @@ instance Outputable AltCon where instance Show AltCon where showsPrec p con = showsPrecSDoc p (ppr con) -cmpAlt :: Alt b -> Alt b -> Ordering +cmpAlt :: (AltCon, a, b) -> (AltCon, a, b) -> Ordering cmpAlt (con1, _, _) (con2, _, _) = con1 `cmpAltCon` con2 -ltAlt :: Alt b -> Alt b -> Bool +ltAlt :: (AltCon, a, b) -> (AltCon, a, b) -> Bool ltAlt a1 a2 = (a1 `cmpAlt` a2) == LT cmpAltCon :: AltCon -> AltCon -> Ordering diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs index 198ac7e610..44aebb8169 100644 --- a/compiler/coreSyn/CoreUtils.lhs +++ b/compiler/coreSyn/CoreUtils.lhs @@ -15,7 +15,8 @@ module CoreUtils ( mkAltExpr, -- * Taking expressions apart - findDefault, findAlt, isDefaultAlt, mergeAlts, trimConArgs, + findDefault, findAlt, isDefaultAlt, + mergeAlts, trimConArgs, filterAlts, -- * Properties of expressions exprType, coreAltType, coreAltsType, @@ -69,7 +70,7 @@ import Util import Pair import Data.Word import Data.Bits -import Data.List ( mapAccumL ) +import Data.List \end{code} @@ -342,18 +343,18 @@ This makes it easy to find, though it makes matching marginally harder. \begin{code} -- | Extract the default case alternative -findDefault :: [CoreAlt] -> ([CoreAlt], Maybe CoreExpr) +findDefault :: [(AltCon, [a], b)] -> ([(AltCon, [a], b)], Maybe b) findDefault ((DEFAULT,args,rhs) : alts) = ASSERT( null args ) (alts, Just rhs) findDefault alts = (alts, Nothing) -isDefaultAlt :: CoreAlt -> Bool +isDefaultAlt :: (AltCon, a, b) -> Bool isDefaultAlt (DEFAULT, _, _) = True isDefaultAlt _ = False -- | Find the case alternative corresponding to a particular -- constructor: panics if no such constructor exists -findAlt :: AltCon -> [CoreAlt] -> Maybe CoreAlt +findAlt :: AltCon -> [(AltCon, a, b)] -> Maybe (AltCon, a, b) -- A "Nothing" result *is* legitmiate -- See Note [Unreachable code] findAlt con alts @@ -369,7 +370,7 @@ findAlt con alts GT -> ASSERT( not (con1 == DEFAULT) ) go alts deflt --------------------------------- -mergeAlts :: [CoreAlt] -> [CoreAlt] -> [CoreAlt] +mergeAlts :: [(AltCon, a, b)] -> [(AltCon, a, b)] -> [(AltCon, a, b)] -- ^ Merge alternatives preserving order; alternatives in -- the first argument shadow ones in the second mergeAlts [] as2 = as2 @@ -396,6 +397,83 @@ trimConArgs (LitAlt _) args = ASSERT( null args ) [] trimConArgs (DataAlt dc) args = dropList (dataConUnivTyVars dc) args \end{code} +\begin{code} +filterAlts :: [Unique] -- ^ Supply of uniques used in case we have to manufacture a new AltCon + -> Type -- ^ Type of scrutinee (used to prune possibilities) + -> [AltCon] -- ^ Constructors known to be impossible due to the form of the scrutinee + -> [(AltCon, [Var], a)] -- ^ Alternatives + -> ([AltCon], Bool, [(AltCon, [Var], a)]) + -- Returns: + -- 1. Constructors that will never be encountered by the *default* case (if any) + -- 2. Whether we managed to refine the default alternative into a specific constructor (for statistcs only) + -- 3. The new alternatives + -- + -- NB: the final list of alternatives may be empty: + -- This is a tricky corner case. If the data type has no constructors, + -- which GHC allows, then the case expression will have at most a default + -- alternative. + -- + -- If callers need to preserve the invariant that there is always at least one branch + -- in a "case" statement then they will need to manually add a dummy case branch that just + -- calls "error" or similar. +filterAlts us ty imposs_cons alts = (imposs_deflt_cons, refined_deflt, merged_alts) + where + (alts_wo_default, maybe_deflt) = findDefault alts + alt_cons = [con | (con,_,_) <- alts_wo_default] + imposs_deflt_cons = nub (imposs_cons ++ alt_cons) + -- "imposs_deflt_cons" are handled + -- EITHER by the context, + -- OR by a non-DEFAULT branch in this case expression. + + trimmed_alts = filterOut impossible_alt alts_wo_default + merged_alts = mergeAlts trimmed_alts (maybeToList maybe_deflt') + -- We need the mergeAlts in case the new default_alt + -- has turned into a constructor alternative. + -- The merge keeps the inner DEFAULT at the front, if there is one + -- and interleaves the alternatives in the right order + + (refined_deflt, maybe_deflt') = case maybe_deflt of + Just deflt_rhs -> case mb_tc_app of + Just (tycon, inst_tys) + | -- This branch handles the case where we are + -- scrutinisng an algebraic data type + isAlgTyCon tycon -- It's a data type, tuple, or unboxed tuples. + , not (isNewTyCon tycon) -- We can have a newtype, if we are just doing an eval: + -- case x of { DEFAULT -> e } + -- and we don't want to fill in a default for them! + , Just all_cons <- tyConDataCons_maybe tycon + , let imposs_data_cons = [con | DataAlt con <- imposs_deflt_cons] -- We now know it's a data type + impossible con = con `elem` imposs_data_cons || dataConCannotMatch inst_tys con + -> case filterOut impossible all_cons of + -- Eliminate the default alternative + -- altogether if it can't match: + [] -> (False, Nothing) + -- It matches exactly one constructor, so fill it in: + [con] -> (True, Just (DataAlt con, ex_tvs ++ arg_ids, deflt_rhs)) + where (ex_tvs, arg_ids) = dataConRepInstPat us con inst_tys + _ -> (False, Just (DEFAULT, [], deflt_rhs)) + + | debugIsOn, isAlgTyCon tycon + , null (tyConDataCons tycon) + , not (isFamilyTyCon tycon || isAbstractTyCon tycon) + -- Check for no data constructors + -- This can legitimately happen for abstract types and type families, + -- so don't report that + -> pprTrace "prepareDefault" (ppr tycon) + (False, Just (DEFAULT, [], deflt_rhs)) + + _ -> (False, Just (DEFAULT, [], deflt_rhs)) + Nothing -> (False, Nothing) + + mb_tc_app = splitTyConApp_maybe ty + Just (_, inst_tys) = mb_tc_app + + impossible_alt :: (AltCon, a, b) -> Bool + impossible_alt (con, _, _) | con `elem` imposs_cons = True + impossible_alt (DataAlt con, _, _) = dataConCannotMatch inst_tys con + impossible_alt _ = False +\end{code} + Note [Unreachable code] ~~~~~~~~~~~~~~~~~~~~~~~ It is possible (although unusual) for GHC to find a case expression diff --git a/compiler/coreSyn/MkExternalCore.lhs b/compiler/coreSyn/MkExternalCore.lhs index 89c0c911d9..bc1429165a 100644 --- a/compiler/coreSyn/MkExternalCore.lhs +++ b/compiler/coreSyn/MkExternalCore.lhs @@ -218,11 +218,12 @@ make_ty t = make_ty' t -- note calls to make_ty so as to expand types recursively make_ty' :: Type -> C.Ty -make_ty' (TyVarTy tv) = C.Tvar (make_var_id (tyVarName tv)) -make_ty' (AppTy t1 t2) = C.Tapp (make_ty t1) (make_ty t2) -make_ty' (FunTy t1 t2) = make_ty (TyConApp funTyCon [t1,t2]) -make_ty' (ForAllTy tv t) = C.Tforall (make_tbind tv) (make_ty t) -make_ty' (TyConApp tc ts) = make_tyConApp tc ts +make_ty' (TyVarTy tv) = C.Tvar (make_var_id (tyVarName tv)) +make_ty' (AppTy t1 t2) = C.Tapp (make_ty t1) (make_ty t2) +make_ty' (FunTy t1 t2) = make_ty (TyConApp funTyCon [t1,t2]) +make_ty' (ForAllTy tv t) = C.Tforall (make_tbind tv) (make_ty t) +make_ty' (TyConApp tc ts) = make_tyConApp tc ts +make_ty' (LitTy {}) = panic "MkExernalCore can't do literal types yet" -- Newtypes are treated just like any other type constructor; not expanded -- Reason: predTypeRep does substitution and, while substitution deals diff --git a/compiler/coreSyn/TrieMap.lhs b/compiler/coreSyn/TrieMap.lhs index fefea6dfdb..7a047e333f 100644 --- a/compiler/coreSyn/TrieMap.lhs +++ b/compiler/coreSyn/TrieMap.lhs @@ -30,6 +30,7 @@ import TypeRep import Var import UniqFM import Unique( Unique ) +import FastString(FastString) import qualified Data.Map as Map import qualified Data.IntMap as IntMap @@ -486,7 +487,10 @@ data TypeMap a , tm_app :: TypeMap (TypeMap a) , tm_fun :: TypeMap (TypeMap a) , tm_tc_app :: NameEnv (ListMap TypeMap a) - , tm_forall :: TypeMap (BndrMap a) } + , tm_forall :: TypeMap (BndrMap a) + , tm_tylit :: TyLitMap a + } + instance Outputable a => Outputable (TypeMap a) where ppr m = text "TypeMap elts" <+> ppr (foldTypeMap (:) [] m) @@ -499,7 +503,8 @@ wrapEmptyTypeMap = TM { tm_var = emptyTM , tm_app = EmptyTM , tm_fun = EmptyTM , tm_tc_app = emptyNameEnv - , tm_forall = EmptyTM } + , tm_forall = EmptyTM + , tm_tylit = emptyTyLitMap } instance TrieMap TypeMap where type Key TypeMap = Type @@ -519,6 +524,7 @@ lkT env ty m go (AppTy t1 t2) = tm_app >.> lkT env t1 >=> lkT env t2 go (FunTy t1 t2) = tm_fun >.> lkT env t1 >=> lkT env t2 go (TyConApp tc tys) = tm_tc_app >.> lkNamed tc >=> lkList (lkT env) tys + go (LitTy l) = tm_tylit >.> lkTyLit l go (ForAllTy tv ty) = tm_forall >.> lkT (extendCME env tv) ty >=> lkBndr env tv @@ -572,6 +578,7 @@ xtT env (ForAllTy tv ty) f m = m { tm_forall = tm_forall m |> xtT (extendCME e |>> xtBndr env tv f } xtT env (TyConApp tc tys) f m = m { tm_tc_app = tm_tc_app m |> xtNamed tc |>> xtList (xtT env) tys f } +xtT _ (LitTy l) f m = m { tm_tylit = tm_tylit m |> xtTyLit l f } fdT :: (a -> b -> b) -> TypeMap a -> b -> b fdT _ EmptyTM = \z -> z @@ -580,6 +587,33 @@ fdT k m = foldTM k (tm_var m) . foldTM (foldTM k) (tm_fun m) . foldTM (foldTM k) (tm_tc_app m) . foldTM (foldTM k) (tm_forall m) + . foldTyLit k (tm_tylit m) + + + +------------------------ +data TyLitMap a = TLM { tlm_number :: Map.Map Integer a + , tlm_string :: Map.Map FastString a + } + +emptyTyLitMap :: TyLitMap a +emptyTyLitMap = TLM { tlm_number = Map.empty, tlm_string = Map.empty } + +lkTyLit :: TyLit -> TyLitMap a -> Maybe a +lkTyLit l = + case l of + NumTyLit n -> tlm_number >.> Map.lookup n + StrTyLit n -> tlm_string >.> Map.lookup n + +xtTyLit :: TyLit -> XT a -> TyLitMap a -> TyLitMap a +xtTyLit l f m = + case l of + NumTyLit n -> m { tlm_number = tlm_number m |> Map.alter f n } + StrTyLit n -> m { tlm_string = tlm_string m |> Map.alter f n } + +foldTyLit :: (a -> b -> b) -> TyLitMap a -> b -> b +foldTyLit l m = flip (Map.fold l) (tlm_string m) + . flip (Map.fold l) (tlm_number m) \end{code} diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs index 99f4d53873..673ca37a3e 100644 --- a/compiler/deSugar/Desugar.lhs +++ b/compiler/deSugar/Desugar.lhs @@ -120,7 +120,7 @@ deSugar hsc_env else return (binds, hpcInfo, emptyModBreaks) initDs hsc_env mod rdr_env type_env $ do - do { let ds_ev_binds = dsEvBinds ev_binds + do { ds_ev_binds <- dsEvBinds ev_binds ; core_prs <- dsTopLHsBinds binds_cvr ; (spec_prs, spec_rules) <- dsImpSpecs imp_specs ; (ds_fords, foreign_prs) <- dsForeigns fords diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs index 4f94a1c3e9..8fc6bd91f3 100644 --- a/compiler/deSugar/DsBinds.lhs +++ b/compiler/deSugar/DsBinds.lhs @@ -32,6 +32,7 @@ import DsUtils import HsSyn -- lots of things import CoreSyn -- lots of things +import HscTypes ( MonadThings ) import Literal ( Literal(MachStr) ) import CoreSubst import MkCore @@ -69,6 +70,7 @@ import ErrUtils( MsgDoc ) import Util import Control.Monad( when ) import MonadUtils +import Control.Monad(liftM) \end{code} %************************************************************************ @@ -112,7 +114,7 @@ dsHsBind (FunBind { fun_id = L _ fun, fun_matches = matches , fun_infix = inf }) = do { (args, body) <- matchWrapper (FunRhs (idName fun) inf) matches ; let body' = mkOptTickBox tick body - rhs = dsHsWrapper co_fn (mkLams args body') + ; rhs <- dsHsWrapper co_fn (mkLams args body') ; {- pprTrace "dsHsBind" (ppr fun <+> ppr (idInlinePragma fun)) $ -} return (unitOL (makeCorePair fun False 0 rhs)) } @@ -136,9 +138,10 @@ dsHsBind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts , abe_mono = local, abe_prags = prags } <- export = do { bind_prs <- ds_lhs_binds binds ; let core_bind = Rec (fromOL bind_prs) - rhs = dsHsWrapper wrap $ -- Usually the identity + ; ds_binds <- dsTcEvBinds ev_binds + ; rhs <- dsHsWrapper wrap $ -- Usually the identity mkLams tyvars $ mkLams dicts $ - mkCoreLets (dsTcEvBinds ev_binds) $ + mkCoreLets ds_binds $ Let core_bind $ Var local @@ -159,24 +162,25 @@ dsHsBind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts | (lcl_id, rhs) <- fromOL bind_prs ] -- Monomorphic recursion possible, hence Rec + locals = map abe_mono exports tup_expr = mkBigCoreVarTup locals tup_ty = exprType tup_expr - poly_tup_rhs = mkLams tyvars $ mkLams dicts $ - mkCoreLets (dsTcEvBinds ev_binds) $ + ; ds_binds <- dsTcEvBinds ev_binds + ; let poly_tup_rhs = mkLams tyvars $ mkLams dicts $ + mkCoreLets ds_binds $ Let core_bind $ tup_expr - locals = map abe_mono exports ; poly_tup_id <- newSysLocalDs (exprType poly_tup_rhs) ; let mk_bind (ABE { abe_wrap = wrap, abe_poly = global , abe_mono = local, abe_prags = spec_prags }) = do { tup_id <- newSysLocalDs tup_ty - ; let rhs = dsHsWrapper wrap $ + ; rhs <- dsHsWrapper wrap $ mkLams tyvars $ mkLams dicts $ mkTupleSelector locals local tup_id $ mkVarApps (Var poly_tup_id) (tyvars ++ dicts) - rhs_for_spec = Let (NonRec poly_tup_id poly_tup_rhs) rhs + ; let rhs_for_spec = Let (NonRec poly_tup_id poly_tup_rhs) rhs ; (spec_binds, rules) <- dsSpecs rhs_for_spec spec_prags ; let global' = (global `setInlinePragma` defaultInlinePragma) `addIdSpecialisations` rules @@ -437,8 +441,9 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl)) = putSrcSpanDs loc $ do { let poly_name = idName poly_id ; spec_name <- newLocalName poly_name - ; let (bndrs, ds_lhs) = collectBinders (dsHsWrapper spec_co (Var poly_id)) - spec_ty = mkPiTypes bndrs (exprType ds_lhs) + ; (bndrs, ds_lhs) <- liftM collectBinders + (dsHsWrapper spec_co (Var poly_id)) + ; let spec_ty = mkPiTypes bndrs (exprType ds_lhs) ; case decomposeRuleLhs bndrs ds_lhs of { Left msg -> do { warnDs msg; return Nothing } ; Right (final_bndrs, _fn, args) -> do @@ -454,8 +459,8 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl)) final_bndrs args (mkVarApps (Var spec_id) bndrs) - spec_rhs = dsHsWrapper spec_co poly_rhs - spec_pair = makeCorePair spec_id False (dictArity bndrs) spec_rhs + ; spec_rhs <- dsHsWrapper spec_co poly_rhs + ; let spec_pair = makeCorePair spec_id False (dictArity bndrs) spec_rhs ; dflags <- getDynFlags ; when (isInlinePragma id_inl && wopt Opt_WarnPointlessPragmas dflags) @@ -690,28 +695,29 @@ as the old one, but with an Internal name and no IdInfo. \begin{code} -dsHsWrapper :: HsWrapper -> CoreExpr -> CoreExpr -dsHsWrapper WpHole e = e -dsHsWrapper (WpTyApp ty) e = App e (Type ty) -dsHsWrapper (WpLet ev_binds) e = mkCoreLets (dsTcEvBinds ev_binds) e -dsHsWrapper (WpCompose c1 c2) e = dsHsWrapper c1 (dsHsWrapper c2 e) -dsHsWrapper (WpCast co) e = dsTcCoercion co (mkCast e) -dsHsWrapper (WpEvLam ev) e = Lam ev e -dsHsWrapper (WpTyLam tv) e = Lam tv e -dsHsWrapper (WpEvApp evtrm) e = App e (dsEvTerm evtrm) +dsHsWrapper :: MonadThings m => HsWrapper -> CoreExpr -> m CoreExpr +dsHsWrapper WpHole e = return e +dsHsWrapper (WpTyApp ty) e = return $ App e (Type ty) +dsHsWrapper (WpLet ev_binds) e = do bs <- dsTcEvBinds ev_binds + return (mkCoreLets bs e) +dsHsWrapper (WpCompose c1 c2) e = dsHsWrapper c1 =<< dsHsWrapper c2 e +dsHsWrapper (WpCast co) e = return $ dsTcCoercion co (mkCast e) +dsHsWrapper (WpEvLam ev) e = return $ Lam ev e +dsHsWrapper (WpTyLam tv) e = return $ Lam tv e +dsHsWrapper (WpEvApp evtrm) e = liftM (App e) (dsEvTerm evtrm) -------------------------------------- -dsTcEvBinds :: TcEvBinds -> [CoreBind] -dsTcEvBinds (TcEvBinds {}) = panic "dsEvBinds" -- Zonker has got rid of this +dsTcEvBinds :: MonadThings m => TcEvBinds -> m [CoreBind] +dsTcEvBinds (TcEvBinds {}) = panic "dsEvBinds" -- Zonker has got rid of this dsTcEvBinds (EvBinds bs) = dsEvBinds bs -dsEvBinds :: Bag EvBind -> [CoreBind] -dsEvBinds bs = map ds_scc (sccEvBinds bs) +dsEvBinds :: MonadThings m => Bag EvBind -> m [CoreBind] +dsEvBinds bs = mapM ds_scc (sccEvBinds bs) where - ds_scc (AcyclicSCC (EvBind v r)) = NonRec v (dsEvTerm r) - ds_scc (CyclicSCC bs) = Rec (map ds_pair bs) + ds_scc (AcyclicSCC (EvBind v r)) = liftM (NonRec v) (dsEvTerm r) + ds_scc (CyclicSCC bs) = liftM Rec (mapM ds_pair bs) - ds_pair (EvBind v r) = (v, dsEvTerm r) + ds_pair (EvBind v r) = liftM ((,) v) (dsEvTerm r) sccEvBinds :: Bag EvBind -> [SCC EvBind] sccEvBinds bs = stronglyConnCompFromEdgedVertices edges @@ -724,19 +730,20 @@ sccEvBinds bs = stronglyConnCompFromEdgedVertices edges --------------------------------------- -dsEvTerm :: EvTerm -> CoreExpr -dsEvTerm (EvId v) = Var v +dsEvTerm :: MonadThings m => EvTerm -> m CoreExpr +dsEvTerm (EvId v) = return (Var v) dsEvTerm (EvCast v co) - = dsTcCoercion co $ mkCast (Var v) -- 'v' is always a lifted evidence variable so it is + = return $ dsTcCoercion co $ mkCast (Var v) -- 'v' is always a lifted evidence variable so it is -- unnecessary to call varToCoreExpr v here. dsEvTerm (EvKindCast v co) - = dsTcCoercion co $ (\_ -> Var v) + = return $ dsTcCoercion co $ (\_ -> Var v) -dsEvTerm (EvDFunApp df tys vars) = Var df `mkTyApps` tys `mkVarApps` vars -dsEvTerm (EvCoercion co) = dsTcCoercion co mkEqBox +dsEvTerm (EvDFunApp df tys vars) = return (Var df `mkTyApps` tys `mkVarApps` vars) +dsEvTerm (EvCoercion co) = return $ dsTcCoercion co mkEqBox dsEvTerm (EvTupleSel v n) = ASSERT( isTupleTyCon tc ) + return $ Case (Var v) (mkWildValBinder (varType v)) (tys !! n) [(DataAlt dc, xs, Var v')] where (tc, tys) = splitTyConApp (evVarPred v) @@ -744,17 +751,23 @@ dsEvTerm (EvTupleSel v n) v' = v `setVarType` ty_want xs = map mkWildValBinder tys_before ++ v' : map mkWildValBinder tys_after (tys_before, ty_want:tys_after) = splitAt n tys -dsEvTerm (EvTupleMk vs) = Var (dataConWorkId dc) `mkTyApps` tys `mkVarApps` vs +dsEvTerm (EvTupleMk vs) = return $ Var (dataConWorkId dc) `mkTyApps` tys `mkVarApps` vs where dc = tupleCon ConstraintTuple (length vs) tys = map varType vs dsEvTerm (EvSuperClass d n) - = Var sc_sel_id `mkTyApps` tys `App` Var d + = return $ Var sc_sel_id `mkTyApps` tys `App` Var d where sc_sel_id = classSCSelId cls n -- Zero-indexed (cls, tys) = getClassPredTys (evVarPred d) -dsEvTerm (EvDelayedError ty msg) = Var errorId `mkTyApps` [ty] `mkApps` [litMsg] - where errorId = rUNTIME_ERROR_ID - litMsg = Lit (MachStr msg) +dsEvTerm (EvDelayedError ty msg) = return $ Var errorId `mkTyApps` [ty] `mkApps` [litMsg] + where + errorId = rUNTIME_ERROR_ID + litMsg = Lit (MachStr msg) + +dsEvTerm (EvLit l) = + case l of + EvNum n -> mkIntegerExpr n + EvStr s -> mkStringExprFS s --------------------------------------- dsTcCoercion :: TcCoercion -> (Coercion -> CoreExpr) -> CoreExpr diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs index b34640a010..d31c77479d 100644 --- a/compiler/deSugar/DsExpr.lhs +++ b/compiler/deSugar/DsExpr.lhs @@ -79,7 +79,8 @@ dsValBinds (ValBindsIn _ _) _ = panic "dsValBinds ValBindsIn" ------------------------- dsIPBinds :: HsIPBinds Id -> CoreExpr -> DsM CoreExpr dsIPBinds (IPBinds ip_binds ev_binds) body - = do { let inner = mkCoreLets (dsTcEvBinds ev_binds) body + = do { ds_binds <- dsTcEvBinds ev_binds + ; let inner = mkCoreLets ds_binds body -- The dict bindings may not be in -- dependency order; hence Rec ; foldrM ds_ip_bind inner ip_binds } @@ -131,7 +132,8 @@ dsStrictBind (AbsBinds { abs_tvs = [], abs_ev_vars = [] bind_export export b = bindNonRec (abe_poly export) (Var (abe_mono export)) b ; body2 <- foldlBagM (\body bind -> dsStrictBind (unLoc bind) body) body1 binds - ; return (mkCoreLets (dsTcEvBinds ev_binds) body2) } + ; ds_binds <- dsTcEvBinds ev_binds + ; return (mkCoreLets ds_binds body2) } dsStrictBind (FunBind { fun_id = L _ fun, fun_matches = matches, fun_co_fn = co_fn , fun_tick = tick, fun_infix = inf }) body @@ -216,7 +218,7 @@ dsExpr (HsOverLit lit) = dsOverLit lit dsExpr (HsWrap co_fn e) = do { e' <- dsExpr e - ; let wrapped_e = dsHsWrapper co_fn e' + ; wrapped_e <- dsHsWrapper co_fn e' ; warn_id <- woptDs Opt_WarnIdentities ; when warn_id $ warnAboutIdentities e' wrapped_e ; return wrapped_e } diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index bef7b5da8d..af3d76bd75 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -65,7 +65,7 @@ import Bag import FastString import ForeignCall import MonadUtils -import Util( equalLength ) +import Util( equalLength, filterOut ) import Data.Maybe import Control.Monad @@ -124,17 +124,17 @@ repTopDs group -- return (Data t [] ...more t's... } -- The other important reason is that the output must mention -- only "T", not "Foo:T" where Foo is the current module - decls <- addBinds ss (do { + fix_ds <- mapM repFixD (hs_fixds group) ; val_ds <- rep_val_binds (hs_valds group) ; tycl_ds <- mapM repTyClD (concat (hs_tyclds group)) ; inst_ds <- mapM repInstD (hs_instds group) ; for_ds <- mapM repForD (hs_fords group) ; -- more needed return (de_loc $ sort_by_loc $ - val_ds ++ catMaybes tycl_ds - ++ catMaybes inst_ds ++ for_ds) }) ; + val_ds ++ catMaybes tycl_ds ++ fix_ds + ++ inst_ds ++ for_ds) }) ; decl_ty <- lookupType decQTyConName ; let { core_list = coreList' decl_ty decls } ; @@ -170,56 +170,35 @@ in repTyClD and repC. -} -repTyClD :: LTyClDecl Name -> DsM (Maybe (SrcSpan, Core TH.DecQ)) +-- represent associated family instances +-- +repTyClDs :: [LTyClDecl Name] -> DsM [Core TH.DecQ] +repTyClDs ds = liftM de_loc (mapMaybeM repTyClD ds) -repTyClD tydecl@(L _ (TyFamily {})) - = repTyFamily tydecl addTyVarBinds -repTyClD (L loc (TyData { tcdND = DataType, tcdCtxt = cxt, - tcdLName = tc, tcdTyVars = tvs, tcdTyPats = opt_tys, - tcdCons = cons, tcdDerivs = mb_derivs })) - = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences] - ; dec <- addTyVarBinds tvs $ \bndrs -> - do { cxt1 <- repLContext cxt - ; opt_tys1 <- maybeMapM repLTys opt_tys -- only for family insts - ; opt_tys2 <- maybeMapM (coreList typeQTyConName) opt_tys1 - ; cons1 <- mapM (repC (hsLTyVarNames tvs)) cons - ; cons2 <- coreList conQTyConName cons1 - ; derivs1 <- repDerivs mb_derivs - ; bndrs1 <- coreList tyVarBndrTyConName bndrs - ; repData cxt1 tc1 bndrs1 opt_tys2 cons2 derivs1 - } - ; return $ Just (loc, dec) - } +repTyClD :: LTyClDecl Name -> DsM (Maybe (SrcSpan, Core TH.DecQ)) -repTyClD (L loc (TyData { tcdND = NewType, tcdCtxt = cxt, - tcdLName = tc, tcdTyVars = tvs, tcdTyPats = opt_tys, - tcdCons = [con], tcdDerivs = mb_derivs })) +repTyClD (L loc (TyFamily { tcdFlavour = flavour, + tcdLName = tc, tcdTyVars = tvs, + tcdKindSig = opt_kind })) = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences] - ; dec <- addTyVarBinds tvs $ \bndrs -> - do { cxt1 <- repLContext cxt - ; opt_tys1 <- maybeMapM repLTys opt_tys -- only for family insts - ; opt_tys2 <- maybeMapM (coreList typeQTyConName) opt_tys1 - ; con1 <- repC (hsLTyVarNames tvs) con - ; derivs1 <- repDerivs mb_derivs - ; bndrs1 <- coreList tyVarBndrTyConName bndrs - ; repNewtype cxt1 tc1 bndrs1 opt_tys2 con1 derivs1 + ; dec <- addTyClTyVarBinds tvs $ \bndrs -> + do { flav <- repFamilyFlavour flavour + ; case opt_kind of + Nothing -> repFamilyNoKind flav tc1 bndrs + Just (HsBSig ki _) + -> do { ki1 <- repKind ki + ; repFamilyKind flav tc1 bndrs ki1 } } - ; return $ Just (loc, dec) + ; return $ Just (loc, dec) } -repTyClD (L loc (TySynonym { tcdLName = tc, tcdTyVars = tvs, tcdTyPats = opt_tys, - tcdSynRhs = ty })) - = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences] - ; dec <- addTyVarBinds tvs $ \bndrs -> - do { opt_tys1 <- maybeMapM repLTys opt_tys -- only for family insts - ; opt_tys2 <- maybeMapM (coreList typeQTyConName) opt_tys1 - ; ty1 <- repLTy ty - ; bndrs1 <- coreList tyVarBndrTyConName bndrs - ; repTySyn tc1 bndrs1 opt_tys2 ty1 - } - ; return (Just (loc, dec)) - } +repTyClD (L loc (TyDecl { tcdLName = tc, tcdTyVars = tvs, tcdTyDefn = defn })) + = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences] + ; tc_tvs <- mk_extra_tvs tc tvs defn + ; dec <- addTyClTyVarBinds tc_tvs $ \bndrs -> + repTyDefn tc1 bndrs Nothing (hsLTyVarNames tc_tvs) defn + ; return (Just (loc, dec)) } repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, tcdTyVars = tvs, tcdFDs = fds, @@ -231,10 +210,9 @@ repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, ; sigs1 <- rep_sigs sigs ; binds1 <- rep_binds meth_binds ; fds1 <- repLFunDeps fds - ; ats1 <- repLAssocFamilys ats + ; ats1 <- repTyClDs ats ; decls1 <- coreList decQTyConName (ats1 ++ sigs1 ++ binds1) - ; bndrs1 <- coreList tyVarBndrTyConName bndrs - ; repClass cxt1 cls1 bndrs1 fds1 decls1 + ; repClass cxt1 cls1 bndrs fds1 decls1 } ; return $ Just (loc, dec) } @@ -244,31 +222,56 @@ repTyClD (L loc d) = putSrcSpanDs loc $ do { warnDs (hang ds_msg 4 (ppr d)) ; return Nothing } --- The type variables in the head of families are treated differently when the --- family declaration is associated. In that case, they are usage, not binding --- occurences. --- -repTyFamily :: LTyClDecl Name - -> ProcessTyVarBinds TH.Dec - -> DsM (Maybe (SrcSpan, Core TH.DecQ)) -repTyFamily (L loc (TyFamily { tcdFlavour = flavour, - tcdLName = tc, tcdTyVars = tvs, - tcdKindSig = opt_kind })) - tyVarBinds - = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences] - ; dec <- tyVarBinds tvs $ \bndrs -> - do { flav <- repFamilyFlavour flavour - ; bndrs1 <- coreList tyVarBndrTyConName bndrs - ; case opt_kind of - Nothing -> repFamilyNoKind flav tc1 bndrs1 - Just ki -> do { ki1 <- repKind ki - ; repFamilyKind flav tc1 bndrs1 ki1 - } - } - ; return $ Just (loc, dec) - } -repTyFamily _ _ = panic "DsMeta.repTyFamily: internal error" - +------------------------- +repTyDefn :: Core TH.Name -> Core [TH.TyVarBndr] + -> Maybe (Core [TH.TypeQ]) + -> [Name] -> HsTyDefn Name + -> DsM (Core TH.DecQ) +repTyDefn tc bndrs opt_tys tv_names + (TyData { td_ND = new_or_data, td_ctxt = cxt + , td_cons = cons, td_derivs = mb_derivs }) + = do { cxt1 <- repLContext cxt + ; derivs1 <- repDerivs mb_derivs + ; case new_or_data of + NewType -> do { con1 <- repC tv_names (head cons) + ; repNewtype cxt1 tc bndrs opt_tys con1 derivs1 } + DataType -> do { cons1 <- mapM (repC tv_names) cons + ; cons2 <- coreList conQTyConName cons1 + ; repData cxt1 tc bndrs opt_tys cons2 derivs1 } } + +repTyDefn tc bndrs opt_tys _ (TySynonym { td_synRhs = ty }) + = do { ty1 <- repLTy ty + ; repTySyn tc bndrs opt_tys ty1 } + +------------------------- +mk_extra_tvs :: Located Name -> [LHsTyVarBndr Name] + -> HsTyDefn Name -> DsM [LHsTyVarBndr Name] +-- If there is a kind signature it must be of form +-- k1 -> .. -> kn -> * +-- Return type variables [tv1:k1, tv2:k2, .., tvn:kn] +mk_extra_tvs tc tvs defn + | TyData { td_kindSig = Just (HsBSig hs_kind _) } <- defn + = do { extra_tvs <- go hs_kind + ; return (tvs ++ extra_tvs) } + | otherwise + = return tvs + where + go :: LHsKind Name -> DsM [LHsTyVarBndr Name] + go (L loc (HsFunTy kind rest)) + = do { uniq <- newUnique + ; let { occ = mkTyVarOccFS (fsLit "t") + ; nm = mkInternalName uniq occ loc + ; hs_tv = L loc (KindedTyVar nm (mkHsBSig kind)) } + ; hs_tvs <- go rest + ; return (hs_tv : hs_tvs) } + + go (L _ (HsTyVar n)) + | n == liftedTypeKindTyConName + = return [] + + go _ = failWithDs (ptext (sLit "Malformed kind signature for") <+> ppr tc) + +------------------------- -- represent fundeps -- repLFunDeps :: [Located (FunDep Name)] -> DsM (Core [TH.FunDep]) @@ -289,32 +292,14 @@ repFamilyFlavour :: FamilyFlavour -> DsM (Core TH.FamFlavour) repFamilyFlavour TypeFamily = rep2 typeFamName [] repFamilyFlavour DataFamily = rep2 dataFamName [] --- represent associated family declarations --- -repLAssocFamilys :: [LTyClDecl Name] -> DsM [Core TH.DecQ] -repLAssocFamilys = mapM repLAssocFamily - where - repLAssocFamily tydecl@(L _ (TyFamily {})) - = liftM (snd . fromJust) $ repTyFamily tydecl lookupTyVarBinds - repLAssocFamily tydecl - = failWithDs msg - where - msg = ptext (sLit "Illegal associated declaration in class:") <+> - ppr tydecl - --- represent associated family instances +-- Represent instance declarations -- -repLAssocFamInst :: [LTyClDecl Name] -> DsM [Core TH.DecQ] -repLAssocFamInst = liftM de_loc . mapMaybeM repTyClD +repInstD :: LInstDecl Name -> DsM (SrcSpan, Core TH.DecQ) +repInstD (L loc (FamInstD fi_decl)) + = do { dec <- repFamInstD fi_decl + ; return (loc, dec) } --- represent instance declarations --- -repInstD :: LInstDecl Name -> DsM (Maybe (SrcSpan, Core TH.DecQ)) -repInstD (L loc (FamInstDecl fi_decl)) - = repTyClD (L loc fi_decl) - - -repInstD (L loc (ClsInstDecl ty binds _ ats)) -- Ignore user pragmas for now +repInstD (L loc (ClsInstD ty binds prags ats)) = do { dec <- addTyVarBinds tvs $ \_ -> -- We must bring the type variables into scope, so their -- occurrences don't fail, even though the binders don't @@ -330,13 +315,24 @@ repInstD (L loc (ClsInstDecl ty binds _ ats)) -- Ignore user pragmas for now ; cls_tys <- repLTys tys ; inst_ty1 <- repTapps cls_tcon cls_tys ; binds1 <- rep_binds binds - ; ats1 <- repLAssocFamInst ats - ; decls <- coreList decQTyConName (ats1 ++ binds1) + ; prags1 <- rep_sigs prags + ; ats1 <- mapM (repFamInstD . unLoc) ats + ; decls <- coreList decQTyConName (ats1 ++ binds1 ++ prags1) ; repInst cxt1 inst_ty1 decls } - ; return (Just (loc, dec)) } + ; return (loc, dec) } where Just (tvs, cxt, cls, tys) = splitHsInstDeclTy_maybe (unLoc ty) +repFamInstD :: FamInstDecl Name -> DsM (Core TH.DecQ) +repFamInstD (FamInstDecl { fid_tycon = tc_name, fid_pats = HsBSig tys tv_names, fid_defn = defn }) + = do { tc <- lookupLOcc tc_name -- See note [Binders and occurrences] + ; let loc = getLoc tc_name + hs_tvs = [ L loc (UserTyVar n) | n <- tv_names] -- Yuk + ; addTyClTyVarBinds hs_tvs $ \ bndrs -> + do { tys1 <- repLTys tys + ; tys2 <- coreList typeQTyConName tys1 + ; repTyDefn tc bndrs (Just tys2) tv_names defn } } + repForD :: Located (ForeignDecl Name) -> DsM (SrcSpan, Core TH.DecQ) repForD (L loc (ForeignImport name typ _ (CImport cc s mch cis))) = do MkC name' <- lookupLOcc name @@ -371,6 +367,17 @@ repSafety PlayRisky = rep2 unsafeName [] repSafety PlayInterruptible = rep2 interruptibleName [] repSafety PlaySafe = rep2 safeName [] +repFixD :: LFixitySig Name -> DsM (SrcSpan, Core TH.DecQ) +repFixD (L loc (FixitySig name (Fixity prec dir))) + = do { MkC name' <- lookupLOcc name + ; MkC prec' <- coreIntLit prec + ; let rep_fn = case dir of + InfixL -> infixLDName + InfixR -> infixRDName + InfixN -> infixNDName + ; dec <- rep2 rep_fn [prec', name'] + ; return (loc, dec) } + ds_msg :: SDoc ds_msg = ptext (sLit "Cannot desugar this Template Haskell declaration:") @@ -395,8 +402,7 @@ repC tvs (L _ (ConDecl { con_name = con do { con1 <- lookupLOcc con -- See note [Binders and occurrences] ; c' <- repConstr con1 details ; ctxt' <- repContext (eq_ctxt ++ ctxt) - ; ex_bndrs' <- coreList tyVarBndrTyConName ex_bndrs - ; rep2 forallCName [unC ex_bndrs', unC ctxt', unC c'] } } + ; rep2 forallCName [unC ex_bndrs, unC ctxt', unC c'] } } in_subst :: Name -> [(Name,Name)] -> Bool in_subst _ [] = False @@ -426,7 +432,7 @@ mkGadtCtxt data_tvs (ResTyGADT res_ty) = return (go [] [] (data_tvs `zip` tys)) | otherwise - = failWithDs (ptext (sLit "Malformed constructor result type") <+> ppr res_ty) + = failWithDs (ptext (sLit "Malformed constructor result type:") <+> ppr res_ty) where go cxt subst [] = (cxt, subst) go cxt subst ((data_tv, ty) : rest) @@ -566,40 +572,48 @@ rep_InlinePrag (InlinePragma { inl_act = activation, inl_rule = match, inl_inlin -- Types ------------------------------------------------------- --- We process type variable bindings in two ways, either by generating fresh --- names or looking up existing names. The difference is crucial for type --- families, depending on whether they are associated or not. --- -type ProcessTyVarBinds a = - [LHsTyVarBndr Name] -- the binders to be added - -> ([Core TH.TyVarBndr] -> DsM (Core (TH.Q a))) -- action in the ext env - -> DsM (Core (TH.Q a)) - +addTyVarBinds :: [LHsTyVarBndr Name] -- the binders to be added + -> (Core [TH.TyVarBndr] -> DsM (Core (TH.Q a))) -- action in the ext env + -> DsM (Core (TH.Q a)) -- gensym a list of type variables and enter them into the meta environment; -- the computations passed as the second argument is executed in that extended -- meta environment and gets the *new* names on Core-level as an argument --- -addTyVarBinds :: ProcessTyVarBinds a + addTyVarBinds tvs m = do { freshNames <- mkGenSyms (hsLTyVarNames tvs) ; term <- addBinds freshNames $ - do { kindedBndrs <- mapM mk_tv_bndr (tvs `zip` freshNames) - ; m kindedBndrs } + do { kbs1 <- mapM mk_tv_bndr (tvs `zip` freshNames) + ; kbs2 <- coreList tyVarBndrTyConName kbs1 + ; m kbs2 } ; wrapGenSyms freshNames term } where mk_tv_bndr (tv, (_,v)) = repTyVarBndrWithKind tv (coreVar v) --- Look up a list of type variables; the computations passed as the second --- argument gets the *new* names on Core-level as an argument --- -lookupTyVarBinds :: ProcessTyVarBinds a -lookupTyVarBinds tvs m = - do - let names = hsLTyVarNames tvs - mkWithKinds = map repTyVarBndrWithKind tvs - bndrs <- mapM lookupBinder names - kindedBndrs <- zipWithM ($) mkWithKinds bndrs - m kindedBndrs +addTyClTyVarBinds :: [LHsTyVarBndr Name] + -> (Core [TH.TyVarBndr] -> DsM (Core (TH.Q a))) + -> DsM (Core (TH.Q a)) + +-- Used for data/newtype declarations, and family instances, +-- so that the nested type variables work right +-- instance C (T a) where +-- type W (T a) = blah +-- The 'a' in the type instance is the one bound by the instance decl +addTyClTyVarBinds tvs m + = do { let tv_names = hsLTyVarNames tvs + ; env <- dsGetMetaEnv + ; freshNames <- mkGenSyms (filterOut (`elemNameEnv` env) tv_names) + -- Make fresh names for the ones that are not already in scope + -- This makes things work for family declarations + + ; term <- addBinds freshNames $ + do { kbs1 <- mapM mk_tv_bndr tvs + ; kbs2 <- coreList tyVarBndrTyConName kbs1 + ; m kbs2 } + + ; wrapGenSyms freshNames term } + where + mk_tv_bndr tv = do { v <- lookupOcc (hsLTyVarName tv) + ; repTyVarBndrWithKind tv v } -- Produce kinded binder constructors from the Haskell tyvar binders -- @@ -607,7 +621,7 @@ repTyVarBndrWithKind :: LHsTyVarBndr Name -> Core TH.Name -> DsM (Core TH.TyVarBndr) repTyVarBndrWithKind (L _ (UserTyVar {})) nm = repPlainTV nm -repTyVarBndrWithKind (L _ (KindedTyVar _ (HsBSig ki _) _)) nm +repTyVarBndrWithKind (L _ (KindedTyVar _ (HsBSig ki _))) nm = repKind ki >>= repKindedTV nm -- represent a type context @@ -657,8 +671,7 @@ repTy (HsForAllTy _ tvs ctxt ty) = addTyVarBinds tvs $ \bndrs -> do ctxt1 <- repLContext ctxt ty1 <- repLTy ty - bndrs1 <- coreList tyVarBndrTyConName bndrs - repTForall bndrs1 ctxt1 ty1 + repTForall bndrs ctxt1 ty1 repTy (HsTyVar n) | isTvOcc (nameOccName n) = do @@ -1767,7 +1780,7 @@ templateHaskellNames = [ classDName, instanceDName, sigDName, forImpDName, pragInlDName, pragSpecDName, pragSpecInlDName, familyNoKindDName, familyKindDName, dataInstDName, newtypeInstDName, - tySynInstDName, + tySynInstDName, infixLDName, infixRDName, infixNDName, -- Cxt cxtName, -- Pred @@ -1963,7 +1976,8 @@ parSName = libFun (fsLit "parS") parSIdKey funDName, valDName, dataDName, newtypeDName, tySynDName, classDName, instanceDName, sigDName, forImpDName, pragInlDName, pragSpecDName, pragSpecInlDName, familyNoKindDName, familyKindDName, dataInstDName, - newtypeInstDName, tySynInstDName :: Name + newtypeInstDName, tySynInstDName, + infixLDName, infixRDName, infixNDName :: Name funDName = libFun (fsLit "funD") funDIdKey valDName = libFun (fsLit "valD") valDIdKey dataDName = libFun (fsLit "dataD") dataDIdKey @@ -1981,6 +1995,9 @@ familyKindDName = libFun (fsLit "familyKindD") familyKindDIdKey dataInstDName = libFun (fsLit "dataInstD") dataInstDIdKey newtypeInstDName = libFun (fsLit "newtypeInstD") newtypeInstDIdKey tySynInstDName = libFun (fsLit "tySynInstD") tySynInstDIdKey +infixLDName = libFun (fsLit "infixLD") infixLDIdKey +infixRDName = libFun (fsLit "infixRD") infixRDIdKey +infixNDName = libFun (fsLit "infixND") infixNDIdKey -- type Ctxt = ... cxtName :: Name @@ -2245,7 +2262,8 @@ parSIdKey = mkPreludeMiscIdUnique 323 funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey, classDIdKey, instanceDIdKey, sigDIdKey, forImpDIdKey, pragInlDIdKey, pragSpecDIdKey, pragSpecInlDIdKey, familyNoKindDIdKey, familyKindDIdKey, - dataInstDIdKey, newtypeInstDIdKey, tySynInstDIdKey :: Unique + dataInstDIdKey, newtypeInstDIdKey, tySynInstDIdKey, + infixLDIdKey, infixRDIdKey, infixNDIdKey :: Unique funDIdKey = mkPreludeMiscIdUnique 330 valDIdKey = mkPreludeMiscIdUnique 331 dataDIdKey = mkPreludeMiscIdUnique 332 @@ -2263,6 +2281,9 @@ familyKindDIdKey = mkPreludeMiscIdUnique 343 dataInstDIdKey = mkPreludeMiscIdUnique 344 newtypeInstDIdKey = mkPreludeMiscIdUnique 345 tySynInstDIdKey = mkPreludeMiscIdUnique 346 +infixLDIdKey = mkPreludeMiscIdUnique 347 +infixRDIdKey = mkPreludeMiscIdUnique 348 +infixNDIdKey = mkPreludeMiscIdUnique 349 -- type Cxt = ... cxtIdKey :: Unique diff --git a/compiler/deSugar/DsMonad.lhs b/compiler/deSugar/DsMonad.lhs index e68e6db7c2..25141362f8 100644 --- a/compiler/deSugar/DsMonad.lhs +++ b/compiler/deSugar/DsMonad.lhs @@ -27,7 +27,7 @@ module DsMonad ( dsLookupDPHRdrEnv, dsLookupDPHRdrEnv_maybe, dsInitPArrBuiltin, - DsMetaEnv, DsMetaVal(..), dsLookupMetaEnv, dsExtendMetaEnv, + DsMetaEnv, DsMetaVal(..), dsGetMetaEnv, dsLookupMetaEnv, dsExtendMetaEnv, -- Warnings DsWarning, warnDs, failWithDs, @@ -480,6 +480,9 @@ dsInitPArrBuiltin thing_inside \end{code} \begin{code} +dsGetMetaEnv :: DsM (NameEnv DsMetaVal) +dsGetMetaEnv = do { env <- getLclEnv; return (ds_meta env) } + dsLookupMetaEnv :: Name -> DsM (Maybe DsMetaVal) dsLookupMetaEnv name = do { env <- getLclEnv; return (lookupNameEnv (ds_meta env) name) } diff --git a/compiler/deSugar/Match.lhs b/compiler/deSugar/Match.lhs index 974d3183a7..c80446a751 100644 --- a/compiler/deSugar/Match.lhs +++ b/compiler/deSugar/Match.lhs @@ -356,7 +356,7 @@ matchCoercion (var:vars) ty (eqns@(eqn1:_)) ; var' <- newUniqueId var (hsPatType pat) ; match_result <- match (var':vars) ty $ map (decomposeFirstPat getCoPat) eqns - ; let rhs' = dsHsWrapper co (Var var) + ; rhs' <- dsHsWrapper co (Var var) ; return (mkCoLetMatchResult (NonRec var' rhs') match_result) } matchCoercion _ _ _ = panic "matchCoercion" diff --git a/compiler/deSugar/MatchCon.lhs b/compiler/deSugar/MatchCon.lhs index f3b613fdbb..29c10bdb48 100644 --- a/compiler/deSugar/MatchCon.lhs +++ b/compiler/deSugar/MatchCon.lhs @@ -32,6 +32,7 @@ import Id import NameEnv import SrcLoc import Outputable +import Control.Monad(liftM) \end{code} We are confronted with the first column of patterns in a set of @@ -131,18 +132,20 @@ matchOneCon vars ty (eqn1 : eqns) -- All eqns for a single constructor match_group :: [Id] -> [(ConArgPats, EquationInfo)] -> DsM MatchResult -- All members of the group have compatible ConArgPats match_group arg_vars arg_eqn_prs - = do { let (wraps, eqns') = unzip (map shift arg_eqn_prs) - group_arg_vars = select_arg_vars arg_vars arg_eqn_prs + = do { (wraps, eqns') <- liftM unzip (mapM shift arg_eqn_prs) + ; let group_arg_vars = select_arg_vars arg_vars arg_eqn_prs ; match_result <- match (group_arg_vars ++ vars) ty eqns' ; return (adjustMatchResult (foldr1 (.) wraps) match_result) } shift (_, eqn@(EqnInfo { eqn_pats = ConPatOut{ pat_tvs = tvs, pat_dicts = ds, pat_binds = bind, pat_args = args } : pats })) - = ( wrapBinds (tvs `zip` tvs1) - . wrapBinds (ds `zip` dicts1) - . mkCoreLets (dsTcEvBinds bind) - , eqn { eqn_pats = conArgPats arg_tys args ++ pats }) + = do ds_bind <- dsTcEvBinds bind + return ( wrapBinds (tvs `zip` tvs1) + . wrapBinds (ds `zip` dicts1) + . mkCoreLets ds_bind + , eqn { eqn_pats = conArgPats arg_tys args ++ pats } + ) shift (_, (EqnInfo { eqn_pats = ps })) = pprPanic "matchOneCon/shift" (ppr ps) -- Choose the right arg_vars in the right order for this group diff --git a/compiler/ghc.mk b/compiler/ghc.mk index 014094c1d5..b4b3c0e924 100644 --- a/compiler/ghc.mk +++ b/compiler/ghc.mk @@ -405,8 +405,9 @@ endif endif ifeq "$(compiler_stage1_VERSION_MUNGED)" "YES" +compiler_stage1_MUNGED_VERSION = $(subst .$(ProjectPatchLevel),,$(ProjectVersion)) define compiler_PACKAGE_MAGIC -compiler_stage1_VERSION = $(subst .$(ProjectPatchLevel),,$(ProjectVersion)) +compiler_stage1_VERSION = $(compiler_stage1_MUNGED_VERSION) endef # Don't register the non-munged package diff --git a/compiler/ghci/Linker.lhs b/compiler/ghci/Linker.lhs index f4ad61757f..f91ee14de7 100644 --- a/compiler/ghci/Linker.lhs +++ b/compiler/ghci/Linker.lhs @@ -8,25 +8,18 @@ -- calling the object-code linker and the byte-code linker where -- necessary. -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - {-# OPTIONS -fno-cse #-} -- -fno-cse is needed for GLOBAL_VAR's to behave properly module Linker ( HValue, getHValue, showLinkerState, - linkExpr, linkDecls, unload, withExtendedLinkEnv, + linkExpr, linkDecls, unload, withExtendedLinkEnv, extendLinkEnv, deleteFromLinkEnv, - extendLoadedPkgs, - linkPackages,initDynLinker,linkModule, + extendLoadedPkgs, + linkPackages,initDynLinker,linkModule, - -- Saving/restoring globals - PersistentLinkerState, saveLinkerGlobals, restoreLinkerGlobals - ) where + -- Saving/restoring globals + PersistentLinkerState, saveLinkerGlobals, restoreLinkerGlobals + ) where #include "HsVersions.h" @@ -80,12 +73,12 @@ import Exception %************************************************************************ -%* * - The Linker's state -%* * +%* * + The Linker's state +%* * %************************************************************************ -The persistent linker state *must* match the actual state of the +The persistent linker state *must* match the actual state of the C dynamic linker at all times, so we keep it in a private global variable. The global IORef used for PersistentLinkerState actually contains another MVar. @@ -97,7 +90,7 @@ interpreted code only), for use during linking. \begin{code} GLOBAL_VAR_M(v_PersistentLinkerState, newMVar (panic "Dynamic linker not initialised"), MVar PersistentLinkerState) -GLOBAL_VAR(v_InitLinkerDone, False, Bool) -- Set True when dynamic linker is initialised +GLOBAL_VAR(v_InitLinkerDone, False, Bool) -- Set True when dynamic linker is initialised modifyPLS_ :: (PersistentLinkerState -> IO PersistentLinkerState) -> IO () modifyPLS_ f = readIORef v_PersistentLinkerState >>= flip modifyMVar_ f @@ -108,37 +101,37 @@ modifyPLS f = readIORef v_PersistentLinkerState >>= flip modifyMVar f data PersistentLinkerState = PersistentLinkerState { - -- Current global mapping from Names to their true values + -- Current global mapping from Names to their true values closure_env :: ClosureEnv, - -- The current global mapping from RdrNames of DataCons to - -- info table addresses. - -- When a new Unlinked is linked into the running image, or an existing - -- module in the image is replaced, the itbl_env must be updated - -- appropriately. + -- The current global mapping from RdrNames of DataCons to + -- info table addresses. + -- When a new Unlinked is linked into the running image, or an existing + -- module in the image is replaced, the itbl_env must be updated + -- appropriately. itbl_env :: !ItblEnv, - -- The currently loaded interpreted modules (home package) - bcos_loaded :: ![Linkable], + -- The currently loaded interpreted modules (home package) + bcos_loaded :: ![Linkable], - -- And the currently-loaded compiled modules (home package) - objs_loaded :: ![Linkable], + -- And the currently-loaded compiled modules (home package) + objs_loaded :: ![Linkable], - -- The currently-loaded packages; always object code - -- Held, as usual, in dependency order; though I am not sure if - -- that is really important - pkgs_loaded :: ![PackageId] + -- The currently-loaded packages; always object code + -- Held, as usual, in dependency order; though I am not sure if + -- that is really important + pkgs_loaded :: ![PackageId] } emptyPLS :: DynFlags -> PersistentLinkerState -emptyPLS _ = PersistentLinkerState { - closure_env = emptyNameEnv, - itbl_env = emptyNameEnv, - pkgs_loaded = init_pkgs, - bcos_loaded = [], - objs_loaded = [] } - - -- Packages that don't need loading, because the compiler +emptyPLS _ = PersistentLinkerState { + closure_env = emptyNameEnv, + itbl_env = emptyNameEnv, + pkgs_loaded = init_pkgs, + bcos_loaded = [], + objs_loaded = [] } + + -- Packages that don't need loading, because the compiler -- shares them with the interpreted program. -- -- The linker's symbol table is populated with RTS symbols using an @@ -180,7 +173,7 @@ getHValue hsc_env name = do else return (pls, pls) lookupName (closure_env pls) name - + linkDependencies :: HscEnv -> PersistentLinkerState -> SrcSpan -> [Module] -> IO (PersistentLinkerState, SuccessFlag) @@ -188,17 +181,17 @@ linkDependencies hsc_env pls span needed_mods = do -- initDynLinker (hsc_dflags hsc_env) let hpt = hsc_HPT hsc_env dflags = hsc_dflags hsc_env - -- The interpreter and dynamic linker can only handle object code built - -- the "normal" way, i.e. no non-std ways like profiling or ticky-ticky. - -- So here we check the build tag: if we're building a non-standard way - -- then we need to find & link object files built the "normal" way. + -- The interpreter and dynamic linker can only handle object code built + -- the "normal" way, i.e. no non-std ways like profiling or ticky-ticky. + -- So here we check the build tag: if we're building a non-standard way + -- then we need to find & link object files built the "normal" way. maybe_normal_osuf <- checkNonStdWay dflags span - -- Find what packages and linkables are required + -- Find what packages and linkables are required (lnks, pkgs) <- getLinkDeps hsc_env hpt pls - maybe_normal_osuf span needed_mods + maybe_normal_osuf span needed_mods - -- Link the packages and modules required + -- Link the packages and modules required pls1 <- linkPackages' dflags pkgs pls linkModules dflags pls1 lnks @@ -223,35 +216,35 @@ withExtendedLinkEnv new_env action new = delListFromNameEnv cur (map fst new_env) in return pls{ closure_env = new } --- filterNameMap removes from the environment all entries except --- those for a given set of modules; --- Note that this removes all *local* (i.e. non-isExternal) names too --- (these are the temporary bindings from the command line). +-- filterNameMap removes from the environment all entries except +-- those for a given set of modules; +-- Note that this removes all *local* (i.e. non-isExternal) names too +-- (these are the temporary bindings from the command line). -- Used to filter both the ClosureEnv and ItblEnv filterNameMap :: [Module] -> NameEnv (Name, a) -> NameEnv (Name, a) -filterNameMap mods env +filterNameMap mods env = filterNameEnv keep_elt env where - keep_elt (n,_) = isExternalName n - && (nameModule n `elem` mods) + keep_elt (n,_) = isExternalName n + && (nameModule n `elem` mods) -- | Display the persistent linker state. showLinkerState :: IO () showLinkerState - = do pls <- readIORef v_PersistentLinkerState >>= readMVar + = do pls <- readIORef v_PersistentLinkerState >>= readMVar printDump (vcat [text "----- Linker state -----", - text "Pkgs:" <+> ppr (pkgs_loaded pls), - text "Objs:" <+> ppr (objs_loaded pls), - text "BCOs:" <+> ppr (bcos_loaded pls)]) + text "Pkgs:" <+> ppr (pkgs_loaded pls), + text "Objs:" <+> ppr (objs_loaded pls), + text "BCOs:" <+> ppr (bcos_loaded pls)]) \end{code} %************************************************************************ -%* * +%* * \subsection{Initialisation} -%* * +%* * %************************************************************************ \begin{code} @@ -284,56 +277,56 @@ initDynLinker dflags = reallyInitDynLinker :: DynFlags -> IO PersistentLinkerState reallyInitDynLinker dflags = do { -- Initialise the linker state - let pls0 = emptyPLS dflags + let pls0 = emptyPLS dflags - -- (a) initialise the C dynamic linker - ; initObjLinker + -- (a) initialise the C dynamic linker + ; initObjLinker - -- (b) Load packages from the command-line - ; pls <- linkPackages' dflags (preloadPackages (pkgState dflags)) pls0 + -- (b) Load packages from the command-line + ; pls <- linkPackages' dflags (preloadPackages (pkgState dflags)) pls0 - -- (c) Link libraries from the command-line - ; let optl = getOpts dflags opt_l - ; let minus_ls = [ lib | '-':'l':lib <- optl ] + -- (c) Link libraries from the command-line + ; let optl = getOpts dflags opt_l + ; let minus_ls = [ lib | '-':'l':lib <- optl ] ; let lib_paths = libraryPaths dflags ; libspecs <- mapM (locateLib dflags False lib_paths) minus_ls - -- (d) Link .o files from the command-line + -- (d) Link .o files from the command-line ; cmdline_ld_inputs <- readIORef v_Ld_inputs - ; classified_ld_inputs <- mapM classifyLdInput cmdline_ld_inputs + ; classified_ld_inputs <- mapM classifyLdInput cmdline_ld_inputs - -- (e) Link any MacOS frameworks - ; let framework_paths + -- (e) Link any MacOS frameworks + ; let framework_paths | isDarwinTarget = frameworkPaths dflags | otherwise = [] - ; let frameworks + ; let frameworks | isDarwinTarget = cmdlineFrameworks dflags | otherwise = [] - -- Finally do (c),(d),(e) + -- Finally do (c),(d),(e) ; let cmdline_lib_specs = [ l | Just l <- classified_ld_inputs ] ++ libspecs - ++ map Framework frameworks - ; if null cmdline_lib_specs then return pls - else do + ++ map Framework frameworks + ; if null cmdline_lib_specs then return pls + else do - { mapM_ (preloadLib dflags lib_paths framework_paths) cmdline_lib_specs - ; maybePutStr dflags "final link ... " - ; ok <- resolveObjs + { mapM_ (preloadLib dflags lib_paths framework_paths) cmdline_lib_specs + ; maybePutStr dflags "final link ... " + ; ok <- resolveObjs - ; if succeeded ok then maybePutStrLn dflags "done" - else ghcError (ProgramError "linking extra libraries/objects failed") + ; if succeeded ok then maybePutStrLn dflags "done" + else ghcError (ProgramError "linking extra libraries/objects failed") ; return pls - }} + }} classifyLdInput :: FilePath -> IO (Maybe LibrarySpec) classifyLdInput f | isObjectFilename f = return (Just (Object f)) | isDynLibFilename f = return (Just (DLLPath f)) - | otherwise = do - hPutStrLn stderr ("Warning: ignoring unrecognised input `" ++ f ++ "'") - return Nothing + | otherwise = do + hPutStrLn stderr ("Warning: ignoring unrecognised input `" ++ f ++ "'") + return Nothing preloadLib :: DynFlags -> [String] -> [String] -> LibrarySpec -> IO () preloadLib dflags lib_paths framework_paths lib_spec @@ -355,13 +348,13 @@ preloadLib dflags lib_paths framework_paths lib_spec Nothing -> maybePutStrLn dflags "done" Just mm -> preloadFailed mm lib_paths lib_spec - DLLPath dll_path - -> do maybe_errstr <- loadDLL dll_path + DLLPath dll_path + -> do maybe_errstr <- loadDLL dll_path case maybe_errstr of Nothing -> maybePutStrLn dflags "done" Just mm -> preloadFailed mm lib_paths lib_spec - Framework framework + Framework framework | isDarwinTarget -> do maybe_errstr <- loadFramework framework_paths framework case maybe_errstr of @@ -374,13 +367,13 @@ preloadLib dflags lib_paths framework_paths lib_spec preloadFailed sys_errmsg paths spec = do maybePutStr dflags "failed.\n" ghcError $ - CmdLineError ( + CmdLineError ( "user specified .o/.so/.DLL could not be loaded (" ++ sys_errmsg ++ ")\nWhilst trying to load: " ++ showLS spec ++ "\nAdditional directories searched:" ++ (if null paths then " (none)" else (concat (intersperse "\n" (map (" "++) paths))))) - + -- Not interested in the paths in the static case. preload_static _paths name = do b <- doesFileExist name @@ -394,9 +387,9 @@ preloadLib dflags lib_paths framework_paths lib_spec %************************************************************************ -%* * - Link a byte-code expression -%* * +%* * + Link a byte-code expression +%* * %************************************************************************ \begin{code} @@ -408,25 +401,25 @@ preloadLib dflags lib_paths framework_paths lib_spec -- linkExpr :: HscEnv -> SrcSpan -> UnlinkedBCO -> IO HValue linkExpr hsc_env span root_ul_bco - = do { - -- Initialise the linker (if it's not been done already) + = do { + -- Initialise the linker (if it's not been done already) let dflags = hsc_dflags hsc_env ; initDynLinker dflags - -- Take lock for the actual work. + -- Take lock for the actual work. ; modifyPLS $ \pls0 -> do { - -- Link the packages and modules required + -- Link the packages and modules required ; (pls, ok) <- linkDependencies hsc_env pls0 span needed_mods ; if failed ok then - ghcError (ProgramError "") + ghcError (ProgramError "") else do { - -- Link the expression itself + -- Link the expression itself let ie = itbl_env pls - ce = closure_env pls + ce = closure_env pls - -- Link the necessary packages and linkables + -- Link the necessary packages and linkables ; (_, (root_hval:_)) <- linkSomeBCOs False ie ce [root_ul_bco] ; return (pls, root_hval) }}} @@ -434,15 +427,15 @@ linkExpr hsc_env span root_ul_bco free_names = nameSetToList (bcoFreeNames root_ul_bco) needed_mods :: [Module] - needed_mods = [ nameModule n | n <- free_names, + needed_mods = [ nameModule n | n <- free_names, isExternalName n, -- Names from other modules not (isWiredInName n) -- Exclude wired-in names ] -- (see note below) - -- Exclude wired-in names because we may not have read - -- their interface files, so getLinkDeps will fail - -- All wired-in names are in the base package, which we link - -- by default, so we can safely ignore them here. - + -- Exclude wired-in names because we may not have read + -- their interface files, so getLinkDeps will fail + -- All wired-in names are in the base package, which we link + -- by default, so we can safely ignore them here. + dieWith :: SrcSpan -> MsgDoc -> IO a dieWith span msg = ghcError (ProgramError (showSDoc (mkLocMessage SevFatal span msg))) @@ -472,41 +465,41 @@ failNonStd srcspan = dieWith srcspan $ ptext (sLit "Dynamic linking required, but this is a non-standard build (eg. prof).") $$ ptext (sLit "You need to build the program twice: once the normal way, and then") $$ ptext (sLit "in the desired way using -osuf to set the object file suffix.") - + getLinkDeps :: HscEnv -> HomePackageTable -> PersistentLinkerState -> Bool -- replace object suffices? - -> SrcSpan -- for error messages - -> [Module] -- If you need these - -> IO ([Linkable], [PackageId]) -- ... then link these first + -> SrcSpan -- for error messages + -> [Module] -- If you need these + -> IO ([Linkable], [PackageId]) -- ... then link these first -- Fails with an IO exception if it can't find enough files getLinkDeps hsc_env hpt pls replace_osuf span mods -- Find all the packages and linkables that a set of modules depends on = do { - -- 1. Find the dependent home-pkg-modules/packages from each iface + -- 1. Find the dependent home-pkg-modules/packages from each iface -- (omitting iINTERACTIVE, which is already linked) (mods_s, pkgs_s) <- follow_deps (filter ((/=) iNTERACTIVE) mods) emptyUniqSet emptyUniqSet; - let { - -- 2. Exclude ones already linked - -- Main reason: avoid findModule calls in get_linkable - mods_needed = mods_s `minusList` linked_mods ; - pkgs_needed = pkgs_s `minusList` pkgs_loaded pls ; + let { + -- 2. Exclude ones already linked + -- Main reason: avoid findModule calls in get_linkable + mods_needed = mods_s `minusList` linked_mods ; + pkgs_needed = pkgs_s `minusList` pkgs_loaded pls ; - linked_mods = map (moduleName.linkableModule) + linked_mods = map (moduleName.linkableModule) (objs_loaded pls ++ bcos_loaded pls) - } ; - - -- 3. For each dependent module, find its linkable - -- This will either be in the HPT or (in the case of one-shot - -- compilation) we may need to use maybe_getFileLinkable + } ; + + -- 3. For each dependent module, find its linkable + -- This will either be in the HPT or (in the case of one-shot + -- compilation) we may need to use maybe_getFileLinkable let { osuf = objectSuf dflags } ; lnks_needed <- mapM (get_linkable osuf replace_osuf) mods_needed ; - return (lnks_needed, pkgs_needed) } + return (lnks_needed, pkgs_needed) } where dflags = hsc_dflags hsc_env this_pkg = thisPackage dflags @@ -527,8 +520,8 @@ getLinkDeps hsc_env hpt pls replace_osuf span mods mb_iface <- initIfaceCheck hsc_env $ loadInterface msg mod (ImportByUser False) iface <- case mb_iface of - Maybes.Failed err -> ghcError (ProgramError (showSDoc err)) - Maybes.Succeeded iface -> return iface + Maybes.Failed err -> ghcError (ProgramError (showSDoc err)) + Maybes.Succeeded iface -> return iface when (mi_boot iface) $ link_boot_mod_error mod @@ -554,44 +547,44 @@ getLinkDeps hsc_env hpt pls replace_osuf span mods text "due to use of Template Haskell" - link_boot_mod_error mod = + link_boot_mod_error mod = ghcError (ProgramError (showSDoc ( - text "module" <+> ppr mod <+> + text "module" <+> ppr mod <+> text "cannot be linked; it is only available as a boot module"))) no_obj :: Outputable a => a -> IO b no_obj mod = dieWith span $ - ptext (sLit "cannot find object file for module ") <> - quotes (ppr mod) $$ - while_linking_expr - + ptext (sLit "cannot find object file for module ") <> + quotes (ppr mod) $$ + while_linking_expr + while_linking_expr = ptext (sLit "while linking an interpreted expression") - -- This one is a build-system bug + -- This one is a build-system bug get_linkable osuf replace_osuf mod_name -- A home-package module - | Just mod_info <- lookupUFM hpt mod_name - = adjust_linkable (Maybes.expectJust "getLinkDeps" (hm_linkable mod_info)) - | otherwise - = do -- It's not in the HPT because we are in one shot mode, - -- so use the Finder to get a ModLocation... - mb_stuff <- findHomeModule hsc_env mod_name - case mb_stuff of - Found loc mod -> found loc mod - _ -> no_obj mod_name + | Just mod_info <- lookupUFM hpt mod_name + = adjust_linkable (Maybes.expectJust "getLinkDeps" (hm_linkable mod_info)) + | otherwise + = do -- It's not in the HPT because we are in one shot mode, + -- so use the Finder to get a ModLocation... + mb_stuff <- findHomeModule hsc_env mod_name + case mb_stuff of + Found loc mod -> found loc mod + _ -> no_obj mod_name where found loc mod = do { - -- ...and then find the linkable for it - mb_lnk <- findObjectLinkableMaybe mod loc ; - case mb_lnk of { - Nothing -> no_obj mod ; - Just lnk -> adjust_linkable lnk - }} + -- ...and then find the linkable for it + mb_lnk <- findObjectLinkableMaybe mod loc ; + case mb_lnk of { + Nothing -> no_obj mod ; + Just lnk -> adjust_linkable lnk + }} adjust_linkable lnk | replace_osuf = do new_uls <- mapM adjust_ul (linkableUnlinked lnk) - return lnk{ linkableUnlinked=new_uls } + return lnk{ linkableUnlinked=new_uls } | otherwise = return lnk @@ -600,19 +593,19 @@ getLinkDeps hsc_env hpt pls replace_osuf span mods let new_file = reverse (drop (length osuf + 1) (reverse file)) <.> normalObjectSuffix ok <- doesFileExist new_file - if (not ok) - then dieWith span $ - ptext (sLit "cannot find normal object file ") - <> quotes (text new_file) $$ while_linking_expr - else return (DotO new_file) + if (not ok) + then dieWith span $ + ptext (sLit "cannot find normal object file ") + <> quotes (text new_file) $$ while_linking_expr + else return (DotO new_file) adjust_ul _ = panic "adjust_ul" \end{code} %************************************************************************ -%* * +%* * Loading a Decls statement -%* * +%* * %************************************************************************ \begin{code} linkDecls :: HscEnv -> SrcSpan -> CompiledByteCode -> IO () --[HValue] @@ -643,7 +636,7 @@ linkDecls hsc_env span (ByteCode unlinkedBCOs itblEnv) = do free_names = concatMap (nameSetToList . bcoFreeNames) unlinkedBCOs needed_mods :: [Module] - needed_mods = [ nameModule n | n <- free_names, + needed_mods = [ nameModule n | n <- free_names, isExternalName n, -- Names from other modules not (isWiredInName n) -- Exclude wired-in names ] -- (see note below) @@ -656,9 +649,9 @@ linkDecls hsc_env span (ByteCode unlinkedBCOs itblEnv) = do %************************************************************************ -%* * +%* * Loading a single module -%* * +%* * %************************************************************************ \begin{code} @@ -672,11 +665,11 @@ linkModule hsc_env mod = do \end{code} %************************************************************************ -%* * - Link some linkables - The linkables may consist of a mixture of - byte-code modules and object modules -%* * +%* * + Link some linkables + The linkables may consist of a mixture of + byte-code modules and object modules +%* * %************************************************************************ \begin{code} @@ -684,19 +677,19 @@ linkModules :: DynFlags -> PersistentLinkerState -> [Linkable] -> IO (PersistentLinkerState, SuccessFlag) linkModules dflags pls linkables = mask_ $ do -- don't want to be interrupted by ^C in here - - let (objs, bcos) = partition isObjectLinkable + + let (objs, bcos) = partition isObjectLinkable (concatMap partitionLinkable linkables) - -- Load objects first; they can't depend on BCOs - (pls1, ok_flag) <- dynLinkObjs dflags pls objs + -- Load objects first; they can't depend on BCOs + (pls1, ok_flag) <- dynLinkObjs dflags pls objs + + if failed ok_flag then + return (pls1, Failed) + else do + pls2 <- dynLinkBCOs pls1 bcos + return (pls2, Succeeded) - if failed ok_flag then - return (pls1, Failed) - else do - pls2 <- dynLinkBCOs pls1 bcos - return (pls2, Succeeded) - -- HACK to support f-x-dynamic in the interpreter; no other purpose partitionLinkable :: Linkable -> [Linkable] @@ -704,7 +697,7 @@ partitionLinkable li = let li_uls = linkableUnlinked li li_uls_obj = filter isObject li_uls li_uls_bco = filter isInterpretable li_uls - in + in case (li_uls_obj, li_uls_bco) of (_:_, _:_) -> [li {linkableUnlinked=li_uls_obj}, li {linkableUnlinked=li_uls_bco}] @@ -720,118 +713,118 @@ findModuleLinkable_maybe lis mod linkableInSet :: Linkable -> [Linkable] -> Bool linkableInSet l objs_loaded = case findModuleLinkable_maybe objs_loaded (linkableModule l) of - Nothing -> False - Just m -> linkableTime l == linkableTime m + Nothing -> False + Just m -> linkableTime l == linkableTime m \end{code} %************************************************************************ -%* * +%* * \subsection{The object-code linker} -%* * +%* * %************************************************************************ \begin{code} dynLinkObjs :: DynFlags -> PersistentLinkerState -> [Linkable] -> IO (PersistentLinkerState, SuccessFlag) dynLinkObjs dflags pls objs = do - -- Load the object files and link them - let (objs_loaded', new_objs) = rmDupLinkables (objs_loaded pls) objs - pls1 = pls { objs_loaded = objs_loaded' } - unlinkeds = concatMap linkableUnlinked new_objs - - mapM_ loadObj (map nameOfObject unlinkeds) - - -- Link the all together - ok <- resolveObjs - - -- If resolving failed, unload all our - -- object modules and carry on - if succeeded ok then do - return (pls1, Succeeded) - else do - pls2 <- unload_wkr dflags [] pls1 + -- Load the object files and link them + let (objs_loaded', new_objs) = rmDupLinkables (objs_loaded pls) objs + pls1 = pls { objs_loaded = objs_loaded' } + unlinkeds = concatMap linkableUnlinked new_objs + + mapM_ loadObj (map nameOfObject unlinkeds) + + -- Link the all together + ok <- resolveObjs + + -- If resolving failed, unload all our + -- object modules and carry on + if succeeded ok then do + return (pls1, Succeeded) + else do + pls2 <- unload_wkr dflags [] pls1 return (pls2, Failed) -rmDupLinkables :: [Linkable] -- Already loaded - -> [Linkable] -- New linkables - -> ([Linkable], -- New loaded set (including new ones) - [Linkable]) -- New linkables (excluding dups) +rmDupLinkables :: [Linkable] -- Already loaded + -> [Linkable] -- New linkables + -> ([Linkable], -- New loaded set (including new ones) + [Linkable]) -- New linkables (excluding dups) rmDupLinkables already ls = go already [] ls where go already extras [] = (already, extras) go already extras (l:ls) - | linkableInSet l already = go already extras ls - | otherwise = go (l:already) (l:extras) ls + | linkableInSet l already = go already extras ls + | otherwise = go (l:already) (l:extras) ls \end{code} %************************************************************************ -%* * +%* * \subsection{The byte-code linker} -%* * +%* * %************************************************************************ \begin{code} dynLinkBCOs :: PersistentLinkerState -> [Linkable] -> IO PersistentLinkerState dynLinkBCOs pls bcos = do - let (bcos_loaded', new_bcos) = rmDupLinkables (bcos_loaded pls) bcos - pls1 = pls { bcos_loaded = bcos_loaded' } - unlinkeds :: [Unlinked] - unlinkeds = concatMap linkableUnlinked new_bcos - - cbcs :: [CompiledByteCode] - cbcs = map byteCodeOfObject unlinkeds - - - ul_bcos = [b | ByteCode bs _ <- cbcs, b <- bs] - ies = [ie | ByteCode _ ie <- cbcs] - gce = closure_env pls + let (bcos_loaded', new_bcos) = rmDupLinkables (bcos_loaded pls) bcos + pls1 = pls { bcos_loaded = bcos_loaded' } + unlinkeds :: [Unlinked] + unlinkeds = concatMap linkableUnlinked new_bcos + + cbcs :: [CompiledByteCode] + cbcs = map byteCodeOfObject unlinkeds + + + ul_bcos = [b | ByteCode bs _ <- cbcs, b <- bs] + ies = [ie | ByteCode _ ie <- cbcs] + gce = closure_env pls final_ie = foldr plusNameEnv (itbl_env pls) ies (final_gce, _linked_bcos) <- linkSomeBCOs True final_ie gce ul_bcos - -- XXX What happens to these linked_bcos? + -- XXX What happens to these linked_bcos? - let pls2 = pls1 { closure_env = final_gce, - itbl_env = final_ie } + let pls2 = pls1 { closure_env = final_gce, + itbl_env = final_ie } - return pls2 + return pls2 -- Link a bunch of BCOs and return them + updated closure env. -linkSomeBCOs :: Bool -- False <=> add _all_ BCOs to returned closure env +linkSomeBCOs :: Bool -- False <=> add _all_ BCOs to returned closure env -- True <=> add only toplevel BCOs to closure env - -> ItblEnv - -> ClosureEnv + -> ItblEnv + -> ClosureEnv -> [UnlinkedBCO] -> IO (ClosureEnv, [HValue]) - -- The returned HValues are associated 1-1 with - -- the incoming unlinked BCOs. Each gives the - -- value of the corresponding unlinked BCO - + -- The returned HValues are associated 1-1 with + -- the incoming unlinked BCOs. Each gives the + -- value of the corresponding unlinked BCO + linkSomeBCOs toplevs_only ie ce_in ul_bcos = do let nms = map unlinkedBCOName ul_bcos - hvals <- fixIO + hvals <- fixIO ( \ hvs -> let ce_out = extendClosureEnv ce_in (zipLazy nms hvs) in mapM (linkBCO ie ce_out) ul_bcos ) let ce_all_additions = zip nms hvals ce_top_additions = filter (isExternalName.fst) ce_all_additions - ce_additions = if toplevs_only then ce_top_additions + ce_additions = if toplevs_only then ce_top_additions else ce_all_additions - ce_out = -- make sure we're not inserting duplicate names into the - -- closure environment, which leads to trouble. - ASSERT (all (not . (`elemNameEnv` ce_in)) (map fst ce_additions)) - extendClosureEnv ce_in ce_additions + ce_out = -- make sure we're not inserting duplicate names into the + -- closure environment, which leads to trouble. + ASSERT (all (not . (`elemNameEnv` ce_in)) (map fst ce_additions)) + extendClosureEnv ce_in ce_additions return (ce_out, hvals) \end{code} %************************************************************************ -%* * - Unload some object modules -%* * +%* * + Unload some object modules +%* * %************************************************************************ \begin{code} @@ -854,92 +847,92 @@ unload :: DynFlags -> IO () unload dflags linkables = mask_ $ do -- mask, so we're safe from Ctrl-C in here - - -- Initialise the linker (if it's not been done already) - initDynLinker dflags - new_pls + -- Initialise the linker (if it's not been done already) + initDynLinker dflags + + new_pls <- modifyPLS $ \pls -> do - pls1 <- unload_wkr dflags linkables pls + pls1 <- unload_wkr dflags linkables pls return (pls1, pls1) - debugTraceMsg dflags 3 (text "unload: retaining objs" <+> ppr (objs_loaded new_pls)) - debugTraceMsg dflags 3 (text "unload: retaining bcos" <+> ppr (bcos_loaded new_pls)) - return () + debugTraceMsg dflags 3 (text "unload: retaining objs" <+> ppr (objs_loaded new_pls)) + debugTraceMsg dflags 3 (text "unload: retaining bcos" <+> ppr (bcos_loaded new_pls)) + return () unload_wkr :: DynFlags - -> [Linkable] -- stable linkables - -> PersistentLinkerState + -> [Linkable] -- stable linkables + -> PersistentLinkerState -> IO PersistentLinkerState -- Does the core unload business -- (the wrapper blocks exceptions and deals with the PLS get and put) unload_wkr _ linkables pls - = do let (objs_to_keep, bcos_to_keep) = partition isObjectLinkable linkables + = do let (objs_to_keep, bcos_to_keep) = partition isObjectLinkable linkables - objs_loaded' <- filterM (maybeUnload objs_to_keep) (objs_loaded pls) + objs_loaded' <- filterM (maybeUnload objs_to_keep) (objs_loaded pls) bcos_loaded' <- filterM (maybeUnload bcos_to_keep) (bcos_loaded pls) - let bcos_retained = map linkableModule bcos_loaded' - itbl_env' = filterNameMap bcos_retained (itbl_env pls) + let bcos_retained = map linkableModule bcos_loaded' + itbl_env' = filterNameMap bcos_retained (itbl_env pls) closure_env' = filterNameMap bcos_retained (closure_env pls) - new_pls = pls { itbl_env = itbl_env', - closure_env = closure_env', - bcos_loaded = bcos_loaded', - objs_loaded = objs_loaded' } + new_pls = pls { itbl_env = itbl_env', + closure_env = closure_env', + bcos_loaded = bcos_loaded', + objs_loaded = objs_loaded' } - return new_pls + return new_pls where maybeUnload :: [Linkable] -> Linkable -> IO Bool maybeUnload keep_linkables lnk | linkableInSet lnk keep_linkables = return True - | otherwise + | otherwise = do mapM_ unloadObj [f | DotO f <- linkableUnlinked lnk] - -- The components of a BCO linkable may contain - -- dot-o files. Which is very confusing. - -- - -- But the BCO parts can be unlinked just by - -- letting go of them (plus of course depopulating - -- the symbol table which is done in the main body) - return False + -- The components of a BCO linkable may contain + -- dot-o files. Which is very confusing. + -- + -- But the BCO parts can be unlinked just by + -- letting go of them (plus of course depopulating + -- the symbol table which is done in the main body) + return False \end{code} %************************************************************************ -%* * - Loading packages -%* * +%* * + Loading packages +%* * %************************************************************************ \begin{code} -data LibrarySpec - = Object FilePath -- Full path name of a .o file, including trailing .o - -- For dynamic objects only, try to find the object - -- file in all the directories specified in - -- v_Library_paths before giving up. +data LibrarySpec + = Object FilePath -- Full path name of a .o file, including trailing .o + -- For dynamic objects only, try to find the object + -- file in all the directories specified in + -- v_Library_paths before giving up. - | Archive FilePath -- Full path name of a .a file, including trailing .a + | Archive FilePath -- Full path name of a .a file, including trailing .a - | DLL String -- "Unadorned" name of a .DLL/.so - -- e.g. On unix "qt" denotes "libqt.so" - -- On WinDoze "burble" denotes "burble.DLL" - -- loadDLL is platform-specific and adds the lib/.so/.DLL - -- suffixes platform-dependently + | DLL String -- "Unadorned" name of a .DLL/.so + -- e.g. On unix "qt" denotes "libqt.so" + -- On WinDoze "burble" denotes "burble.DLL" + -- loadDLL is platform-specific and adds the lib/.so/.DLL + -- suffixes platform-dependently | DLLPath FilePath -- Absolute or relative pathname to a dynamic library - -- (ends with .dll or .so). + -- (ends with .dll or .so). - | Framework String -- Only used for darwin, but does no harm + | Framework String -- Only used for darwin, but does no harm -- If this package is already part of the GHCi binary, we'll already -- have the right DLLs for this package loaded, so don't try to -- load them again. --- +-- -- But on Win32 we must load them 'again'; doing so is a harmless no-op -- as far as the loader is concerned, but it does initialise the list --- of DLL handles that rts/Linker.c maintains, and that in turn is --- used by lookupSymbol. So we must call addDLL for each library +-- of DLL handles that rts/Linker.c maintains, and that in turn is +-- used by lookupSymbol. So we must call addDLL for each library -- just to get the DLL handle into the list. partOfGHCi :: [PackageName] partOfGHCi @@ -964,7 +957,7 @@ linkPackages :: DynFlags -> [PackageId] -> IO () -- we don't really need to use the package-config dependencies. -- -- However we do need the package-config stuff (to find aux libs etc), --- and following them lets us load libraries in the right order, which +-- and following them lets us load libraries in the right order, which -- perhaps makes the error message a bit more localised if we get a link -- failure. So the dependency walking code is still here. @@ -989,25 +982,25 @@ linkPackages' dflags new_pks pls = do foldM link_one pkgs new_pkgs link_one pkgs new_pkg - | new_pkg `elem` pkgs -- Already linked - = return pkgs + | new_pkg `elem` pkgs -- Already linked + = return pkgs - | Just pkg_cfg <- lookupPackage pkg_map new_pkg - = do { -- Link dependents first + | Just pkg_cfg <- lookupPackage pkg_map new_pkg + = do { -- Link dependents first pkgs' <- link pkgs [ Maybes.expectJust "link_one" $ Map.lookup ipid ipid_map | ipid <- depends pkg_cfg ] - -- Now link the package itself - ; linkPackage dflags pkg_cfg - ; return (new_pkg : pkgs') } + -- Now link the package itself + ; linkPackage dflags pkg_cfg + ; return (new_pkg : pkgs') } - | otherwise - = ghcError (CmdLineError ("unknown package: " ++ packageIdString new_pkg)) + | otherwise + = ghcError (CmdLineError ("unknown package: " ++ packageIdString new_pkg)) linkPackage :: DynFlags -> PackageConfig -> IO () linkPackage dflags pkg - = do + = do let dirs = Packages.libraryDirs pkg let hs_libs = Packages.hsLibraries pkg @@ -1035,29 +1028,29 @@ linkPackage dflags pkg extra_classifieds <- mapM (locateLib dflags False dirs) extra_libs let classifieds = hs_classifieds ++ extra_classifieds - -- Complication: all the .so's must be loaded before any of the .o's. + -- Complication: all the .so's must be loaded before any of the .o's. let known_dlls = [ dll | DLLPath dll <- classifieds ] dlls = [ dll | DLL dll <- classifieds ] objs = [ obj | Object obj <- classifieds ] archs = [ arch | Archive arch <- classifieds ] - maybePutStr dflags ("Loading package " ++ display (sourcePackageId pkg) ++ " ... ") + maybePutStr dflags ("Loading package " ++ display (sourcePackageId pkg) ++ " ... ") - -- See comments with partOfGHCi - when (packageName pkg `notElem` partOfGHCi) $ do - loadFrameworks pkg + -- See comments with partOfGHCi + when (packageName pkg `notElem` partOfGHCi) $ do + loadFrameworks pkg mapM_ load_dyn (known_dlls ++ map mkSOName dlls) - -- After loading all the DLLs, we can load the static objects. - -- Ordering isn't important here, because we do one final link - -- step to resolve everything. - mapM_ loadObj objs - mapM_ loadArchive archs + -- After loading all the DLLs, we can load the static objects. + -- Ordering isn't important here, because we do one final link + -- step to resolve everything. + mapM_ loadObj objs + mapM_ loadArchive archs maybePutStr dflags "linking ... " ok <- resolveObjs - if succeeded ok then maybePutStrLn dflags "done." - else ghcError (InstallationError ("unable to load package `" ++ display (sourcePackageId pkg) ++ "'")) + if succeeded ok then maybePutStrLn dflags "done." + else ghcError (InstallationError ("unable to load package `" ++ display (sourcePackageId pkg) ++ "'")) -- we have already searched the filesystem; the strings passed to load_dyn -- can be passed directly to loadDLL. They are either fully-qualified @@ -1080,10 +1073,10 @@ loadFrameworks pkg frameworks = Packages.frameworks pkg load fw = do r <- loadFramework fw_dirs fw - case r of - Nothing -> return () - Just err -> ghcError (CmdLineError ("can't load framework: " - ++ fw ++ " (" ++ err ++ ")" )) + case r of + Nothing -> return () + Just err -> ghcError (CmdLineError ("can't load framework: " + ++ fw ++ " (" ++ err ++ ")" )) -- Try to find an object file for a given library in the given paths. -- If it isn't present, we assume that addDLL in the RTS can find it, @@ -1178,40 +1171,40 @@ loadFramework extraPaths rootname \end{code} %************************************************************************ -%* * - Helper functions -%* * +%* * + Helper functions +%* * %************************************************************************ \begin{code} -findFile :: (FilePath -> FilePath) -- Maps a directory path to a file path - -> [FilePath] -- Directories to look in - -> IO (Maybe FilePath) -- The first file path to match -findFile _ [] +findFile :: (FilePath -> FilePath) -- Maps a directory path to a file path + -> [FilePath] -- Directories to look in + -> IO (Maybe FilePath) -- The first file path to match +findFile _ [] = return Nothing findFile mk_file_path (dir:dirs) - = do { let file_path = mk_file_path dir - ; b <- doesFileExist file_path - ; if b then - return (Just file_path) - else - findFile mk_file_path dirs } + = do { let file_path = mk_file_path dir + ; b <- doesFileExist file_path + ; if b then + return (Just file_path) + else + findFile mk_file_path dirs } \end{code} \begin{code} maybePutStr :: DynFlags -> String -> IO () maybePutStr dflags s | verbosity dflags > 0 = putStr s - | otherwise = return () + | otherwise = return () maybePutStrLn :: DynFlags -> String -> IO () maybePutStrLn dflags s | verbosity dflags > 0 = putStrLn s - | otherwise = return () + | otherwise = return () \end{code} %************************************************************************ -%* * - Tunneling global variables into new instance of GHC library -%* * +%* * + Tunneling global variables into new instance of GHC library +%* * %************************************************************************ \begin{code} diff --git a/compiler/ghci/ObjLink.lhs b/compiler/ghci/ObjLink.lhs index dedc9ceb2f..2e3965ab0d 100644 --- a/compiler/ghci/ObjLink.lhs +++ b/compiler/ghci/ObjLink.lhs @@ -3,38 +3,31 @@ % -- --------------------------------------------------------------------------- --- The dynamic linker for object code (.o .so .dll files) +-- The dynamic linker for object code (.o .so .dll files) -- --------------------------------------------------------------------------- Primarily, this module consists of an interface to the C-land dynamic linker. \begin{code} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - -module ObjLink ( - initObjLinker, -- :: IO () - loadDLL, -- :: String -> IO (Maybe String) - loadArchive, -- :: String -> IO () - loadObj, -- :: String -> IO () - unloadObj, -- :: String -> IO () +module ObjLink ( + initObjLinker, -- :: IO () + loadDLL, -- :: String -> IO (Maybe String) + loadArchive, -- :: String -> IO () + loadObj, -- :: String -> IO () + unloadObj, -- :: String -> IO () insertSymbol, -- :: String -> String -> Ptr a -> IO () - lookupSymbol, -- :: String -> IO (Maybe (Ptr a)) - resolveObjs -- :: IO SuccessFlag + lookupSymbol, -- :: String -> IO (Maybe (Ptr a)) + resolveObjs -- :: IO SuccessFlag ) where import Panic -import BasicTypes ( SuccessFlag, successIf ) -import Config ( cLeadingUnderscore ) +import BasicTypes ( SuccessFlag, successIf ) +import Config ( cLeadingUnderscore ) import Util import Control.Monad ( when ) import Foreign.C -import Foreign ( nullPtr ) +import Foreign ( nullPtr ) import GHC.Exts ( Ptr(..) ) import System.Posix.Internals ( CFilePath, withFilePath ) import System.FilePath ( dropExtension ) @@ -57,8 +50,8 @@ lookupSymbol str_in = do withCAString str $ \c_str -> do addr <- c_lookupSymbol c_str if addr == nullPtr - then return Nothing - else return (Just addr) + then return Nothing + else return (Just addr) prefixUnderscore :: String -> String prefixUnderscore @@ -85,9 +78,9 @@ loadDLL str0 = do -- maybe_errmsg <- withFilePath str $ \dll -> c_addDLL dll if maybe_errmsg == nullPtr - then return Nothing - else do str <- peekCString maybe_errmsg - return (Just str) + then return Nothing + else do str <- peekCString maybe_errmsg + return (Just str) loadArchive :: String -> IO () loadArchive str = do diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs index 4bff46c853..90deaa7edf 100644 --- a/compiler/hsSyn/Convert.lhs +++ b/compiler/hsSyn/Convert.lhs @@ -31,7 +31,6 @@ import TysWiredIn import BasicTypes as Hs import ForeignCall import Unique -import MonadUtils import ErrUtils import Bag import Util @@ -42,7 +41,6 @@ import Control.Monad( unless ) import Language.Haskell.TH as TH hiding (sigP) import Language.Haskell.TH.Syntax as TH - import GHC.Exts ------------------------------------------------------------------- @@ -154,6 +152,10 @@ cvtDec (TH.SigD nm typ) ; ty' <- cvtType typ ; returnL $ Hs.SigD (TypeSig [nm'] ty') } +cvtDec (TH.InfixD fx nm) + = do { nm' <- vNameL nm + ; returnL (Hs.SigD (FixSig (FixitySig nm' (cvtFixity fx)))) } + cvtDec (PragmaD prag) = do { prag' <- cvtPragmaD prag ; returnL $ Hs.SigD prag' } @@ -161,45 +163,52 @@ cvtDec (PragmaD prag) cvtDec (TySynD tc tvs rhs) = do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs ; rhs' <- cvtType rhs - ; returnL $ TyClD (TySynonym { tcdLName = tc' - , tcdTyVars = tvs', tcdTyPats = Nothing - , tcdSynRhs = rhs', tcdFVs = placeHolderNames }) } + ; returnL $ TyClD (TyDecl { tcdLName = tc' + , tcdTyVars = tvs' + , tcdTyDefn = TySynonym rhs' + , tcdFVs = placeHolderNames }) } cvtDec (DataD ctxt tc tvs constrs derivs) = do { (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs ; cons' <- mapM cvtConstr constrs ; derivs' <- cvtDerivs derivs - ; returnL $ TyClD (TyData { tcdND = DataType, tcdCType = Nothing - , tcdLName = tc', tcdCtxt = ctxt' - , tcdTyVars = tvs', tcdTyPats = Nothing, tcdKindSig = Nothing - , tcdCons = cons', tcdDerivs = derivs' }) } + ; let defn = TyData { td_ND = DataType, td_cType = Nothing + , td_ctxt = ctxt' + , td_kindSig = Nothing + , td_cons = cons', td_derivs = derivs' } + ; returnL $ TyClD (TyDecl { tcdLName = tc', tcdTyVars = tvs' + , tcdTyDefn = defn, tcdFVs = placeHolderNames }) } cvtDec (NewtypeD ctxt tc tvs constr derivs) = do { (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs ; con' <- cvtConstr constr ; derivs' <- cvtDerivs derivs - ; returnL $ TyClD (TyData { tcdND = NewType, tcdCType = Nothing - , tcdLName = tc', tcdCtxt = ctxt' - , tcdTyVars = tvs', tcdTyPats = Nothing, tcdKindSig = Nothing - , tcdCons = [con'], tcdDerivs = derivs'}) } + ; let defn = TyData { td_ND = DataType, td_cType = Nothing + , td_ctxt = ctxt' + , td_kindSig = Nothing + , td_cons = [con'], td_derivs = derivs' } + ; returnL $ TyClD (TyDecl { tcdLName = tc', tcdTyVars = tvs' + , tcdTyDefn = defn, tcdFVs = placeHolderNames }) } cvtDec (ClassD ctxt cl tvs fds decs) = do { (cxt', tc', tvs') <- cvt_tycl_hdr ctxt cl tvs ; fds' <- mapM cvt_fundep fds - ; (binds', sigs', ats') <- cvt_ci_decs (ptext (sLit "a class declaration")) decs - ; returnL $ - TyClD $ ClassDecl { tcdCtxt = cxt', tcdLName = tc', tcdTyVars = tvs' - , tcdFDs = fds', tcdSigs = sigs', tcdMeths = binds' - , tcdATs = ats', tcdATDefs = [], tcdDocs = [] } - -- no docs in TH ^^ + ; (binds', sigs', fams', ats') <- cvt_ci_decs (ptext (sLit "a class declaration")) decs + ; returnL $ TyClD $ + ClassDecl { tcdCtxt = cxt', tcdLName = tc', tcdTyVars = tvs' + , tcdFDs = fds', tcdSigs = sigs', tcdMeths = binds' + , tcdATs = fams', tcdATDefs = ats', tcdDocs = [] } + -- no docs in TH ^^ } cvtDec (InstanceD ctxt ty decs) - = do { (binds', sigs', ats') <- cvt_ci_decs (ptext (sLit "an instance declaration")) decs + = do { let doc = ptext (sLit "an instance declaration") + ; (binds', sigs', fams', ats') <- cvt_ci_decs doc decs + ; unless (null fams') (failWith (mkBadDecMsg doc fams')) ; ctxt' <- cvtContext ctxt ; L loc ty' <- cvtType ty ; let inst_ty' = L loc $ mkImplicitHsForAllTy ctxt' $ L loc ty' - ; returnL $ InstD (ClsInstDecl inst_ty' binds' sigs' ats') } + ; returnL $ InstD (ClsInstD inst_ty' binds' sigs' ats') } cvtDec (ForeignD ford) = do { ford' <- cvtForD ford @@ -214,47 +223,50 @@ cvtDec (FamilyD flav tc tvs kind) cvtFamFlavour DataFam = DataFamily cvtDec (DataInstD ctxt tc tys constrs derivs) - = do { (ctxt', tc', tvs', typats') <- cvt_tyinst_hdr ctxt tc tys + = do { (ctxt', tc', typats') <- cvt_tyinst_hdr ctxt tc tys ; cons' <- mapM cvtConstr constrs ; derivs' <- cvtDerivs derivs - ; returnL $ InstD $ FamInstDecl $ - TyData { tcdND = DataType, tcdCType = Nothing - , tcdLName = tc', tcdCtxt = ctxt' - , tcdTyVars = tvs', tcdTyPats = typats', tcdKindSig = Nothing - , tcdCons = cons', tcdDerivs = derivs' } } + ; let defn = TyData { td_ND = DataType, td_cType = Nothing + , td_ctxt = ctxt' + , td_kindSig = Nothing + , td_cons = cons', td_derivs = derivs' } + + ; returnL $ InstD $ FamInstD $ + FamInstDecl { fid_tycon = tc', fid_pats = typats', fid_defn = defn } } cvtDec (NewtypeInstD ctxt tc tys constr derivs) - = do { (ctxt', tc', tvs', typats') <- cvt_tyinst_hdr ctxt tc tys + = do { (ctxt', tc', typats') <- cvt_tyinst_hdr ctxt tc tys ; con' <- cvtConstr constr ; derivs' <- cvtDerivs derivs - ; returnL $ InstD $ FamInstDecl $ - TyData { tcdND = NewType, tcdCType = Nothing - , tcdLName = tc', tcdCtxt = ctxt' - , tcdTyVars = tvs', tcdTyPats = typats', tcdKindSig = Nothing - , tcdCons = [con'], tcdDerivs = derivs' } } + ; let defn = TyData { td_ND = NewType, td_cType = Nothing + , td_ctxt = ctxt' + , td_kindSig = Nothing + , td_cons = [con'], td_derivs = derivs' } + ; returnL $ InstD $ FamInstD $ + FamInstDecl { fid_tycon = tc', fid_pats = typats', fid_defn = defn } } cvtDec (TySynInstD tc tys rhs) - = do { (_, tc', tvs', tys') <- cvt_tyinst_hdr [] tc tys + = do { (_, tc', tys') <- cvt_tyinst_hdr [] tc tys ; rhs' <- cvtType rhs - ; returnL $ InstD $ FamInstDecl $ - TySynonym { tcdLName = tc' - , tcdTyVars = tvs', tcdTyPats = tys' - , tcdSynRhs = rhs', tcdFVs = placeHolderNames } } + ; returnL $ InstD $ FamInstD $ + FamInstDecl { fid_tycon = tc', fid_pats = tys', fid_defn = TySynonym rhs' } } ---------------- cvt_ci_decs :: MsgDoc -> [TH.Dec] -> CvtM (LHsBinds RdrName, [LSig RdrName], - [LTyClDecl RdrName]) + [LTyClDecl RdrName], -- Family decls + [LFamInstDecl RdrName]) -- Convert the declarations inside a class or instance decl -- ie signatures, bindings, and associated types cvt_ci_decs doc decs = do { decs' <- mapM cvtDec decs - ; let (ats', bind_sig_decs') = partitionWith is_tycl decs' - ; let (sigs', prob_binds') = partitionWith is_sig bind_sig_decs' - ; let (binds', bads) = partitionWith is_bind prob_binds' + ; let (ats', bind_sig_decs') = partitionWith is_fam_inst decs' + ; let (sigs', prob_binds') = partitionWith is_sig bind_sig_decs' + ; let (binds', prob_fams') = partitionWith is_bind prob_binds' + ; let (fams', bads) = partitionWith is_fam_decl prob_fams' ; unless (null bads) (failWith (mkBadDecMsg doc bads)) - ; return (listToBag binds', sigs', ats') } + ; return (listToBag binds', sigs', fams', ats') } ---------------- cvt_tycl_hdr :: TH.Cxt -> TH.Name -> [TH.TyVarBndr] @@ -271,40 +283,24 @@ cvt_tycl_hdr cxt tc tvs cvt_tyinst_hdr :: TH.Cxt -> TH.Name -> [TH.Type] -> CvtM ( LHsContext RdrName , Located RdrName - , [LHsTyVarBndr RdrName] - , Maybe [LHsType RdrName]) + , HsBndrSig [LHsType RdrName]) cvt_tyinst_hdr cxt tc tys = do { cxt' <- cvtContext cxt ; tc' <- tconNameL tc - ; tvs <- concatMapM collect tys - ; tvs' <- cvtTvs tvs ; tys' <- mapM cvtType tys - ; return (cxt', tc', tvs', Just tys') - } - where - collect (ForallT _ _ _) - = failWith $ text "Forall type not allowed as type parameter" - collect (VarT tv) = return [PlainTV tv] - collect (ConT _) = return [] - collect (TupleT _) = return [] - collect (UnboxedTupleT _) = return [] - collect ArrowT = return [] - collect ListT = return [] - collect (AppT t1 t2) - = do { tvs1 <- collect t1 - ; tvs2 <- collect t2 - ; return $ tvs1 ++ tvs2 - } - collect (SigT (VarT tv) ki) = return [KindedTV tv ki] - collect (SigT ty _) = collect ty + ; return (cxt', tc', mkHsBSig tys') } ------------------------------------------------------------------- -- Partitioning declarations ------------------------------------------------------------------- -is_tycl :: LHsDecl RdrName -> Either (LTyClDecl RdrName) (LHsDecl RdrName) -is_tycl (L loc (Hs.TyClD tcd)) = Left (L loc tcd) -is_tycl decl = Right decl +is_fam_decl :: LHsDecl RdrName -> Either (LTyClDecl RdrName) (LHsDecl RdrName) +is_fam_decl (L loc (TyClD d@(TyFamily {}))) = Left (L loc d) +is_fam_decl decl = Right decl + +is_fam_inst :: LHsDecl RdrName -> Either (LFamInstDecl RdrName) (LHsDecl RdrName) +is_fam_inst (L loc (Hs.InstD (FamInstD d))) = Left (L loc d) +is_fam_inst decl = Right decl is_sig :: LHsDecl RdrName -> Either (LSig RdrName) (LHsDecl RdrName) is_sig (L loc (Hs.SigD sig)) = Left (L loc sig) @@ -314,7 +310,7 @@ is_bind :: LHsDecl RdrName -> Either (LHsBind RdrName) (LHsDecl RdrName) is_bind (L loc (Hs.ValD bind)) = Left (L loc bind) is_bind decl = Right decl -mkBadDecMsg :: MsgDoc -> [LHsDecl RdrName] -> MsgDoc +mkBadDecMsg :: Outputable a => MsgDoc -> [a] -> MsgDoc mkBadDecMsg doc bads = sep [ ptext (sLit "Illegal declaration(s) in") <+> doc <> colon , nest 2 (vcat (map Outputable.ppr bads)) ] @@ -760,7 +756,7 @@ cvtp (RecP c fs) = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs ; return $ ConPatIn c' $ Hs.RecCon (HsRecFields fs' Nothing) } cvtp (ListP ps) = do { ps' <- cvtPats ps; return $ ListPat ps' void } cvtp (SigP p t) = do { p' <- cvtPat p; t' <- cvtType t - ; return $ SigPatIn p' (HsBSig t' placeHolderBndrs) } + ; return $ SigPatIn p' (mkHsBSig t') } cvtp (ViewP e p) = do { e' <- cvtl e; p' <- cvtPat p; return $ ViewPat e' p' void } cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (HsRecField RdrName (LPat RdrName)) @@ -791,12 +787,11 @@ cvtTvs tvs = mapM cvt_tv tvs cvt_tv :: TH.TyVarBndr -> CvtM (LHsTyVarBndr RdrName) cvt_tv (TH.PlainTV nm) = do { nm' <- tName nm - ; returnL $ UserTyVar nm' placeHolderKind - } + ; returnL $ UserTyVar nm' } cvt_tv (TH.KindedTV nm ki) = do { nm' <- tName nm ; ki' <- cvtKind ki - ; returnL $ KindedTyVar nm' (HsBSig ki' placeHolderBndrs) placeHolderKind } + ; returnL $ KindedTyVar nm' (mkHsBSig ki') } cvtContext :: TH.Cxt -> CvtM (LHsContext RdrName) cvtContext tys = do { preds' <- mapM cvtPred tys; returnL preds' } @@ -877,9 +872,18 @@ cvtKind (ArrowK k1 k2) = do k2' <- cvtKind k2 returnL (HsFunTy k1' k2') -cvtMaybeKind :: Maybe TH.Kind -> CvtM (Maybe (LHsKind RdrName)) +cvtMaybeKind :: Maybe TH.Kind -> CvtM (Maybe (HsBndrSig (LHsKind RdrName))) cvtMaybeKind Nothing = return Nothing -cvtMaybeKind (Just ki) = cvtKind ki >>= return . Just +cvtMaybeKind (Just ki) = do { ki' <- cvtKind ki + ; return (Just (mkHsBSig ki')) } + +----------------------------------------------------------- +cvtFixity :: TH.Fixity -> Hs.Fixity +cvtFixity (TH.Fixity prec dir) = Hs.Fixity prec (cvt_dir dir) + where + cvt_dir TH.InfixL = Hs.InfixL + cvt_dir TH.InfixR = Hs.InfixR + cvt_dir TH.InfixN = Hs.InfixN ----------------------------------------------------------- diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs index 26d49f726c..d573be52d4 100644 --- a/compiler/hsSyn/HsDecls.lhs +++ b/compiler/hsSyn/HsDecls.lhs @@ -12,16 +12,16 @@ -- @InstDecl@, @DefaultDecl@ and @ForeignDecl@. module HsDecls ( -- * Toplevel declarations - HsDecl(..), LHsDecl, + HsDecl(..), LHsDecl, HsTyDefn(..), -- ** Class or type declarations TyClDecl(..), LTyClDecl, TyClGroup, - isClassDecl, isSynDecl, isDataDecl, isTypeDecl, isFamilyDecl, - isFamInstDecl, tcdName, tyClDeclTyVars, - countTyClDecls, + isClassDecl, isDataDecl, isSynDecl, isFamilyDecl, + isHsDataDefn, isHsSynDefn, tcdName, famInstDeclName, + countTyClDecls, pprTyDefnFlavour, pprTyClDeclFlavour, -- ** Instance declarations InstDecl(..), LInstDecl, NewOrData(..), FamilyFlavour(..), - FamInstDecl, LFamInstDecl, instDeclFamInsts, + FamInstDecl(..), LFamInstDecl, instDeclFamInsts, -- ** Standalone deriving declarations DerivDecl(..), LDerivDecl, @@ -80,7 +80,6 @@ import FastString import Bag import Control.Monad ( liftM ) import Data.Data hiding (TyCon) -import Data.Maybe ( isJust ) \end{code} %************************************************************************ @@ -414,27 +413,6 @@ Interface file code: \begin{code} --- Representation of indexed types --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- Family kind signatures are represented by the variant `TyFamily'. It --- covers "type family", "newtype family", and "data family" declarations, --- distinguished by the value of the field `tcdFlavour'. --- --- Indexed types are represented by 'TyData' and 'TySynonym' using the field --- 'tcdTyPats::Maybe [LHsType name]', with the following meaning: --- --- * If it is 'Nothing', we have a *vanilla* data type declaration or type --- synonym declaration and 'tcdVars' contains the type parameters of the --- type constructor. --- --- * If it is 'Just pats', we have the definition of an indexed type. Then, --- 'pats' are type patterns for the type-indexes of the type constructor --- and 'tcdTyVars' are the variables in those patterns. Hence, the arity of --- the indexed type (ie, the number of indexes) is 'length tcdTyPats' and --- *not* 'length tcdVars'. --- --- In both cases, 'tcdVars' collects all variables we need to quantify over. - type LTyClDecl name = Located (TyClDecl name) type TyClGroup name = [LTyClDecl name] -- This is used in TcTyClsDecls to represent -- strongly connected components of decls @@ -447,64 +425,20 @@ data TyClDecl name tcdExtName :: Maybe FastString } - | -- | @type/data family T :: *->*@ TyFamily { tcdFlavour :: FamilyFlavour, -- type or data tcdLName :: Located name, -- type constructor tcdTyVars :: [LHsTyVarBndr name], -- type variables - tcdKindSig :: Maybe (LHsKind name) -- result kind - } - - - | -- | Declares a data type or newtype, giving its construcors - -- @ - -- data/newtype T a = <constrs> - -- data/newtype instance T [a] = <constrs> - -- @ - TyData { tcdND :: NewOrData, - tcdCtxt :: LHsContext name, -- ^ Context - tcdLName :: Located name, -- ^ Type constructor - - tcdCType :: Maybe CType, - tcdTyVars :: [LHsTyVarBndr name], -- ^ Type variables - tcdTyPats :: Maybe [LHsType name], -- ^ Type patterns. - -- See Note [tcdTyVars and tcdTyPats] - - tcdKindSig:: Maybe (LHsKind name), - -- ^ Optional kind signature. - -- - -- @(Just k)@ for a GADT-style @data@, or @data - -- instance@ decl with explicit kind sig - - tcdCons :: [LConDecl name], - -- ^ Data constructors - -- - -- For @data T a = T1 | T2 a@ - -- the 'LConDecl's all have 'ResTyH98'. - -- For @data T a where { T1 :: T a }@ - -- the 'LConDecls' all have 'ResTyGADT'. - - tcdDerivs :: Maybe [LHsType name] - -- ^ Derivings; @Nothing@ => not specified, - -- @Just []@ => derive exactly what is asked - -- - -- These "types" must be of form - -- @ - -- forall ab. C ty1 ty2 - -- @ - -- Typically the foralls and ty args are empty, but they - -- are non-empty for the newtype-deriving case + tcdKindSig :: Maybe (HsBndrSig (LHsKind name)) -- result kind } - | TySynonym { tcdLName :: Located name, -- ^ type constructor - tcdTyVars :: [LHsTyVarBndr name], -- ^ type variables - tcdTyPats :: Maybe [LHsType name], -- ^ Type patterns - -- See Note [tcdTyVars and tcdTyPats] - tcdSynRhs :: LHsType name, -- ^ synonym expansion - tcdFVs :: NameSet -- ^ Free tycons of the decl - -- (Used for cycle detection) - } + | -- | @type/data declaration + TyDecl { tcdLName :: Located name -- ^ Type constructor + , tcdTyVars :: [LHsTyVarBndr name] + , tcdTyDefn :: HsTyDefn name + , tcdFVs :: NameSet } -- ^ Free tycons of the decl + -- (Used for cycle detection) | ClassDecl { tcdCtxt :: LHsContext name, -- ^ Context... tcdLName :: Located name, -- ^ Name of the class @@ -520,6 +454,47 @@ data TyClDecl name } deriving (Data, Typeable) + +data HsTyDefn name -- The payload of a type synonym or data type defn + -- Used *both* for vanialla type/data declarations, + -- *and* for type/data family instances + = TySynonym { td_synRhs :: LHsType name } -- ^ Synonym expansion + + | -- | Declares a data type or newtype, giving its construcors + -- @ + -- data/newtype T a = <constrs> + -- data/newtype instance T [a] = <constrs> + -- @ + TyData { td_ND :: NewOrData, + td_ctxt :: LHsContext name, -- ^ Context + td_cType :: Maybe CType, + td_kindSig:: Maybe (HsBndrSig (LHsKind name)), + -- ^ Optional kind signature. + -- + -- @(Just k)@ for a GADT-style @data@, or @data + -- instance@ decl with explicit kind sig + + td_cons :: [LConDecl name], + -- ^ Data constructors + -- + -- For @data T a = T1 | T2 a@ + -- the 'LConDecl's all have 'ResTyH98'. + -- For @data T a where { T1 :: T a }@ + -- the 'LConDecls' all have 'ResTyGADT'. + + td_derivs :: Maybe [LHsType name] + -- ^ Derivings; @Nothing@ => not specified, + -- @Just []@ => derive exactly what is asked + -- + -- These "types" must be of form + -- @ + -- forall ab. C ty1 ty2 + -- @ + -- Typically the foralls and ty args are empty, but they + -- are non-empty for the newtype-deriving case + } + deriving( Data, Typeable ) + data NewOrData = NewType -- ^ @newtype Blah ...@ | DataType -- ^ @data Blah ...@ @@ -531,53 +506,39 @@ data FamilyFlavour deriving (Data, Typeable) \end{code} -Note [tcdTyVars and tcdTyPats] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [tcdTypats and HsTyPats] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We use TyData and TySynonym both for vanilla data/type declarations type T a = Int AND for data/type family instance declarations type instance F [a] = (a,Int) -tcdTyPats = Nothing +tcdTyPats = HsTyDefn tvs This is a vanilla data type or type synonym - tcdTyVars are the quantified type variables + tvs are the quantified type variables -tcdTyPats = Just tys - This is a data/type family instance declaration - tcdTyVars are fv(tys) - - Eg class C s t where - type F t p :: * - instance C w (a,b) where - type F (a,b) x = x->a - The tcdTyVars of the F decl are {a,b,x}, even though the F decl - is nested inside the 'instance' decl. - - However after the renamer, the uniques will match up: - instance C w7 (a8,b9) where - type F (a8,b9) x10 = x10->a8 - so that we can compare the type patter in the 'instance' decl and - in the associated 'type' decl ------------------------------ Simple classifiers \begin{code} --- | @True@ <=> argument is a @data@\/@newtype@ or @data@\/@newtype instance@ +isHsDataDefn, isHsSynDefn :: HsTyDefn name -> Bool +isHsDataDefn (TyData {}) = True +isHsDataDefn _ = False + +isHsSynDefn (TySynonym {}) = True +isHsSynDefn _ = False + +-- | @True@ <=> argument is a @data@\/@newtype@ -- declaration. isDataDecl :: TyClDecl name -> Bool -isDataDecl (TyData {}) = True -isDataDecl _other = False +isDataDecl (TyDecl { tcdTyDefn = defn }) = isHsDataDefn defn +isDataDecl _other = False -- | type or type instance declaration -isTypeDecl :: TyClDecl name -> Bool -isTypeDecl (TySynonym {}) = True -isTypeDecl _other = False - --- | vanilla Haskell type synonym (ie, not a type instance) isSynDecl :: TyClDecl name -> Bool -isSynDecl (TySynonym {tcdTyPats = Nothing}) = True -isSynDecl _other = False +isSynDecl (TyDecl { tcdTyDefn = defn }) = isHsSynDefn defn +isSynDecl _other = False -- | type class isClassDecl :: TyClDecl name -> Bool @@ -588,27 +549,16 @@ isClassDecl _ = False isFamilyDecl :: TyClDecl name -> Bool isFamilyDecl (TyFamily {}) = True isFamilyDecl _other = False - --- | family instance (types, newtypes, and data types) -isFamInstDecl :: TyClDecl name -> Bool -isFamInstDecl tydecl - | isTypeDecl tydecl - || isDataDecl tydecl = isJust (tcdTyPats tydecl) - | otherwise = False \end{code} Dealing with names \begin{code} +famInstDeclName :: LFamInstDecl a -> a +famInstDeclName (L _ (FamInstDecl { fid_tycon = L _ name })) = name + tcdName :: TyClDecl name -> name tcdName decl = unLoc (tcdLName decl) - -tyClDeclTyVars :: TyClDecl name -> [LHsTyVarBndr name] -tyClDeclTyVars (TyFamily {tcdTyVars = tvs}) = tvs -tyClDeclTyVars (TySynonym {tcdTyVars = tvs}) = tvs -tyClDeclTyVars (TyData {tcdTyVars = tvs}) = tvs -tyClDeclTyVars (ClassDecl {tcdTyVars = tvs}) = tvs -tyClDeclTyVars (ForeignType {}) = [] \end{code} \begin{code} @@ -621,11 +571,11 @@ countTyClDecls decls count isNewTy decls, -- ...instances count isFamilyDecl decls) where - isDataTy TyData{tcdND = DataType, tcdTyPats = Nothing} = True - isDataTy _ = False + isDataTy TyDecl{ tcdTyDefn = TyData { td_ND = DataType } } = True + isDataTy _ = False - isNewTy TyData{tcdND = NewType, tcdTyPats = Nothing} = True - isNewTy _ = False + isNewTy TyDecl{ tcdTyDefn = TyData { td_ND = NewType } } = True + isNewTy _ = False \end{code} \begin{code} @@ -637,7 +587,7 @@ instance OutputableBndr name ppr (TyFamily {tcdFlavour = flavour, tcdLName = ltycon, tcdTyVars = tyvars, tcdKindSig = mb_kind}) - = pp_flavour <+> pp_decl_head [] ltycon tyvars Nothing <+> pp_kind + = pp_flavour <+> pp_vanilla_decl_head ltycon tyvars [] <+> pp_kind where pp_flavour = case flavour of TypeFamily -> ptext (sLit "type family") @@ -647,27 +597,8 @@ instance OutputableBndr name Nothing -> empty Just kind -> dcolon <+> ppr kind - ppr (TySynonym {tcdLName = ltycon, tcdTyVars = tyvars, tcdTyPats = typats, - tcdSynRhs = mono_ty}) - = hang (ptext (sLit "type") <+> - (if isJust typats then ptext (sLit "instance") else empty) <+> - pp_decl_head [] ltycon tyvars typats <+> - equals) - 4 (ppr mono_ty) - - ppr (TyData {tcdND = new_or_data, tcdCtxt = context, tcdLName = ltycon, - tcdTyVars = tyvars, tcdTyPats = typats, tcdKindSig = mb_sig, - tcdCons = condecls, tcdDerivs = derivings}) - = pp_tydecl (null condecls && isJust mb_sig) - (ppr new_or_data <+> - (if isJust typats then ptext (sLit "instance") else empty) <+> - pp_decl_head (unLoc context) ltycon tyvars typats <+> - ppr_sigx mb_sig) - (pp_condecls condecls) - derivings - where - ppr_sigx Nothing = empty - ppr_sigx (Just kind) = dcolon <+> ppr kind + ppr (TyDecl { tcdLName = ltycon, tcdTyVars = tyvars, tcdTyDefn = defn }) + = pp_ty_defn (pp_vanilla_decl_head ltycon tyvars) defn ppr (ClassDecl {tcdCtxt = context, tcdLName = lclas, tcdTyVars = tyvars, tcdFDs = fds, @@ -683,20 +614,25 @@ instance OutputableBndr name pprLHsBindsForUser methods sigs) ] where top_matter = ptext (sLit "class") - <+> pp_decl_head (unLoc context) lclas tyvars Nothing + <+> pp_vanilla_decl_head lclas tyvars (unLoc context) <+> pprFundeps (map unLoc fds) -pp_decl_head :: OutputableBndr name - => HsContext name - -> Located name +pp_vanilla_decl_head :: OutputableBndr name + => Located name -> [LHsTyVarBndr name] - -> Maybe [LHsType name] + -> HsContext name -> SDoc -pp_decl_head context thing tyvars Nothing -- no explicit type patterns - = hsep [pprHsContext context, ppr thing, interppSP tyvars] -pp_decl_head context thing _ (Just typats) -- explicit type patterns - = hsep [ pprHsContext context, ppr thing - , hsep (map (pprParendHsType.unLoc) typats)] +pp_vanilla_decl_head thing tyvars context + = hsep [pprHsContext context, pprPrefixOcc (unLoc thing), interppSP tyvars] + +pp_fam_inst_head :: OutputableBndr name + => Located name + -> HsBndrSig [LHsType name] + -> HsContext name + -> SDoc +pp_fam_inst_head thing (HsBSig typats _) context -- explicit type patterns + = hsep [ ptext (sLit "instance"), pprHsContext context, pprPrefixOcc (unLoc thing) + , hsep (map (pprParendHsType.unLoc) typats)] pp_condecls :: OutputableBndr name => [LConDecl name] -> SDoc pp_condecls cs@(L _ ConDecl{ con_res = ResTyGADT _ } : _) -- In GADT syntax @@ -704,20 +640,48 @@ pp_condecls cs@(L _ ConDecl{ con_res = ResTyGADT _ } : _) -- In GADT syntax pp_condecls cs -- In H98 syntax = equals <+> sep (punctuate (ptext (sLit " |")) (map ppr cs)) -pp_tydecl :: OutputableBndr name => Bool -> SDoc -> SDoc -> Maybe [LHsType name] -> SDoc -pp_tydecl True pp_head _ _ - = pp_head -pp_tydecl False pp_head pp_decl_rhs derivings - = hang pp_head 4 (sep [ - pp_decl_rhs, - case derivings of - Nothing -> empty - Just ds -> hsep [ptext (sLit "deriving"), parens (interpp'SP ds)] - ]) +pp_ty_defn :: OutputableBndr name + => (HsContext name -> SDoc) -- Printing the header + -> HsTyDefn name + -> SDoc + +pp_ty_defn pp_hdr (TySynonym rhs) + = hang (ptext (sLit "type") <+> pp_hdr [] <+> equals) + 4 (ppr rhs) + +pp_ty_defn pp_hdr (TyData { td_ND = new_or_data, td_ctxt = L _ context + , td_kindSig = mb_sig + , td_cons = condecls, td_derivs = derivings }) + | null condecls + = ppr new_or_data <+> pp_hdr context <+> pp_sig + + | otherwise + = hang (ppr new_or_data <+> pp_hdr context <+> pp_sig) + 2 (pp_condecls condecls $$ pp_derivings) + where + pp_sig = case mb_sig of + Nothing -> empty + Just (HsBSig kind _) -> dcolon <+> ppr kind + pp_derivings = case derivings of + Nothing -> empty + Just ds -> hsep [ptext (sLit "deriving"), parens (interpp'SP ds)] + +instance OutputableBndr name => Outputable (HsTyDefn name) where + ppr d = pp_ty_defn (\_ -> ptext (sLit "Naked HsTyDefn")) d instance Outputable NewOrData where ppr NewType = ptext (sLit "newtype") ppr DataType = ptext (sLit "data") + +pprTyDefnFlavour :: HsTyDefn a -> SDoc +pprTyDefnFlavour (TyData { td_ND = nd }) = ppr nd +pprTyDefnFlavour (TySynonym {}) = ptext (sLit "type") + +pprTyClDeclFlavour :: TyClDecl a -> SDoc +pprTyClDeclFlavour (ClassDecl {}) = ptext (sLit "class") +pprTyClDeclFlavour (TyFamily {}) = ptext (sLit "family") +pprTyClDeclFlavour (TyDecl { tcdTyDefn = defn }) = pprTyDefnFlavour defn +pprTyClDeclFlavour (ForeignType {}) = ptext (sLit "foreign type") \end{code} @@ -840,27 +804,58 @@ pprConDecl (ConDecl {con_name = con, con_details = InfixCon {}, con_res = ResTyG %************************************************************************ \begin{code} -type LInstDecl name = Located (InstDecl name) - type LFamInstDecl name = Located (FamInstDecl name) -type FamInstDecl name = TyClDecl name -- Type or data family instance +data FamInstDecl name + = FamInstDecl + { fid_tycon :: Located name + , fid_pats :: HsBndrSig [LHsType name] -- ^ Type patterns (with bndrs) + , fid_defn :: HsTyDefn name } -- Type or data family instance + deriving( Typeable, Data ) +type LInstDecl name = Located (InstDecl name) data InstDecl name -- Both class and family instances - = ClsInstDecl - (LHsType name) -- Context => Class Instance-type - -- Using a polytype means that the renamer conveniently - -- figures out the quantified type variables for us. - (LHsBinds name) - [LSig name] -- User-supplied pragmatic info - [LFamInstDecl name] -- Family instances for associated types - - | FamInstDecl -- type/data family instance + = ClsInstD + { cid_poly_ty :: LHsType name -- Context => Class Instance-type + -- Using a polytype means that the renamer conveniently + -- figures out the quantified type variables for us. + , cid_binds :: LHsBinds name + , cid_sigs :: [LSig name] -- User-supplied pragmatic info + , cid_fam_insts :: [LFamInstDecl name] } -- Family instances for associated types + + | FamInstD -- type/data family instance (FamInstDecl name) deriving (Data, Typeable) +\end{code} + +Note [Family instance declaration binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A FamInstDecl is a data/type family instance declaration +the fid_pats field is LHS patterns, and the tvs of the HsBSig +tvs are fv(pat_tys), *including* ones that are already in scope + + Eg class C s t where + type F t p :: * + instance C w (a,b) where + type F (a,b) x = x->a + The tcdTyVars of the F decl are {a,b,x}, even though the F decl + is nested inside the 'instance' decl. + + However after the renamer, the uniques will match up: + instance C w7 (a8,b9) where + type F (a8,b9) x10 = x10->a8 + so that we can compare the type patter in the 'instance' decl and + in the associated 'type' decl + +\begin{code} +instance (OutputableBndr name) => Outputable (FamInstDecl name) where + ppr (FamInstDecl { fid_tycon = tycon + , fid_pats = pats + , fid_defn = defn }) + = pp_ty_defn (pp_fam_inst_head tycon pats) defn instance (OutputableBndr name) => Outputable (InstDecl name) where - ppr (ClsInstDecl inst_ty binds sigs ats) + ppr (ClsInstD inst_ty binds sigs ats) | null sigs && null ats && isEmptyBag binds -- No "where" part = top_matter @@ -871,16 +866,16 @@ instance (OutputableBndr name) => Outputable (InstDecl name) where where top_matter = ptext (sLit "instance") <+> ppr inst_ty - ppr (FamInstDecl decl) = ppr decl + ppr (FamInstD decl) = ppr decl -- Extract the declarations of associated types from an instance -instDeclFamInsts :: [LInstDecl name] -> [LTyClDecl name] +instDeclFamInsts :: [LInstDecl name] -> [FamInstDecl name] instDeclFamInsts inst_decls = concatMap do_one inst_decls where - do_one (L _ (ClsInstDecl _ _ _ fam_insts)) = fam_insts - do_one (L loc (FamInstDecl fam_inst)) = [L loc fam_inst] + do_one (L _ (ClsInstD _ _ _ fam_insts)) = map unLoc fam_insts + do_one (L _ (FamInstD fam_inst)) = [fam_inst] \end{code} %************************************************************************ diff --git a/compiler/hsSyn/HsImpExp.lhs b/compiler/hsSyn/HsImpExp.lhs index ee75414d4c..7163cbfe10 100644 --- a/compiler/hsSyn/HsImpExp.lhs +++ b/compiler/hsSyn/HsImpExp.lhs @@ -12,6 +12,7 @@ module HsImpExp where import Module ( ModuleName ) import HsDoc ( HsDocString ) +import OccName ( HasOccName(..), isTcOcc, isSymOcc ) import Outputable import FastString @@ -57,7 +58,7 @@ simpleImportDecl mn = ImportDecl { \end{code} \begin{code} -instance (OutputableBndr name) => Outputable (ImportDecl name) where +instance (OutputableBndr name, HasOccName name) => Outputable (ImportDecl name) where ppr (ImportDecl { ideclName = mod', ideclPkgQual = pkg , ideclSource = from, ideclSafe = safe , ideclQualified = qual, ideclImplicit = implicit @@ -134,12 +135,20 @@ ieNames (IEDocNamed _ ) = [] \end{code} \begin{code} -instance (OutputableBndr name, Outputable name) => Outputable (IE name) where + +pprImpExp :: (HasOccName name, OutputableBndr name) => name -> SDoc +pprImpExp name = type_pref <+> pprPrefixOcc name + where + occ = occName name + type_pref | isTcOcc occ && isSymOcc occ = ptext (sLit "type") + | otherwise = empty + +instance (HasOccName name, OutputableBndr name) => Outputable (IE name) where ppr (IEVar var) = pprPrefixOcc var - ppr (IEThingAbs thing) = ppr thing - ppr (IEThingAll thing) = hcat [ppr thing, text "(..)"] + ppr (IEThingAbs thing) = pprImpExp thing + ppr (IEThingAll thing) = hcat [pprImpExp thing, text "(..)"] ppr (IEThingWith thing withs) - = pprPrefixOcc thing <> parens (fsep (punctuate comma (map pprPrefixOcc withs))) + = pprImpExp thing <> parens (fsep (punctuate comma (map pprImpExp withs))) ppr (IEModuleContents mod') = ptext (sLit "module") <+> ppr mod' ppr (IEGroup n _) = text ("<IEGroup: " ++ (show n) ++ ">") diff --git a/compiler/hsSyn/HsSyn.lhs b/compiler/hsSyn/HsSyn.lhs index a8ae81e935..ba1794d281 100644 --- a/compiler/hsSyn/HsSyn.lhs +++ b/compiler/hsSyn/HsSyn.lhs @@ -46,6 +46,7 @@ import HsUtils import HsDoc -- others: +import OccName ( HasOccName ) import IfaceSyn ( IfaceBinding ) import Outputable import SrcLoc @@ -97,7 +98,7 @@ data HsExtCore name -- Read from Foo.hcr instance Outputable Char where ppr c = text [c] -instance (OutputableBndr name) +instance (OutputableBndr name, HasOccName name) => Outputable (HsModule name) where ppr (HsModule Nothing _ imports decls _ mbDoc) diff --git a/compiler/hsSyn/HsTypes.lhs b/compiler/hsSyn/HsTypes.lhs index 696b48f0a1..9e8d27bde0 100644 --- a/compiler/hsSyn/HsTypes.lhs +++ b/compiler/hsSyn/HsTypes.lhs @@ -22,6 +22,7 @@ module HsTypes ( HsContext, LHsContext, HsQuasiQuote(..), HsTyWrapper(..), + HsTyLit(..), LBangType, BangType, HsBang(..), getBangType, getBangStrictness, @@ -30,7 +31,6 @@ module HsTypes ( mkExplicitHsForAllTy, mkImplicitHsForAllTy, hsExplicitTvs, hsTyVarName, hsTyVarNames, - hsTyVarKind, hsLTyVarKind, hsTyVarNameKind, hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, hsLTyVarLocNames, splitHsInstDeclTy_maybe, splitLHsInstDeclTy_maybe, splitHsForAllTy, splitLHsForAllTy, @@ -143,12 +143,10 @@ placeHolderBndrs = panic "placeHolderBndrs" data HsTyVarBndr name = UserTyVar -- No explicit kinding name -- See Note [Printing KindedTyVars] - PostTcKind | KindedTyVar name (HsBndrSig (LHsKind name)) -- The user-supplied kind signature - PostTcKind -- *** NOTA BENE *** A "monotype" in a pragma can have -- for-alls in it, (mostly to do with dictionaries). These -- must be explicitly Kinded. @@ -215,9 +213,17 @@ data HsType name [PostTcKind] -- See Note [Promoted lists and tuples] [LHsType name] + | HsTyLit HsTyLit -- A promoted numeric literal. + | HsWrapTy HsTyWrapper (HsType name) -- only in typechecker output deriving (Data, Typeable) + +data HsTyLit + = HsNumTy Integer + | HsStrTy FastString + deriving (Data, Typeable) + data HsTyWrapper = WpKiApps [Kind] -- kind instantiation: [] k1 k2 .. kn deriving (Data, Typeable) @@ -374,19 +380,8 @@ hsExplicitTvs _ = [] --------------------- hsTyVarName :: HsTyVarBndr name -> name -hsTyVarName (UserTyVar n _) = n -hsTyVarName (KindedTyVar n _ _) = n - -hsTyVarKind :: HsTyVarBndr name -> Kind -hsTyVarKind (UserTyVar _ k) = k -hsTyVarKind (KindedTyVar _ _ k) = k - -hsLTyVarKind :: LHsTyVarBndr name -> Kind -hsLTyVarKind = hsTyVarKind . unLoc - -hsTyVarNameKind :: HsTyVarBndr name -> (name, Kind) -hsTyVarNameKind (UserTyVar n k) = (n,k) -hsTyVarNameKind (KindedTyVar n _ k) = (n,k) +hsTyVarName (UserTyVar n) = n +hsTyVarName (KindedTyVar n _) = n hsLTyVarName :: LHsTyVarBndr name -> name hsLTyVarName = hsTyVarName . unLoc @@ -489,12 +484,15 @@ splitHsFunType other = ([], other) instance (OutputableBndr name) => Outputable (HsType name) where ppr ty = pprHsType ty +instance Outputable HsTyLit where + ppr = ppr_tylit + instance (Outputable sig) => Outputable (HsBndrSig sig) where ppr (HsBSig ty _) = ppr ty instance (OutputableBndr name) => Outputable (HsTyVarBndr name) where - ppr (UserTyVar name _) = ppr name - ppr (KindedTyVar name kind _) = parens $ hsep [ppr name, dcolon, ppr kind] + ppr (UserTyVar name) = ppr name + ppr (KindedTyVar name kind) = parens $ hsep [ppr name, dcolon, ppr kind] pprHsForAll :: OutputableBndr name => HsExplicitFlag -> [LHsTyVarBndr name] -> LHsContext name -> SDoc pprHsForAll exp tvs cxt @@ -590,6 +588,7 @@ ppr_mono_ty _ (HsSpliceTy s _ _) = pprSplice s ppr_mono_ty _ (HsCoreTy ty) = ppr ty ppr_mono_ty _ (HsExplicitListTy _ tys) = quote $ brackets (interpp'SP tys) ppr_mono_ty _ (HsExplicitTupleTy _ tys) = quote $ parens (interpp'SP tys) +ppr_mono_ty _ (HsTyLit t) = ppr_tylit t ppr_mono_ty ctxt_prec (HsWrapTy (WpKiApps _kis) ty) = ppr_mono_ty ctxt_prec ty @@ -637,6 +636,11 @@ ppr_fun_ty ctxt_prec ty1 ty2 in maybeParen ctxt_prec pREC_FUN $ sep [p1, ptext (sLit "->") <+> p2] + +-------------------------- +ppr_tylit :: HsTyLit -> SDoc +ppr_tylit (HsNumTy i) = integer i +ppr_tylit (HsStrTy s) = text (show s) \end{code} diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs index f7a1a10a5b..ab1449fe77 100644 --- a/compiler/hsSyn/HsUtils.lhs +++ b/compiler/hsSyn/HsUtils.lhs @@ -33,7 +33,7 @@ module HsUtils( nlHsTyApp, nlHsVar, nlHsLit, nlHsApp, nlHsApps, nlHsIntLit, nlHsVarApps, nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList, - mkLHsTupleExpr, mkLHsVarTuple, missingTupArg, + mkLHsTupleExpr, mkLHsVarTuple, missingTupArg, mkHsBSig, -- Bindings mkFunBind, mkVarBind, mkHsVarBind, mk_easy_FunBind, mkTopFunBind, @@ -69,7 +69,7 @@ module HsUtils( collectSigTysFromPats, collectSigTysFromPat, hsLTyClDeclBinders, hsTyClDeclBinders, hsTyClDeclsBinders, - hsForeignDeclsBinders, hsGroupBinders, + hsForeignDeclsBinders, hsGroupBinders, hsFamInstBinders, -- Collecting implicit binders lStmtsImplicits, hsValBindsImplicits, lPatImplicits @@ -96,7 +96,6 @@ import Util import Bag import Data.Either -import Data.Maybe \end{code} @@ -266,9 +265,13 @@ unqualQuasiQuote = mkRdrUnqual (mkVarOccFS (fsLit "quasiquote")) mkHsString :: String -> HsLit mkHsString s = HsString (mkFastString s) +mkHsBSig :: a -> HsBndrSig a +mkHsBSig x = HsBSig x placeHolderBndrs + ------------- -userHsTyVarBndrs :: [Located name] -> [Located (HsTyVarBndr name)] -userHsTyVarBndrs bndrs = [ L loc (UserTyVar v placeHolderKind) | L loc v <- bndrs ] +userHsTyVarBndrs :: SrcSpan -> [name] -> [Located (HsTyVarBndr name)] +-- Caller sets location +userHsTyVarBndrs loc bndrs = [ L loc (UserTyVar v) | v <- bndrs ] \end{code} @@ -622,9 +625,10 @@ hsTyClDeclsBinders :: [[LTyClDecl Name]] -> [Located (InstDecl Name)] -> [Name] -- We need to look at instance declarations too, -- because their associated types may bind data constructors hsTyClDeclsBinders tycl_decls inst_decls - = [n | d <- instDeclFamInsts inst_decls ++ concat tycl_decls - , L _ n <- hsLTyClDeclBinders d] + = map unLoc (concatMap (concatMap hsLTyClDeclBinders) tycl_decls ++ + concatMap (hsInstDeclBinders . unLoc) inst_decls) +------------------- hsLTyClDeclBinders :: Eq name => Located (TyClDecl name) -> [Located name] -- ^ Returns all the /binding/ names of the decl, along with their SrcLocs. -- The first one is guaranteed to be the name of the decl. For record fields @@ -632,24 +636,37 @@ hsLTyClDeclBinders :: Eq name => Located (TyClDecl name) -> [Located name] -- occurence. We use the equality to filter out duplicate field names hsLTyClDeclBinders (L _ d) = hsTyClDeclBinders d +------------------- hsTyClDeclBinders :: Eq name => TyClDecl name -> [Located name] hsTyClDeclBinders (TyFamily {tcdLName = name}) = [name] hsTyClDeclBinders (ForeignType {tcdLName = name}) = [name] -hsTyClDeclBinders (ClassDecl {tcdLName = cls_name, tcdSigs = sigs, tcdATs = ats}) +hsTyClDeclBinders (ClassDecl { tcdLName = cls_name, tcdSigs = sigs + , tcdATs = ats, tcdATDefs = fam_insts }) = cls_name : - concatMap hsLTyClDeclBinders ats ++ [n | L _ (TypeSig ns _) <- sigs, n <- ns] - -hsTyClDeclBinders (TySynonym {tcdLName = name, tcdTyPats = mb_pats }) - | isJust mb_pats = [] - | otherwise = [name] - -- See Note [Binders in family instances] - -hsTyClDeclBinders (TyData {tcdLName = tc_name, tcdCons = cons, tcdTyPats = mb_pats }) - | isJust mb_pats = hsConDeclsBinders cons - | otherwise = tc_name : hsConDeclsBinders cons + concatMap hsLTyClDeclBinders ats ++ + concatMap (hsFamInstBinders . unLoc) fam_insts ++ + [n | L _ (TypeSig ns _) <- sigs, n <- ns] + +hsTyClDeclBinders (TyDecl { tcdLName = name, tcdTyDefn = defn }) + = name : hsTyDefnBinders defn + +------------------- +hsInstDeclBinders :: Eq name => InstDecl name -> [Located name] +hsInstDeclBinders (ClsInstD { cid_fam_insts = fis }) = concatMap (hsFamInstBinders . unLoc) fis +hsInstDeclBinders (FamInstD fi) = hsFamInstBinders fi + +------------------- +hsFamInstBinders :: Eq name => FamInstDecl name -> [Located name] +hsFamInstBinders (FamInstDecl { fid_defn = defn }) = hsTyDefnBinders defn + +------------------- +hsTyDefnBinders :: Eq name => HsTyDefn name -> [Located name] +hsTyDefnBinders (TySynonym {}) = [] +hsTyDefnBinders (TyData { td_cons = cons }) = hsConDeclsBinders cons -- See Note [Binders in family instances] +------------------- hsConDeclsBinders :: (Eq name) => [LConDecl name] -> [Located name] -- See hsTyClDeclBinders for what this does -- The function is boringly complicated because of the records diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs index 4776860c60..eff699fd6b 100644 --- a/compiler/iface/BinIface.hs +++ b/compiler/iface/BinIface.hs @@ -1003,6 +1003,10 @@ instance Binary IfaceType where put_ bh (IfaceTyConApp tc tys) = do { putByte bh 5; put_ bh tc; put_ bh tys } + put_ bh (IfaceLitTy n) + = do { putByte bh 30; put_ bh n } + + get bh = do h <- getByte bh case h of @@ -1022,8 +1026,24 @@ instance Binary IfaceType where 5 -> do { tc <- get bh; tys <- get bh ; return (IfaceTyConApp tc tys) } + 30 -> do n <- get bh + return (IfaceLitTy n) + _ -> panic ("get IfaceType " ++ show h) +instance Binary IfaceTyLit where + put_ bh (IfaceNumTyLit n) = putByte bh 1 >> put_ bh n + put_ bh (IfaceStrTyLit n) = putByte bh 2 >> put_ bh n + + get bh = + do tag <- getByte bh + case tag of + 1 -> do { n <- get bh + ; return (IfaceNumTyLit n) } + 2 -> do { n <- get bh + ; return (IfaceStrTyLit n) } + _ -> panic ("get IfaceTyLit " ++ show tag) + instance Binary IfaceTyCon where put_ bh (IfaceTc ext) = put_ bh ext get bh = liftM IfaceTc (get bh) diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs index 7327e5bd51..d3e44fe54f 100644 --- a/compiler/iface/IfaceSyn.lhs +++ b/compiler/iface/IfaceSyn.lhs @@ -802,6 +802,7 @@ freeNamesIfType (IfaceTyVar _) = emptyNameSet freeNamesIfType (IfaceAppTy s t) = freeNamesIfType s &&& freeNamesIfType t freeNamesIfType (IfaceTyConApp tc ts) = freeNamesIfTc tc &&& fnList freeNamesIfType ts +freeNamesIfType (IfaceLitTy _) = emptyNameSet freeNamesIfType (IfaceForAllTy tv t) = freeNamesIfTvBndr tv &&& freeNamesIfType t freeNamesIfType (IfaceFunTy s t) = freeNamesIfType s &&& freeNamesIfType t diff --git a/compiler/iface/IfaceType.lhs b/compiler/iface/IfaceType.lhs index f10900b174..c4c876d1a7 100644 --- a/compiler/iface/IfaceType.lhs +++ b/compiler/iface/IfaceType.lhs @@ -17,6 +17,7 @@ module IfaceType ( IfExtName, IfLclName, IfIPName, IfaceType(..), IfacePredType, IfaceKind, IfaceTyCon(..), IfaceCoCon(..), + IfaceTyLit(..), IfaceContext, IfaceBndr(..), IfaceTvBndr, IfaceIdBndr, IfaceCoercion, -- Conversion from Type -> IfaceType @@ -82,10 +83,15 @@ data IfaceType -- A kind of universal type, used for types, kinds, and coerci | IfaceTyConApp IfaceTyCon [IfaceType] -- Not necessarily saturated -- Includes newtypes, synonyms, tuples | IfaceCoConApp IfaceCoCon [IfaceType] -- Always saturated + | IfaceLitTy IfaceTyLit type IfacePredType = IfaceType type IfaceContext = [IfacePredType] +data IfaceTyLit + = IfaceNumTyLit Integer + | IfaceStrTyLit FastString + -- Encodes type constructors, kind constructors -- coercion constructors, the lot newtype IfaceTyCon = IfaceTc { ifaceTyConName :: IfExtName } @@ -198,6 +204,8 @@ ppr_ty :: Int -> IfaceType -> SDoc ppr_ty _ (IfaceTyVar tyvar) = ppr tyvar ppr_ty ctxt_prec (IfaceTyConApp tc tys) = ppr_tc_app ctxt_prec tc tys +ppr_ty _ (IfaceLitTy n) = ppr_tylit n + ppr_ty ctxt_prec (IfaceCoConApp tc tys) = maybeParen ctxt_prec tYCON_PREC (sep [ppr tc, nest 4 (sep (map pprParendIfaceType tys))]) @@ -255,7 +263,15 @@ ppr_tc_app ctxt_prec tc tys ppr_tc :: IfaceTyCon -> SDoc -- Wrap infix type constructors in parens -ppr_tc tc = parenSymOcc (getOccName (ifaceTyConName tc)) (ppr tc) +ppr_tc tc = wrap (ifaceTyConName tc) (ppr tc) + where + -- The kind * does not get wrapped in parens. + wrap name | name == liftedTypeKindTyConName = id + wrap name = parenSymOcc (getOccName name) + +ppr_tylit :: IfaceTyLit -> SDoc +ppr_tylit (IfaceNumTyLit n) = integer n +ppr_tylit (IfaceStrTyLit n) = text (show n) ------------------- instance Outputable IfaceTyCon where @@ -271,6 +287,9 @@ instance Outputable IfaceCoCon where ppr IfaceInstCo = ptext (sLit "Inst") ppr (IfaceNthCo d) = ptext (sLit "Nth:") <> int d +instance Outputable IfaceTyLit where + ppr = ppr_tylit + ------------------- pprIfaceContext :: IfaceContext -> SDoc -- Prints "(C a, D b) =>", including the arrow @@ -312,6 +331,7 @@ toIfaceType (TyVarTy tv) = IfaceTyVar (toIfaceTyVar tv) toIfaceType (AppTy t1 t2) = IfaceAppTy (toIfaceType t1) (toIfaceType t2) toIfaceType (FunTy t1 t2) = IfaceFunTy (toIfaceType t1) (toIfaceType t2) toIfaceType (TyConApp tc tys) = IfaceTyConApp (toIfaceTyCon tc) (toIfaceTypes tys) +toIfaceType (LitTy n) = IfaceLitTy (toIfaceTyLit n) toIfaceType (ForAllTy tv t) = IfaceForAllTy (toIfaceTvBndr tv) (toIfaceType t) toIfaceTyVar :: TyVar -> FastString @@ -327,6 +347,10 @@ toIfaceTyCon = toIfaceTyCon_name . tyConName toIfaceTyCon_name :: Name -> IfaceTyCon toIfaceTyCon_name = IfaceTc +toIfaceTyLit :: TyLit -> IfaceTyLit +toIfaceTyLit (NumTyLit x) = IfaceNumTyLit x +toIfaceTyLit (StrTyLit x) = IfaceStrTyLit x + ---------------- toIfaceTypes :: [Type] -> [IfaceType] toIfaceTypes ts = map toIfaceType ts diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index 0de092742c..e0b0f1d2a8 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -856,6 +856,7 @@ tcIfaceVectInfo mod typeEnv (IfaceVectInfo tcIfaceType :: IfaceType -> IfL Type tcIfaceType (IfaceTyVar n) = do { tv <- tcIfaceTyVar n; return (TyVarTy tv) } tcIfaceType (IfaceAppTy t1 t2) = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2; return (AppTy t1' t2') } +tcIfaceType (IfaceLitTy l) = do { l1 <- tcIfaceTyLit l; return (LitTy l1) } tcIfaceType (IfaceFunTy t1 t2) = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2; return (FunTy t1' t2') } tcIfaceType (IfaceTyConApp tc ts) = do { tc' <- tcIfaceTyCon tc; ts' <- tcIfaceTypes ts; return (mkTyConApp tc' ts') } tcIfaceType (IfaceForAllTy tv t) = bindIfaceTyVar tv $ \ tv' -> do { t' <- tcIfaceType t; return (ForAllTy tv' t') } @@ -867,6 +868,11 @@ tcIfaceTypes tys = mapM tcIfaceType tys ----------------------------------------- tcIfaceCtxt :: IfaceContext -> IfL ThetaType tcIfaceCtxt sts = mapM tcIfaceType sts + +----------------------------------------- +tcIfaceTyLit :: IfaceTyLit -> IfL TyLit +tcIfaceTyLit (IfaceNumTyLit n) = return (NumTyLit n) +tcIfaceTyLit (IfaceStrTyLit n) = return (StrTyLit n) \end{code} %************************************************************************ @@ -881,6 +887,7 @@ tcIfaceCo (IfaceTyVar n) = mkCoVarCo <$> tcIfaceCoVar n tcIfaceCo (IfaceAppTy t1 t2) = mkAppCo <$> tcIfaceCo t1 <*> tcIfaceCo t2 tcIfaceCo (IfaceFunTy t1 t2) = mkFunCo <$> tcIfaceCo t1 <*> tcIfaceCo t2 tcIfaceCo (IfaceTyConApp tc ts) = mkTyConAppCo <$> tcIfaceTyCon tc <*> mapM tcIfaceCo ts +tcIfaceCo t@(IfaceLitTy _) = mkReflCo <$> tcIfaceType t tcIfaceCo (IfaceCoConApp tc ts) = tcIfaceCoApp tc ts tcIfaceCo (IfaceForAllTy tv t) = bindIfaceTyVar tv $ \ tv' -> mkForAllCo tv' <$> tcIfaceCo t diff --git a/compiler/main/Annotations.lhs b/compiler/main/Annotations.hs index ec61a1f4a6..277c059b11 100644 --- a/compiler/main/Annotations.lhs +++ b/compiler/main/Annotations.hs @@ -1,37 +1,30 @@ -% -% (c) The University of Glasgow 2006 -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% - -\begin{code} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - +-- | +-- Support for source code annotation feature of GHC. That is the ANN pragma. +-- +-- (c) The University of Glasgow 2006 +-- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-- module Annotations ( - -- * Main Annotation data types - Annotation(..), - AnnTarget(..), CoreAnnTarget, - getAnnTargetName_maybe, - - -- * AnnEnv for collecting and querying Annotations - AnnEnv, - mkAnnEnv, extendAnnEnvList, plusAnnEnv, emptyAnnEnv, findAnns, - deserializeAnns - ) where + -- * Main Annotation data types + Annotation(..), + AnnTarget(..), CoreAnnTarget, + getAnnTargetName_maybe, + + -- * AnnEnv for collecting and querying Annotations + AnnEnv, + mkAnnEnv, extendAnnEnvList, plusAnnEnv, emptyAnnEnv, findAnns, + deserializeAnns + ) where -import Name import Module ( Module ) +import Name import Outputable -import UniqFM import Serialized +import UniqFM import Unique -import Data.Typeable import Data.Maybe +import Data.Typeable import Data.Word ( Word8 ) @@ -40,14 +33,14 @@ import Data.Word ( Word8 ) data Annotation = Annotation { ann_target :: CoreAnnTarget, -- ^ The target of the annotation ann_value :: Serialized -- ^ 'Serialized' version of the annotation that - -- allows recovery of its value or can + -- allows recovery of its value or can -- be persisted to an interface file } -- | An annotation target data AnnTarget name = NamedTarget name -- ^ We are annotating something with a name: - -- a type or identifier + -- a type or identifier | ModuleTarget Module -- ^ We are annotating a particular module -- | The kind of annotation target found in the middle end of the compiler @@ -57,6 +50,7 @@ instance Functor AnnTarget where fmap f (NamedTarget nm) = NamedTarget (f nm) fmap _ (ModuleTarget mod) = ModuleTarget mod +-- | Get the 'name' of an annotation target if it exists. getAnnTargetName_maybe :: AnnTarget name -> Maybe name getAnnTargetName_maybe (NamedTarget nm) = Just nm getAnnTargetName_maybe _ = Nothing @@ -74,20 +68,25 @@ instance Outputable Annotation where ppr ann = ppr (ann_target ann) -- | A collection of annotations -newtype AnnEnv = MkAnnEnv (UniqFM [Serialized]) -- Can't use a type synonym or we hit bug #2412 due to source import +newtype AnnEnv = MkAnnEnv (UniqFM [Serialized]) +-- | An empty annotation environment. emptyAnnEnv :: AnnEnv emptyAnnEnv = MkAnnEnv emptyUFM +-- | Construct a new annotation environment that contains the list of +-- annotations provided. mkAnnEnv :: [Annotation] -> AnnEnv mkAnnEnv = extendAnnEnvList emptyAnnEnv +-- | Add the given annotation to the environment. extendAnnEnvList :: AnnEnv -> [Annotation] -> AnnEnv extendAnnEnvList (MkAnnEnv env) anns = MkAnnEnv $ addListToUFM_C (++) env $ map (\ann -> (getUnique (ann_target ann), [ann_value ann])) anns +-- | Union two annotation environments. plusAnnEnv :: AnnEnv -> AnnEnv -> AnnEnv plusAnnEnv (MkAnnEnv env1) (MkAnnEnv env2) = MkAnnEnv $ plusUFM_C (++) env1 env2 @@ -105,4 +104,4 @@ findAnns deserialize (MkAnnEnv ann_env) deserializeAnns :: Typeable a => ([Word8] -> a) -> AnnEnv -> UniqFM [a] deserializeAnns deserialize (MkAnnEnv ann_env) = mapUFM (mapMaybe (fromSerialized deserialize)) ann_env -\end{code} + diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index eeb1dfc280..c24e5772e7 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -229,7 +229,7 @@ data DynFlag | Opt_DoStgLinting | Opt_DoCmmLinting | Opt_DoAsmLinting - | Opt_NoLlvmMangler + | Opt_NoLlvmMangler -- hidden flag | Opt_WarnIsError -- -Werror; makes warnings fatal @@ -252,11 +252,12 @@ data DynFlag | Opt_DictsCheap | Opt_EnableRewriteRules -- Apply rewrite rules during simplification | Opt_Vectorise + | Opt_AvoidVect | Opt_RegsGraph -- do graph coloring register allocation | Opt_RegsIterative -- do iterative coalescing graph coloring register allocation | Opt_PedanticBottoms -- Be picky about how we treat bottom - | Opt_LlvmTBAA -- Use LLVM TBAA infastructure for improving AA - | Opt_RegLiveness -- Use the STG Reg liveness information + | Opt_LlvmTBAA -- Use LLVM TBAA infastructure for improving AA (hidden flag) + | Opt_RegLiveness -- Use the STG Reg liveness information (hidden flag) -- Interface files | Opt_IgnoreInterfacePragmas @@ -449,6 +450,7 @@ data ExtensionFlag | Opt_RankNTypes | Opt_ImpredicativeTypes | Opt_TypeOperators + | Opt_ExplicitNamespaces | Opt_PackageImports | Opt_ExplicitForAll | Opt_AlternativeLayoutRule @@ -1639,7 +1641,7 @@ dynamic_flags = [ , Flag "dshow-passes" (NoArg (do forceRecompile setVerbosity $ Just 2)) , Flag "dfaststring-stats" (NoArg (setDynFlag Opt_D_faststring_stats)) - , Flag "dno-llvm-mangler" (NoArg (setDynFlag Opt_NoLlvmMangler)) + , Flag "dno-llvm-mangler" (NoArg (setDynFlag Opt_NoLlvmMangler)) -- hidden flag ------ Machine dependant (-m<blah>) stuff --------------------------- @@ -1865,10 +1867,11 @@ fFlags = [ ( "run-cpsz", Opt_RunCPSZ, nop ), ( "new-codegen", Opt_TryNewCodeGen, nop ), ( "vectorise", Opt_Vectorise, nop ), + ( "avoid-vect", Opt_AvoidVect, nop ), ( "regs-graph", Opt_RegsGraph, nop ), ( "regs-iterative", Opt_RegsIterative, nop ), - ( "llvm-tbaa", Opt_LlvmTBAA, nop), - ( "reg-liveness", Opt_RegLiveness, nop), + ( "llvm-tbaa", Opt_LlvmTBAA, nop), -- hidden flag + ( "regs-liveness", Opt_RegLiveness, nop), -- hidden flag ( "gen-manifest", Opt_GenManifest, nop ), ( "embed-manifest", Opt_EmbedManifest, nop ), ( "ext-core", Opt_EmitExternalCore, nop ), @@ -1973,6 +1976,7 @@ xFlags = [ ( "RankNTypes", Opt_RankNTypes, nop ), ( "ImpredicativeTypes", Opt_ImpredicativeTypes, nop), ( "TypeOperators", Opt_TypeOperators, nop ), + ( "ExplicitNamespaces", Opt_ExplicitNamespaces, nop ), ( "RecursiveDo", Opt_RecursiveDo, -- Enables 'mdo' deprecatedForExtension "DoRec"), ( "DoRec", Opt_DoRec, nop ), -- Enables 'rec' keyword @@ -2084,7 +2088,11 @@ impliedFlags , (Opt_TypeFamilies, turnOn, Opt_MonoLocalBinds) , (Opt_TypeFamilies, turnOn, Opt_KindSignatures) -- Type families use kind signatures - -- all over the place + + -- We turn this on so that we can export associated type + -- type synonyms in subordinates (e.g. MyClass(type AssocType)) + , (Opt_TypeFamilies, turnOn, Opt_ExplicitNamespaces) + , (Opt_TypeOperators, turnOn, Opt_ExplicitNamespaces) , (Opt_ImpredicativeTypes, turnOn, Opt_RankNTypes) @@ -2215,6 +2223,7 @@ glasgowExtsFlags = [ , Opt_LiberalTypeSynonyms , Opt_RankNTypes , Opt_TypeOperators + , Opt_ExplicitNamespaces , Opt_DoRec , Opt_ParallelListComp , Opt_EmptyDataDecls diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs index 545993d62d..f0662ab3fb 100644 --- a/compiler/main/GhcMake.hs +++ b/compiler/main/GhcMake.hs @@ -4,73 +4,65 @@ -- -- (c) The University of Glasgow, 2011 -- --- This module implements multi-module compilation, and is used --- by --make and GHCi. +-- This module implements multi-module compilation, and is used +-- by --make and GHCi. -- -- ----------------------------------------------------------------------------- - -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module GhcMake( - depanal, - load, LoadHowMuch(..), + depanal, + load, LoadHowMuch(..), - topSortModuleGraph, + topSortModuleGraph, - noModError, cyclicModuleErr - ) where + noModError, cyclicModuleErr + ) where #include "HsVersions.h" #ifdef GHCI -import qualified Linker ( unload ) +import qualified Linker ( unload ) #endif -import DriverPipeline import DriverPhases -import GhcMonad -import Module -import HscTypes -import ErrUtils +import DriverPipeline import DynFlags -import HsSyn +import ErrUtils import Finder +import GhcMonad import HeaderInfo -import TcIface ( typecheckIface ) -import TcRnMonad ( initIfaceCheck ) -import RdrName ( RdrName ) +import HsSyn +import HscTypes +import Module +import RdrName ( RdrName ) +import TcIface ( typecheckIface ) +import TcRnMonad ( initIfaceCheck ) -import Exception ( evaluate, tryIO ) -import Panic -import SysTools +import Bag ( listToBag ) import BasicTypes -import SrcLoc -import Util import Digraph -import Bag ( listToBag ) -import Maybes ( expectJust, mapCatMaybes ) -import StringBuffer +import Exception ( evaluate, tryIO ) import FastString +import Maybes ( expectJust, mapCatMaybes ) import Outputable +import Panic +import SrcLoc +import StringBuffer +import SysTools import UniqFM +import Util import qualified Data.Map as Map -import qualified FiniteMap as Map( insertListWith) +import qualified FiniteMap as Map ( insertListWith ) -import System.Directory -import System.IO ( fixIO ) -import System.IO.Error ( isDoesNotExistError ) -import System.FilePath import Control.Monad -import Data.Maybe import Data.List import qualified Data.List as List +import Data.Maybe import Data.Time +import System.Directory +import System.FilePath +import System.IO ( fixIO ) +import System.IO.Error ( isDoesNotExistError ) -- ----------------------------------------------------------------------------- -- Loading the program @@ -94,14 +86,14 @@ depanal :: GhcMonad m => 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 - + 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))]) + 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 } @@ -133,225 +125,219 @@ data LoadHowMuch -- 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 $ \_ -> discardIC $ hsc_env { 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. + mod_graph <- depanal [] False + 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 $ \_ -> discardIC $ hsc_env { 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. +loadFinish :: GhcMonad m => SuccessFlag -> SuccessFlag -> m SuccessFlag -- 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 [] @@ -365,13 +351,13 @@ loadFinish all_ok Succeeded return all_ok --- Forget the current program, but retain the persistent info in HscEnv +-- | Forget the current program, but retain the persistent info in HscEnv discardProg :: HscEnv -> HscEnv discardProg hsc_env = discardIC $ hsc_env { hsc_mod_graph = emptyMG , hsc_HPT = emptyHomePackageTable } --- discard the contents of the InteractiveContext, but keep the DynFlags +-- | Discard the contents of the InteractiveContext, but keep the DynFlags discardIC :: HscEnv -> HscEnv discardIC hsc_env = hsc_env { hsc_IC = emptyInteractiveContext (ic_dflags (hsc_IC hsc_env)) } @@ -419,13 +405,13 @@ guessOutputFile = modifySession $ \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 ModDetails, all linked code -- - all unlinked code that is out of date with respect to -- the source file -- @@ -433,34 +419,31 @@ guessOutputFile = modifySession $ \env -> -- 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 :: 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) + | 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 + 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. +-- +-- | 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 @@ -481,22 +464,21 @@ findPartiallyCompletedCycles modsDone theGraph -- --------------------------------------------------------------------------- --- Unloading - +-- +-- | Unloading unload :: HscEnv -> [Linkable] -> IO () -unload hsc_env stable_linkables -- Unload everthing *except* 'stable_linkables' +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 + LinkInMemory -> Linker.unload (hsc_dflags hsc_env) stable_linkables #else - LinkInMemory -> panic "unload: no interpreter" + LinkInMemory -> panic "unload: no interpreter" -- urgh. avoid warnings: hsc_env stable_linkables #endif - _other -> return () + _other -> return () -- ----------------------------------------------------------------------------- - {- | Stability tells us which modules definitely do not need to be recompiled. @@ -517,25 +499,25 @@ unload hsc_env stable_linkables -- Unload everthing *except* 'stable_linkables' 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) + 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) + 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 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'. + 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'. @@ -545,13 +527,12 @@ unload hsc_env stable_linkables -- Unload everthing *except* 'stable_linkables' - 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 + :: 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 @@ -560,65 +541,64 @@ checkStability hpt sccs all_home_mods = foldl checkSCC ([],[]) sccs | 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 = 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. + -- 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. -- -- But see #5527, where someone ran into this and it caused -- a problem. - 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 + 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) + => 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) + -> [SCC ModSummary] -- ^ Mods to do (the worklist) -> m (SuccessFlag, [ModSummary]) -- ^ Returns: @@ -645,8 +625,8 @@ upsweep old_hpt stable_mods cleanup sccs = do 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))) + -- show (map (moduleUserString.moduleName.mi_module.hm_iface) + -- (moduleEnvElts (hsc_HPT hsc_env))) let logger _mod = defaultWarnErrLogger hsc_env <- getSession @@ -665,21 +645,21 @@ upsweep old_hpt stable_mods cleanup sccs = do 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 + 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 + old_hpt1 | isBootSummary mod = old_hpt + | otherwise = delFromUFM old_hpt this_mod done' = mod:done @@ -688,30 +668,29 @@ upsweep old_hpt stable_mods cleanup sccs = do hsc_env2 <- liftIO $ reTypecheckLoop hsc_env1 mod done' setSession hsc_env2 - upsweep' old_hpt1 done' mods (mod_index+1) nmods + 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]) + -> ([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 + 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 + 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 + 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. @@ -732,23 +711,23 @@ upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods -- 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 + -- 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 + = 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 -> SourceModified -> IO HomeModInfo compile_it mb_linkable src_modified = @@ -853,13 +832,12 @@ upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods 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 ] + | 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 @@ -887,7 +865,6 @@ 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) && @@ -927,17 +904,15 @@ reachableBackwards mod summaries root = expectJust "reachableBackwards" (lookup_node HsBootFile mod) -- --------------------------------------------------------------------------- --- Topological sort of the module graph - -type SummaryNode = (ModSummary, Int, [Int]) - +-- +-- | Topological sort of the module graph topSortModuleGraph - :: Bool + :: Bool -- ^ Drop hi-boot nodes? (see below) - -> [ModSummary] - -> Maybe ModuleName + -> [ModSummary] + -> Maybe ModuleName -- ^ Root module name. If @Nothing@, use the full graph. - -> [SCC ModSummary] + -> [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 @@ -946,12 +921,12 @@ topSortModuleGraph -- -- Drop hi-boot nodes (first boolean arg)? -- --- - @False@: treat the hi-boot summaries as nodes of the graph, --- so the graph must be acyclic +-- - @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 +-- - @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 @@ -969,6 +944,8 @@ topSortModuleGraph drop_hs_boot_nodes summaries mb_root_mod | otherwise = ghcError (ProgramError "module does not exist") in graphFromEdgedVertices (seq root (reachableG graph root)) +type SummaryNode = (ModSummary, Int, [Int]) + summaryNodeKey :: SummaryNode -> Int summaryNodeKey (_, k, _) = k @@ -1025,14 +1002,14 @@ moduleGraphNodes drop_hs_boot_nodes summaries = (graphFromEdgedVertices nodes, l type NodeKey = (ModuleName, HscSource) -- The nodes of the graph are -type NodeMap a = Map.Map NodeKey a -- keyed by (mod, src_file_type) pairs +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 @@ -1044,23 +1021,24 @@ 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 ] + 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)) + warn :: Located ModuleName -> WarnMsg + warn (L loc mod) = + mkPlainErrMsg loc + (ptext (sLit "Warning: {-# SOURCE #-} unnecessary in import of ") + <+> quotes (ppr mod)) ----------------------------------------------------------------------------- --- Downsweep (dependency analysis) - +-- +-- | 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. @@ -1068,18 +1046,17 @@ warnUnnecessarySourceImports sccs = do -- 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 + -> [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 @@ -1088,86 +1065,85 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots summs <- loop (concatMap msDeps rootSummaries) root_map return summs where - roots = hsc_targets hsc_env + roots = hsc_targets hsc_env - old_summary_map :: NodeMap ModSummary - old_summary_map = mkNodeMap old_summaries + 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 + 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 + 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 "<command line>") - - -- 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 + case maybe_summary of + Nothing -> packageModErr modl + Just s -> return s + + rootLoc = mkGeneralSrcSpan (fsLit "<command line>") + + -- 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) + 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. +-- | 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 +-- *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 :: ModSummary -> [(Located ModuleName, IsBootInterface)] msDeps s = concat [ [(m,True), (m,False)] | m <- ms_home_srcimps s ] - ++ [ (m,False) | m <- ms_home_imps 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) ] @@ -1190,107 +1166,107 @@ ms_home_imps = home_imps . ms_imps -- 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. +-- 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. +-- 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 + :: HscEnv + -> [ModSummary] -- old summaries + -> FilePath -- source file name + -> Maybe Phase -- start phase -> Bool -- object code allowed? - -> Maybe (StringBuffer,UTCTime) - -> IO ModSummary + -> Maybe (StringBuffer,UTCTime) + -> 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. + -- 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 $ getModificationUTCTime file - -- The file exists; we checked in getRootSummary above. - -- If it gets removed subsequently, then this - -- getModificationUTCTime 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 <- + 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 $ getModificationUTCTime file + -- The file exists; we checked in getRootSummary above. + -- If it gets removed subsequently, then this + -- getModificationUTCTime 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 + return old_summary{ ms_obj_date = obj_timestamp } + else + new_summary | otherwise = new_summary where new_summary = do - let dflags = hsc_dflags hsc_env + let dflags = hsc_dflags hsc_env - (dflags', hspp_fn, buf) - <- preprocessFile hsc_env file mb_phase maybe_buf + (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 + -- 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 + -- 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 $ getModificationUTCTime file - -- getMofificationTime may fail + Just (_,t) -> return t + Nothing -> liftIO $ getModificationUTCTime 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 <- + 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_location = location, ms_hspp_file = hspp_fn, ms_hspp_opts = dflags', - ms_hspp_buf = Just buf, + ms_hspp_buf = Just buf, ms_srcimps = srcimps, ms_textual_imps = the_imps, - ms_hs_date = src_timestamp, - ms_obj_date = obj_timestamp }) + 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 + 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 + :: 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, UTCTime) - -> [ModuleName] -- Modules to exclude - -> IO (Maybe ModSummary) -- Its new summary + -> Maybe (StringBuffer, UTCTime) + -> [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 @@ -1298,22 +1274,22 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) = 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 (getModificationUTCTime src_fn) - case m of - Right t -> check_timestamp old_summary location src_fn t - Left e | isDoesNotExistError e -> find_it - | otherwise -> ioError e + = 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 (getModificationUTCTime 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 @@ -1322,89 +1298,89 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) 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 + | 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 + 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 + -- 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') + -- 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 + -- 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 + -- 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) + 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 <- + -- 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, + 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_textual_imps = the_imps, - ms_hs_date = src_timestamp, - ms_obj_date = obj_timestamp })) + ms_hspp_buf = Just buf, + ms_srcimps = srcimps, + ms_textual_imps = the_imps, + ms_hs_date = src_timestamp, + ms_obj_date = obj_timestamp })) getObjTimestamp :: ModLocation -> Bool -> IO (Maybe UTCTime) getObjTimestamp location is_boot = if is_boot then return Nothing - else modificationTimeIfExists (ml_obj_file location) + else modificationTimeIfExists (ml_obj_file location) preprocessFile :: HscEnv @@ -1414,43 +1390,43 @@ preprocessFile :: HscEnv -> 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) + (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 - let local_opts = getOptions dflags buf src_fn + let local_opts = getOptions dflags buf src_fn - (dflags', leftovers, warns) + (dflags', leftovers, warns) <- parseDynamicFilePragma 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 + 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") + when needs_preprocessing $ + ghcError (ProgramError "buffer needs preprocesing; interactive check disabled") - return (dflags', src_fn, buf) + return (dflags', src_fn, buf) ----------------------------------------------------------------------------- --- Error messages +-- 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 @@ -1458,15 +1434,15 @@ noHsFileErr loc path packageModErr :: ModuleName -> IO a packageModErr mod = throwOneError $ mkPlainErrMsg noSrcSpan $ - text "module" <+> quotes (ppr mod) <+> text "is a package module" + 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) + 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 @@ -1501,5 +1477,5 @@ cyclicModuleErr mss ppr_ms :: ModSummary -> SDoc ppr_ms ms = quotes (ppr (moduleName (ms_mod ms))) <+> - (parens (text (msHsFilePath ms))) + (parens (text (msHsFilePath ms))) diff --git a/compiler/main/HscStats.hs b/compiler/main/HscStats.hs new file mode 100644 index 0000000000..ea3739a88e --- /dev/null +++ b/compiler/main/HscStats.hs @@ -0,0 +1,159 @@ +-- | +-- Statistics for per-module compilations +-- +-- (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 +-- +module HscStats ( ppSourceStats ) where + +import Bag +import HsSyn +import Outputable +import RdrName +import SrcLoc +import Util + +import Data.Char + +-- | Source Statistics +ppSourceStats :: Bool -> Located (HsModule RdrName) -> SDoc +ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _)) + = (if short then hcat else vcat) + (map pp_val + [("ExportAll ", export_all), -- 1 if no export list + ("ExportDecls ", export_ds), + ("ExportModules ", export_ms), + ("Imports ", imp_no), + (" ImpSafe ", imp_safe), + (" ImpQual ", imp_qual), + (" ImpAs ", imp_as), + (" ImpAll ", imp_all), + (" ImpPartial ", imp_partial), + (" ImpHiding ", imp_hiding), + ("FixityDecls ", fixity_sigs), + ("DefaultDecls ", default_ds), + ("TypeDecls ", type_ds), + ("DataDecls ", data_ds), + ("NewTypeDecls ", newt_ds), + ("TypeFamilyDecls ", type_fam_ds), + ("DataConstrs ", data_constrs), + ("DataDerivings ", data_derivs), + ("ClassDecls ", class_ds), + ("ClassMethods ", class_method_ds), + ("DefaultMethods ", default_method_ds), + ("InstDecls ", inst_ds), + ("InstMethods ", inst_method_ds), + ("InstType ", inst_type_ds), + ("InstData ", inst_data_ds), + ("TypeSigs ", bind_tys), + ("GenericSigs ", generic_sigs), + ("ValBinds ", val_bind_ds), + ("FunBinds ", fn_bind_ds), + ("InlineMeths ", method_inlines), + ("InlineBinds ", bind_inlines), + ("SpecialisedMeths ", method_specs), + ("SpecialisedBinds ", bind_specs) + ]) + where + decls = map unLoc ldecls + + pp_val (_, 0) = empty + pp_val (str, n) + | not short = hcat [text str, int n] + | otherwise = hcat [text (trim str), equals, int n, semi] + + trim ls = takeWhile (not.isSpace) (dropWhile isSpace ls) + + (fixity_sigs, bind_tys, bind_specs, bind_inlines, generic_sigs) + = count_sigs [d | SigD d <- decls] + -- NB: this omits fixity decls on local bindings and + -- in class decls. ToDo + + tycl_decls = [d | TyClD d <- decls] + (class_ds, type_ds, data_ds, newt_ds, type_fam_ds) = + countTyClDecls tycl_decls + + inst_decls = [d | InstD d <- decls] + inst_ds = length inst_decls + default_ds = count (\ x -> case x of { DefD{} -> True; _ -> False}) decls + val_decls = [d | ValD d <- decls] + + real_exports = case exports of { Nothing -> []; Just es -> es } + n_exports = length real_exports + export_ms = count (\ e -> case unLoc e of { IEModuleContents{} -> True;_ -> False}) + real_exports + export_ds = n_exports - export_ms + export_all = case exports of { Nothing -> 1; _ -> 0 } + + (val_bind_ds, fn_bind_ds) + = foldr add2 (0,0) (map count_bind val_decls) + + (imp_no, imp_safe, imp_qual, imp_as, imp_all, imp_partial, imp_hiding) + = foldr add7 (0,0,0,0,0,0,0) (map import_info imports) + (data_constrs, data_derivs) + = foldr add2 (0,0) (map data_info tycl_decls) + (class_method_ds, default_method_ds) + = foldr add2 (0,0) (map class_info tycl_decls) + (inst_method_ds, method_specs, method_inlines, inst_type_ds, inst_data_ds) + = foldr add5 (0,0,0,0,0) (map inst_info inst_decls) + + count_bind (PatBind { pat_lhs = L _ (VarPat _) }) = (1,0) + count_bind (PatBind {}) = (0,1) + count_bind (FunBind {}) = (0,1) + count_bind b = pprPanic "count_bind: Unhandled binder" (ppr b) + + count_sigs sigs = foldr add5 (0,0,0,0,0) (map sig_info sigs) + + sig_info (FixSig _) = (1,0,0,0,0) + sig_info (TypeSig _ _) = (0,1,0,0,0) + sig_info (SpecSig _ _ _) = (0,0,1,0,0) + sig_info (InlineSig _ _) = (0,0,0,1,0) + sig_info (GenericSig _ _) = (0,0,0,0,1) + sig_info _ = (0,0,0,0,0) + + import_info (L _ (ImportDecl { ideclSafe = safe, ideclQualified = qual + , ideclAs = as, ideclHiding = spec })) + = add7 (1, safe_info safe, qual_info qual, as_info as, 0,0,0) (spec_info spec) + safe_info = qual_info + qual_info False = 0 + qual_info True = 1 + as_info Nothing = 0 + as_info (Just _) = 1 + spec_info Nothing = (0,0,0,0,1,0,0) + spec_info (Just (False, _)) = (0,0,0,0,0,1,0) + spec_info (Just (True, _)) = (0,0,0,0,0,0,1) + + data_info (TyDecl { tcdTyDefn = TyData {td_cons = cs, td_derivs = derivs}}) + = (length cs, case derivs of Nothing -> 0 + Just ds -> length ds) + data_info _ = (0,0) + + class_info decl@(ClassDecl {}) + = case count_sigs (map unLoc (tcdSigs decl)) of + (_,classops,_,_,_) -> + (classops, addpr (foldr add2 (0,0) (map (count_bind.unLoc) (bagToList (tcdMeths decl))))) + class_info _ = (0,0) + + inst_info (FamInstD d) = case countATDecl d of + (tyd, dtd) -> (0,0,0,tyd,dtd) + inst_info (ClsInstD _ inst_meths inst_sigs ats) + = case count_sigs (map unLoc inst_sigs) of + (_,_,ss,is,_) -> + case foldr add2 (0, 0) (map (countATDecl . unLoc) ats) of + (tyDecl, dtDecl) -> + (addpr (foldr add2 (0,0) + (map (count_bind.unLoc) (bagToList inst_meths))), + ss, is, tyDecl, dtDecl) + where + countATDecl (FamInstDecl { fid_defn = TyData {} }) = (0, 1) + countATDecl (FamInstDecl { fid_defn = TySynonym {} }) = (1, 0) + + addpr :: (Int,Int) -> Int + add2 :: (Int,Int) -> (Int,Int) -> (Int, Int) + add5 :: (Int,Int,Int,Int,Int) -> (Int,Int,Int,Int,Int) -> (Int, Int, Int, Int, Int) + add7 :: (Int,Int,Int,Int,Int,Int,Int) -> (Int,Int,Int,Int,Int,Int,Int) -> (Int, Int, Int, Int, Int, Int, Int) + + addpr (x,y) = x+y + add2 (x1,x2) (y1,y2) = (x1+y1,x2+y2) + add5 (x1,x2,x3,x4,x5) (y1,y2,y3,y4,y5) = (x1+y1,x2+y2,x3+y3,x4+y4,x5+y5) + add7 (x1,x2,x3,x4,x5,x6,x7) (y1,y2,y3,y4,y5,y6,y7) = (x1+y1,x2+y2,x3+y3,x4+y4,x5+y5,x6+y6,x7+y7) + diff --git a/compiler/main/HscStats.lhs b/compiler/main/HscStats.lhs index 168e49af4a..b5fe0fdf86 100644 --- a/compiler/main/HscStats.lhs +++ b/compiler/main/HscStats.lhs @@ -141,7 +141,7 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _)) spec_info (Just (False, _)) = (0,0,0,0,0,1,0) spec_info (Just (True, _)) = (0,0,0,0,0,0,1) - data_info (TyData {tcdCons = cs, tcdDerivs = derivs}) + data_info (TyDecl { tcdTyDefn = TyData {td_cons = cs, td_derivs = derivs}}) = (length cs, case derivs of Nothing -> 0 Just ds -> length ds) data_info _ = (0,0) @@ -152,9 +152,9 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _)) (classops, addpr (foldr add2 (0,0) (map (count_bind.unLoc) (bagToList (tcdMeths decl))))) class_info _ = (0,0) - inst_info (FamInstDecl d) = case countATDecl d of + inst_info (FamInstD d) = case countATDecl d of (tyd, dtd) -> (0,0,0,tyd,dtd) - inst_info (ClsInstDecl _ inst_meths inst_sigs ats) + inst_info (ClsInstD _ inst_meths inst_sigs ats) = case count_sigs (map unLoc inst_sigs) of (_,_,ss,is,_) -> case foldr add2 (0, 0) (map (countATDecl . unLoc) ats) of @@ -163,10 +163,8 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _)) (map (count_bind.unLoc) (bagToList inst_meths))), ss, is, tyDecl, dtDecl) where - countATDecl (TyData {}) = (0, 1) - countATDecl (TySynonym {}) = (1, 0) - countATDecl d = pprPanic "countATDecl: Unhandled decl" - (ppr d) + countATDecl (FamInstDecl { fid_defn = TyData {} }) = (0, 1) + countATDecl (FamInstDecl { fid_defn = TySynonym {} }) = (1, 0) addpr :: (Int,Int) -> Int add2 :: (Int,Int) -> (Int,Int) -> (Int, Int) diff --git a/compiler/main/PackageConfig.hs b/compiler/main/PackageConfig.hs index 913e58c6fb..d34d9e1f5c 100644 --- a/compiler/main/PackageConfig.hs +++ b/compiler/main/PackageConfig.hs @@ -1,47 +1,42 @@ +-- | +-- Package configuration information: essentially the interface to Cabal, with +-- some utilities -- -- (c) The University of Glasgow, 2004 -- +module PackageConfig ( + -- $package_naming --- | Package configuration information: essentially the interface to Cabal, with some utilities - -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details + -- * PackageId + mkPackageId, packageConfigId, -module PackageConfig ( - -- $package_naming - - -- * PackageId - mkPackageId, packageConfigId, - - -- * The PackageConfig type: information about a package - PackageConfig, - InstalledPackageInfo_(..), display, - Version(..), - PackageIdentifier(..), - defaultPackageConfig, + -- * The PackageConfig type: information about a package + PackageConfig, + InstalledPackageInfo_(..), display, + Version(..), + PackageIdentifier(..), + defaultPackageConfig, packageConfigToInstalledPackageInfo, - installedPackageInfoToPackageConfig, - ) where + installedPackageInfoToPackageConfig + ) where #include "HsVersions.h" -import Maybes -import Module import Distribution.InstalledPackageInfo import Distribution.ModuleName import Distribution.Package hiding (PackageId) import Distribution.Text import Distribution.Version +import Maybes +import Module + -- ----------------------------------------------------------------------------- --- Our PackageConfig type is just InstalledPackageInfo from Cabal. Later we +-- Our PackageConfig type is just InstalledPackageInfo from Cabal. Later we -- might need to extend it with some GHC-specific stuff, but for now it's fine. type PackageConfig = InstalledPackageInfo_ Module.ModuleName + defaultPackageConfig :: PackageConfig defaultPackageConfig = emptyInstalledPackageInfo @@ -51,9 +46,9 @@ defaultPackageConfig = emptyInstalledPackageInfo -- $package_naming -- #package_naming# -- Mostly the compiler deals in terms of 'PackageName's, which don't --- have the version suffix. This is so that we don't need to know the +-- have the version suffix. This is so that we don't need to know the -- version for the @-package-name@ flag, or know the versions of --- wired-in packages like @base@ & @rts@. Versions are confined to the +-- wired-in packages like @base@ & @rts@. Versions are confined to the -- package sub-system. -- -- This means that in theory you could have multiple base packages installed @@ -88,3 +83,4 @@ installedPackageInfoToPackageConfig hiddenModules = h })) = pkgconf{ exposedModules = map mkModuleName e, hiddenModules = map mkModuleName h } + diff --git a/compiler/nativeGen/PPC/Ppr.hs b/compiler/nativeGen/PPC/Ppr.hs index 26f06c373b..155df3cfaa 100644 --- a/compiler/nativeGen/PPC/Ppr.hs +++ b/compiler/nativeGen/PPC/Ppr.hs @@ -6,22 +6,15 @@ -- ----------------------------------------------------------------------------- -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module PPC.Ppr ( - pprNatCmmDecl, - pprBasicBlock, - pprSectionHeader, - pprData, - pprInstr, - pprSize, - pprImm, - pprDataItem, + pprNatCmmDecl, + pprBasicBlock, + pprSectionHeader, + pprData, + pprInstr, + pprSize, + pprImm, + pprDataItem, ) where @@ -40,7 +33,7 @@ import OldCmm import CLabel -import Unique ( pprUnique, Uniquable(..) ) +import Unique ( pprUnique, Uniquable(..) ) import Platform import Pretty import FastString @@ -209,23 +202,23 @@ pprReg platform r pprSize :: Size -> Doc pprSize x = ptext (case x of - II8 -> sLit "b" - II16 -> sLit "h" - II32 -> sLit "w" - FF32 -> sLit "fs" - FF64 -> sLit "fd" - _ -> panic "PPC.Ppr.pprSize: no match") - - + II8 -> sLit "b" + II16 -> sLit "h" + II32 -> sLit "w" + FF32 -> sLit "fs" + FF64 -> sLit "fd" + _ -> panic "PPC.Ppr.pprSize: no match") + + pprCond :: Cond -> Doc pprCond c = ptext (case c of { - ALWAYS -> sLit ""; - EQQ -> sLit "eq"; NE -> sLit "ne"; - LTT -> sLit "lt"; GE -> sLit "ge"; - GTT -> sLit "gt"; LE -> sLit "le"; - LU -> sLit "lt"; GEU -> sLit "ge"; - GU -> sLit "gt"; LEU -> sLit "le"; }) + ALWAYS -> sLit ""; + EQQ -> sLit "eq"; NE -> sLit "ne"; + LTT -> sLit "lt"; GE -> sLit "ge"; + GTT -> sLit "gt"; LE -> sLit "le"; + LU -> sLit "lt"; GEU -> sLit "ge"; + GU -> sLit "gt"; LEU -> sLit "le"; }) pprImm :: Platform -> Imm -> Doc @@ -294,21 +287,21 @@ pprDataItem :: Platform -> CmmLit -> Doc pprDataItem platform lit = vcat (ppr_item (cmmTypeSize $ cmmLitType lit) lit) where - imm = litToImm lit + imm = litToImm lit - ppr_item II8 _ = [ptext (sLit "\t.byte\t") <> pprImm platform imm] + ppr_item II8 _ = [ptext (sLit "\t.byte\t") <> pprImm platform imm] - ppr_item II32 _ = [ptext (sLit "\t.long\t") <> pprImm platform imm] + ppr_item II32 _ = [ptext (sLit "\t.long\t") <> pprImm platform imm] - ppr_item FF32 (CmmFloat r _) + ppr_item FF32 (CmmFloat r _) = let bs = floatToBytes (fromRational r) in map (\b -> ptext (sLit "\t.byte\t") <> pprImm platform (ImmInt b)) bs - ppr_item FF64 (CmmFloat r _) + ppr_item FF64 (CmmFloat r _) = let bs = doubleToBytes (fromRational r) in map (\b -> ptext (sLit "\t.byte\t") <> pprImm platform (ImmInt b)) bs - ppr_item II16 _ = [ptext (sLit "\t.short\t") <> pprImm platform imm] + ppr_item II16 _ = [ptext (sLit "\t.short\t") <> pprImm platform imm] ppr_item II64 (CmmInt x _) = [ptext (sLit "\t.long\t") @@ -317,8 +310,8 @@ pprDataItem platform lit ptext (sLit "\t.long\t") <> int (fromIntegral (fromIntegral x :: Word32))] - ppr_item _ _ - = panic "PPC.Ppr.pprDataItem: no match" + ppr_item _ _ + = panic "PPC.Ppr.pprDataItem: no match" pprInstr :: Platform -> Instr -> Doc @@ -342,145 +335,145 @@ pprInstr _ (LDATA _ _) {- pprInstr _ (SPILL reg slot) = hcat [ - ptext (sLit "\tSPILL"), - char '\t', - pprReg platform reg, - comma, - ptext (sLit "SLOT") <> parens (int slot)] + ptext (sLit "\tSPILL"), + char '\t', + pprReg platform reg, + comma, + ptext (sLit "SLOT") <> parens (int slot)] pprInstr _ (RELOAD slot reg) = hcat [ - ptext (sLit "\tRELOAD"), - char '\t', - ptext (sLit "SLOT") <> parens (int slot), - comma, - pprReg platform reg] + ptext (sLit "\tRELOAD"), + char '\t', + ptext (sLit "SLOT") <> parens (int slot), + comma, + pprReg platform reg] -} pprInstr platform (LD sz reg addr) = hcat [ - char '\t', - ptext (sLit "l"), - ptext (case sz of - II8 -> sLit "bz" - II16 -> sLit "hz" - II32 -> sLit "wz" - FF32 -> sLit "fs" - FF64 -> sLit "fd" - _ -> panic "PPC.Ppr.pprInstr: no match" - ), + char '\t', + ptext (sLit "l"), + ptext (case sz of + II8 -> sLit "bz" + II16 -> sLit "hz" + II32 -> sLit "wz" + FF32 -> sLit "fs" + FF64 -> sLit "fd" + _ -> panic "PPC.Ppr.pprInstr: no match" + ), case addr of AddrRegImm _ _ -> empty AddrRegReg _ _ -> char 'x', - char '\t', - pprReg platform reg, - ptext (sLit ", "), - pprAddr platform addr + char '\t', + pprReg platform reg, + ptext (sLit ", "), + pprAddr platform addr ] pprInstr platform (LA sz reg addr) = hcat [ - char '\t', - ptext (sLit "l"), - ptext (case sz of - II8 -> sLit "ba" - II16 -> sLit "ha" - II32 -> sLit "wa" - FF32 -> sLit "fs" - FF64 -> sLit "fd" - _ -> panic "PPC.Ppr.pprInstr: no match" - ), + char '\t', + ptext (sLit "l"), + ptext (case sz of + II8 -> sLit "ba" + II16 -> sLit "ha" + II32 -> sLit "wa" + FF32 -> sLit "fs" + FF64 -> sLit "fd" + _ -> panic "PPC.Ppr.pprInstr: no match" + ), case addr of AddrRegImm _ _ -> empty AddrRegReg _ _ -> char 'x', - char '\t', - pprReg platform reg, - ptext (sLit ", "), - pprAddr platform addr + char '\t', + pprReg platform reg, + ptext (sLit ", "), + pprAddr platform addr ] pprInstr platform (ST sz reg addr) = hcat [ - char '\t', - ptext (sLit "st"), - pprSize sz, + char '\t', + ptext (sLit "st"), + pprSize sz, case addr of AddrRegImm _ _ -> empty AddrRegReg _ _ -> char 'x', - char '\t', - pprReg platform reg, - ptext (sLit ", "), - pprAddr platform addr + char '\t', + pprReg platform reg, + ptext (sLit ", "), + pprAddr platform addr ] pprInstr platform (STU sz reg addr) = hcat [ - char '\t', - ptext (sLit "st"), - pprSize sz, - ptext (sLit "u\t"), + char '\t', + ptext (sLit "st"), + pprSize sz, + ptext (sLit "u\t"), case addr of AddrRegImm _ _ -> empty AddrRegReg _ _ -> char 'x', - pprReg platform reg, - ptext (sLit ", "), - pprAddr platform addr + pprReg platform reg, + ptext (sLit ", "), + pprAddr platform addr ] pprInstr platform (LIS reg imm) = hcat [ - char '\t', - ptext (sLit "lis"), - char '\t', - pprReg platform reg, - ptext (sLit ", "), - pprImm platform imm + char '\t', + ptext (sLit "lis"), + char '\t', + pprReg platform reg, + ptext (sLit ", "), + pprImm platform imm ] pprInstr platform (LI reg imm) = hcat [ - char '\t', - ptext (sLit "li"), - char '\t', - pprReg platform reg, - ptext (sLit ", "), - pprImm platform imm + char '\t', + ptext (sLit "li"), + char '\t', + pprReg platform reg, + ptext (sLit ", "), + pprImm platform imm ] pprInstr platform (MR reg1 reg2) | reg1 == reg2 = empty | otherwise = hcat [ - char '\t', - case targetClassOfReg platform reg1 of - RcInteger -> ptext (sLit "mr") - _ -> ptext (sLit "fmr"), - char '\t', - pprReg platform reg1, - ptext (sLit ", "), - pprReg platform reg2 + char '\t', + case targetClassOfReg platform reg1 of + RcInteger -> ptext (sLit "mr") + _ -> ptext (sLit "fmr"), + char '\t', + pprReg platform reg1, + ptext (sLit ", "), + pprReg platform reg2 ] pprInstr platform (CMP sz reg ri) = hcat [ - char '\t', - op, - char '\t', - pprReg platform reg, - ptext (sLit ", "), - pprRI platform ri + char '\t', + op, + char '\t', + pprReg platform reg, + ptext (sLit ", "), + pprRI platform ri ] where - op = hcat [ - ptext (sLit "cmp"), - pprSize sz, - case ri of - RIReg _ -> empty - RIImm _ -> char 'i' - ] + op = hcat [ + ptext (sLit "cmp"), + pprSize sz, + case ri of + RIReg _ -> empty + RIImm _ -> char 'i' + ] pprInstr platform (CMPL sz reg ri) = hcat [ - char '\t', - op, - char '\t', - pprReg platform reg, - ptext (sLit ", "), - pprRI platform ri + char '\t', + op, + char '\t', + pprReg platform reg, + ptext (sLit ", "), + pprRI platform ri ] where - op = hcat [ - ptext (sLit "cmpl"), - pprSize sz, - case ri of - RIReg _ -> empty - RIImm _ -> char 'i' - ] + op = hcat [ + ptext (sLit "cmpl"), + pprSize sz, + case ri of + RIReg _ -> empty + RIImm _ -> char 'i' + ] pprInstr platform (BCC cond blockid) = hcat [ - char '\t', - ptext (sLit "b"), - pprCond cond, - char '\t', - pprCLabel_asm platform lbl + char '\t', + ptext (sLit "b"), + pprCond cond, + char '\t', + pprCLabel_asm platform lbl ] where lbl = mkAsmTempLabel (getUnique blockid) @@ -498,40 +491,40 @@ pprInstr platform (BCCFAR cond blockid) = vcat [ where lbl = mkAsmTempLabel (getUnique blockid) pprInstr platform (JMP lbl) = hcat [ -- an alias for b that takes a CLabel - char '\t', - ptext (sLit "b"), - char '\t', - pprCLabel_asm platform lbl + char '\t', + ptext (sLit "b"), + char '\t', + pprCLabel_asm platform lbl ] pprInstr platform (MTCTR reg) = hcat [ - char '\t', - ptext (sLit "mtctr"), - char '\t', - pprReg platform reg + char '\t', + ptext (sLit "mtctr"), + char '\t', + pprReg platform reg ] pprInstr _ (BCTR _ _) = hcat [ - char '\t', - ptext (sLit "bctr") + char '\t', + ptext (sLit "bctr") ] pprInstr platform (BL lbl _) = hcat [ - ptext (sLit "\tbl\t"), + ptext (sLit "\tbl\t"), pprCLabel_asm platform lbl ] pprInstr _ (BCTRL _) = hcat [ - char '\t', - ptext (sLit "bctrl") + char '\t', + ptext (sLit "bctrl") ] pprInstr platform (ADD reg1 reg2 ri) = pprLogic platform (sLit "add") reg1 reg2 ri pprInstr platform (ADDIS reg1 reg2 imm) = hcat [ - char '\t', - ptext (sLit "addis"), - char '\t', - pprReg platform reg1, - ptext (sLit ", "), - pprReg platform reg2, - ptext (sLit ", "), - pprImm platform imm + char '\t', + ptext (sLit "addis"), + char '\t', + pprReg platform reg1, + ptext (sLit ", "), + pprReg platform reg2, + ptext (sLit ", "), + pprImm platform imm ] pprInstr platform (ADDC reg1 reg2 reg3) = pprLogic platform (sLit "addc") reg1 reg2 (RIReg reg3) @@ -552,17 +545,17 @@ pprInstr platform (MULLW_MayOflo reg1 reg2 reg3) = vcat [ ptext (sLit "2, 31, 31") ] ] - -- for some reason, "andi" doesn't exist. - -- we'll use "andi." instead. + -- for some reason, "andi" doesn't exist. + -- we'll use "andi." instead. pprInstr platform (AND reg1 reg2 (RIImm imm)) = hcat [ - char '\t', - ptext (sLit "andi."), - char '\t', - pprReg platform reg1, - ptext (sLit ", "), - pprReg platform reg2, - ptext (sLit ", "), - pprImm platform imm + char '\t', + ptext (sLit "andi."), + char '\t', + pprReg platform reg1, + ptext (sLit ", "), + pprReg platform reg2, + ptext (sLit ", "), + pprImm platform imm ] pprInstr platform (AND reg1 reg2 ri) = pprLogic platform (sLit "and") reg1 reg2 ri @@ -570,31 +563,39 @@ pprInstr platform (OR reg1 reg2 ri) = pprLogic platform (sLit "or") reg1 reg2 ri pprInstr platform (XOR reg1 reg2 ri) = pprLogic platform (sLit "xor") reg1 reg2 ri pprInstr platform (XORIS reg1 reg2 imm) = hcat [ - char '\t', - ptext (sLit "xoris"), - char '\t', - pprReg platform reg1, - ptext (sLit ", "), - pprReg platform reg2, - ptext (sLit ", "), - pprImm platform imm + char '\t', + ptext (sLit "xoris"), + char '\t', + pprReg platform reg1, + ptext (sLit ", "), + pprReg platform reg2, + ptext (sLit ", "), + pprImm platform imm ] pprInstr platform (EXTS sz reg1 reg2) = hcat [ - char '\t', - ptext (sLit "exts"), - pprSize sz, - char '\t', - pprReg platform reg1, - ptext (sLit ", "), - pprReg platform reg2 + char '\t', + ptext (sLit "exts"), + pprSize sz, + char '\t', + pprReg platform reg1, + ptext (sLit ", "), + pprReg platform reg2 ] pprInstr platform (NEG reg1 reg2) = pprUnary platform (sLit "neg") reg1 reg2 pprInstr platform (NOT reg1 reg2) = pprUnary platform (sLit "not") reg1 reg2 pprInstr platform (SLW reg1 reg2 ri) = pprLogic platform (sLit "slw") reg1 reg2 (limitShiftRI ri) + +pprInstr platform (SRW reg1 reg2 (RIImm (ImmInt i))) | i > 31 || i < 0 = + -- Handle the case where we are asked to shift a 32 bit register by + -- less than zero or more than 31 bits. We convert this into a clear + -- of the destination register. + -- Fixes ticket http://hackage.haskell.org/trac/ghc/ticket/5900 + pprInstr platform (XOR reg1 reg2 (RIReg reg2)) pprInstr platform (SRW reg1 reg2 ri) = pprLogic platform (sLit "srw") reg1 reg2 (limitShiftRI ri) + pprInstr platform (SRAW reg1 reg2 ri) = pprLogic platform (sLit "sraw") reg1 reg2 (limitShiftRI ri) pprInstr platform (RLWINM reg1 reg2 sh mb me) = hcat [ ptext (sLit "\trlwinm\t"), @@ -616,14 +617,14 @@ pprInstr platform (FDIV sz reg1 reg2 reg3) = pprBinaryF platform (sLit "fdiv") s pprInstr platform (FNEG reg1 reg2) = pprUnary platform (sLit "fneg") reg1 reg2 pprInstr platform (FCMP reg1 reg2) = hcat [ - char '\t', - ptext (sLit "fcmpu\tcr0, "), - -- Note: we're using fcmpu, not fcmpo - -- The difference is with fcmpo, compare with NaN is an invalid operation. - -- We don't handle invalid fp ops, so we don't care - pprReg platform reg1, - ptext (sLit ", "), - pprReg platform reg2 + char '\t', + ptext (sLit "fcmpu\tcr0, "), + -- Note: we're using fcmpu, not fcmpo + -- The difference is with fcmpo, compare with NaN is an invalid operation. + -- We don't handle invalid fp ops, so we don't care + pprReg platform reg1, + ptext (sLit ", "), + pprReg platform reg2 ] pprInstr platform (FCTIWZ reg1 reg2) = pprUnary platform (sLit "fctiwz") reg1 reg2 @@ -639,17 +640,17 @@ pprInstr _ (CRNOR dst src1 src2) = hcat [ ] pprInstr platform (MFCR reg) = hcat [ - char '\t', - ptext (sLit "mfcr"), - char '\t', - pprReg platform reg + char '\t', + ptext (sLit "mfcr"), + char '\t', + pprReg platform reg ] pprInstr platform (MFLR reg) = hcat [ - char '\t', - ptext (sLit "mflr"), - char '\t', - pprReg platform reg + char '\t', + ptext (sLit "mflr"), + char '\t', + pprReg platform reg ] pprInstr platform (FETCHPC reg) = vcat [ @@ -664,42 +665,42 @@ pprInstr _ LWSYNC = ptext (sLit "\tlwsync") pprLogic :: Platform -> LitString -> Reg -> Reg -> RI -> Doc pprLogic platform op reg1 reg2 ri = hcat [ - char '\t', - ptext op, - case ri of - RIReg _ -> empty - RIImm _ -> char 'i', - char '\t', - pprReg platform reg1, - ptext (sLit ", "), - pprReg platform reg2, - ptext (sLit ", "), - pprRI platform ri + char '\t', + ptext op, + case ri of + RIReg _ -> empty + RIImm _ -> char 'i', + char '\t', + pprReg platform reg1, + ptext (sLit ", "), + pprReg platform reg2, + ptext (sLit ", "), + pprRI platform ri ] pprUnary :: Platform -> LitString -> Reg -> Reg -> Doc pprUnary platform op reg1 reg2 = hcat [ - char '\t', - ptext op, - char '\t', - pprReg platform reg1, - ptext (sLit ", "), - pprReg platform reg2 + char '\t', + ptext op, + char '\t', + pprReg platform reg1, + ptext (sLit ", "), + pprReg platform reg2 ] pprBinaryF :: Platform -> LitString -> Size -> Reg -> Reg -> Reg -> Doc pprBinaryF platform op sz reg1 reg2 reg3 = hcat [ - char '\t', - ptext op, - pprFSize sz, - char '\t', - pprReg platform reg1, - ptext (sLit ", "), - pprReg platform reg2, - ptext (sLit ", "), - pprReg platform reg3 + char '\t', + ptext op, + pprFSize sz, + char '\t', + pprReg platform reg1, + ptext (sLit ", "), + pprReg platform reg2, + ptext (sLit ", "), + pprReg platform reg3 ] pprRI :: Platform -> RI -> Doc @@ -708,13 +709,13 @@ pprRI platform (RIImm r) = pprImm platform r pprFSize :: Size -> Doc -pprFSize FF64 = empty -pprFSize FF32 = char 's' -pprFSize _ = panic "PPC.Ppr.pprFSize: no match" +pprFSize FF64 = empty +pprFSize FF32 = char 's' +pprFSize _ = panic "PPC.Ppr.pprFSize: no match" - -- limit immediate argument for shift instruction to range 0..32 - -- (yes, the maximum is really 32, not 31) + -- limit immediate argument for shift instruction to range 0..31 limitShiftRI :: RI -> RI -limitShiftRI (RIImm (ImmInt i)) | i > 32 || i < 0 = RIImm (ImmInt 32) +limitShiftRI (RIImm (ImmInt i)) | i > 31 || i < 0 = + panic $ "PPC.Ppr: Shift by " ++ show i ++ " bits is not allowed." limitShiftRI x = x diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs index f134255578..be07078c1a 100644 --- a/compiler/nativeGen/X86/CodeGen.hs +++ b/compiler/nativeGen/X86/CodeGen.hs @@ -1930,7 +1930,10 @@ genCCall64 target dest_regs args = (CmmPrim _ (Just stmts), _) -> stmtsToInstrs stmts - _ -> genCCall64' target dest_regs args + _ -> + do dflags <- getDynFlags + let platform = targetPlatform dflags + genCCall64' platform target dest_regs args where divOp signed width [CmmHinted res_q _, CmmHinted res_r _] [CmmHinted arg_x _, CmmHinted arg_y _] @@ -1952,22 +1955,32 @@ genCCall64 target dest_regs args = divOp _ _ _ _ = panic "genCCall64: Wrong number of arguments/results for divOp" -genCCall64' :: CmmCallTarget -- function to call +genCCall64' :: Platform + -> CmmCallTarget -- function to call -> [HintedCmmFormal] -- where to put the result -> [HintedCmmActual] -- arguments (of mixed type) -> NatM InstrBlock -genCCall64' target dest_regs args = do +genCCall64' platform target dest_regs args = do -- load up the register arguments - (stack_args, aregs, fregs, load_args_code) - <- load_args args allArgRegs allFPArgRegs nilOL + (stack_args, int_regs_used, fp_regs_used, load_args_code) + <- + if platformOS platform == OSMinGW32 + then load_args_win args [] [] allArgRegs nilOL + else do (stack_args, aregs, fregs, load_args_code) + <- load_args args allIntArgRegs allFPArgRegs nilOL + let fp_regs_used = reverse (drop (length fregs) (reverse allFPArgRegs)) + int_regs_used = reverse (drop (length aregs) (reverse allIntArgRegs)) + return (stack_args, int_regs_used, fp_regs_used, load_args_code) let - fp_regs_used = reverse (drop (length fregs) (reverse allFPArgRegs)) - int_regs_used = reverse (drop (length aregs) (reverse allArgRegs)) - arg_regs = [eax] ++ int_regs_used ++ fp_regs_used + arg_regs_used = int_regs_used ++ fp_regs_used + arg_regs = [eax] ++ arg_regs_used -- for annotating the call instruction with sse_regs = length fp_regs_used - tot_arg_size = arg_size * length stack_args + arg_stack_slots = if platformOS platform == OSMinGW32 + then length stack_args + length allArgRegs + else length stack_args + tot_arg_size = arg_size * arg_stack_slots -- Align stack to 16n for calls, assuming a starting stack @@ -1985,6 +1998,11 @@ genCCall64' target dest_regs args = do -- push the stack args, right to left push_code <- push_args (reverse stack_args) nilOL + -- On Win64, we also have to leave stack space for the arguments + -- that we are passing in registers + lss_code <- if platformOS platform == OSMinGW32 + then leaveStackSpace (length allArgRegs) + else return nilOL delta <- getDeltaNat -- deal with static vs dynamic call targets @@ -2041,6 +2059,7 @@ genCCall64' target dest_regs args = do return (load_args_code `appOL` adjust_rsp `appOL` push_code `appOL` + lss_code `appOL` assign_eax sse_regs `appOL` call `appOL` assign_code dest_regs) @@ -2076,15 +2095,43 @@ genCCall64' target dest_regs args = do (args',ars,frs,code') <- load_args rest aregs fregs code return ((CmmHinted arg hint):args', ars, frs, code') + load_args_win :: [CmmHinted CmmExpr] + -> [Reg] -- used int regs + -> [Reg] -- used FP regs + -> [(Reg, Reg)] -- (int, FP) regs avail for args + -> InstrBlock + -> NatM ([CmmHinted CmmExpr],[Reg],[Reg],InstrBlock) + load_args_win args usedInt usedFP [] code + = return (args, usedInt, usedFP, code) + -- no more regs to use + load_args_win [] usedInt usedFP _ code + = return ([], usedInt, usedFP, code) + -- no more args to push + load_args_win ((CmmHinted arg _) : rest) usedInt usedFP + ((ireg, freg) : regs) code + | isFloatType arg_rep = do + arg_code <- getAnyReg arg + load_args_win rest (ireg : usedInt) (freg : usedFP) regs + (code `appOL` + arg_code freg `snocOL` + -- If we are calling a varargs function + -- then we need to define ireg as well + -- as freg + MOV II64 (OpReg freg) (OpReg ireg)) + | otherwise = do + arg_code <- getAnyReg arg + load_args_win rest (ireg : usedInt) usedFP regs + (code `appOL` arg_code ireg) + where + arg_rep = cmmExprType arg + push_args [] code = return code push_args ((CmmHinted arg _):rest) code | isFloatType arg_rep = do (arg_reg, arg_code) <- getSomeReg arg delta <- getDeltaNat setDeltaNat (delta-arg_size) - dflags <- getDynFlags - let platform = targetPlatform dflags - code' = code `appOL` arg_code `appOL` toOL [ + let code' = code `appOL` arg_code `appOL` toOL [ SUB (intSize wordWidth) (OpImm (ImmInt arg_size)) (OpReg rsp) , DELTA (delta-arg_size), MOV (floatSize width) (OpReg arg_reg) (OpAddr (spRel platform 0))] @@ -2106,6 +2153,13 @@ genCCall64' target dest_regs args = do arg_rep = cmmExprType arg width = typeWidth arg_rep + leaveStackSpace n = do + delta <- getDeltaNat + setDeltaNat (delta - n * arg_size) + return $ toOL [ + SUB II64 (OpImm (ImmInt (n * wORD_SIZE))) (OpReg rsp), + DELTA (delta - n * arg_size)] + -- | We're willing to inline and unroll memcpy/memset calls that touch -- at most these many bytes. This threshold is the same as the one -- used by GCC and LLVM. diff --git a/compiler/nativeGen/X86/Regs.hs b/compiler/nativeGen/X86/Regs.hs index 68ab351e86..997caf5574 100644 --- a/compiler/nativeGen/X86/Regs.hs +++ b/compiler/nativeGen/X86/Regs.hs @@ -16,6 +16,7 @@ module X86.Regs ( spRel, argRegs, allArgRegs, + allIntArgRegs, callClobberedRegs, allMachRegNos, classOfRealReg, @@ -378,9 +379,6 @@ xmm13 = regSingle 37 xmm14 = regSingle 38 xmm15 = regSingle 39 -allFPArgRegs :: [Reg] -allFPArgRegs = map regSingle [firstxmm .. firstxmm+7] - ripRel :: Displacement -> AddrMode ripRel imm = AddrBaseIndex EABaseRip EAIndexNone imm @@ -406,7 +404,9 @@ xmm n = regSingle (firstxmm+n) -- horror show ----------------------------------------------------------------- freeReg :: RegNo -> FastBool globalRegMaybe :: GlobalReg -> Maybe RealReg -allArgRegs :: [Reg] +allArgRegs :: [(Reg, Reg)] +allIntArgRegs :: [Reg] +allFPArgRegs :: [Reg] callClobberedRegs :: [Reg] #if defined(i386_TARGET_ARCH) || defined(x86_64_TARGET_ARCH) @@ -625,16 +625,28 @@ globalRegMaybe _ = Nothing -- -#if i386_TARGET_ARCH -allArgRegs = panic "X86.Regs.allArgRegs: should not be used!" +#if defined(mingw32_HOST_OS) && x86_64_TARGET_ARCH -#elif x86_64_TARGET_ARCH -allArgRegs = map regSingle [rdi,rsi,rdx,rcx,r8,r9] +allArgRegs = zip (map regSingle [rcx,rdx,r8,r9]) + (map regSingle [firstxmm ..]) +allIntArgRegs = panic "X86.Regs.allIntArgRegs: not defined for this platform" +allFPArgRegs = panic "X86.Regs.allFPArgRegs: not defined for this platform" #else -allArgRegs = panic "X86.Regs.allArgRegs: not defined for this architecture" -#endif +allArgRegs = panic "X86.Regs.allArgRegs: not defined for this arch" + +# if i386_TARGET_ARCH +allIntArgRegs = panic "X86.Regs.allIntArgRegs: should not be used!" +# elif x86_64_TARGET_ARCH +allIntArgRegs = map regSingle [rdi,rsi,rdx,rcx,r8,r9] +# else +allIntArgRegs = panic "X86.Regs.allIntArgRegs: not defined for this arch" +# endif + +allFPArgRegs = map regSingle [firstxmm .. firstxmm+7] + +#endif -- | these are the regs which we cannot assume stay alive over a C call. @@ -661,8 +673,10 @@ callClobberedRegs freeReg _ = 0# globalRegMaybe _ = panic "X86.Regs.globalRegMaybe: not defined" -allArgRegs = panic "X86.Regs.globalRegMaybe: not defined" -callClobberedRegs = panic "X86.Regs.globalRegMaybe: not defined" +allArgRegs = panic "X86.Regs.allArgRegs: not defined" +allIntArgRegs = panic "X86.Regs.allIntArgRegs: not defined" +allFPArgRegs = panic "X86.Regs.allFPArgRegs: not defined" +callClobberedRegs = panic "X86.Regs.callClobberedRegs: not defined" #endif diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index 74da99a005..94b2019e9e 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -56,6 +56,8 @@ module Lexer ( getLexState, popLexState, pushLexState, extension, bangPatEnabled, datatypeContextsEnabled, traditionalRecordSyntaxEnabled, + typeLiteralsEnabled, + explicitNamespacesEnabled, addWarning, lexTokenStream ) where @@ -1806,6 +1808,11 @@ safeHaskellBit :: Int safeHaskellBit = 26 traditionalRecordSyntaxBit :: Int traditionalRecordSyntaxBit = 27 +typeLiteralsBit :: Int +typeLiteralsBit = 28 +explicitNamespacesBit :: Int +explicitNamespacesBit = 29 + always :: Int -> Bool always _ = True @@ -1849,6 +1856,11 @@ nondecreasingIndentation :: Int -> Bool nondecreasingIndentation flags = testBit flags nondecreasingIndentationBit traditionalRecordSyntaxEnabled :: Int -> Bool traditionalRecordSyntaxEnabled flags = testBit flags traditionalRecordSyntaxBit +typeLiteralsEnabled :: Int -> Bool +typeLiteralsEnabled flags = testBit flags typeLiteralsBit + +explicitNamespacesEnabled :: Int -> Bool +explicitNamespacesEnabled flags = testBit flags explicitNamespacesBit -- PState for parsing options pragmas -- @@ -1908,6 +1920,8 @@ mkPState flags buf loc = .|. nondecreasingIndentationBit `setBitIf` xopt Opt_NondecreasingIndentation flags .|. safeHaskellBit `setBitIf` safeImportsOn flags .|. traditionalRecordSyntaxBit `setBitIf` xopt Opt_TraditionalRecordSyntax flags + .|. typeLiteralsBit `setBitIf` xopt Opt_DataKinds flags + .|. explicitNamespacesBit `setBitIf` xopt Opt_ExplicitNamespaces flags -- setBitIf :: Int -> Bool -> Int b `setBitIf` cond | cond = bit b diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index 8de1e0b03f..6424dea79f 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -464,27 +464,29 @@ exp_doc :: { LIE RdrName } : docsection { L1 (case (unLoc $1) of (n, doc) -> IEGroup n doc) } | docnamed { L1 (IEDocNamed ((fst . unLoc) $1)) } | docnext { L1 (IEDoc (unLoc $1)) } - + + -- No longer allow things like [] and (,,,) to be exported -- They are built in syntax, always available export :: { LIE RdrName } - : qvar { L1 (IEVar (unLoc $1)) } - | oqtycon { L1 (IEThingAbs (unLoc $1)) } - | oqtycon '(' '..' ')' { LL (IEThingAll (unLoc $1)) } - | oqtycon '(' ')' { LL (IEThingWith (unLoc $1) []) } - | oqtycon '(' qcnames ')' { LL (IEThingWith (unLoc $1) (reverse $3)) } + : qcname_ext export_subspec { LL (mkModuleImpExp (unLoc $1) + (unLoc $2)) } | 'module' modid { LL (IEModuleContents (unLoc $2)) } -qcnames :: { [RdrName] } +export_subspec :: { Located ImpExpSubSpec } + : {- empty -} { L0 ImpExpAbs } + | '(' '..' ')' { LL ImpExpAll } + | '(' ')' { LL (ImpExpList []) } + | '(' qcnames ')' { LL (ImpExpList (reverse $2)) } + +qcnames :: { [RdrName] } -- A reversed list : qcnames ',' qcname_ext { unLoc $3 : $1 } | qcname_ext { [unLoc $1] } qcname_ext :: { Located RdrName } -- Variable or data constructor -- or tagged type constructor : qcname { $1 } - | 'type' qcon { sL (comb2 $1 $2) - (setRdrNameSpace (unLoc $2) - tcClsName) } + | 'type' qcname {% mkTypeImpExp (LL (unLoc $2)) } -- Cannot pull into qcname_ext, as qcname is also used in expression. qcname :: { Located RdrName } -- Variable or data constructor @@ -617,7 +619,7 @@ ty_decl :: { LTyClDecl RdrName } -- -- Note the use of type for the head; this allows -- infix type constructors to be declared - {% mkTySynonym (comb2 $1 $4) False $2 $4 } + {% mkTySynonym (comb2 $1 $4) $2 $4 } -- type family declarations | 'type' 'family' type opt_kind_sig @@ -627,7 +629,7 @@ ty_decl :: { LTyClDecl RdrName } -- ordinary data type or newtype declaration | data_or_newtype capi_ctype tycl_hdr constrs deriving - {% mkTyData (comb4 $1 $3 $4 $5) (unLoc $1) False $2 $3 + {% mkTyData (comb4 $1 $3 $4 $5) (unLoc $1) $2 $3 Nothing (reverse (unLoc $4)) (unLoc $5) } -- We need the location on tycl_hdr in case -- constrs and deriving are both empty @@ -636,7 +638,7 @@ ty_decl :: { LTyClDecl RdrName } | data_or_newtype capi_ctype tycl_hdr opt_kind_sig gadt_constrlist deriving - {% mkTyData (comb4 $1 $3 $5 $6) (unLoc $1) False $2 $3 + {% mkTyData (comb4 $1 $3 $5 $6) (unLoc $1) $2 $3 (unLoc $4) (unLoc $5) (unLoc $6) } -- We need the location on tycl_hdr in case -- constrs and deriving are both empty @@ -647,29 +649,29 @@ ty_decl :: { LTyClDecl RdrName } inst_decl :: { LInstDecl RdrName } : 'instance' inst_type where_inst - { let (binds, sigs, ats, _) = cvBindsAndSigs (unLoc $3) - in L (comb3 $1 $2 $3) (ClsInstDecl $2 binds sigs ats) } + { let (binds, sigs, _, ats, _) = cvBindsAndSigs (unLoc $3) + in L (comb3 $1 $2 $3) (ClsInstD $2 binds sigs ats) } -- type instance declarations | 'type' 'instance' type '=' ctype -- Note the use of type for the head; this allows -- infix type constructors and type patterns - {% do { L loc d <- mkTySynonym (comb2 $1 $5) True $3 $5 - ; return (L loc (FamInstDecl d)) } } + {% do { L loc d <- mkFamInstSynonym (comb2 $1 $5) $3 $5 + ; return (L loc (FamInstD d)) } } -- data/newtype instance declaration | data_or_newtype 'instance' tycl_hdr constrs deriving - {% do { L loc d <- mkTyData (comb4 $1 $3 $4 $5) (unLoc $1) True Nothing $3 + {% do { L loc d <- mkFamInstData (comb4 $1 $3 $4 $5) (unLoc $1) Nothing $3 Nothing (reverse (unLoc $4)) (unLoc $5) - ; return (L loc (FamInstDecl d)) } } + ; return (L loc (FamInstD d)) } } -- GADT instance declaration | data_or_newtype 'instance' tycl_hdr opt_kind_sig gadt_constrlist deriving - {% do { L loc d <- mkTyData (comb4 $1 $3 $5 $6) (unLoc $1) True Nothing $3 + {% do { L loc d <- mkFamInstData (comb4 $1 $3 $5 $6) (unLoc $1) Nothing $3 (unLoc $4) (unLoc $5) (unLoc $6) - ; return (L loc (FamInstDecl d)) } } + ; return (L loc (FamInstD d)) } } -- Associated type family declarations -- @@ -680,51 +682,53 @@ inst_decl :: { LInstDecl RdrName } -- declarations without a kind signature cause parsing conflicts with empty -- data declarations. -- -at_decl_cls :: { LTyClDecl RdrName } - -- type family declarations +at_decl_cls :: { LHsDecl RdrName } + -- family declarations : 'type' type opt_kind_sig -- Note the use of type for the head; this allows -- infix type constructors to be declared. - {% mkTyFamily (comb3 $1 $2 $3) TypeFamily $2 (unLoc $3) } + {% do { L loc decl <- mkTyFamily (comb3 $1 $2 $3) TypeFamily $2 (unLoc $3) + ; return (L loc (TyClD decl)) } } + + | 'data' type opt_kind_sig + {% do { L loc decl <- mkTyFamily (comb3 $1 $2 $3) DataFamily $2 (unLoc $3) + ; return (L loc (TyClD decl)) } } -- default type instance | 'type' type '=' ctype -- Note the use of type for the head; this allows -- infix type constructors and type patterns - {% mkTySynonym (comb2 $1 $4) True $2 $4 } - - -- data/newtype family declaration - | 'data' type opt_kind_sig - {% mkTyFamily (comb3 $1 $2 $3) DataFamily $2 (unLoc $3) } + {% do { L loc fid <- mkFamInstSynonym (comb2 $1 $4) $2 $4 + ; return (L loc (InstD (FamInstD fid))) } } -- Associated type instances -- -at_decl_inst :: { LTyClDecl RdrName } +at_decl_inst :: { LFamInstDecl RdrName } -- type instance declarations : 'type' type '=' ctype -- Note the use of type for the head; this allows -- infix type constructors and type patterns - {% mkTySynonym (comb2 $1 $4) True $2 $4 } + {% mkFamInstSynonym (comb2 $1 $4) $2 $4 } -- data/newtype instance declaration | data_or_newtype capi_ctype tycl_hdr constrs deriving - {% mkTyData (comb4 $1 $3 $4 $5) (unLoc $1) True $2 $3 - Nothing (reverse (unLoc $4)) (unLoc $5) } + {% mkFamInstData (comb4 $1 $3 $4 $5) (unLoc $1) $2 $3 + Nothing (reverse (unLoc $4)) (unLoc $5) } -- GADT instance declaration | data_or_newtype capi_ctype tycl_hdr opt_kind_sig gadt_constrlist deriving - {% mkTyData (comb4 $1 $3 $5 $6) (unLoc $1) True $2 $3 - (unLoc $4) (unLoc $5) (unLoc $6) } + {% mkFamInstData (comb4 $1 $3 $5 $6) (unLoc $1) $2 $3 + (unLoc $4) (unLoc $5) (unLoc $6) } data_or_newtype :: { Located NewOrData } : 'data' { L1 DataType } | 'newtype' { L1 NewType } -opt_kind_sig :: { Located (Maybe (LHsKind RdrName)) } +opt_kind_sig :: { Located (Maybe (HsBndrSig (LHsKind RdrName))) } : { noLoc Nothing } - | '::' kind { LL (Just $2) } + | '::' kind { LL (Just (HsBSig $2 placeHolderBndrs)) } -- tycl_hdr parses the header of a class or data type decl, -- which takes the form @@ -755,7 +759,7 @@ stand_alone_deriving :: { LDerivDecl RdrName } -- Declaration in class bodies -- decl_cls :: { Located (OrdList (LHsDecl RdrName)) } -decl_cls : at_decl_cls { LL (unitOL (L1 (TyClD (unLoc $1)))) } +decl_cls : at_decl_cls { LL (unitOL $1) } | decl { $1 } -- A 'default' signature used with the generic-programming extension @@ -786,7 +790,7 @@ where_cls :: { Located (OrdList (LHsDecl RdrName)) } -- Reversed -- Declarations in instance bodies -- decl_inst :: { Located (OrdList (LHsDecl RdrName)) } -decl_inst : at_decl_inst { LL (unitOL (L1 (TyClD (unLoc $1)))) } +decl_inst : at_decl_inst { LL (unitOL (L1 (InstD (FamInstD (unLoc $1))))) } | decl { $1 } decls_inst :: { Located (OrdList (LHsDecl RdrName)) } -- Reversed @@ -1076,6 +1080,8 @@ atype :: { LHsType RdrName } | SIMPLEQUOTE '(' ctype ',' comma_types1 ')' { LL $ HsExplicitTupleTy [] ($3 : $5) } | SIMPLEQUOTE '[' comma_types0 ']' { LL $ HsExplicitListTy placeHolderKind $3 } | '[' ctype ',' comma_types1 ']' { LL $ HsExplicitListTy placeHolderKind ($2 : $4) } + | INTEGER {% mkTyLit $ LL $ HsNumTy $ getINTEGER $1 } + | STRING {% mkTyLit $ LL $ HsStrTy $ getSTRING $1 } -- An inst_type is what occurs in the head of an instance decl -- e.g. (Foo a, Gaz b) => Wibble a b @@ -1101,8 +1107,8 @@ tv_bndrs :: { [LHsTyVarBndr RdrName] } | {- empty -} { [] } tv_bndr :: { LHsTyVarBndr RdrName } - : tyvar { L1 (UserTyVar (unLoc $1) placeHolderKind) } - | '(' tyvar '::' kind ')' { LL (KindedTyVar (unLoc $2) (HsBSig $4 placeHolderBndrs) placeHolderKind) } + : tyvar { L1 (UserTyVar (unLoc $1)) } + | '(' tyvar '::' kind ')' { LL (KindedTyVar (unLoc $2) (HsBSig $4 placeHolderBndrs)) } fds :: { Located [Located (FunDep RdrName)] } : {- empty -} { noLoc [] } @@ -1834,10 +1840,16 @@ tycon :: { Located RdrName } -- Unqualified qtyconsym :: { Located RdrName } : QCONSYM { L1 $! mkQual tcClsName (getQCONSYM $1) } + | QVARSYM { L1 $! mkQual tcClsName (getQVARSYM $1) } | tyconsym { $1 } +-- Does not include "!", because that is used for strictness marks +-- or ".", because that separates the quantified type vars from the rest tyconsym :: { Located RdrName } : CONSYM { L1 $! mkUnqual tcClsName (getCONSYM $1) } + | VARSYM { L1 $! mkUnqual tcClsName (getVARSYM $1) } + | '*' { L1 $! mkUnqual tcClsName (fsLit "*") } + ----------------------------------------------------------------------------- -- Operators @@ -1871,11 +1883,9 @@ qvaropm :: { Located RdrName } tyvar :: { Located RdrName } tyvar : tyvarid { $1 } - | '(' tyvarsym ')' { LL (unLoc $2) } tyvarop :: { Located RdrName } tyvarop : '`' tyvarid '`' { LL (unLoc $2) } - | tyvarsym { $1 } | '.' {% parseErrorSDoc (getLoc $1) (vcat [ptext (sLit "Illegal symbol '.' in type"), ptext (sLit "Perhaps you intended -XRankNTypes or similar flag"), @@ -1889,12 +1899,6 @@ tyvarid :: { Located RdrName } | 'safe' { L1 $! mkUnqual tvName (fsLit "safe") } | 'interruptible' { L1 $! mkUnqual tvName (fsLit "interruptible") } -tyvarsym :: { Located RdrName } --- Does not include "!", because that is used for strictness marks --- or ".", because that separates the quantified type vars from the rest --- or "*", because that's used for kinds -tyvarsym : VARSYM { L1 $! mkUnqual tvName (getVARSYM $1) } - ----------------------------------------------------------------------------- -- Variables diff --git a/compiler/parser/ParserCore.y b/compiler/parser/ParserCore.y index 872bcdefc0..70a0e886f1 100644 --- a/compiler/parser/ParserCore.y +++ b/compiler/parser/ParserCore.y @@ -127,18 +127,18 @@ tdefs :: { [TyClDecl RdrName] } tdef :: { TyClDecl RdrName } : '%data' q_tc_name tv_bndrs '=' '{' cons '}' ';' - { TyData { tcdND = DataType, tcdCtxt = noLoc [] - , tcdLName = noLoc (ifaceExtRdrName $2) - , tcdTyVars = map toHsTvBndr $3 - , tcdTyPats = Nothing, tcdKindSig = Nothing - , tcdCons = $6, tcdDerivs = Nothing } } + { TyDecl { tcdLName = noLoc (ifaceExtRdrName $2) + , tcdTyVars = map toHsTvBndr $3 + , tcdTyDefn = TyData { td_ND = DataType, td_ctxt = noLoc [] + , td_kindSig = Nothing + , td_cons = $6, td_derivs = Nothing } } } | '%newtype' q_tc_name tv_bndrs trep ';' - { let tc_rdr = ifaceExtRdrName $2 in - TyData { tcdND = NewType, tcdCtxt = noLoc [] - , tcdLName = noLoc tc_rdr - , tcdTyVars = map toHsTvBndr $3 - , tcdTyPats = Nothing, tcdKindSig = Nothing - , tcdCons = $4 (rdrNameOcc tc_rdr), tcdDerivs = Nothing } } + { let tc_rdr = ifaceExtRdrName $2 in + TyDecl { tcdLName = noLoc tc_rdr + , tcdTyVars = map toHsTvBndr $3 + , tcdTyDefn = TyData { td_ND = NewType, td_ctxt = noLoc [] + , td_kindSig = Nothing + , td_cons = $4 (rdrNameOcc tc_rdr), td_derivs = Nothing } } } -- For a newtype we have to invent a fake data constructor name -- It doesn't matter what it is, because it won't be used @@ -375,7 +375,7 @@ ifaceUnliftedTypeKind = ifaceTcType (IfaceTc unliftedTypeKindTyConName) ifaceArrow ifT1 ifT2 = IfaceFunTy ifT1 ifT2 toHsTvBndr :: IfaceTvBndr -> LHsTyVarBndr RdrName -toHsTvBndr (tv,k) = noLoc $ KindedTyVar (mkRdrUnqual (mkTyVarOccFS tv)) bsig placeHolderKind +toHsTvBndr (tv,k) = noLoc $ KindedTyVar (mkRdrUnqual (mkTyVarOccFS tv)) bsig where bsig = HsBSig (toHsKind k) placeHolderBndrs diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index be1f5c4f4b..91bab6c3fb 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -5,15 +5,18 @@ Functions over HsSyn specialised to RdrName. \begin{code} module RdrHsSyn ( - extractHsTyRdrTyVars, - extractHsRhoRdrTyVars, extractGenericPatTyVars, + extractHsTyRdrTyVars, extractHsTysRdrTyVars, mkHsOpApp, mkHsIntegral, mkHsFractional, mkHsIsString, mkHsDo, mkHsSplice, mkTopSpliceDecl, - mkClassDecl, mkTyData, mkTyFamily, mkTySynonym, + mkClassDecl, + mkTyData, mkFamInstData, + mkTySynonym, mkFamInstSynonym, + mkTyFamily, splitCon, mkInlinePragma, mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp + mkTyLit, cvBindGroup, cvBindsAndSigs, @@ -34,7 +37,6 @@ module RdrHsSyn ( checkPrecP, -- Int -> P Int checkContext, -- HsType -> P HsContext checkTyVars, -- [LHsType RdrName] -> P () - checkKindSigs, -- [LTyClDecl RdrName] -> P () checkPattern, -- HsExp -> P HsPat bang_RDR, checkPatterns, -- SrcLoc -> [HsExp] -> P [HsPat] @@ -45,12 +47,20 @@ module RdrHsSyn ( checkRecordSyntax, parseError, parseErrorSDoc, + + -- Help with processing exports + ImpExpSubSpec(..), + mkModuleImpExp, + mkTypeImpExp + ) where import HsSyn -- Lots of it import Class ( FunDep ) import RdrName ( RdrName, isRdrTyVar, isRdrTc, mkUnqual, rdrNameOcc, - isRdrDataCon, isUnqual, getRdrName, setRdrNameSpace ) + isRdrDataCon, isUnqual, getRdrName, setRdrNameSpace, + rdrNameSpace ) +import OccName ( tcClsName, isVarNameSpace ) import Name ( Name ) import BasicTypes ( maxPrecedence, Activation(..), RuleMatchInfo, InlinePragma(..), InlineSpec(..) ) @@ -64,15 +74,15 @@ import PrelNames ( forall_tv_RDR ) import DynFlags import SrcLoc import OrdList ( OrdList, fromOL ) -import Bag ( Bag, emptyBag, consBag, foldrBag ) +import Bag ( Bag, emptyBag, consBag ) import Outputable import FastString import Maybes - +import Util ( filterOut ) import Control.Applicative ((<$>)) import Control.Monad import Text.ParserCombinators.ReadP as ReadP -import Data.List ( nubBy, partition ) +import Data.List ( nub ) import Data.Char #include "HsVersions.h" @@ -89,30 +99,24 @@ extractHsTyRdrNames finds the free variables of a HsType It's used when making the for-alls explicit. \begin{code} -extractHsTyRdrTyVars :: LHsType RdrName -> [Located RdrName] -extractHsTyRdrTyVars ty = nubBy eqLocated (extract_lty ty []) +extractHsTyRdrTyVars :: LHsType RdrName -> [RdrName] +extractHsTyRdrTyVars ty = nub (extract_lty ty []) -extractHsTysRdrTyVars :: [LHsType RdrName] -> [Located RdrName] -extractHsTysRdrTyVars ty = nubBy eqLocated (extract_ltys ty []) +extractHsTysRdrTyVars :: [LHsType RdrName] -> [RdrName] +extractHsTysRdrTyVars ty = nub (extract_ltys ty []) -extractHsRhoRdrTyVars :: LHsContext RdrName -> LHsType RdrName -> [Located RdrName] --- This one takes the context and tau-part of a --- sigma type and returns their free type variables -extractHsRhoRdrTyVars ctxt ty - = nubBy eqLocated $ extract_lctxt ctxt (extract_lty ty []) - -extract_lctxt :: LHsContext RdrName -> [Located RdrName] -> [Located RdrName] +extract_lctxt :: LHsContext RdrName -> [RdrName] -> [RdrName] extract_lctxt ctxt acc = foldr extract_lty acc (unLoc ctxt) -extract_ltys :: [LHsType RdrName] -> [Located RdrName] -> [Located RdrName] +extract_ltys :: [LHsType RdrName] -> [RdrName] -> [RdrName] extract_ltys tys acc = foldr extract_lty acc tys -- IA0_NOTE: Should this function also return kind variables? -- (explicit kind poly) -extract_lty :: LHsType RdrName -> [Located RdrName] -> [Located RdrName] -extract_lty (L loc ty) acc +extract_lty :: LHsType RdrName -> [RdrName] -> [RdrName] +extract_lty (L _ ty) acc = case ty of - HsTyVar tv -> extract_tv loc tv acc + HsTyVar tv -> extract_tv tv acc HsBangTy _ ty -> extract_lty ty acc HsRecTy flds -> foldr (extract_lty . cd_fld_type) acc flds HsAppTy ty1 ty2 -> extract_lty ty1 (extract_lty ty2 acc) @@ -122,36 +126,26 @@ extract_lty (L loc ty) acc HsFunTy ty1 ty2 -> extract_lty ty1 (extract_lty ty2 acc) HsIParamTy _ ty -> extract_lty ty acc HsEqTy ty1 ty2 -> extract_lty ty1 (extract_lty ty2 acc) - HsOpTy ty1 (_, (L loc tv)) ty2 -> extract_tv loc tv (extract_lty ty1 (extract_lty ty2 acc)) + HsOpTy ty1 (_, (L _ tv)) ty2 -> extract_tv tv (extract_lty ty1 (extract_lty ty2 acc)) HsParTy ty -> extract_lty ty acc HsCoreTy {} -> acc -- The type is closed HsQuasiQuoteTy {} -> acc -- Quasi quotes mention no type variables HsSpliceTy {} -> acc -- Type splices mention no type variables HsKindSig ty _ -> extract_lty ty acc HsForAllTy _ [] cx ty -> extract_lctxt cx (extract_lty ty acc) - HsForAllTy _ tvs cx ty -> acc ++ (filter ((`notElem` locals) . unLoc) $ + HsForAllTy _ tvs cx ty -> acc ++ (filterOut (`elem` locals) $ extract_lctxt cx (extract_lty ty [])) where locals = hsLTyVarNames tvs HsDocTy ty _ -> extract_lty ty acc HsExplicitListTy _ tys -> extract_ltys tys acc HsExplicitTupleTy _ tys -> extract_ltys tys acc + HsTyLit _ -> acc HsWrapTy _ _ -> panic "extract_lty" -extract_tv :: SrcSpan -> RdrName -> [Located RdrName] -> [Located RdrName] -extract_tv loc tv acc | isRdrTyVar tv = L loc tv : acc - | otherwise = acc - -extractGenericPatTyVars :: LHsBinds RdrName -> [Located RdrName] --- Get the type variables out of the type patterns in a bunch of --- possibly-generic bindings in a class declaration -extractGenericPatTyVars binds - = nubBy eqLocated (foldrBag get [] binds) - where - get (L _ (FunBind { fun_matches = MatchGroup ms _ })) acc = foldr (get_m.unLoc) acc ms - get _ acc = acc - - get_m _ acc = acc +extract_tv :: RdrName -> [RdrName] -> [RdrName] +extract_tv tv acc | isRdrTyVar tv = tv : acc + | otherwise = acc \end{code} @@ -179,53 +173,82 @@ mkClassDecl :: SrcSpan -> P (LTyClDecl RdrName) mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls - = do { let (binds, sigs, at_stuff, docs) = cvBindsAndSigs (unLoc where_cls) - (at_defs, ats) = partition (isTypeDecl . unLoc) at_stuff + = do { let (binds, sigs, ats, at_defs, docs) = cvBindsAndSigs (unLoc where_cls) cxt = fromMaybe (noLoc []) mcxt ; (cls, tparams) <- checkTyClHdr tycl_hdr ; tyvars <- checkTyVars tycl_hdr tparams -- Only type vars allowed - ; checkKindSigs ats ; return (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, tcdTyVars = tyvars, tcdFDs = unLoc fds, tcdSigs = sigs, tcdMeths = binds, tcdATs = ats, tcdATDefs = at_defs, tcdDocs = docs })) } mkTyData :: SrcSpan -> NewOrData - -> Bool -- True <=> data family instance -> Maybe CType -> Located (Maybe (LHsContext RdrName), LHsType RdrName) - -> Maybe (LHsKind RdrName) + -> Maybe (HsBndrSig (LHsKind RdrName)) -> [LConDecl RdrName] -> Maybe [LHsType RdrName] -> P (LTyClDecl RdrName) -mkTyData loc new_or_data is_family cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv +mkTyData loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv = do { (tc, tparams) <- checkTyClHdr tycl_hdr + ; tyvars <- checkTyVars tycl_hdr tparams + ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv + ; return (L loc (TyDecl { tcdLName = tc, tcdTyVars = tyvars, + tcdTyDefn = defn, tcdFVs = placeHolderNames })) } - ; checkDatatypeContext mcxt +mkFamInstData :: SrcSpan + -> NewOrData + -> Maybe CType + -> Located (Maybe (LHsContext RdrName), LHsType RdrName) + -> Maybe (HsBndrSig (LHsKind RdrName)) + -> [LConDecl RdrName] + -> Maybe [LHsType RdrName] + -> P (LFamInstDecl RdrName) +mkFamInstData loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv + = do { (tc, tparams) <- checkTyClHdr tycl_hdr + ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv + ; return (L loc (FamInstDecl { fid_tycon = tc, fid_pats = mkHsBSig tparams + , fid_defn = defn })) } + +mkDataDefn :: NewOrData + -> Maybe CType + -> Maybe (LHsContext RdrName) + -> Maybe (HsBndrSig (LHsKind RdrName)) + -> [LConDecl RdrName] + -> Maybe [LHsType RdrName] + -> P (HsTyDefn RdrName) +mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv + = do { checkDatatypeContext mcxt ; let cxt = fromMaybe (noLoc []) mcxt - ; (tyvars, typats) <- checkTParams is_family tycl_hdr tparams - ; return (L loc (TyData { tcdND = new_or_data, tcdCType = cType, - tcdCtxt = cxt, tcdLName = tc, - tcdTyVars = tyvars, tcdTyPats = typats, - tcdCons = data_cons, - tcdKindSig = ksig, tcdDerivs = maybe_deriv })) } + ; return (TyData { td_ND = new_or_data, td_cType = cType + , td_ctxt = cxt + , td_cons = data_cons + , td_kindSig = ksig + , td_derivs = maybe_deriv }) } mkTySynonym :: SrcSpan - -> Bool -- True <=> type family instances -> LHsType RdrName -- LHS -> LHsType RdrName -- RHS -> P (LTyClDecl RdrName) -mkTySynonym loc is_family lhs rhs +mkTySynonym loc lhs rhs + = do { (tc, tparams) <- checkTyClHdr lhs + ; tyvars <- checkTyVars lhs tparams + ; return (L loc (TyDecl { tcdLName = tc, tcdTyVars = tyvars, + tcdTyDefn = TySynonym rhs, tcdFVs = placeHolderNames })) } + +mkFamInstSynonym :: SrcSpan + -> LHsType RdrName -- LHS + -> LHsType RdrName -- RHS + -> P (LFamInstDecl RdrName) +mkFamInstSynonym loc lhs rhs = do { (tc, tparams) <- checkTyClHdr lhs - ; (tyvars, typats) <- checkTParams is_family lhs tparams - ; return (L loc (TySynonym { tcdLName = tc - , tcdTyVars = tyvars, tcdTyPats = typats - , tcdSynRhs = rhs, tcdFVs = placeHolderNames })) } + ; return (L loc (FamInstDecl { fid_tycon = tc, fid_pats = mkHsBSig tparams + , fid_defn = TySynonym rhs })) } mkTyFamily :: SrcSpan -> FamilyFlavour -> LHsType RdrName -- LHS - -> Maybe (LHsKind RdrName) -- Optional kind signature + -> Maybe (HsBndrSig (LHsKind RdrName)) -- Optional kind signature -> P (LTyClDecl RdrName) mkTyFamily loc flavour lhs ksig = do { (tc, tparams) <- checkTyClHdr lhs @@ -242,6 +265,19 @@ mkTopSpliceDecl :: LHsExpr RdrName -> HsDecl RdrName mkTopSpliceDecl (L _ (HsQuasiQuoteE qq)) = QuasiQuoteD qq mkTopSpliceDecl (L _ (HsSpliceE (HsSplice _ expr))) = SpliceD (SpliceDecl expr Explicit) mkTopSpliceDecl other_expr = SpliceD (SpliceDecl other_expr Implicit) + + +mkTyLit :: Located (HsTyLit) -> P (LHsType RdrName) +mkTyLit l = + do allowed <- extension typeLiteralsEnabled + if allowed + then return (HsTyLit `fmap` l) + else parseErrorSDoc (getLoc l) + (text "Illegal literal in type (use -XDataKinds to enable):" <+> + ppr l) + + + \end{code} %************************************************************************ @@ -270,27 +306,31 @@ cvTopDecls decls = go (fromOL decls) cvBindGroup :: OrdList (LHsDecl RdrName) -> HsValBinds RdrName cvBindGroup binding = case cvBindsAndSigs binding of - (mbs, sigs, tydecls, _) -> ASSERT( null tydecls ) - ValBindsIn mbs sigs + (mbs, sigs, fam_ds, fam_insts, _) + -> ASSERT( null fam_ds && null fam_insts ) + ValBindsIn mbs sigs cvBindsAndSigs :: OrdList (LHsDecl RdrName) - -> (Bag (LHsBind RdrName), [LSig RdrName], [LTyClDecl RdrName], [LDocDecl]) + -> (Bag ( LHsBind RdrName), [LSig RdrName], [LTyClDecl RdrName] + , [LFamInstDecl RdrName], [LDocDecl]) -- Input decls contain just value bindings and signatures -- and in case of class or instance declarations also -- associated type declarations. They might also contain Haddock comments. cvBindsAndSigs fb = go (fromOL fb) where - go [] = (emptyBag, [], [], []) - go (L l (SigD s) : ds) = (bs, L l s : ss, ts, docs) - where (bs, ss, ts, docs) = go ds - go (L l (ValD b) : ds) = (b' `consBag` bs, ss, ts, docs) + go [] = (emptyBag, [], [], [], []) + go (L l (SigD s) : ds) = (bs, L l s : ss, ts, fis, docs) + where (bs, ss, ts, fis, docs) = go ds + go (L l (ValD b) : ds) = (b' `consBag` bs, ss, ts, fis, docs) where (b', ds') = getMonoBind (L l b) ds - (bs, ss, ts, docs) = go ds' - go (L l (TyClD t): ds) = (bs, ss, L l t : ts, docs) - where (bs, ss, ts, docs) = go ds - go (L l (DocD d) : ds) = (bs, ss, ts, (L l d) : docs) - where (bs, ss, ts, docs) = go ds - go (L _ d : _) = pprPanic "cvBindsAndSigs" (ppr d) + (bs, ss, ts, fis, docs) = go ds' + go (L l (TyClD t@(TyFamily {})) : ds) = (bs, ss, L l t : ts, fis, docs) + where (bs, ss, ts, fis, docs) = go ds + go (L l (InstD (FamInstD fi)) : ds) = (bs, ss, ts, L l fi : fis, docs) + where (bs, ss, ts, fis, docs) = go ds + go (L l (DocD d) : ds) = (bs, ss, ts, fis, (L l d) : docs) + where (bs, ss, ts, fis, docs) = go ds + go (L _ d : _) = pprPanic "cvBindsAndSigs" (ppr d) ----------------------------------------------------------------------------- -- Group function bindings into equation groups @@ -464,33 +504,6 @@ we can bring x,y into scope. So: * For RecCon we do not \begin{code} -checkTParams :: Bool -- Type/data family - -> LHsType RdrName - -> [LHsType RdrName] - -> P ([LHsTyVarBndr RdrName], Maybe [LHsType RdrName]) --- checkTParams checks the type parameters of a data/newtype declaration --- There are two cases: --- --- a) Vanilla data/newtype decl. In that case --- - the type parameters should all be type variables --- - they may have a kind annotation --- --- b) Family data/newtype decl. In that case --- - The type parameters may be arbitrary types --- - We find the type-varaible binders by find the --- free type vars of those types --- - We make them all kind-sig-free binders (UserTyVar) --- If there are kind sigs in the type parameters, they --- will fix the binder's kind when we kind-check the --- type parameters -checkTParams is_family tycl_hdr tparams - | not is_family -- Vanilla case (a) - = do { tyvars <- checkTyVars tycl_hdr tparams - ; return (tyvars, Nothing) } - | otherwise -- Family case (b) - = do { let tyvars = userHsTyVarBndrs (extractHsTysRdrTyVars tparams) - ; return (tyvars, Just tparams) } - checkTyVars :: LHsType RdrName -> [LHsType RdrName] -> P [LHsTyVarBndr RdrName] -- Check whether the given list of type parameters are all type variables -- (possibly with a kind signature). If the second argument is `False', @@ -501,9 +514,9 @@ checkTyVars tycl_hdr tparms = mapM chk tparms where -- Check that the name space is correct! chk (L l (HsKindSig (L _ (HsTyVar tv)) k)) - | isRdrTyVar tv = return (L l (KindedTyVar tv (HsBSig k placeHolderBndrs) placeHolderKind)) + | isRdrTyVar tv = return (L l (KindedTyVar tv (mkHsBSig k))) chk (L l (HsTyVar tv)) - | isRdrTyVar tv = return (L l (UserTyVar tv placeHolderKind)) + | isRdrTyVar tv = return (L l (UserTyVar tv)) chk t@(L l _) = parseErrorSDoc l $ vcat [ sep [ ptext (sLit "Unexpected type") <+> quotes (ppr t) @@ -550,18 +563,6 @@ checkTyClHdr ty -- See Note [Unit tuples] in HsTypes go l _ _ = parseErrorSDoc l (text "Malformed head of type or class declaration:" <+> ppr ty) --- Check that associated type declarations of a class are all kind signatures. --- -checkKindSigs :: [LTyClDecl RdrName] -> P () -checkKindSigs = mapM_ check - where - check (L l tydecl) - | isFamilyDecl tydecl = return () - | isTypeDecl tydecl = return () - | otherwise - = parseErrorSDoc l (text "Type declaration in a class must be a kind signature or synonym default:" - $$ ppr tydecl) - checkContext :: LHsType RdrName -> P (LHsContext RdrName) checkContext (L l orig_t) = check orig_t @@ -638,7 +639,7 @@ checkAPat dynflags loc e0 = case e0 of let t' = case t of L _ (HsForAllTy Implicit _ (L _ []) ty) -> ty other -> other - return (SigPatIn e (HsBSig t' placeHolderBndrs)) + return (SigPatIn e (mkHsBSig t')) -- n+k patterns OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _ @@ -1001,6 +1002,32 @@ mkExtName :: RdrName -> CLabelString mkExtName rdrNm = mkFastString (occNameString (rdrNameOcc rdrNm)) \end{code} +-------------------------------------------------------------------------------- +-- Help with module system imports/exports + +\begin{code} +data ImpExpSubSpec = ImpExpAbs | ImpExpAll | ImpExpList [ RdrName ] + +mkModuleImpExp :: RdrName -> ImpExpSubSpec -> IE RdrName +mkModuleImpExp name subs = + case subs of + ImpExpAbs + | isVarNameSpace (rdrNameSpace name) -> IEVar name + | otherwise -> IEThingAbs nameT + ImpExpAll -> IEThingAll nameT + ImpExpList xs -> IEThingWith nameT xs + + where + nameT = setRdrNameSpace name tcClsName + +mkTypeImpExp :: Located RdrName -> P (Located RdrName) +mkTypeImpExp name = + do allowed <- extension explicitNamespacesEnabled + if allowed + then return (fmap (`setRdrNameSpace` tcClsName) name) + else parseErrorSDoc (getLoc name) + (text "Illegal keyword 'type' (use -XExplicitNamespaces to enable)") +\end{code} ----------------------------------------------------------------------------- -- Misc utils diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs index e939c27ec0..35806a1dc6 100644 --- a/compiler/prelude/PrelNames.lhs +++ b/compiler/prelude/PrelNames.lhs @@ -273,6 +273,16 @@ basicKnownKeyNames -- Other classes randomClassName, randomGenClassName, monadPlusClassName, + -- Type-level naturals + typeNatKindConName, + typeStringKindConName, + typeNatClassName, + typeStringClassName, + typeNatLeqClassName, + typeNatAddTyFamName, + typeNatMulTyFamName, + typeNatExpTyFamName, + -- Annotation type checking toAnnotationWrapperName @@ -333,7 +343,7 @@ gHC_PRIM, gHC_TYPES, gHC_GENERICS, gHC_FLOAT, gHC_TOP_HANDLER, sYSTEM_IO, dYNAMIC, tYPEABLE, tYPEABLE_INTERNAL, gENERICS, dOTNET, rEAD_PREC, lEX, gHC_INT, gHC_WORD, mONAD, mONAD_FIX, mONAD_ZIP, aRROW, cONTROL_APPLICATIVE, gHC_DESUGAR, rANDOM, gHC_EXTS, - cONTROL_EXCEPTION_BASE :: Module + cONTROL_EXCEPTION_BASE, gHC_TYPELITS :: Module gHC_PRIM = mkPrimModule (fsLit "GHC.Prim") -- Primitive types and values gHC_TYPES = mkPrimModule (fsLit "GHC.Types") @@ -385,6 +395,7 @@ gHC_DESUGAR = mkBaseModule (fsLit "GHC.Desugar") rANDOM = mkBaseModule (fsLit "System.Random") gHC_EXTS = mkBaseModule (fsLit "GHC.Exts") cONTROL_EXCEPTION_BASE = mkBaseModule (fsLit "Control.Exception.Base") +gHC_TYPELITS = mkBaseModule (fsLit "GHC.TypeLits") gHC_PARR' :: Module gHC_PARR' = mkBaseModule (fsLit "GHC.PArr") @@ -1039,6 +1050,21 @@ randomClassName = clsQual rANDOM (fsLit "Random") randomClassKey randomGenClassName = clsQual rANDOM (fsLit "RandomGen") randomGenClassKey isStringClassName = clsQual dATA_STRING (fsLit "IsString") isStringClassKey +-- Type-level naturals +typeNatKindConName, typeStringKindConName, + typeNatClassName, typeStringClassName, typeNatLeqClassName, + typeNatAddTyFamName, typeNatMulTyFamName, typeNatExpTyFamName :: Name +typeNatKindConName = tcQual gHC_TYPELITS (fsLit "Nat") typeNatKindConNameKey +typeStringKindConName = tcQual gHC_TYPELITS (fsLit "Symbol") + typeStringKindConNameKey +typeNatClassName = clsQual gHC_TYPELITS (fsLit "NatI") typeNatClassNameKey +typeStringClassName = clsQual gHC_TYPELITS (fsLit "SymbolI") + typeStringClassNameKey +typeNatLeqClassName = clsQual gHC_TYPELITS (fsLit "<=") typeNatLeqClassNameKey +typeNatAddTyFamName = tcQual gHC_TYPELITS (fsLit "+") typeNatAddTyFamNameKey +typeNatMulTyFamName = tcQual gHC_TYPELITS (fsLit "*") typeNatMulTyFamNameKey +typeNatExpTyFamName = tcQual gHC_TYPELITS (fsLit "^") typeNatExpTyFamNameKey + -- dotnet interop objectTyConName :: Name objectTyConName = tcQual dOTNET (fsLit "Object") objectTyConKey @@ -1152,6 +1178,11 @@ gen1ClassKey = mkPreludeClassUnique 38 datatypeClassKey = mkPreludeClassUnique 39 constructorClassKey = mkPreludeClassUnique 40 selectorClassKey = mkPreludeClassUnique 41 + +typeNatClassNameKey, typeStringClassNameKey, typeNatLeqClassNameKey :: Unique +typeNatClassNameKey = mkPreludeClassUnique 42 +typeStringClassNameKey = mkPreludeClassUnique 43 +typeNatLeqClassNameKey = mkPreludeClassUnique 44 \end{code} %************************************************************************ @@ -1334,6 +1365,16 @@ noSelTyConKey = mkPreludeTyConUnique 154 repTyConKey = mkPreludeTyConUnique 155 rep1TyConKey = mkPreludeTyConUnique 156 +-- Type-level naturals +typeNatKindConNameKey, typeStringKindConNameKey, + typeNatAddTyFamNameKey, typeNatMulTyFamNameKey, typeNatExpTyFamNameKey + :: Unique +typeNatKindConNameKey = mkPreludeTyConUnique 160 +typeStringKindConNameKey = mkPreludeTyConUnique 161 +typeNatAddTyFamNameKey = mkPreludeTyConUnique 162 +typeNatMulTyFamNameKey = mkPreludeTyConUnique 163 +typeNatExpTyFamNameKey = mkPreludeTyConUnique 164 + ---------------- Template Haskell ------------------- -- USES TyConUniques 200-299 ----------------------------------------------------- diff --git a/compiler/prelude/TysPrim.lhs b/compiler/prelude/TysPrim.lhs index 04bda6b0fe..89181e89cb 100644 --- a/compiler/prelude/TysPrim.lhs +++ b/compiler/prelude/TysPrim.lhs @@ -38,6 +38,7 @@ module TysPrim( anyKind, liftedTypeKind, unliftedTypeKind, openTypeKind, argTypeKind, ubxTupleKind, constraintKind, mkArrowKind, mkArrowKinds, + typeNatKind, typeStringKind, funTyCon, funTyConName, primTyCons, @@ -364,6 +365,12 @@ argTypeKind = kindTyConType argTypeKindTyCon ubxTupleKind = kindTyConType ubxTupleKindTyCon constraintKind = kindTyConType constraintKindTyCon +typeNatKind :: Kind +typeNatKind = kindTyConType (mkKindTyCon typeNatKindConName superKind) + +typeStringKind :: Kind +typeStringKind = kindTyConType (mkKindTyCon typeStringKindConName superKind) + -- | Given two kinds @k1@ and @k2@, creates the 'Kind' @k1 -> k2@ mkArrowKind :: Kind -> Kind -> Kind mkArrowKind k1 k2 = FunTy k1 k2 diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs index f1adba6bd3..66c40928a2 100644 --- a/compiler/rename/RnEnv.lhs +++ b/compiler/rename/RnEnv.lhs @@ -22,7 +22,7 @@ module RnEnv ( HsSigCtxt(..), lookupLocalDataTcNames, lookupSigOccRn, lookupFixityRn, lookupTyFixityRn, - lookupInstDeclBndr, lookupSubBndrOcc, lookupTcdName, + lookupInstDeclBndr, lookupSubBndrOcc, lookupFamInstName, greRdrName, lookupSubBndrGREs, lookupConstructorFields, lookupSyntaxName, lookupSyntaxTable, lookupIfThenElse, @@ -272,22 +272,13 @@ lookupInstDeclBndr cls what rdr ----------------------------------------------- -lookupTcdName :: Maybe Name -> TyClDecl RdrName -> RnM (Located Name) --- Used for TyData and TySynonym only, --- both ordinary ones and family instances +lookupFamInstName :: Maybe Name -> Located RdrName -> RnM (Located Name) +-- Used for TyData and TySynonym family instances only, -- See Note [Family instance binders] -lookupTcdName mb_cls tc_decl - | not (isFamInstDecl tc_decl) -- The normal case - = ASSERT2( isNothing mb_cls, ppr tc_rdr ) -- Parser prevents this - lookupLocatedTopBndrRn tc_rdr - - | Just cls <- mb_cls -- Associated type; c.f RnBinds.rnMethodBind +lookupFamInstName (Just cls) tc_rdr -- Associated type; c.f RnBinds.rnMethodBind = wrapLocM (lookupInstDeclBndr cls (ptext (sLit "associated type"))) tc_rdr - - | otherwise -- Family instance; tc_rdr is an *occurrence* +lookupFamInstName Nothing tc_rdr -- Family instance; tc_rdr is an *occurrence* = lookupLocatedOccRn tc_rdr - where - tc_rdr = tcdLName tc_decl ----------------------------------------------- lookupConstructorFields :: Name -> RnM [Name] diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs index 553c3ef81a..7007eb559c 100644 --- a/compiler/rename/RnNames.lhs +++ b/compiler/rename/RnNames.lhs @@ -529,10 +529,10 @@ getLocalNonValBinders fixity_env ; return (AvailTC main_name names) } new_assoc :: LInstDecl RdrName -> RnM [AvailInfo] - new_assoc (L _ (FamInstDecl d)) + new_assoc (L _ (FamInstD d)) = do { avail <- new_ti Nothing d ; return [avail] } - new_assoc (L _ (ClsInstDecl inst_ty _ _ ats)) + new_assoc (L _ (ClsInstD { cid_poly_ty = inst_ty, cid_fam_insts = ats })) | Just (_, _, L loc cls_rdr, _) <- splitLHsInstDeclTy_maybe inst_ty = do { cls_nm <- setSrcSpan loc $ lookupGlobalOccRn cls_rdr ; mapM (new_ti (Just cls_nm) . unLoc) ats } @@ -542,9 +542,8 @@ getLocalNonValBinders fixity_env new_ti :: Maybe Name -> FamInstDecl RdrName -> RnM AvailInfo new_ti mb_cls ti_decl -- ONLY for type/data instances - = ASSERT( isFamInstDecl ti_decl ) - do { main_name <- lookupTcdName mb_cls ti_decl - ; sub_names <- mapM newTopSrcBinder (hsTyClDeclBinders ti_decl) + = do { main_name <- lookupFamInstName mb_cls (fid_tycon ti_decl) + ; sub_names <- mapM newTopSrcBinder (hsFamInstBinders ti_decl) ; return (AvailTC (unLoc main_name) sub_names) } -- main_name is not bound here! \end{code} @@ -1612,7 +1611,7 @@ dodgyImportWarn item = dodgyMsg (ptext (sLit "import")) item dodgyExportWarn :: Name -> SDoc dodgyExportWarn item = dodgyMsg (ptext (sLit "export")) item -dodgyMsg :: OutputableBndr n => SDoc -> n -> SDoc +dodgyMsg :: (OutputableBndr n, HasOccName n) => SDoc -> n -> SDoc dodgyMsg kind tc = sep [ ptext (sLit "The") <+> kind <+> ptext (sLit "item") <+> quotes (ppr (IEThingAll tc)) <+> ptext (sLit "suggests that"), diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index a4a734cca1..27ae036d61 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -24,7 +24,7 @@ import {-# SOURCE #-} TcSplice ( runQuasiQuoteDecl ) import HsSyn import RdrName -import RdrHsSyn ( extractHsRhoRdrTyVars ) +import RdrHsSyn ( extractHsTysRdrTyVars ) import RnTypes import RnBinds import RnEnv @@ -423,11 +423,12 @@ patchCCallTarget packageId callTarget \begin{code} rnSrcInstDecl :: InstDecl RdrName -> RnM (InstDecl Name, FreeVars) -rnSrcInstDecl (FamInstDecl ty_decl) - = do { (ty_decl', fvs) <- rnTyClDecl Nothing ty_decl - ; return (FamInstDecl ty_decl', fvs) } +rnSrcInstDecl (FamInstD fi) + = do { (fi', fvs) <- rnFamInstDecl Nothing fi + ; return (FamInstD fi', fvs) } -rnSrcInstDecl (ClsInstDecl inst_ty mbinds uprags ats) +rnSrcInstDecl (ClsInstD { cid_poly_ty = inst_ty, cid_binds = mbinds + , cid_sigs = uprags, cid_fam_insts = ats }) -- Used for both source and interface file decls = do { (inst_ty', inst_fvs) <- rnLHsInstType (text "In an instance declaration") inst_ty ; let Just (inst_tyvars, _, L _ cls,_) = splitLHsInstDeclTy_maybe inst_ty' @@ -438,7 +439,7 @@ rnSrcInstDecl (ClsInstDecl inst_ty mbinds uprags ats) -- Both need to have the instance type variables in scope ; ((ats', other_sigs'), more_fvs) <- extendTyVarEnvFVRn tv_names $ - do { (ats', at_fvs) <- rnATDecls cls tv_names ats + do { (ats', at_fvs) <- rnATInstDecls cls tv_names ats ; (other_sigs', sig_fvs) <- renameSigs (InstDeclCtxt cls) other_sigs ; return ( (ats', other_sigs') , at_fvs `plusFV` sig_fvs) } @@ -462,7 +463,8 @@ rnSrcInstDecl (ClsInstDecl inst_ty mbinds uprags ats) <- renameSigs (InstDeclCtxt cls) spec_inst_prags ; let uprags' = spec_inst_prags' ++ other_sigs' - ; return (ClsInstDecl inst_ty' mbinds' uprags' ats', + ; return (ClsInstD { cid_poly_ty = inst_ty', cid_binds = mbinds' + , cid_sigs = uprags', cid_fam_insts = ats' }, meth_fvs `plusFV` more_fvs `plusFV` spec_inst_fvs `plusFV` inst_fvs) } @@ -476,23 +478,50 @@ rnSrcInstDecl (ClsInstDecl inst_ty mbinds uprags ats) -- the instance context after renaming. This is a bit -- strange, but should not matter (and it would be more work -- to remove the context). + +rnFamInstDecl :: Maybe (Name, [Name]) -> FamInstDecl RdrName -> RnM (FamInstDecl Name, FreeVars) +rnFamInstDecl mb_cls (FamInstDecl { fid_tycon = tycon, fid_pats = HsBSig pats _, fid_defn = defn }) + = do { tycon' <- lookupFamInstName (fmap fst mb_cls) tycon + ; let loc = case pats of + [] -> pprPanic "rnFamInstDecl" (ppr tycon) + (L loc _ : []) -> loc + (L loc _ : ps) -> combineSrcSpans loc (getLoc (last ps)) + ; tv_names <- mkTyVarBndrNames mb_cls (map (L loc) (extractHsTysRdrTyVars pats)) + -- All the free vars of the family patterns + -- with a sensible binding location + ; bindLocalNamesFV tv_names $ + do { (pats', pat_fvs) <- rnLHsTypes (TyDataCtx tycon) pats + ; (defn', rhs_fvs) <- rnTyDefn tycon defn + + -- See Note [Renaming associated types] + ; let bad_tvs = case mb_cls of + Nothing -> [] + Just (_,cls_tvs) -> filter is_bad cls_tvs + is_bad tv = not (tv `elem` tv_names) && tv `elemNameSet` rhs_fvs + ; unless (null bad_tvs) (badAssocRhs bad_tvs) + + ; return ( FamInstDecl { fid_tycon = tycon' + , fid_pats = HsBSig pats' tv_names + , fid_defn = defn' } + , (rhs_fvs `plusFV` pat_fvs) `addOneFV` unLoc tycon') } } + -- type instance => use, hence addOneFV \end{code} Renaming of the associated types in instances. \begin{code} -rnATDecls :: Name -- Class - -> [Name] -- Type variable binders (but NOT kind variables) +rnATInstDecls :: Name -- Class + -> [Name] -- Type variable binders (but NOT kind variables) -- See Note [Renaming associated types] in RnTypes - -> [LTyClDecl RdrName] - -> RnM ([LTyClDecl Name], FreeVars) + -> [LFamInstDecl RdrName] + -> RnM ([LFamInstDecl Name], FreeVars) -- Used for the family declarations and defaults in a class decl -- and the family instance declarations in an instance -- -- NB: We allow duplicate associated-type decls; -- See Note [Associated type instances] in TcInstDcls -rnATDecls cls tvs atDecls - = rnList (rnTyClDecl (Just (cls, tvs))) atDecls +rnATInstDecls cls tvs atDecls + = rnList (rnFamInstDecl (Just (cls, tvs))) atDecls \end{code} For the method bindings in class and instance decls, we extend the @@ -797,79 +826,27 @@ rnTyClDecl _ (ForeignType {tcdLName = name, tcdExtName = ext_name}) -- in a class decl rnTyClDecl mb_cls (TyFamily { tcdLName = tycon, tcdTyVars = tyvars , tcdFlavour = flav, tcdKindSig = kind }) - = bindTyClTyVars fmly_doc mb_cls tyvars $ \tyvars' -> + = do { let tv_rdr_names = hsLTyVarLocNames tyvars + ; checkDupRdrNames tv_rdr_names -- Check for duplicated bindings + ; tv_names <- mkTyVarBndrNames mb_cls tv_rdr_names + ; bindTyVarsRn fmly_doc tyvars tv_names $ \tyvars' -> do { tycon' <- lookupLocatedTopBndrRn tycon ; (kind', fv_kind) <- rnLHsMaybeKind fmly_doc kind ; return ( TyFamily { tcdLName = tycon', tcdTyVars = tyvars' , tcdFlavour = flav, tcdKindSig = kind' } - , fv_kind) } + , fv_kind) } } where fmly_doc = TyFamilyCtx tycon --- "data", "newtype", "data instance, and "newtype instance" declarations +-- "data", "newtype" declarations -- both top level and (for an associated type) in an instance decl -rnTyClDecl mb_cls tydecl@TyData {tcdND = new_or_data, tcdCType = cType, - tcdCtxt = context, - tcdLName = tycon, tcdTyVars = tyvars, - tcdTyPats = typats, tcdCons = condecls, - tcdKindSig = sig, tcdDerivs = derivs} - = bindTyClTyVars data_doc mb_cls tyvars $ \ tyvars' -> - -- Checks for distinct tyvars - do { tycon' <- lookupTcdName (fmap fst mb_cls) tydecl - ; checkTc (h98_style || null (unLoc context)) - (badGadtStupidTheta tycon) - - ; (sig', sig_fvs) <- rnLHsMaybeKind data_doc sig - ; (context', fvs1) <- rnContext data_doc context - ; (typats', fvs2) <- rnTyPats data_doc tycon' typats - ; (derivs', fvs3) <- rn_derivs derivs - - -- For the constructor declarations, drop the LocalRdrEnv - -- in the GADT case, where the type variables in the declaration - -- do not scope over the constructor signatures - -- data T a where { T1 :: forall b. b-> b } - ; let { zap_lcl_env | h98_style = \ thing -> thing - | otherwise = setLocalRdrEnv emptyLocalRdrEnv } - ; (condecls', con_fvs) <- zap_lcl_env $ - rnConDecls condecls - -- No need to check for duplicate constructor decls - -- since that is done by RnNames.extendGlobalRdrEnvRn - - ; return ( TyData { tcdND = new_or_data, tcdCType = cType - , tcdCtxt = context' - , tcdLName = tycon', tcdTyVars = tyvars' - , tcdTyPats = typats', tcdKindSig = sig' - , tcdCons = condecls', tcdDerivs = derivs'} - , fvs1 `plusFV` fvs2 `plusFV` fvs3 `plusFV` - con_fvs `plusFV` sig_fvs ) - } - where - h98_style = case condecls of -- Note [Stupid theta] - L _ (ConDecl { con_res = ResTyGADT {} }) : _ -> False - _ -> True - - data_doc = TyDataCtx tycon - - rn_derivs Nothing = return (Nothing, emptyFVs) - rn_derivs (Just ds) = do { (ds', fvs) <- rnLHsTypes data_doc ds - ; return (Just ds', fvs) } - --- "type" and "type instance" declarations -rnTyClDecl mb_cls tydecl@(TySynonym { tcdTyVars = tyvars - , tcdLName = name - , tcdTyPats = typats, tcdSynRhs = ty}) - = do { name' <- lookupTcdName (fmap fst mb_cls) tydecl - ; ((tyvars', typats', ty'), fvs) - <- bindTyClTyVars syn_doc mb_cls tyvars $ \ tyvars' -> do - do { (typats',fvs1) <- rnTyPats syn_doc name' typats - ; (ty', fvs2) <- rnLHsType syn_doc ty - ; return ((tyvars', typats', ty'), fvs1 `plusFV` fvs2) } - ; return (TySynonym { tcdLName = name', tcdTyVars = tyvars' - , tcdTyPats = typats', tcdSynRhs = ty' - , tcdFVs = fvs } - , fvs) } - where - syn_doc = TySynCtx name +rnTyClDecl _ (TyDecl { tcdLName = tycon, tcdTyVars = tyvars, tcdTyDefn = defn }) + = do { tycon' <- lookupLocatedTopBndrRn tycon + ; ((tyvars', defn'), fvs) <- bindHsTyVars (TyDataCtx tycon) tyvars $ \ tyvars' -> + do { (defn', fvs) <- rnTyDefn tycon defn + ; return ((tyvars', defn'), fvs) } + ; return (TyDecl { tcdLName = tycon', tcdTyVars = tyvars' + , tcdTyDefn = defn', tcdFVs = fvs }, fvs) } rnTyClDecl _ (ClassDecl {tcdCtxt = context, tcdLName = lcls, tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs, @@ -886,8 +863,8 @@ rnTyClDecl _ (ClassDecl {tcdCtxt = context, tcdLName = lcls, ; fds' <- rnFds (docOfHsDocContext cls_doc) fds -- The fundeps have no free variables ; let tv_ns = hsLTyVarNames tyvars' - ; (ats', fv_ats) <- rnATDecls cls' tv_ns ats - ; (at_defs', fv_at_defs) <- rnATDecls cls' tv_ns at_defs + ; (ats', fv_ats) <- rnList (rnTyClDecl (Just (cls', tv_ns))) ats + ; (at_defs', fv_at_defs) <- rnATInstDecls cls' tv_ns at_defs ; (sigs', sig_fvs) <- renameSigs (ClsDeclCtxt cls') sigs ; let fvs = cxt_fvs `plusFV` sig_fvs `plusFV` @@ -934,6 +911,52 @@ rnTyClDecl _ (ClassDecl {tcdCtxt = context, tcdLName = lcls, cls_doc = ClassDeclCtx lcls +rnTyDefn :: Located RdrName -> HsTyDefn RdrName -> RnM (HsTyDefn Name, FreeVars) +rnTyDefn tycon (TyData { td_ND = new_or_data, td_cType = cType + , td_ctxt = context, td_cons = condecls + , td_kindSig = sig, td_derivs = derivs }) + = do { checkTc (h98_style || null (unLoc context)) + (badGadtStupidTheta tycon) + + ; (sig', sig_fvs) <- rnLHsMaybeKind data_doc sig + ; (context', fvs1) <- rnContext data_doc context + ; (derivs', fvs3) <- rn_derivs derivs + + -- For the constructor declarations, drop the LocalRdrEnv + -- in the GADT case, where the type variables in the declaration + -- do not scope over the constructor signatures + -- data T a where { T1 :: forall b. b-> b } + ; let { zap_lcl_env | h98_style = \ thing -> thing + | otherwise = setLocalRdrEnv emptyLocalRdrEnv } + ; (condecls', con_fvs) <- zap_lcl_env $ + rnConDecls condecls + -- No need to check for duplicate constructor decls + -- since that is done by RnNames.extendGlobalRdrEnvRn + + ; return ( TyData { td_ND = new_or_data, td_cType = cType + , td_ctxt = context', td_kindSig = sig' + , td_cons = condecls', td_derivs = derivs'} + , fvs1 `plusFV` fvs3 `plusFV` + con_fvs `plusFV` sig_fvs ) + } + where + h98_style = case condecls of -- Note [Stupid theta] + L _ (ConDecl { con_res = ResTyGADT {} }) : _ -> False + _ -> True + + data_doc = TyDataCtx tycon + + rn_derivs Nothing = return (Nothing, emptyFVs) + rn_derivs (Just ds) = do { (ds', fvs) <- rnLHsTypes data_doc ds + ; return (Just ds', fvs) } + +-- "type" and "type instance" declarations +rnTyDefn tycon (TySynonym { td_synRhs = ty }) + = do { (ty', rhs_fvs) <- rnLHsType syn_doc ty + ; return (TySynonym { td_synRhs = ty' }, rhs_fvs) } + where + syn_doc = TySynCtx tycon + badGadtStupidTheta :: Located RdrName -> SDoc badGadtStupidTheta _ = vcat [ptext (sLit "No context is allowed on a GADT-style data declaration"), @@ -973,10 +996,10 @@ depAnalTyClDecls ds_w_fvs , tcdATs = ats } -> do L _ assoc_decl <- ats return (tcdName assoc_decl, cls_name) - TyData { tcdLName = L _ data_name - , tcdCons = cons } -> do - L _ dc <- cons - return (unLoc (con_name dc), data_name) + TyDecl { tcdLName = L _ data_name + , tcdTyDefn = TyData { td_cons = cons } } + -> do L _ dc <- cons + return (unLoc (con_name dc), data_name) _ -> [] \end{code} @@ -1001,24 +1024,36 @@ is jolly confusing. See Trac #4875 %********************************************************* \begin{code} -rnTyPats :: HsDocContext -> Located Name -> Maybe [LHsType RdrName] - -> RnM (Maybe [LHsType Name], FreeVars) --- Although, we are processing type patterns here, all type variables will --- already be in scope (they are the same as in the 'tcdTyVars' field of the --- type declaration to which these patterns belong) -rnTyPats _ _ Nothing - = return (Nothing, emptyFVs) -rnTyPats doc tc (Just typats) - = do { (typats', fvs) <- rnLHsTypes doc typats - ; return (Just typats', addOneFV fvs (unLoc tc)) } - -- type instance => use, hence addOneFV - +--------------- +mkTyVarBndrNames :: Maybe a -> [Located RdrName] -> RnM [Name] +mkTyVarBndrNames Nothing tv_rdr_names + = newLocalBndrsRn tv_rdr_names +mkTyVarBndrNames (Just _) tv_rdr_names + = do { rdr_env <- getLocalRdrEnv + ; let mk_tv_name :: Located RdrName -> RnM Name + -- Use the same Name as the parent class decl + mk_tv_name (L l tv_rdr) + = case lookupLocalRdrEnv rdr_env tv_rdr of + Just n -> return n + Nothing -> newLocalBndrRn (L l tv_rdr) + + ; mapM mk_tv_name tv_rdr_names } + +--------------- +badAssocRhs :: [Name] -> RnM () +badAssocRhs ns + = addErr (hang (ptext (sLit "The RHS of an associated type declaration mentions type variable") + <> plural ns + <+> pprWithCommas (quotes . ppr) ns) + 2 (ptext (sLit "All such variables must be bound on the LHS"))) + +----------------- rnConDecls :: [LConDecl RdrName] -> RnM ([LConDecl Name], FreeVars) rnConDecls = mapFvRn (wrapLocFstM rnConDecl) rnConDecl :: ConDecl RdrName -> RnM (ConDecl Name, FreeVars) rnConDecl decl@(ConDecl { con_name = name, con_qvars = tvs - , con_cxt = cxt, con_details = details + , con_cxt = lcxt@(L loc cxt), con_details = details , con_res = res_ty, con_doc = mb_doc , con_old_rec = old_rec, con_explicit = expl }) = do { addLocM checkConName name @@ -1029,7 +1064,7 @@ rnConDecl decl@(ConDecl { con_name = name, con_qvars = tvs -- For GADT syntax, the tvs are all the quantified tyvars -- Hence the 'filter' in the ResTyH98 case only ; rdr_env <- getLocalRdrEnv - ; let in_scope = (`elemLocalRdrEnv` rdr_env) . unLoc + ; let in_scope tv = tv `elemLocalRdrEnv` rdr_env arg_tys = hsConDeclArgTys details mentioned_tvs = case res_ty of ResTyH98 -> filterOut in_scope (get_rdr_tvs arg_tys) @@ -1038,14 +1073,14 @@ rnConDecl decl@(ConDecl { con_name = name, con_qvars = tvs -- With an Explicit forall, check for unused binders -- With Implicit, find the mentioned ones, and use them as binders ; new_tvs <- case expl of - Implicit -> return (userHsTyVarBndrs mentioned_tvs) + Implicit -> return (userHsTyVarBndrs loc mentioned_tvs) Explicit -> do { warnUnusedForAlls (docOfHsDocContext doc) tvs mentioned_tvs ; return tvs } ; mb_doc' <- rnMbLHsDoc mb_doc ; bindHsTyVars doc new_tvs $ \new_tyvars -> do - { (new_context, fvs1) <- rnContext doc cxt + { (new_context, fvs1) <- rnContext doc lcxt ; (new_details, fvs2) <- rnConDeclDetails doc details ; (new_details', new_res_ty, fvs3) <- rnConResult doc (unLoc new_name) new_details res_ty ; return (decl { con_name = new_name, con_qvars = new_tyvars, con_cxt = new_context @@ -1053,7 +1088,7 @@ rnConDecl decl@(ConDecl { con_name = name, con_qvars = tvs fvs1 `plusFV` fvs2 `plusFV` fvs3) }} where doc = ConDeclCtx name - get_rdr_tvs tys = extractHsRhoRdrTyVars cxt (noLoc (HsTupleTy HsBoxedTuple tys)) + get_rdr_tvs tys = extractHsTysRdrTyVars (cxt ++ tys) rnConResult :: HsDocContext -> Name -> HsConDetails (LHsType Name) [ConDeclField Name] @@ -1171,10 +1206,10 @@ extendRecordFieldEnv tycl_decls inst_decls ; return $ unLoc x'} all_data_cons :: [ConDecl RdrName] - all_data_cons = [con | L _ (TyData { tcdCons = cons }) <- all_tycl_decls + all_data_cons = [con | TyData { td_cons = cons } <- all_ty_defs , L _ con <- cons ] - all_tycl_decls = at_tycl_decls ++ concat tycl_decls - at_tycl_decls = instDeclFamInsts inst_decls -- Do not forget associated types! + all_ty_defs = [ defn | L _ (TyDecl { tcdTyDefn = defn }) <- concat tycl_decls ] + ++ map fid_defn (instDeclFamInsts inst_decls) -- Do not forget associated types! get_con (ConDecl { con_name = con, con_details = RecCon flds }) (RecFields env fld_set) diff --git a/compiler/rename/RnTypes.lhs b/compiler/rename/RnTypes.lhs index 15e5501fe0..ddd788f0bf 100644 --- a/compiler/rename/RnTypes.lhs +++ b/compiler/rename/RnTypes.lhs @@ -26,7 +26,7 @@ module RnTypes ( rnSplice, checkTH, -- Binding related stuff - bindSigTyVarsFV, bindHsTyVars, bindTyClTyVars, rnHsBndrSig + bindSigTyVarsFV, bindHsTyVars, bindTyVarsRn, rnHsBndrSig ) where import {-# SOURCE #-} RnExpr( rnLExpr ) @@ -36,7 +36,7 @@ import {-# SOURCE #-} TcSplice( runQuasiQuoteType ) import DynFlags import HsSyn -import RdrHsSyn ( extractHsRhoRdrTyVars, extractHsTyRdrTyVars ) +import RdrHsSyn ( extractHsTyRdrTyVars, extractHsTysRdrTyVars ) import RnHsDoc ( rnLHsDoc, rnMbLHsDoc ) import RnEnv import TcRnMonad @@ -106,12 +106,13 @@ rnLHsType = rnLHsTyKi True rnLHsKind :: HsDocContext -> LHsKind RdrName -> RnM (LHsKind Name, FreeVars) rnLHsKind = rnLHsTyKi False -rnLHsMaybeKind :: HsDocContext -> Maybe (LHsKind RdrName) - -> RnM (Maybe (LHsKind Name), FreeVars) -rnLHsMaybeKind _ Nothing = return (Nothing, emptyFVs) -rnLHsMaybeKind doc (Just k) - = do { (k', fvs) <- rnLHsKind doc k - ; return (Just k', fvs) } +rnLHsMaybeKind :: HsDocContext -> Maybe (HsBndrSig (LHsKind RdrName)) + -> RnM (Maybe (HsBndrSig (LHsKind Name)), FreeVars) +rnLHsMaybeKind _ Nothing + = return (Nothing, emptyFVs) +rnLHsMaybeKind doc (Just bsig) + = rnHsBndrSig False doc bsig $ \ bsig' -> + return (Just bsig', emptyFVs) rnHsType :: HsDocContext -> HsType RdrName -> RnM (HsType Name, FreeVars) rnHsType = rnHsTyKi True @@ -120,33 +121,34 @@ rnHsKind = rnHsTyKi False rnHsTyKi :: Bool -> HsDocContext -> HsType RdrName -> RnM (HsType Name, FreeVars) -rnHsTyKi isType doc (HsForAllTy Implicit _ ctxt ty) +rnHsTyKi isType doc (HsForAllTy Implicit _ lctxt@(L _ ctxt) ty) = ASSERT ( isType ) do -- Implicit quantifiction in source code (no kinds on tyvars) -- Given the signature C => T we universally quantify -- over FV(T) \ {in-scope-tyvars} name_env <- getLocalRdrEnv + loc <- getSrcSpanM let - mentioned = extractHsRhoRdrTyVars ctxt ty + mentioned = extractHsTysRdrTyVars (ty:ctxt) -- Don't quantify over type variables that are in scope; -- when GlasgowExts is off, there usually won't be any, except for -- class signatures: -- class C a where { op :: a -> a } - forall_tyvars = filter (not . (`elemLocalRdrEnv` name_env) . unLoc) mentioned - tyvar_bndrs = userHsTyVarBndrs forall_tyvars + forall_tyvars = filter (not . (`elemLocalRdrEnv` name_env)) mentioned + tyvar_bndrs = userHsTyVarBndrs loc forall_tyvars - rnForAll doc Implicit tyvar_bndrs ctxt ty + rnForAll doc Implicit tyvar_bndrs lctxt ty -rnHsTyKi isType doc ty@(HsForAllTy Explicit forall_tyvars ctxt tau) +rnHsTyKi isType doc ty@(HsForAllTy Explicit forall_tyvars lctxt@(L _ ctxt) tau) = ASSERT ( isType ) do { -- Explicit quantification. -- Check that the forall'd tyvars are actually -- mentioned in the type, and produce a warning if not - let mentioned = extractHsRhoRdrTyVars ctxt tau + let mentioned = extractHsTysRdrTyVars (tau:ctxt) in_type_doc = ptext (sLit "In the type") <+> quotes (ppr ty) ; warnUnusedForAlls (in_type_doc $$ docOfHsDocContext doc) forall_tyvars mentioned - ; rnForAll doc Explicit forall_tyvars ctxt tau } + ; rnForAll doc Explicit forall_tyvars lctxt tau } rnHsTyKi isType _ (HsTyVar rdr_name) = do { name <- rnTyVar isType rdr_name @@ -224,6 +226,13 @@ rnHsTyKi isType doc tupleTy@(HsTupleTy tup_con tys) ; (tys', fvs) <- mapFvRn (rnLHsTyKi isType doc) tys ; return (HsTupleTy tup_con tys', fvs) } +-- 1. Perhaps we should use a separate extension here? +-- 2. Check that the integer is positive? +rnHsTyKi isType _ tyLit@(HsTyLit t) + = do { data_kinds <- xoptM Opt_DataKinds + ; unless (data_kinds || isType) (addErr (dataKindsErr tyLit)) + ; return (HsTyLit t, emptyFVs) } + rnHsTyKi isType doc (HsAppTy ty1 ty2) = do { (ty1', fvs1) <- rnLHsTyKi isType doc ty1 ; (ty2', fvs2) <- rnLHsTyKi isType doc ty2 @@ -286,6 +295,7 @@ rnTyVar is_type rdr_name | is_type = lookupTypeOccRn rdr_name | otherwise = lookupKindOccRn rdr_name + -------------- rnLHsTypes :: HsDocContext -> [LHsType RdrName] -> RnM ([LHsType Name], FreeVars) @@ -330,56 +340,6 @@ bindSigTyVarsFV tvs thing_inside bindLocalNamesFV tvs thing_inside } --------------- -bindTyClTyVars - :: HsDocContext - -> Maybe (Name, [Name]) -- Parent class and its tyvars - -- (but not kind vars) - -> [LHsTyVarBndr RdrName] - -> ([LHsTyVarBndr Name] -> RnM (a, FreeVars)) - -> RnM (a, FreeVars) --- Used for tyvar binders in type/class declarations --- Just like bindHsTyVars, but deals with the case of associated --- types, where the type variables may be already in scope -bindTyClTyVars doc mb_cls tyvars thing_inside - | Just (_, cls_tvs) <- mb_cls -- Associated type family or type instance - = do { let tv_rdr_names = map hsLTyVarLocName tyvars - -- *All* the free vars of the family patterns - - -- Check for duplicated bindings - -- This test is irrelevant for data/type *instances*, where the tyvars - -- are the free tyvars of the patterns, and hence have no duplicates - -- But it's needed for data/type *family* decls - ; checkDupRdrNames tv_rdr_names - - -- Make the Names for the tyvars - ; rdr_env <- getLocalRdrEnv - ; let mk_tv_name :: Located RdrName -> RnM Name - -- Use the same Name as the parent class decl - mk_tv_name (L l tv_rdr) - = case lookupLocalRdrEnv rdr_env tv_rdr of - Just n -> return n - Nothing -> newLocalBndrRn (L l tv_rdr) - ; tv_ns <- mapM mk_tv_name tv_rdr_names - - ; (thing, fvs) <- bindTyVarsRn doc tyvars tv_ns thing_inside - - -- See Note [Renaming associated types] - ; let bad_tvs = fvs `intersectNameSet` mkNameSet cls_tvs - ; unless (isEmptyNameSet bad_tvs) (badAssocRhs (nameSetToList bad_tvs)) - - ; return (thing, fvs) } - - | otherwise -- Not associated, just fall through to bindHsTyVars - = bindHsTyVars doc tyvars thing_inside - -badAssocRhs :: [Name] -> RnM () -badAssocRhs ns - = addErr (hang (ptext (sLit "The RHS of an associated type declaration mentions type variable") - <> plural ns - <+> pprWithCommas (quotes . ppr) ns) - 2 (ptext (sLit "All such variables must be bound on the LHS"))) - ---------------- bindHsTyVars :: HsDocContext -> [LHsTyVarBndr RdrName] -> ([LHsTyVarBndr Name] -> RnM (a, FreeVars)) -> RnM (a, FreeVars) @@ -404,14 +364,14 @@ bindTyVarsRn doc tv_bndrs names thing_inside where go [] [] thing_inside = thing_inside [] - go (L loc (UserTyVar _ tck) : tvs) (n : ns) thing_inside + go (L loc (UserTyVar _) : tvs) (n : ns) thing_inside = go tvs ns $ \ tvs' -> - thing_inside (L loc (UserTyVar n tck) : tvs') + thing_inside (L loc (UserTyVar n) : tvs') - go (L loc (KindedTyVar _ bsig tck) : tvs) (n : ns) thing_inside + go (L loc (KindedTyVar _ bsig) : tvs) (n : ns) thing_inside = rnHsBndrSig False doc bsig $ \ bsig' -> go tvs ns $ \ tvs' -> - thing_inside (L loc (KindedTyVar n bsig' tck) : tvs') + thing_inside (L loc (KindedTyVar n bsig') : tvs') -- Lists of unequal length go tvs names _ = pprPanic "bindTyVarsRn" (ppr tvs $$ ppr names) @@ -422,19 +382,20 @@ rnHsBndrSig :: Bool -- True <=> type sig, False <=> kind sig -> HsBndrSig (LHsType RdrName) -> (HsBndrSig (LHsType Name) -> RnM (a, FreeVars)) -> RnM (a, FreeVars) -rnHsBndrSig is_type doc (HsBSig ty _) thing_inside +rnHsBndrSig is_type doc (HsBSig ty@(L loc _) _) thing_inside = do { name_env <- getLocalRdrEnv ; let tv_bndrs = [ tv | tv <- extractHsTyRdrTyVars ty - , not (unLoc tv `elemLocalRdrEnv` name_env) ] + , not (tv `elemLocalRdrEnv` name_env) ] ; checkHsBndrFlags is_type doc ty tv_bndrs - ; bindLocatedLocalsFV tv_bndrs $ \ tv_names -> do + ; tv_names <- newLocalBndrsRn [L loc tv | tv <- tv_bndrs] + ; bindLocalNamesFV tv_names $ do { (ty', fvs1) <- rnLHsTyKi is_type doc ty ; (res, fvs2) <- thing_inside (HsBSig ty' tv_names) ; return (res, fvs1 `plusFV` fvs2) } } checkHsBndrFlags :: Bool -> HsDocContext - -> LHsType RdrName -> [Located RdrName] -> RnM () + -> LHsType RdrName -> [RdrName] -> RnM () checkHsBndrFlags is_type doc ty tv_bndrs | is_type -- Type = do { sig_ok <- xoptM Opt_ScopedTypeVariables @@ -446,7 +407,7 @@ checkHsBndrFlags is_type doc ty tv_bndrs ; unless (poly_kind || null tv_bndrs) (addErr (badKindBndrs doc ty tv_bndrs)) } -badKindBndrs :: HsDocContext -> LHsKind RdrName -> [Located RdrName] -> SDoc +badKindBndrs :: HsDocContext -> LHsKind RdrName -> [RdrName] -> SDoc badKindBndrs doc _kind kvs = vcat [ hang (ptext (sLit "Kind signature mentions kind variable") <> plural kvs <+> pprQuotedList kvs) @@ -810,14 +771,13 @@ ppr_opfix (op, fixity) = pp_op <+> brackets (ppr fixity) %********************************************************* \begin{code} -warnUnusedForAlls :: SDoc -> [LHsTyVarBndr RdrName] -> [Located RdrName] -> TcM () -warnUnusedForAlls in_doc bound used +warnUnusedForAlls :: SDoc -> [LHsTyVarBndr RdrName] -> [RdrName] -> TcM () +warnUnusedForAlls in_doc bound mentioned_rdrs = ifWOptM Opt_WarnUnusedMatches $ mapM_ add_warn bound_but_not_used where bound_names = hsLTyVarLocNames bound bound_but_not_used = filterOut ((`elem` mentioned_rdrs) . unLoc) bound_names - mentioned_rdrs = map unLoc used add_warn (L loc tv) = addWarnAt loc $ @@ -888,7 +848,8 @@ checkTH _ _ = return () -- OK #else checkTH e what -- Raise an error in a stage-1 compiler = addErr (vcat [ptext (sLit "Template Haskell") <+> text what <+> - ptext (sLit "illegal in a stage-1 compiler"), + ptext (sLit "requires GHC with interpreter support"), + ptext (sLit "Perhaps you are using a stage-1 compiler?"), nest 2 (ppr e)]) #endif \end{code} diff --git a/compiler/simplCore/SetLevels.lhs b/compiler/simplCore/SetLevels.lhs index 394cd9801e..076df2e67c 100644 --- a/compiler/simplCore/SetLevels.lhs +++ b/compiler/simplCore/SetLevels.lhs @@ -818,7 +818,7 @@ lvlLamBndrs lvl bndrs \end{code} \begin{code} - -- Destintion level is the max Id level of the expression + -- Destination level is the max Id level of the expression -- (We'll abstract the type variables, if any.) destLevel :: LevelEnv -> VarSet -> Bool -> Maybe (Arity, StrictSig) -> Level destLevel env fvs is_function mb_bot @@ -830,6 +830,7 @@ destLevel env fvs is_function mb_bot , countFreeIds fvs <= n_args = tOP_LEVEL -- Send functions to top level; see -- the comments with isFunction + | otherwise = maxFvLevel isId env fvs -- Max over Ids only; the tyvars -- will be abstracted diff --git a/compiler/simplCore/SimplUtils.lhs b/compiler/simplCore/SimplUtils.lhs index 7da185a1ae..59ebeea1bc 100644 --- a/compiler/simplCore/SimplUtils.lhs +++ b/compiler/simplCore/SimplUtils.lhs @@ -44,7 +44,6 @@ import StaticFlags import CoreSyn import qualified CoreSubst import PprCore -import DataCon ( dataConCannotMatch, dataConWorkId ) import CoreFVs import CoreUtils import CoreArity @@ -56,7 +55,7 @@ import Demand import SimplMonad import Type hiding( substTy ) import Coercion hiding( substCo ) -import TyCon +import DataCon ( dataConWorkId ) import VarSet import BasicTypes import Util @@ -65,7 +64,7 @@ import Outputable import FastString import Pair -import Data.List +import Control.Monad ( when ) \end{code} @@ -1495,97 +1494,18 @@ of the inner case y, which give us nowhere to go! \begin{code} prepareAlts :: OutExpr -> OutId -> [InAlt] -> SimplM ([AltCon], [InAlt]) -prepareAlts scrut case_bndr' alts - = do { let (alts_wo_default, maybe_deflt) = findDefault alts - alt_cons = [con | (con,_,_) <- alts_wo_default] - imposs_deflt_cons = nub (imposs_cons ++ alt_cons) - -- "imposs_deflt_cons" are handled - -- EITHER by the context, - -- OR by a non-DEFAULT branch in this case expression. - - ; default_alts <- prepareDefault case_bndr' mb_tc_app - imposs_deflt_cons maybe_deflt - - ; let trimmed_alts = filterOut impossible_alt alts_wo_default - merged_alts = mergeAlts trimmed_alts default_alts - -- We need the mergeAlts in case the new default_alt - -- has turned into a constructor alternative. - -- The merge keeps the inner DEFAULT at the front, if there is one - -- and interleaves the alternatives in the right order - - ; return (imposs_deflt_cons, merged_alts) } +prepareAlts scrut case_bndr' alts = do + us <- getUniquesM + -- Case binder is needed just for its type. Note that as an + -- OutId, it has maximum information; this is important. + -- Test simpl013 is an example + let (imposs_deflt_cons, refined_deflt, alts') = filterAlts us (varType case_bndr') imposs_cons alts + when refined_deflt $ tick (FillInCaseDefault case_bndr') + return (imposs_deflt_cons, alts') where - mb_tc_app = splitTyConApp_maybe (idType case_bndr') - Just (_, inst_tys) = mb_tc_app - imposs_cons = case scrut of Var v -> otherCons (idUnfolding v) _ -> [] - - impossible_alt :: CoreAlt -> Bool - impossible_alt (con, _, _) | con `elem` imposs_cons = True - impossible_alt (DataAlt con, _, _) = dataConCannotMatch inst_tys con - impossible_alt _ = False - - -prepareDefault :: OutId -- Case binder; need just for its type. Note that as an - -- OutId, it has maximum information; this is important. - -- Test simpl013 is an example - -> Maybe (TyCon, [Type]) -- Type of scrutinee, decomposed - -> [AltCon] -- These cons can't happen when matching the default - -> Maybe InExpr -- Rhs - -> SimplM [InAlt] -- Still unsimplified - -- We use a list because it's what mergeAlts expects, - ---------- Fill in known constructor ----------- -prepareDefault case_bndr (Just (tycon, inst_tys)) imposs_cons (Just deflt_rhs) - | -- This branch handles the case where we are - -- scrutinisng an algebraic data type - isAlgTyCon tycon -- It's a data type, tuple, or unboxed tuples. - , not (isNewTyCon tycon) -- We can have a newtype, if we are just doing an eval: - -- case x of { DEFAULT -> e } - -- and we don't want to fill in a default for them! - , Just all_cons <- tyConDataCons_maybe tycon - , not (null all_cons) - -- This is a tricky corner case. If the data type has no constructors, - -- which GHC allows, then the case expression will have at most a default - -- alternative. We don't want to eliminate that alternative, because the - -- invariant is that there's always one alternative. It's more convenient - -- to leave - -- case x of { DEFAULT -> e } - -- as it is, rather than transform it to - -- error "case cant match" - -- which would be quite legitmate. But it's a really obscure corner, and - -- not worth wasting code on. - , let imposs_data_cons = [con | DataAlt con <- imposs_cons] -- We now know it's a data type - impossible con = con `elem` imposs_data_cons || dataConCannotMatch inst_tys con - = case filterOut impossible all_cons of - [] -> return [] -- Eliminate the default alternative - -- altogether if it can't match - - [con] -> -- It matches exactly one constructor, so fill it in - do { tick (FillInCaseDefault case_bndr) - ; us <- getUniquesM - ; let (ex_tvs, arg_ids) = dataConRepInstPat us con inst_tys - ; return [(DataAlt con, ex_tvs ++ arg_ids, deflt_rhs)] } - - _ -> return [(DEFAULT, [], deflt_rhs)] - - | debugIsOn, isAlgTyCon tycon - , null (tyConDataCons tycon) - , not (isFamilyTyCon tycon || isAbstractTyCon tycon) - -- Check for no data constructors - -- This can legitimately happen for abstract types and type families, - -- so don't report that - = pprTrace "prepareDefault" (ppr case_bndr <+> ppr tycon) - $ return [(DEFAULT, [], deflt_rhs)] - ---------- Catch-all cases ----------- -prepareDefault _case_bndr _bndr_ty _imposs_cons (Just deflt_rhs) - = return [(DEFAULT, [], deflt_rhs)] - -prepareDefault _case_bndr _bndr_ty _imposs_cons Nothing - = return [] -- No default branch \end{code} diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs index b8c8160972..ab195e87b1 100644 --- a/compiler/simplCore/Simplify.lhs +++ b/compiler/simplCore/Simplify.lhs @@ -1958,6 +1958,8 @@ simplAlts env scrut case_bndr alts cont' case_bndr case_bndr1 alts ; (imposs_deflt_cons, in_alts) <- prepareAlts scrut' case_bndr' alts + -- NB: it's possible that the returned in_alts is empty: this is handled + -- by the caller (rebuildCase) in the missingAlt function ; let mb_var_scrut = case scrut' of { Var v -> Just v; _ -> Nothing } ; alts' <- mapM (simplAlt alt_env' mb_var_scrut diff --git a/compiler/stgSyn/StgLint.lhs b/compiler/stgSyn/StgLint.lhs index 9ccdfc32ed..ec09c4d9a7 100644 --- a/compiler/stgSyn/StgLint.lhs +++ b/compiler/stgSyn/StgLint.lhs @@ -4,13 +4,6 @@ \section[StgLint]{A ``lint'' pass to check for Stg correctness} \begin{code} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module StgLint ( lintStgBindings ) where import StgSyn diff --git a/compiler/typecheck/TcCanonical.lhs b/compiler/typecheck/TcCanonical.lhs index 76b6626223..7625438c41 100644 --- a/compiler/typecheck/TcCanonical.lhs +++ b/compiler/typecheck/TcCanonical.lhs @@ -631,6 +631,8 @@ flatten d ctxt ty = do { (xi, co) <- flatten d ctxt ty' ; return (xi,co) } +flatten _ _ xi@(LitTy {}) = return (xi, mkTcReflCo xi) + flatten d ctxt (TyVarTy tv) = flattenTyVar d ctxt tv @@ -734,6 +736,7 @@ flatten d ctxt ty@(ForAllTy {}) where under_families tvs rho = go (mkVarSet tvs) rho where go _bound (TyVarTy _tv) = False + go _ (LitTy {}) = False go bound (TyConApp tc tys) | isSynFamilyTyCon tc , (args,rest) <- splitAt (tyConArity tc) tys @@ -1711,6 +1714,8 @@ expandAway tv ty@(ForAllTy {}) expandAway tv ty@(TyConApp tc tys) = (mkTyConApp tc <$> mapM (expandAway tv) tys) <|> (tcView ty >>= expandAway tv) +expandAway _ xi@(LitTy {}) = return xi + \end{code} Note [Type synonyms and canonicalization] diff --git a/compiler/typecheck/TcClassDcl.lhs b/compiler/typecheck/TcClassDcl.lhs index f2f6059cee..b9711576c4 100644 --- a/compiler/typecheck/TcClassDcl.lhs +++ b/compiler/typecheck/TcClassDcl.lhs @@ -404,18 +404,7 @@ tcAddDeclCtxt :: TyClDecl Name -> TcM a -> TcM a tcAddDeclCtxt decl thing_inside = addErrCtxt ctxt thing_inside where - thing | isClassDecl decl = "class" - | isTypeDecl decl = "type synonym" ++ maybeInst - | isDataDecl decl = if tcdND decl == NewType - then "newtype" ++ maybeInst - else "data type" ++ maybeInst - | isFamilyDecl decl = "family" - | otherwise = panic "tcAddDeclCtxt/thing" - - maybeInst | isFamInstDecl decl = " instance" - | otherwise = "" - - ctxt = hsep [ptext (sLit "In the"), text thing, + ctxt = hsep [ptext (sLit "In the"), pprTyClDeclFlavour decl, ptext (sLit "declaration for"), quotes (ppr (tcdName decl))] badMethodErr :: Outputable a => a -> Name -> SDoc diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index e8691a4996..572b2a2dc4 100644 --- a/compiler/typecheck/TcDeriv.lhs +++ b/compiler/typecheck/TcDeriv.lhs @@ -23,7 +23,7 @@ import DynFlags import TcRnMonad import FamInst import TcEnv -import TcTyClsDecls( tcFamTyPats ) +import TcTyClsDecls( tcFamTyPats, tcAddFamInstCtxt ) import TcClassDcl( tcAddDeclCtxt ) -- Small helper import TcGenDeriv -- Deriv stuff import TcGenGenerics @@ -447,27 +447,58 @@ makeDerivSpecs :: Bool -> [LDerivDecl Name] -> TcM [EarlyDerivSpec] makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls - | is_boot -- No 'deriving' at all in hs-boot files - = do { mapM_ add_deriv_err deriv_locs - ; return [] } - | otherwise - = do { eqns1 <- mapAndRecoverM deriveTyData all_tydata - ; eqns2 <- mapAndRecoverM deriveStandalone deriv_decls - ; return (eqns1 ++ eqns2) } + = do { eqns1 <- concatMapM (recoverM (return []) . deriveTyDecl) tycl_decls + ; eqns2 <- concatMapM (recoverM (return []) . deriveInstDecl) inst_decls + ; eqns3 <- mapAndRecoverM deriveStandalone deriv_decls + ; let eqns = eqns1 ++ eqns2 ++ eqns3 + ; if is_boot then -- No 'deriving' at all in hs-boot files + do { unless (null eqns) (add_deriv_err (head eqns)) + ; return [] } + else return eqns } where - extractTyDataPreds decls - = [(p, d) | d@(L _ (TyData {tcdDerivs = Just preds})) <- decls, p <- preds] + add_deriv_err eqn + = setSrcSpan loc $ + addErr (hang (ptext (sLit "Deriving not permitted in hs-boot file")) + 2 (ptext (sLit "Use an instance declaration instead"))) + where + loc = case eqn of { Left ds -> ds_loc ds; Right ds -> ds_loc ds } - all_tydata :: [(LHsType Name, LTyClDecl Name)] - -- Derived predicate paired with its data type declaration - all_tydata = extractTyDataPreds (instDeclFamInsts inst_decls ++ tycl_decls) +------------------------------------------------------------------ +deriveTyDecl :: LTyClDecl Name -> TcM [EarlyDerivSpec] +deriveTyDecl (L _ decl@(TyDecl { tcdLName = L _ tc_name + , tcdTyDefn = TyData { td_derivs = Just preds } })) + = tcAddDeclCtxt decl $ + do { tc <- tcLookupTyCon tc_name + ; let tvs = tyConTyVars tc + tys = mkTyVarTys tvs + ; mapM (deriveTyData tvs tc tys) preds } - deriv_locs = map (getLoc . snd) all_tydata - ++ map getLoc deriv_decls +deriveTyDecl _ = return [] - add_deriv_err loc = setSrcSpan loc $ - addErr (hang (ptext (sLit "Deriving not permitted in hs-boot file")) - 2 (ptext (sLit "Use an instance declaration instead"))) +------------------------------------------------------------------ +deriveInstDecl :: LInstDecl Name -> TcM [EarlyDerivSpec] +deriveInstDecl (L _ (FamInstD fam_inst)) + = deriveFamInst fam_inst +deriveInstDecl (L _ (ClsInstD { cid_fam_insts = fam_insts })) + = concatMapM (deriveFamInst . unLoc) fam_insts + +------------------------------------------------------------------ +deriveFamInst :: FamInstDecl Name -> TcM [EarlyDerivSpec] +deriveFamInst decl@(FamInstDecl { fid_tycon = L _ tc_name, fid_pats = pats + , fid_defn = TyData { td_derivs = Just preds } }) + = tcAddFamInstCtxt decl $ + do { fam_tc <- tcLookupTyCon tc_name + ; tcFamTyPats fam_tc pats (\_ -> return ()) $ \ tvs' pats' _ -> + mapM (deriveTyData tvs' fam_tc pats') preds } + -- Tiresomely we must figure out the "lhs", which is awkward for type families + -- E.g. data T a b = .. deriving( Eq ) + -- Here, the lhs is (T a b) + -- data instance TF Int b = ... deriving( Eq ) + -- Here, the lhs is (TF Int b) + -- But if we just look up the tycon_name, we get is the *family* + -- tycon, but not pattern types -- they are in the *rep* tycon. + +deriveFamInst _ = return [] ------------------------------------------------------------------ deriveStandalone :: LDerivDecl Name -> TcM EarlyDerivSpec @@ -496,16 +527,14 @@ deriveStandalone (L loc (DerivDecl deriv_ty)) (Just theta) } ------------------------------------------------------------------ -deriveTyData :: (LHsType Name, LTyClDecl Name) -> TcM EarlyDerivSpec +deriveTyData :: [TyVar] -> TyCon -> [Type] + -> LHsType Name -- The deriving predicate + -> TcM EarlyDerivSpec -- The deriving clause of a data or newtype declaration -deriveTyData (L loc deriv_pred, L _ decl@(TyData { tcdLName = L _ tycon_name, - tcdTyVars = hs_tvs, - tcdTyPats = ty_pats })) +deriveTyData tvs tc tc_args (L loc deriv_pred) = setSrcSpan loc $ -- Use the location of the 'deriving' item - tcAddDeclCtxt decl $ - do { (tvs, tc, tc_args) <- get_lhs ty_pats - ; tcExtendTyVarEnv tvs $ -- Deriving preds may (now) mention - -- the type variables for the type constructor + tcExtendTyVarEnv tvs $ -- Deriving preds may (now) mention + -- the type variables for the type constructor do { (deriv_tvs, cls, cls_tys) <- tcHsDeriv deriv_pred -- The "deriv_pred" is a LHsType to take account of the fact that for @@ -525,7 +554,8 @@ deriveTyData (L loc deriv_pred, L _ decl@(TyData { tcdLName = L _ tycon_name, univ_tvs = (mkVarSet tvs `extendVarSetList` deriv_tvs) `minusVarSet` dropped_tvs - ; traceTc "derivTyData" (pprTvBndrs tvs $$ ppr tc $$ ppr tc_args $$ pprTvBndrs (varSetElems $ tyVarsOfTypes tc_args) $$ ppr inst_ty) + ; traceTc "derivTyData" (pprTvBndrs tvs $$ ppr tc $$ ppr tc_args $$ + pprTvBndrs (varSetElems $ tyVarsOfTypes tc_args) $$ ppr inst_ty) -- Check that the result really is well-kinded ; checkTc (n_args_to_keep >= 0 && (inst_ty_kind `eqKind` kind)) @@ -547,25 +577,7 @@ deriveTyData (L loc deriv_pred, L _ decl@(TyData { tcdLName = L _ tycon_name, ; checkTc (not (isFamilyTyCon tc) || n_args_to_drop == 0) (typeFamilyPapErr tc cls cls_tys inst_ty) - ; mkEqnHelp DerivOrigin (varSetElemsKvsFirst univ_tvs) cls cls_tys inst_ty Nothing } } - where - -- Tiresomely we must figure out the "lhs", which is awkward for type families - -- E.g. data T a b = .. deriving( Eq ) - -- Here, the lhs is (T a b) - -- data instance TF Int b = ... deriving( Eq ) - -- Here, the lhs is (TF Int b) - -- But if we just look up the tycon_name, we get is the *family* - -- tycon, but not pattern types -- they are in the *rep* tycon. - get_lhs Nothing = do { tc <- tcLookupTyCon tycon_name - ; let tvs = tyConTyVars tc - ; return (tvs, tc, mkTyVarTys tvs) } - get_lhs (Just pats) = do { fam_tc <- tcLookupTyCon tycon_name - ; tcFamTyPats fam_tc hs_tvs pats (\_ -> return ()) $ - \ tvs' pats' _ -> - return (tvs', fam_tc, pats') } - -deriveTyData _other - = panic "derivTyData" -- Caller ensures that only TyData can happen + ; mkEqnHelp DerivOrigin (varSetElemsKvsFirst univ_tvs) cls cls_tys inst_ty Nothing } \end{code} Note [Deriving, type families, and partial applications] diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs index d97a0884f9..604db4de47 100644 --- a/compiler/typecheck/TcEnv.lhs +++ b/compiler/typecheck/TcEnv.lhs @@ -20,7 +20,7 @@ module TcEnv( tcLookupLocatedClass, tcLookupInstance, tcLookupAxiom, -- Local environment - tcExtendKindEnv, tcExtendKindEnvTvs, tcExtendTcTyThingEnv, + tcExtendKindEnv, tcExtendTcTyThingEnv, tcExtendTyVarEnv, tcExtendTyVarEnv2, tcExtendGhciEnv, tcExtendLetEnv, tcExtendIdEnv, tcExtendIdEnv1, tcExtendIdEnv2, @@ -340,11 +340,6 @@ tcExtendKindEnv things thing_inside upd lcl_env = lcl_env { tcl_env = extend (tcl_env lcl_env) } extend env = extendNameEnvList env [(n, AThing k) | (n,k) <- things] -tcExtendKindEnvTvs :: [LHsTyVarBndr Name] -> ([LHsTyVarBndr Name] -> TcM r) -> TcM r -tcExtendKindEnvTvs bndrs thing_inside - = tcExtendKindEnv (map (hsTyVarNameKind . unLoc) bndrs) - (thing_inside bndrs) - ----------------------- -- Scoped type and kind variables tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r diff --git a/compiler/typecheck/TcErrors.lhs b/compiler/typecheck/TcErrors.lhs index e8dc9bcdff..abcdfbaae2 100644 --- a/compiler/typecheck/TcErrors.lhs +++ b/compiler/typecheck/TcErrors.lhs @@ -875,6 +875,7 @@ quickFlattenTy :: TcType -> TcM TcType quickFlattenTy ty | Just ty' <- tcView ty = quickFlattenTy ty' quickFlattenTy ty@(TyVarTy {}) = return ty quickFlattenTy ty@(ForAllTy {}) = return ty -- See +quickFlattenTy ty@(LitTy {}) = return ty -- Don't flatten because of the danger or removing a bound variable quickFlattenTy (AppTy ty1 ty2) = do { fy1 <- quickFlattenTy ty1 ; fy2 <- quickFlattenTy ty2 diff --git a/compiler/typecheck/TcEvidence.lhs b/compiler/typecheck/TcEvidence.lhs index 491cf8cb80..571643c9f8 100644 --- a/compiler/typecheck/TcEvidence.lhs +++ b/compiler/typecheck/TcEvidence.lhs @@ -17,6 +17,7 @@ module TcEvidence ( EvBind(..), emptyTcEvBinds, isEmptyTcEvBinds, EvTerm(..), mkEvCast, evVarsOfTerm, mkEvKindCast, + EvLit(..), -- TcCoercion TcCoercion(..), @@ -262,6 +263,7 @@ liftTcCoSubstWith tvs cos ty Nothing -> mkTcReflCo ty go (AppTy t1 t2) = mkTcAppCo (go t1) (go t2) go (TyConApp tc tys) = mkTcTyConAppCo tc (map go tys) + go ty@(LitTy {}) = mkTcReflCo ty
go (ForAllTy tv ty) = mkTcForAllCo tv (go ty) go (FunTy t1 t2) = mkTcFunCo (go t1) (go t2) \end{code} @@ -470,8 +472,18 @@ data EvTerm -- selector Id. We count up from _0_ | EvKindCast EvVar TcCoercion -- See Note [EvKindCast] - + + | EvLit EvLit -- The dictionary for class "NatI" + -- Note [EvLit] + deriving( Data.Data, Data.Typeable) + + +data EvLit + = EvNum Integer + | EvStr FastString + deriving( Data.Data, Data.Typeable) + \end{code} Note [EvKindCast] @@ -505,6 +517,37 @@ Conclusion: a new wanted coercion variable should be made mutable. from super classes will be "given" and hence rigid] +Note [EvLit] +~~~~~~~~~~~~ +A part of the type-level naturals implementation is the class "NatI", +which provides a "smart" constructor for defining singleton values. + +newtype TNat (n :: Nat) = TNat Integer + +class NatI n where + tNat :: TNat n + +Conceptually, this class has infinitely many instances: + +instance NatI 0 where natS = TNat 0 +instance NatI 1 where natS = TNat 1 +instance NatI 2 where natS = TNat 2 +... + +In practice, we solve "NatI" predicates in the type-checker because we can't +have infinately many instances. The evidence (aka "dictionary") +for "NatI n" is of the form "EvLit (EvNum n)". + +We make the following assumptions about dictionaries in GHC: + 1. The "dictionary" for classes with a single method---like NatI---is + a newtype for the type of the method, so using a evidence amounts + to a coercion, and + 2. Newtypes use the same representation as their definition types. + +So, the evidence for "NatI" is just an integer wrapped in 2 newtypes: +one to make it into a "TNat" value, and another to make it into "NatI" evidence. + + \begin{code} mkEvCast :: EvVar -> TcCoercion -> EvTerm mkEvCast ev lco @@ -534,6 +577,7 @@ evVarsOfTerm (EvCast v co) = v : varSetElems (coVarsOfTcCo co) evVarsOfTerm (EvTupleMk evs) = evs evVarsOfTerm (EvDelayedError _ _) = [] evVarsOfTerm (EvKindCast v co) = v : varSetElems (coVarsOfTcCo co) +evVarsOfTerm (EvLit _) = [] \end{code} @@ -593,7 +637,12 @@ instance Outputable EvTerm where ppr (EvTupleMk vs) = ptext (sLit "tupmk") <+> ppr vs ppr (EvSuperClass d n) = ptext (sLit "sc") <> parens (ppr (d,n)) ppr (EvDFunApp df tys ts) = ppr df <+> sep [ char '@' <> ppr tys, ppr ts ] + ppr (EvLit l) = ppr l ppr (EvDelayedError ty msg) = ptext (sLit "error") <+> sep [ char '@' <> ppr ty, ppr msg ] + +instance Outputable EvLit where + ppr (EvNum n) = integer n + ppr (EvStr s) = text (show s) \end{code} diff --git a/compiler/typecheck/TcForeign.lhs b/compiler/typecheck/TcForeign.lhs index ab850399c8..7bda323f5b 100644 --- a/compiler/typecheck/TcForeign.lhs +++ b/compiler/typecheck/TcForeign.lhs @@ -48,8 +48,6 @@ import Platform import SrcLoc import Bag import FastString - -import Control.Monad \end{code} \begin{code} @@ -157,8 +155,8 @@ normaliseFfiType' env ty0 = go [] ty0 = do (coi,nty1) <- go rec_nts ty1 return (mkForAllCo tyvar coi, ForAllTy tyvar nty1) - go _ ty@(TyVarTy _) - = return (Refl ty, ty) + go _ ty@(TyVarTy {}) = return (Refl ty, ty) + go _ ty@(LitTy {}) = return (Refl ty, ty) add_co co rec_nts ty = do (co', ty') <- go rec_nts ty @@ -210,14 +208,14 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport _ _ _ (CLabel _)) ; return idecl } -- NB check res_ty not sig_ty! -- In case sig_ty is (forall a. ForeignPtr a) -tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv _ _ CWrapper) = do +tcCheckFIType sig_ty arg_tys res_ty (CImport cconv safety mh CWrapper) = do -- Foreign wrapper (former f.e.d.) -- The type must be of the form ft -> IO (FunPtr ft), where ft is a -- valid foreign type. For legacy reasons ft -> IO (Ptr ft) as well -- as ft -> IO Addr is accepted, too. The use of the latter two forms -- is DEPRECATED, though. checkCg checkCOrAsmOrLlvmOrInterp - checkCConv cconv + cconv' <- checkCConv cconv case arg_tys of [arg1_ty] -> do checkForeignArgs isFFIExternalTy arg1_tys checkForeignRes nonIOok checkSafe isFFIExportResultTy res1_ty @@ -226,23 +224,22 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv _ _ CWrapper) = do where (arg1_tys, res1_ty) = tcSplitFunTys arg1_ty _ -> addErrTc (illegalForeignTyErr empty sig_ty) - return idecl + return (CImport cconv' safety mh CWrapper) -tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ (CFunction target)) +tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety mh (CFunction target)) | isDynamicTarget target = do -- Foreign import dynamic checkCg checkCOrAsmOrLlvmOrInterp - checkCConv cconv + cconv' <- checkCConv cconv case arg_tys of -- The first arg must be Ptr, FunPtr, or Addr [] -> do check False (illegalForeignTyErr empty sig_ty) - return idecl (arg1_ty:arg_tys) -> do dflags <- getDynFlags check (isFFIDynArgumentTy arg1_ty) (illegalForeignTyErr argument arg1_ty) checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys checkForeignRes nonIOok checkSafe (isFFIImportResultTy dflags) res_ty - return idecl + return $ CImport cconv' safety mh (CFunction target) | cconv == PrimCallConv = do dflags <- getDynFlags check (xopt Opt_GHCForeignImportPrim dflags) @@ -257,7 +254,7 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ (CFunction tar return idecl | otherwise = do -- Normal foreign import checkCg checkCOrAsmOrLlvmOrDotNetOrInterp - checkCConv cconv + cconv' <- checkCConv cconv checkCTarget target dflags <- getDynFlags checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys @@ -268,7 +265,7 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ (CFunction tar | not (null arg_tys) -> addErrTc (text "`value' imports cannot have function types") _ -> return () - return idecl + return $ CImport cconv' safety mh (CFunction target) -- This makes a convenient place to check @@ -315,7 +312,7 @@ tcFExport fo@(ForeignExport (L loc nm) hs_ty _ spec) (norm_co, norm_sig_ty) <- normaliseFfiType sig_ty - tcCheckFEType norm_sig_ty spec + spec' <- tcCheckFEType norm_sig_ty spec -- we're exporting a function, but at a type possibly more -- constrained than its declared/inferred type. Hence the need @@ -327,20 +324,21 @@ tcFExport fo@(ForeignExport (L loc nm) hs_ty _ spec) -- is *stable* (i.e. the compiler won't change it later), -- because this name will be referred to by the C code stub. id <- mkStableIdFromName nm sig_ty loc mkForeignExportOcc - return (mkVarBind id rhs, ForeignExport (L loc id) undefined norm_co spec) + return (mkVarBind id rhs, ForeignExport (L loc id) undefined norm_co spec') tcFExport d = pprPanic "tcFExport" (ppr d) \end{code} ------------ Checking argument types for foreign export ---------------------- \begin{code} -tcCheckFEType :: Type -> ForeignExport -> TcM () +tcCheckFEType :: Type -> ForeignExport -> TcM ForeignExport tcCheckFEType sig_ty (CExport (CExportStatic str cconv)) = do checkCg checkCOrAsmOrLlvm check (isCLabelString str) (badCName str) - checkCConv cconv + cconv' <- checkCConv cconv checkForeignArgs isFFIExternalTy arg_tys checkForeignRes nonIOok noCheckSafe isFFIExportResultTy res_ty + return (CExport (CExportStatic str cconv')) where -- Drop the foralls before inspecting n -- the structure of the foreign type. @@ -449,15 +447,18 @@ checkCg check = do Calling conventions \begin{code} -checkCConv :: CCallConv -> TcM () -checkCConv CCallConv = return () -checkCConv CApiConv = return () +checkCConv :: CCallConv -> TcM CCallConv +checkCConv CCallConv = return CCallConv +checkCConv CApiConv = return CApiConv checkCConv StdCallConv = do dflags <- getDynFlags let platform = targetPlatform dflags - unless (platformArch platform == ArchX86) $ - -- This is a warning, not an error. see #3336 - addWarnTc (text "the 'stdcall' calling convention is unsupported on this platform," $$ text "treating as ccall") -checkCConv PrimCallConv = addErrTc (text "The `prim' calling convention can only be used with `foreign import'") + if platformArch platform == ArchX86 + then return StdCallConv + else do -- This is a warning, not an error. see #3336 + addWarnTc (text "the 'stdcall' calling convention is unsupported on this platform," $$ text "treating as ccall") + return CCallConv +checkCConv PrimCallConv = do addErrTc (text "The `prim' calling convention can only be used with `foreign import'") + return PrimCallConv checkCConv CmmCallConv = panic "checkCConv CmmCallConv" \end{code} diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs index b514dc1adc..75dedd0622 100644 --- a/compiler/typecheck/TcHsSyn.lhs +++ b/compiler/typecheck/TcHsSyn.lhs @@ -1109,6 +1109,7 @@ zonkEvTerm env (EvKindCast v co) = ASSERT( isId v) zonkEvTerm env (EvTupleSel v n) = return (EvTupleSel (zonkIdOcc env v) n) zonkEvTerm env (EvTupleMk vs) = return (EvTupleMk (map (zonkIdOcc env) vs)) +zonkEvTerm _ (EvLit l) = return (EvLit l) zonkEvTerm env (EvSuperClass d n) = return (EvSuperClass (zonkIdOcc env d) n) zonkEvTerm env (EvDFunApp df tys tms) = do { tys' <- zonkTcTypeToTypes env tys diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs index 276d6957da..c29f1a4bc3 100644 --- a/compiler/typecheck/TcHsType.lhs +++ b/compiler/typecheck/TcHsType.lhs @@ -461,6 +461,13 @@ tc_hs_type ty@(HsSpliceTy {}) _exp_kind tc_hs_type (HsWrapTy {}) _exp_kind = panic "tc_hs_type HsWrapTy" -- We kind checked something twice +tc_hs_type hs_ty@(HsTyLit tl) exp_kind = do + let (ty,k) = case tl of + HsNumTy n -> (mkNumLitTy n, typeNatKind) + HsStrTy s -> (mkStrLitTy s, typeStringKind) + checkExpectedKind hs_ty k exp_kind + return ty + --------------------------- tc_tuple :: HsType Name -> HsTupleSort -> [LHsType Name] -> ExpKind -> TcM TcType -- Invariant: tup_sort is not HsBoxedOrConstraintTuple @@ -785,7 +792,7 @@ bindScopedKindVars hs_tvs thing_inside where kvs :: [KindVar] -- All skolems kvs = [ mkKindSigVar kv - | L _ (KindedTyVar _ (HsBSig _ kvs) _) <- hs_tvs + | L _ (KindedTyVar _ (HsBSig _ kvs)) <- hs_tvs , kv <- kvs ] tcHsTyVarBndrs :: [LHsTyVarBndr Name] @@ -818,7 +825,7 @@ tcHsTyVarBndr (L _ hs_tv) _ -> do { kind <- case hs_tv of UserTyVar {} -> newMetaKindVar - KindedTyVar _ (HsBSig kind _) _ -> tcLHsKind kind + KindedTyVar _ (HsBSig kind _) -> tcLHsKind kind ; return (mkTyVar name kind) } } } ------------------ @@ -908,7 +915,7 @@ kcLookupKind nm _ -> pprPanic "kcLookupKind" (ppr tc_ty_thing) } kcTyClTyVars :: Name -> [LHsTyVarBndr Name] -> (TcKind -> TcM a) -> TcM a --- Used for the type varaibles of a type or class decl, +-- Used for the type variables of a type or class decl, -- when doing the initial kind-check. kcTyClTyVars name hs_tvs thing_inside = bindScopedKindVars hs_tvs $ @@ -920,10 +927,10 @@ kcTyClTyVars name hs_tvs thing_inside ; tcExtendKindEnv name_ks (thing_inside res_k) } where kc_tv :: LHsTyVarBndr Name -> Kind -> TcM (Name, Kind) - kc_tv (L _ (UserTyVar n _)) exp_k + kc_tv (L _ (UserTyVar n)) exp_k = do { check_in_scope n exp_k ; return (n, exp_k) } - kc_tv (L _ (KindedTyVar n (HsBSig hs_k _) _)) exp_k + kc_tv (L _ (KindedTyVar n (HsBSig hs_k _))) exp_k = do { k <- tcLHsKind hs_k ; _ <- unifyKind k exp_k ; check_in_scope n exp_k diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index 229fed36b6..64b839c83f 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -443,13 +443,14 @@ tcLocalInstDecl1 :: LInstDecl Name -- Type-check all the stuff before the "where" -- -- We check for respectable instance type, and context -tcLocalInstDecl1 (L loc (FamInstDecl decl)) +tcLocalInstDecl1 (L loc (FamInstD decl)) = setSrcSpan loc $ - tcAddDeclCtxt decl $ + tcAddFamInstCtxt decl $ do { fam_inst <- tcFamInstDecl TopLevel decl ; return ([], [fam_inst]) } -tcLocalInstDecl1 (L loc (ClsInstDecl poly_ty binds uprags ats)) +tcLocalInstDecl1 (L loc (ClsInstD { cid_poly_ty = poly_ty, cid_binds = binds + , cid_sigs = uprags, cid_fam_insts = ats })) = setSrcSpan loc $ addErrCtxt (instDeclCtxt1 poly_ty) $ @@ -468,7 +469,7 @@ tcLocalInstDecl1 (L loc (ClsInstDecl poly_ty binds uprags ats)) -- Check for missing associated types and build them -- from their defaults (if available) - ; let defined_ats = mkNameSet $ map (tcdName . unLoc) ats + ; let defined_ats = mkNameSet $ map famInstDeclName ats mk_deflt_at_instances :: ClassATItem -> TcM [FamInst] mk_deflt_at_instances (fam_tc, defs) @@ -522,12 +523,12 @@ lot of kinding and type checking code with ordinary algebraic data types (and GADTs). \begin{code} -tcFamInstDecl :: TopLevelFlag -> TyClDecl Name -> TcM FamInst +tcFamInstDecl :: TopLevelFlag -> FamInstDecl Name -> TcM FamInst tcFamInstDecl top_lvl decl = do { -- Type family instances require -XTypeFamilies -- and can't (currently) be in an hs-boot file ; traceTc "tcFamInstDecl" (ppr decl) - ; let fam_tc_lname = tcdLName decl + ; let fam_tc_lname = fid_tycon decl ; type_families <- xoptM Opt_TypeFamilies ; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file? ; checkTc type_families $ badFamInstDecl fam_tc_lname @@ -544,10 +545,11 @@ tcFamInstDecl top_lvl decl -- This is where type and data decls are treated separately ; tcFamInstDecl1 fam_tc decl } -tcFamInstDecl1 :: TyCon -> TyClDecl Name -> TcM FamInst +tcFamInstDecl1 :: TyCon -> FamInstDecl Name -> TcM FamInst -- "type instance" -tcFamInstDecl1 fam_tc (decl@TySynonym {}) +tcFamInstDecl1 fam_tc decl@(FamInstDecl { fid_tycon = fam_tc_name + , fid_defn = TySynonym {} }) = do { -- (1) do the work of verifying the synonym ; (t_tvs, t_typats, t_rhs) <- tcSynFamInstDecl fam_tc decl @@ -555,21 +557,22 @@ tcFamInstDecl1 fam_tc (decl@TySynonym {}) ; checkValidFamInst t_typats t_rhs -- (3) construct representation tycon - ; rep_tc_name <- newFamInstAxiomName (tcdLName decl) t_typats + ; rep_tc_name <- newFamInstAxiomName fam_tc_name t_typats ; return (mkSynFamInst rep_tc_name t_tvs fam_tc t_typats t_rhs) } -- "newtype instance" and "data instance" -tcFamInstDecl1 fam_tc (decl@TyData { tcdND = new_or_data, tcdCType = cType - , tcdCtxt = ctxt - , tcdTyVars = tvs, tcdTyPats = Just pats - , tcdCons = cons}) +tcFamInstDecl1 fam_tc + (FamInstDecl { fid_pats = pats + , fid_tycon = fam_tc_name + , fid_defn = defn@TyData { td_ND = new_or_data, td_cType = cType + , td_ctxt = ctxt, td_cons = cons } }) = do { -- Check that the family declaration is for the right kind checkTc (isFamilyTyCon fam_tc) (notFamily fam_tc) ; checkTc (isAlgTyCon fam_tc) (wrongKindOfFamily fam_tc) -- Kind check type patterns - ; tcFamTyPats fam_tc tvs pats (kcDataDecl decl) $ + ; tcFamTyPats fam_tc pats (kcTyDefn defn) $ \tvs' pats' res_kind -> do -- Check that left-hand side contains no type family applications @@ -581,10 +584,10 @@ tcFamInstDecl1 fam_tc (decl@TyData { tcdND = new_or_data, tcdCType = cType ; checkTc (isLiftedTypeKind res_kind) $ tooFewParmsErr (tyConArity fam_tc) ; stupid_theta <- tcHsContext ctxt - ; dataDeclChecks (tcdName decl) new_or_data stupid_theta cons + ; dataDeclChecks (tyConName fam_tc) new_or_data stupid_theta cons -- Construct representation tycon - ; rep_tc_name <- newFamInstTyConName (tcdLName decl) pats' + ; rep_tc_name <- newFamInstTyConName fam_tc_name pats' ; axiom_name <- newImplicitBinder rep_tc_name mkInstTyCoOcc ; let ex_ok = True -- Existentials ok for type families! orig_res_ty = mkTyConApp fam_tc pats' @@ -615,17 +618,15 @@ tcFamInstDecl1 fam_tc (decl@TyData { tcdND = new_or_data, tcdCType = cType L _ (ConDecl { con_res = ResTyGADT _ }) : _ -> False _ -> True -tcFamInstDecl1 _ d = pprPanic "tcFamInstDecl1" (ppr d) - ---------------- -tcAssocDecl :: Class -- ^ Class of associated type - -> VarEnv Type -- ^ Instantiation of class TyVars - -> LTyClDecl Name -- ^ RHS +tcAssocDecl :: Class -- ^ Class of associated type + -> VarEnv Type -- ^ Instantiation of class TyVars + -> LFamInstDecl Name -- ^ RHS -> TcM FamInst tcAssocDecl clas mini_env (L loc decl) = setSrcSpan loc $ - tcAddDeclCtxt decl $ + tcAddFamInstCtxt decl $ do { fam_inst <- tcFamInstDecl NotTopLevel decl ; let (fam_tc, at_tys) = famInstLHS fam_inst diff --git a/compiler/typecheck/TcInteract.lhs b/compiler/typecheck/TcInteract.lhs index 1c6760d18f..21479b670f 100644 --- a/compiler/typecheck/TcInteract.lhs +++ b/compiler/typecheck/TcInteract.lhs @@ -26,6 +26,7 @@ import Id import Var import TcType +import PrelNames (typeNatClassName, typeStringClassName) import Class import TyCon @@ -1982,6 +1983,15 @@ data LookupInstResult | GenInst [EvVar] EvTerm matchClassInst :: InertSet -> Class -> [Type] -> WantedLoc -> TcS LookupInstResult + +matchClassInst _ clas [ ty ] _ + | className clas == typeNatClassName + , Just n <- isNumLitTy ty = return $ GenInst [] $ EvLit $ EvNum n + + | className clas == typeStringClassName + , Just s <- isStrLitTy ty = return $ GenInst [] $ EvLit $ EvStr s + + matchClassInst inerts clas tys loc = do { let pred = mkClassPred clas tys ; mb_result <- matchClass clas tys diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs index 831e130143..82acc9e5d3 100644 --- a/compiler/typecheck/TcMType.lhs +++ b/compiler/typecheck/TcMType.lhs @@ -817,6 +817,8 @@ zonkType zonk_tc_tyvar ty go (TyConApp tc tys) = do tys' <- mapM go tys return (TyConApp tc tys') + go (LitTy n) = return (LitTy n) + go (FunTy arg res) = do arg' <- go arg res' <- go res return (FunTy arg' res') @@ -1075,6 +1077,8 @@ check_type rank ubx_tup ty@(TyConApp tc tys) arity_msg = arityErr "Type synonym" (tyConName tc) tc_arity n_args ubx_tup_msg = ubxArgTyErr ty +check_type _ _ (LitTy {}) = return () + check_type _ _ ty = pprPanic "check_type" (ppr ty) ---------------------------------------- @@ -1744,6 +1748,7 @@ fvType :: Type -> [TyVar] fvType ty | Just exp_ty <- tcView ty = fvType exp_ty fvType (TyVarTy tv) = [tv] fvType (TyConApp _ tys) = fvTypes tys +fvType (LitTy {}) = [] fvType (FunTy arg res) = fvType arg ++ fvType res fvType (AppTy fun arg) = fvType fun ++ fvType arg fvType (ForAllTy tyvar ty) = filter (/= tyvar) (fvType ty) @@ -1754,8 +1759,9 @@ fvTypes tys = concat (map fvType tys) sizeType :: Type -> Int -- Size of a type: the number of variables and constructors sizeType ty | Just exp_ty <- tcView ty = sizeType exp_ty -sizeType (TyVarTy _) = 1 +sizeType (TyVarTy {}) = 1 sizeType (TyConApp _ tys) = sizeTypes tys + 1 +sizeType (LitTy {}) = 1 sizeType (FunTy arg res) = sizeType arg + sizeType res + 1 sizeType (AppTy fun arg) = sizeType fun + sizeType arg sizeType (ForAllTy _ ty) = sizeType ty diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs index 30376288b2..1e68e4b4ea 100644 --- a/compiler/typecheck/TcSimplify.lhs +++ b/compiler/typecheck/TcSimplify.lhs @@ -958,6 +958,7 @@ floatEqualities skols can_given wantders | FlatSkol ty <- tcTyVarDetails tv = tvs_under_fsks ty | otherwise = unitVarSet tv tvs_under_fsks (TyConApp _ tys) = unionVarSets (map tvs_under_fsks tys) + tvs_under_fsks (LitTy {}) = emptyVarSet tvs_under_fsks (FunTy arg res) = tvs_under_fsks arg `unionVarSet` tvs_under_fsks res tvs_under_fsks (AppTy fun arg) = tvs_under_fsks fun `unionVarSet` tvs_under_fsks arg tvs_under_fsks (ForAllTy tv ty) -- The kind of a coercion binder @@ -1446,4 +1447,4 @@ newFlatWanteds orig theta ; return $ CNonCanonical { cc_flavor = Wanted loc v , cc_depth = 0 } } -\end{code}
\ No newline at end of file +\end{code} diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs index 63501e9c07..1ff9dc12e6 100644 --- a/compiler/typecheck/TcSplice.lhs +++ b/compiler/typecheck/TcSplice.lhs @@ -1303,6 +1303,7 @@ reifyFamilyInstance fi reifyType :: TypeRep.Type -> TcM TH.Type -- Monadic only because of failure reifyType ty@(ForAllTy _ _) = reify_for_all ty +reifyType (LitTy t) = do { r <- reifyTyLit t; return (TH.LitT r) } reifyType (TyVarTy tv) = return (TH.VarT (reifyName tv)) reifyType (TyConApp tc tys) = reify_tc_app tc tys -- Do not expand type synonyms here reifyType (AppTy t1 t2) = do { [r1,r2] <- reifyTypes [t1,t2] ; return (r1 `TH.AppT` r2) } @@ -1319,6 +1320,10 @@ reify_for_all ty where (tvs, cxt, tau) = tcSplitSigmaTy ty +reifyTyLit :: TypeRep.TyLit -> TcM TH.TyLit +reifyTyLit (NumTyLit n) = return (TH.NumTyLit n) +reifyTyLit (StrTyLit s) = return (TH.StrTyLit (unpackFS s)) + reifyTypes :: [Type] -> TcM [TH.Type] reifyTypes = mapM reifyType diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index c166e6210e..89a018dbe3 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -18,9 +18,9 @@ module TcTyClsDecls ( -- Functions used by TcInstDcls to check -- data/type family instance declarations - kcDataDecl, tcConDecls, dataDeclChecks, checkValidTyCon, + kcTyDefn, tcConDecls, dataDeclChecks, checkValidTyCon, tcSynFamInstDecl, tcFamTyPats, - wrongKindOfFamily, badATErr, wrongATArgErr + tcAddFamInstCtxt, wrongKindOfFamily, badATErr, wrongATArgErr ) where #include "HsVersions.h" @@ -309,30 +309,38 @@ getInitialKinds :: LTyClDecl Name -> TcM [(Name, TcTyThing)] -- -- ALSO for each datacon, return (dc, ANothing) -- See Note [ANothing] in TcRnTypes +-- +-- No family instances are passed to getInitialKinds getInitialKinds (L _ decl) - = do { arg_kinds <- mapM (\_ -> newMetaKindVar) (tyClDeclTyVars decl) + = do { arg_kinds <- mapM (\_ -> newMetaKindVar) (get_tvs decl) ; res_kind <- get_res_kind decl ; let main_pair = (tcdName decl, AThing (mkArrowKinds arg_kinds res_kind)) ; inner_pairs <- get_inner_kinds decl ; return (main_pair : inner_pairs) } where get_inner_kinds :: TyClDecl Name -> TcM [(Name,TcTyThing)] - get_inner_kinds (TyData { tcdCons = cons }) + get_inner_kinds (TyDecl { tcdTyDefn = TyData { td_cons = cons } }) = return [ (unLoc (con_name con), ANothing) | L _ con <- cons ] get_inner_kinds (ClassDecl { tcdATs = ats }) = concatMapM getInitialKinds ats get_inner_kinds _ = return [] - get_res_kind (ClassDecl {}) = return constraintKind - get_res_kind (TyData { tcdKindSig = Nothing }) = return liftedTypeKind - get_res_kind _ = newMetaKindVar + get_res_kind (ClassDecl {}) = return constraintKind + get_res_kind (TyDecl { tcdTyDefn = TyData { td_kindSig = Nothing } }) + = return liftedTypeKind + get_res_kind _ = newMetaKindVar -- Warning: you might be tempted to return * for all data decls -- but on GADT-style declarations we allow a kind signature -- data T :: *->* where { ... } - -- with *no tyClDeclTyVars* + -- with *no* tvs in the HsTyDefn + get_tvs (TyFamily {tcdTyVars = tvs}) = tvs + get_tvs (ClassDecl {tcdTyVars = tvs}) = tvs + get_tvs (TyDecl {tcdTyVars = tvs}) = tvs + get_tvs (ForeignType {}) = [] + ---------------- kcSynDecls :: [SCC (LTyClDecl Name)] -> TcM (TcLclEnv) -- Kind bindings kcSynDecls [] = getLclEnv @@ -349,12 +357,12 @@ kcSynDecl1 (CyclicSCC decls) = do { recSynErr decls; failM } -- of out-of-scope tycons kcSynDecl :: TyClDecl Name -> TcM (Name, TcKind) -kcSynDecl decl@(TySynonym { tcdTyVars = hs_tvs, tcdLName = L _ name - , tcdSynRhs = rhs }) +kcSynDecl decl@(TyDecl { tcdTyVars = hs_tvs, tcdLName = L _ name + , tcdTyDefn = TySynonym { td_synRhs = rhs } }) -- Vanilla type synonyoms only, not family instances -- Returns a possibly-unzonked kind = tcAddDeclCtxt decl $ - tcHsTyVarBndrs (tcdTyVars decl) $ \ k_tvs -> + tcHsTyVarBndrs hs_tvs $ \ k_tvs -> do { traceTc "kcd1" (ppr name <+> brackets (ppr hs_tvs) <+> brackets (ppr k_tvs)) ; (_, rhs_kind) <- tcLHsType rhs @@ -365,46 +373,46 @@ kcSynDecl decl = pprPanic "kcSynDecl" (ppr decl) ------------------------------------------------------------------------ kcLTyClDecl :: LTyClDecl Name -> TcM () + -- See Note [Kind checking for type and class decls] kcLTyClDecl (L loc decl) = setSrcSpan loc $ tcAddDeclCtxt decl $ kcTyClDecl decl kcTyClDecl :: TyClDecl Name -> TcM () -- This function is used solely for its side effect on kind variables -kcTyClDecl decl@(TyData { tcdLName = L _ name, tcdTyVars = hs_tvs }) - = ASSERT2( not . isFamInstDecl $ decl, ppr decl ) -- must not be a family instance - kcTyClTyVars name hs_tvs $ \ res_k -> kcDataDecl decl res_k +kcTyClDecl (TyDecl { tcdLName = L _ name, tcdTyVars = hs_tvs, tcdTyDefn = defn }) + = kcTyClTyVars name hs_tvs $ \ res_k -> kcTyDefn defn res_k kcTyClDecl (ClassDecl { tcdLName = L _ name, tcdTyVars = hs_tvs , tcdCtxt = ctxt, tcdSigs = sigs, tcdATs = ats}) = kcTyClTyVars name hs_tvs $ \ res_k -> do { _ <- tcHsContext ctxt ; _ <- unifyKind res_k constraintKind - ; mapM_ (wrapLocM kcFamilyDecl) ats - ; mapM_ (wrapLocM kc_sig) sigs } + ; mapM_ (wrapLocM kcTyClDecl) ats + ; mapM_ (wrapLocM kc_sig) sigs } where kc_sig (TypeSig _ op_ty) = discardResult (tcHsLiftedType op_ty) kc_sig (GenericSig _ op_ty) = discardResult (tcHsLiftedType op_ty) kc_sig _ = return () kcTyClDecl (ForeignType {}) = return () -kcTyClDecl decl@(TyFamily {}) = kcFamilyDecl decl -kcTyClDecl (TySynonym {}) -- Type synonyms are never passed to kcTyClDecl - = panic "kcTyClDecl TySynonym" -- See Note [Kind checking for type and class decls] +kcTyClDecl (TyFamily { tcdLName = L _ name, tcdTyVars = hs_tvs + , tcdKindSig = mb_kind}) + = kcTyClTyVars name hs_tvs $ \res_k -> kcResultKind mb_kind res_k ------------------- -- Kind check a data declaration, assuming that we already extended the -- kind environment with the type variables of the left-hand side (these -- kinded type variables are also passed as the second parameter). --- -kcDataDecl :: TyClDecl Name -> Kind -> TcM () -kcDataDecl (TyData { tcdND = new_or_data, tcdCtxt = ctxt - , tcdCons = cons, tcdKindSig = mb_kind }) res_k +kcTyDefn :: HsTyDefn Name -> Kind -> TcM () +kcTyDefn (TyData { td_ND = new_or_data, td_ctxt = ctxt + , td_cons = cons, td_kindSig = mb_kind }) res_k = do { _ <- tcHsContext ctxt ; mapM_ (wrapLocM (kcConDecl new_or_data)) cons ; kcResultKind mb_kind res_k } -kcDataDecl d _ = pprPanic "kcDataDecl" (ppr d) +kcTyDefn (TySynonym { td_synRhs = rhs_ty }) res_k + = discardResult (tcCheckLHsType rhs_ty res_k) ------------------- kcConDecl :: NewOrData -> ConDecl Name -> TcM () @@ -417,27 +425,15 @@ kcConDecl new_or_data (ConDecl { con_name = name, con_qvars = ex_tvs ; _ <- tcConRes res ; return () } -------------------- --- Kind check a family declaration or type family default declaration. --- -kcFamilyDecl :: TyClDecl Name -> TcM () -kcFamilyDecl (TyFamily { tcdLName = L _ name, tcdTyVars = hs_tvs - , tcdKindSig = mb_kind}) - = kcTyClTyVars name hs_tvs $ \res_k -> kcResultKind mb_kind res_k - -kcFamilyDecl (TySynonym {}) = return () - -- We don't have to do anything here for type family defaults: - -- tcClassATs will use tcAssocDecl to check them -kcFamilyDecl d = pprPanic "kcFamilyDecl" (ppr d) - ------------------ -kcResultKind :: Maybe (LHsKind Name) -> Kind -> TcM () +kcResultKind :: Maybe (HsBndrSig (LHsKind Name)) -> Kind -> TcM () kcResultKind Nothing res_k = discardResult (unifyKind res_k liftedTypeKind) -- type family F a -- defaults to type family F a :: * -kcResultKind (Just k) res_k - = do { k' <- tcLHsKind k +kcResultKind (Just (HsBSig k ns)) res_k + = do { let kvs = map mkKindSigVar ns + ; k' <- tcExtendTyVarEnv kvs (tcLHsKind k) ; discardResult (unifyKind k' res_k) } \end{code} @@ -502,7 +498,7 @@ tcTyClDecl calc_isrec (L loc decl) -- "type family" declarations tcTyClDecl1 :: TyConParent -> (Name -> RecFlag) -> TyClDecl Name -> TcM [TyThing] tcTyClDecl1 parent _calc_isrec - (TyFamily {tcdFlavour = TypeFamily, tcdLName = L _ tc_name, tcdTyVars = tvs}) + (TyFamily {tcdFlavour = TypeFamily, tcdLName = L _ tc_name, tcdTyVars = tvs}) = tcTyClTyVars tc_name tvs $ \ tvs' kind -> do { traceTc "type family:" (ppr tc_name) ; checkFamFlag tc_name @@ -522,60 +518,18 @@ tcTyClDecl1 parent _calc_isrec ; return [ATyCon tycon] } -- "type" synonym declaration -tcTyClDecl1 _parent _calc_isrec - (TySynonym {tcdLName = L _ tc_name, tcdTyVars = tvs, tcdSynRhs = hs_ty}) - = ASSERT( isNoParent _parent ) - tcTyClTyVars tc_name tvs $ \ tvs' kind -> do - { env <- getLclEnv - ; traceTc "tc-syn" (ppr tc_name $$ ppr (tcl_env env)) - ; rhs_ty <- tcCheckLHsType hs_ty kind - ; rhs_ty <- zonkTcTypeToType emptyZonkEnv rhs_ty - ; tycon <- buildSynTyCon tc_name tvs' (SynonymTyCon rhs_ty) - kind NoParentTyCon - ; return [ATyCon tycon] } - - -- "newtype" and "data" - -- NB: not used for newtype/data instances (whether associated or not) tcTyClDecl1 _parent calc_isrec - (TyData { tcdND = new_or_data, tcdCType = cType - , tcdCtxt = ctxt, tcdTyVars = tvs - , tcdLName = L _ tc_name, tcdKindSig = mb_ksig, tcdCons = cons }) + (TyDecl { tcdLName = L _ tc_name, tcdTyVars = tvs, tcdTyDefn = defn }) + = ASSERT( isNoParent _parent ) - tcTyClTyVars tc_name tvs $ \ tvs' kind -> do - { extra_tvs <- tcDataKindSig kind - ; let is_rec = calc_isrec tc_name - h98_syntax = consUseH98Syntax cons - final_tvs = tvs' ++ extra_tvs - ; stupid_theta <- tcHsContext ctxt - ; kind_signatures <- xoptM Opt_KindSignatures - ; existential_ok <- xoptM Opt_ExistentialQuantification - ; gadt_ok <- xoptM Opt_GADTs - ; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file? - ; let ex_ok = existential_ok || gadt_ok -- Data cons can have existential context - - -- Check that we don't use kind signatures without Glasgow extensions - ; checkTc (kind_signatures || isNothing mb_ksig) (badSigTyDecl tc_name) - - ; dataDeclChecks tc_name new_or_data stupid_theta cons - - ; tycon <- fixM $ \ tycon -> do - { let res_ty = mkTyConApp tycon (mkTyVarTys final_tvs) - ; data_cons <- tcConDecls new_or_data ex_ok tycon (final_tvs, res_ty) cons - ; tc_rhs <- - if null cons && is_boot -- In a hs-boot file, empty cons means - then return totallyAbstractTyConRhs -- "don't know"; hence totally Abstract - else case new_or_data of - DataType -> return (mkDataTyConRhs data_cons) - NewType -> ASSERT( not (null data_cons) ) - mkNewTyConRhs tc_name tycon (head data_cons) - ; return (buildAlgTyCon tc_name final_tvs cType stupid_theta tc_rhs - is_rec (not h98_syntax) NoParentTyCon) } - ; return [ATyCon tycon] } + tcTyClTyVars tc_name tvs $ \ tvs' kind -> + tcTyDefn calc_isrec tc_name tvs' kind defn tcTyClDecl1 _parent calc_isrec (ClassDecl { tcdLName = L _ class_name, tcdTyVars = tvs - , tcdCtxt = ctxt, tcdMeths = meths - , tcdFDs = fundeps, tcdSigs = sigs, tcdATs = ats, tcdATDefs = at_defs }) + , tcdCtxt = ctxt, tcdMeths = meths + , tcdFDs = fundeps, tcdSigs = sigs + , tcdATs = ats, tcdATDefs = at_defs }) = ASSERT( isNoParent _parent ) do { (tvs', ctxt', fds', sig_stuff, gen_dm_env) @@ -627,6 +581,55 @@ tcTyClDecl1 _ _ = return [ATyCon (mkForeignTyCon tc_name tc_ext_name liftedTypeKind 0)] \end{code} +\begin{code} +tcTyDefn :: (Name -> RecFlag) -> Name + -> [TyVar] -> Kind + -> HsTyDefn Name -> TcM [TyThing] + -- NB: not used for newtype/data instances (whether associated or not) +tcTyDefn _calc_isrec tc_name tvs kind (TySynonym { td_synRhs = hs_ty }) + = do { env <- getLclEnv + ; traceTc "tc-syn" (ppr tc_name $$ ppr (tcl_env env)) + ; rhs_ty <- tcCheckLHsType hs_ty kind + ; rhs_ty <- zonkTcTypeToType emptyZonkEnv rhs_ty + ; tycon <- buildSynTyCon tc_name tvs (SynonymTyCon rhs_ty) + kind NoParentTyCon + ; return [ATyCon tycon] } + +tcTyDefn calc_isrec tc_name tvs kind + (TyData { td_ND = new_or_data, td_cType = cType + , td_ctxt = ctxt, td_kindSig = mb_ksig + , td_cons = cons }) + = do { extra_tvs <- tcDataKindSig kind + ; let is_rec = calc_isrec tc_name + h98_syntax = consUseH98Syntax cons + final_tvs = tvs ++ extra_tvs + ; stupid_theta <- tcHsContext ctxt + ; kind_signatures <- xoptM Opt_KindSignatures + ; existential_ok <- xoptM Opt_ExistentialQuantification + ; gadt_ok <- xoptM Opt_GADTs + ; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file? + ; let ex_ok = existential_ok || gadt_ok -- Data cons can have existential context + + -- Check that we don't use kind signatures without Glasgow extensions + ; checkTc (kind_signatures || isNothing mb_ksig) (badSigTyDecl tc_name) + + ; dataDeclChecks tc_name new_or_data stupid_theta cons + + ; tycon <- fixM $ \ tycon -> do + { let res_ty = mkTyConApp tycon (mkTyVarTys final_tvs) + ; data_cons <- tcConDecls new_or_data ex_ok tycon (final_tvs, res_ty) cons + ; tc_rhs <- + if null cons && is_boot -- In a hs-boot file, empty cons means + then return totallyAbstractTyConRhs -- "don't know"; hence totally Abstract + else case new_or_data of + DataType -> return (mkDataTyConRhs data_cons) + NewType -> ASSERT( not (null data_cons) ) + mkNewTyConRhs tc_name tycon (head data_cons) + ; return (buildAlgTyCon tc_name final_tvs cType stupid_theta tc_rhs + is_rec (not h98_syntax) NoParentTyCon) } + ; return [ATyCon tycon] } +\end{code} + %************************************************************************ %* * Typechecking associated types (in class decls) @@ -654,21 +657,21 @@ Note that: tcClassATs :: Name -- The class name (not knot-tied) -> TyConParent -- The class parent of this associated type -> [LTyClDecl Name] -- Associated types. All FamTyCon - -> [LTyClDecl Name] -- Associated type defaults. All SynTyCon + -> [LFamInstDecl Name] -- Associated type defaults. All SynTyCon -> TcM [ClassATItem] tcClassATs class_name parent ats at_defs = do { -- Complain about associated type defaults for non associated-types sequence_ [ failWithTc (badATErr class_name n) - | n <- map (tcdName . unLoc) at_defs + | L _ n <- map (fid_tycon . unLoc) at_defs , not (n `elemNameSet` at_names) ] ; mapM tc_at ats } where at_names = mkNameSet (map (tcdName . unLoc) ats) - at_defs_map :: NameEnv [LTyClDecl Name] + at_defs_map :: NameEnv [LFamInstDecl Name] -- Maps an AT in 'ats' to a list of all its default defs in 'at_defs' at_defs_map = foldr (\at_def nenv -> extendNameEnv_C (++) nenv - (tcdName (unLoc at_def)) [at_def]) + (famInstDeclName at_def) [at_def]) emptyNameEnv at_defs tc_at at = do { [ATyCon fam_tc] <- addLocM (tcTyClDecl1 parent @@ -678,31 +681,27 @@ tcClassATs class_name parent ats at_defs ; atd <- mapM (tcDefaultAssocDecl fam_tc) at_defs ; return (fam_tc, atd) } - ------------------------- tcDefaultAssocDecl :: TyCon -- ^ Family TyCon - -> LTyClDecl Name -- ^ RHS + -> LFamInstDecl Name -- ^ RHS -> TcM ATDefault -- ^ Type checked RHS and free TyVars tcDefaultAssocDecl fam_tc (L loc decl) = setSrcSpan loc $ - tcAddDefaultAssocDeclCtxt (tcdName decl) $ + tcAddFamInstCtxt decl $ do { traceTc "tcDefaultAssocDecl" (ppr decl) ; (at_tvs, at_tys, at_rhs) <- tcSynFamInstDecl fam_tc decl ; return (ATD at_tvs at_tys at_rhs loc) } -- We check for well-formedness and validity later, in checkValidClass ------------------------- -tcSynFamInstDecl :: TyCon -> TyClDecl Name -> TcM ([TyVar], [Type], Type) +tcSynFamInstDecl :: TyCon -> FamInstDecl Name -> TcM ([TyVar], [Type], Type) -- Placed here because type family instances appear as -- default decls in class declarations -tcSynFamInstDecl fam_tc (TySynonym { tcdTyVars = tvs, tcdTyPats = Just pats - , tcdSynRhs = hs_ty }) +tcSynFamInstDecl fam_tc (FamInstDecl { fid_pats = pats, fid_defn = defn@(TySynonym hs_ty) }) = do { checkTc (isSynTyCon fam_tc) (wrongKindOfFamily fam_tc) - ; tcFamTyPats fam_tc tvs pats - (discardResult . tcCheckLHsType hs_ty) - $ \tvs' pats' res_kind -> do - { rhs_ty <- tcCheckLHsType hs_ty res_kind + ; tcFamTyPats fam_tc pats (kcTyDefn defn) $ \tvs' pats' res_kind -> + do { rhs_ty <- tcCheckLHsType hs_ty res_kind ; rhs_ty <- zonkTcTypeToType emptyZonkEnv rhs_ty ; traceTc "tcSynFamInstDecl" (ppr fam_tc <+> (ppr tvs' $$ ppr pats' $$ ppr rhs_ty)) ; return (tvs', pats', rhs_ty) } } @@ -719,7 +718,7 @@ tcSynFamInstDecl _ decl = pprPanic "tcSynFamInstDecl" (ppr decl) ----------------- tcFamTyPats :: TyCon - -> [LHsTyVarBndr Name] -> [LHsType Name] + -> HsBndrSig [LHsType Name] -- Patterns -> (TcKind -> TcM ()) -- Kind checker for RHS -- result is ignored -> ([TKVar] -> [TcType] -> Kind -> TcM a) @@ -735,7 +734,7 @@ tcFamTyPats :: TyCon -- In that case, the type variable 'a' will *already be in scope* -- (and, if C is poly-kinded, so will its kind parameter). -tcFamTyPats fam_tc tyvars arg_pats kind_checker thing_inside +tcFamTyPats fam_tc (HsBSig arg_pats tyvars) kind_checker thing_inside = do { -- A family instance must have exactly the same number of type -- parameters as the family declaration. You can't write -- type family F a :: * -> * @@ -754,7 +753,7 @@ tcFamTyPats fam_tc tyvars arg_pats kind_checker thing_inside -- Kind-check and quantify -- See Note [Quantifying over family patterns] - ; (tkvs, typats) <- tcHsTyVarBndrsGen tyvars $ do + ; (tkvs, typats) <- tcHsTyVarBndrsGen (map (noLoc . UserTyVar) tyvars) $ do { typats <- tcHsArgTys (quotes (ppr fam_tc)) arg_pats arg_kinds ; kind_checker res_kind ; return (tyVarsOfTypes typats, typats) } @@ -1635,6 +1634,14 @@ tcAddDefaultAssocDeclCtxt name thing_inside ctxt = hsep [ptext (sLit "In the type synonym instance default declaration for"), quotes (ppr name)] +tcAddFamInstCtxt :: FamInstDecl Name -> TcM a -> TcM a +tcAddFamInstCtxt (FamInstDecl { fid_tycon = tc, fid_defn = defn }) thing_inside + = addErrCtxt ctxt thing_inside + where + ctxt = hsep [ptext (sLit "In the") <+> pprTyDefnFlavour defn + <+> ptext (sLit "instance declaration for"), + quotes (ppr tc)] + resultTypeMisMatch :: Name -> DataCon -> DataCon -> SDoc resultTypeMisMatch field_name con1 con2 = vcat [sep [ptext (sLit "Constructors") <+> ppr con1 <+> ptext (sLit "and") <+> ppr con2, diff --git a/compiler/typecheck/TcTyDecls.lhs b/compiler/typecheck/TcTyDecls.lhs index 86dee6c400..e7acc3a9a2 100644 --- a/compiler/typecheck/TcTyDecls.lhs +++ b/compiler/typecheck/TcTyDecls.lhs @@ -233,7 +233,8 @@ calcClassCycles cls | otherwise = flip (foldr (expandType seen path)) tys - expandType _ _ (TyVarTy _) = id + expandType _ _ (TyVarTy {}) = id + expandType _ _ (LitTy {}) = id expandType seen path (AppTy t1 t2) = expandType seen path t1 . expandType seen path t2 expandType seen path (FunTy t1 t2) = expandType seen path t1 . expandType seen path t2 expandType seen path (ForAllTy _tv t) = expandType seen path t @@ -468,7 +469,8 @@ tcTyConsOfType ty where go :: Type -> NameEnv TyCon -- The NameEnv does duplicate elim go ty | Just ty' <- tcView ty = go ty' - go (TyVarTy _) = emptyNameEnv + go (TyVarTy {}) = emptyNameEnv + go (LitTy {}) = emptyNameEnv go (TyConApp tc tys) = go_tc tc tys go (AppTy a b) = go a `plusNameEnv` go b go (FunTy a b) = go a `plusNameEnv` go b diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs index ea134ede4b..e9af2015ba 100644 --- a/compiler/typecheck/TcType.lhs +++ b/compiler/typecheck/TcType.lhs @@ -174,7 +174,9 @@ import TyCon -- others: import DynFlags -import Name hiding (varName) +import Name -- hiding (varName) + -- We use this to make dictionaries for type literals. + -- Perhaps there's a better way to do this? import NameSet import VarEnv import PrelNames @@ -529,6 +531,7 @@ tidyTypes env tys = map (tidyType env) tys --------------- tidyType :: TidyEnv -> Type -> Type +tidyType _ (LitTy n) = LitTy n tidyType env (TyVarTy tv) = tidyTyVarOcc env tv tidyType env (TyConApp tycon tys) = let args = tidyTypes env tys in args `seqList` TyConApp tycon args @@ -609,13 +612,14 @@ tidyCos env = map (tidyCo env) tcTyFamInsts :: Type -> [(TyCon, [Type])] tcTyFamInsts ty | Just exp_ty <- tcView ty = tcTyFamInsts exp_ty -tcTyFamInsts (TyVarTy _) = [] +tcTyFamInsts (TyVarTy _) = [] tcTyFamInsts (TyConApp tc tys) - | isSynFamilyTyCon tc = [(tc, tys)] + | isSynFamilyTyCon tc = [(tc, tys)] | otherwise = concat (map tcTyFamInsts tys) -tcTyFamInsts (FunTy ty1 ty2) = tcTyFamInsts ty1 ++ tcTyFamInsts ty2 -tcTyFamInsts (AppTy ty1 ty2) = tcTyFamInsts ty1 ++ tcTyFamInsts ty2 -tcTyFamInsts (ForAllTy _ ty) = tcTyFamInsts ty +tcTyFamInsts (LitTy {}) = [] +tcTyFamInsts (FunTy ty1 ty2) = tcTyFamInsts ty1 ++ tcTyFamInsts ty2 +tcTyFamInsts (AppTy ty1 ty2) = tcTyFamInsts ty1 ++ tcTyFamInsts ty2 +tcTyFamInsts (ForAllTy _ ty) = tcTyFamInsts ty \end{code} %************************************************************************ @@ -662,6 +666,7 @@ exactTyVarsOfType ty go ty | Just ty' <- tcView ty = go ty' -- This is the key line go (TyVarTy tv) = unitVarSet tv go (TyConApp _ tys) = exactTyVarsOfTypes tys + go (LitTy {}) = emptyVarSet go (FunTy arg res) = go arg `unionVarSet` go res go (AppTy fun arg) = go fun `unionVarSet` go arg go (ForAllTy tyvar ty) = delVarSet (go ty) tyvar @@ -808,9 +813,14 @@ getDFunTyKey :: Type -> OccName -- Get some string from a type, to be used to getDFunTyKey ty | Just ty' <- tcView ty = getDFunTyKey ty' getDFunTyKey (TyVarTy tv) = getOccName tv getDFunTyKey (TyConApp tc _) = getOccName tc +getDFunTyKey (LitTy x) = getDFunTyLitKey x getDFunTyKey (AppTy fun _) = getDFunTyKey fun getDFunTyKey (FunTy _ _) = getOccName funTyCon getDFunTyKey (ForAllTy _ t) = getDFunTyKey t + +getDFunTyLitKey :: TyLit -> OccName +getDFunTyLitKey (NumTyLit n) = mkOccName Name.varName (show n) +getDFunTyLitKey (StrTyLit n) = mkOccName Name.varName (show n) -- hm \end{code} @@ -1219,6 +1229,7 @@ tcTyVarsOfType :: Type -> TcTyVarSet tcTyVarsOfType (TyVarTy tv) = if isTcTyVar tv then unitVarSet tv else emptyVarSet tcTyVarsOfType (TyConApp _ tys) = tcTyVarsOfTypes tys +tcTyVarsOfType (LitTy {}) = emptyVarSet tcTyVarsOfType (FunTy arg res) = tcTyVarsOfType arg `unionVarSet` tcTyVarsOfType res tcTyVarsOfType (AppTy fun arg) = tcTyVarsOfType fun `unionVarSet` tcTyVarsOfType arg tcTyVarsOfType (ForAllTy tyvar ty) = tcTyVarsOfType ty `delVarSet` tyvar @@ -1243,6 +1254,7 @@ orphNamesOfType ty | Just ty' <- tcView ty = orphNamesOfType ty' orphNamesOfType (TyVarTy _) = emptyNameSet orphNamesOfType (TyConApp tycon tys) = orphNamesOfTyCon tycon `unionNameSets` orphNamesOfTypes tys +orphNamesOfType (LitTy {}) = emptyNameSet orphNamesOfType (FunTy arg res) = orphNamesOfType arg `unionNameSets` orphNamesOfType res orphNamesOfType (AppTy fun arg) = orphNamesOfType fun `unionNameSets` orphNamesOfType arg orphNamesOfType (ForAllTy _ ty) = orphNamesOfType ty diff --git a/compiler/typecheck/TcUnify.lhs b/compiler/typecheck/TcUnify.lhs index c3b939de2a..d22fbdaca1 100644 --- a/compiler/typecheck/TcUnify.lhs +++ b/compiler/typecheck/TcUnify.lhs @@ -614,7 +614,11 @@ uType_np origin orig_ty1 orig_ty2 | tc1 == tc2, length tys1 == length tys2 = do { cos <- zipWithM (uType origin) tys1 tys2 ; return $ mkTcTyConAppCo tc1 cos } - + + go (LitTy m) ty@(LitTy n) + | m == n + = return $ mkTcReflCo ty + -- See Note [Care with type applications] -- Do not decompose FunTy against App; -- it's often a type error, so leave it for the constraint solver @@ -884,6 +888,7 @@ checkTauTvUpdate tv ty = Just (TyConApp tc tys') | isSynTyCon tc, Just ty_expanded <- tcView this_ty = ok ty_expanded -- See Note [Type synonyms and the occur check] + ok ty@(LitTy {}) = Just ty ok (FunTy arg res) | Just arg' <- ok arg, Just res' <- ok res = Just (FunTy arg' res') ok (AppTy fun arg) | Just fun' <- ok fun, Just arg' <- ok arg diff --git a/compiler/types/Coercion.lhs b/compiler/types/Coercion.lhs index 2f22c35b46..169198c77a 100644 --- a/compiler/types/Coercion.lhs +++ b/compiler/types/Coercion.lhs @@ -950,6 +950,7 @@ ty_co_subst subst ty go (ForAllTy v ty) = mkForAllCo v' $! (ty_co_subst subst' ty) where (subst', v') = liftCoSubstTyVarBndr subst v + go ty@(LitTy {}) = mkReflCo ty liftCoSubstTyVar :: LiftCoSubst -> TyVar -> Maybe Coercion liftCoSubstTyVar (LCS _ cenv) tv = lookupVarEnv cenv tv diff --git a/compiler/types/FamInstEnv.lhs b/compiler/types/FamInstEnv.lhs index 3c85395cbb..c7b9dedd37 100644 --- a/compiler/types/FamInstEnv.lhs +++ b/compiler/types/FamInstEnv.lhs @@ -414,7 +414,6 @@ lookupFamInstEnvConflicts envs fam_inst skol_tvs (ppr tpl_tvs <+> ppr tpl_tys) ) -- Unification will break badly if the variables overlap -- They shouldn't because we allocate separate uniques for them - pprTrace "tcUnifyTys" (ppr tpl_tys $$ ppr match_tys $$ ppr fam_inst) $ case tcUnifyTys instanceBindFun tpl_tys match_tys of Just subst | conflicting old_fam_inst subst -> Just subst _other -> Nothing @@ -654,6 +653,7 @@ normaliseType env ty | Just ty' <- coreView ty = normaliseType env ty' normaliseType env (TyConApp tc tys) = normaliseTcApp env tc tys +normaliseType _env ty@(LitTy {}) = (Refl ty, ty) normaliseType env (AppTy ty1 ty2) = let (coi1,nty1) = normaliseType env ty1 (coi2,nty2) = normaliseType env ty2 diff --git a/compiler/types/Kind.lhs b/compiler/types/Kind.lhs index 31c0011db1..c0364fa511 100644 --- a/compiler/types/Kind.lhs +++ b/compiler/types/Kind.lhs @@ -18,6 +18,7 @@ module Kind ( anyKind, liftedTypeKind, unliftedTypeKind, openTypeKind, argTypeKind, ubxTupleKind, constraintKind, mkArrowKind, mkArrowKinds, + typeNatKind, typeStringKind, -- Kind constructors... anyKindTyCon, liftedTypeKindTyCon, openTypeKindTyCon, diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs index 1946f1801c..c004c21bcb 100644 --- a/compiler/types/Type.lhs +++ b/compiler/types/Type.lhs @@ -41,6 +41,9 @@ module Type ( mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys, mkPiKinds, mkPiType, mkPiTypes, applyTy, applyTys, applyTysD, isForAllTy, dropForAlls, + + mkNumLitTy, isNumLitTy, + mkStrLitTy, isStrLitTy, -- (Newtypes) newTyConInstRhs, carefullySplitNewType_maybe, @@ -280,6 +283,7 @@ expandTypeSynonyms ty = go (mkAppTys (substTy (mkTopTvSubst tenv) rhs) tys') | otherwise = TyConApp tc (map go tys) + go (LitTy l) = LitTy l go (TyVarTy tv) = TyVarTy tv go (AppTy t1 t2) = AppTy (go t1) (go t2) go (FunTy t1 t2) = FunTy (go t1) (go t2) @@ -399,6 +403,27 @@ splitAppTys ty = split ty ty [] \end{code} + LitTy + ~~~~~ + +\begin{code} +mkNumLitTy :: Integer -> Type +mkNumLitTy n = LitTy (NumTyLit n) + +isNumLitTy :: Type -> Maybe Integer +isNumLitTy (LitTy (NumTyLit n)) = Just n +isNumLitTy _ = Nothing + +mkStrLitTy :: FastString -> Type +mkStrLitTy s = LitTy (StrTyLit s) + +isStrLitTy :: Type -> Maybe FastString +isStrLitTy (LitTy (StrTyLit s)) = Just s +isStrLitTy _ = Nothing + +\end{code} + + --------------------------------------------------------------------- FunTy ~~~~~ @@ -978,7 +1003,8 @@ getIPPredTy_maybe ty = case splitTyConApp_maybe ty of \begin{code} typeSize :: Type -> Int -typeSize (TyVarTy _) = 1 +typeSize (LitTy {}) = 1 +typeSize (TyVarTy {}) = 1 typeSize (AppTy t1 t2) = typeSize t1 + typeSize t2 typeSize (FunTy t1 t2) = typeSize t1 + typeSize t2 typeSize (ForAllTy _ t) = 1 + typeSize t @@ -1122,6 +1148,7 @@ isPrimitiveType ty = case splitTyConApp_maybe ty of \begin{code} seqType :: Type -> () +seqType (LitTy n) = n `seq` () seqType (TyVarTy tv) = tv `seq` () seqType (AppTy t1 t2) = seqType t1 `seq` seqType t2 seqType (FunTy t1 t2) = seqType t1 `seq` seqType t2 @@ -1195,20 +1222,27 @@ cmpTypeX env (ForAllTy tv1 t1) (ForAllTy tv2 t2) = cmpTypeX (rnBndr2 env tv1 cmpTypeX env (AppTy s1 t1) (AppTy s2 t2) = cmpTypeX env s1 s2 `thenCmp` cmpTypeX env t1 t2 cmpTypeX env (FunTy s1 t1) (FunTy s2 t2) = cmpTypeX env s1 s2 `thenCmp` cmpTypeX env t1 t2 cmpTypeX env (TyConApp tc1 tys1) (TyConApp tc2 tys2) = (tc1 `compare` tc2) `thenCmp` cmpTypesX env tys1 tys2 +cmpTypeX _ (LitTy l1) (LitTy l2) = compare l1 l2 - -- Deal with the rest: TyVarTy < AppTy < FunTy < TyConApp < ForAllTy < PredTy + -- Deal with the rest: TyVarTy < AppTy < FunTy < LitTy < TyConApp < ForAllTy < PredTy cmpTypeX _ (AppTy _ _) (TyVarTy _) = GT cmpTypeX _ (FunTy _ _) (TyVarTy _) = GT cmpTypeX _ (FunTy _ _) (AppTy _ _) = GT +cmpTypeX _ (LitTy _) (TyVarTy _) = GT +cmpTypeX _ (LitTy _) (AppTy _ _) = GT +cmpTypeX _ (LitTy _) (FunTy _ _) = GT + cmpTypeX _ (TyConApp _ _) (TyVarTy _) = GT cmpTypeX _ (TyConApp _ _) (AppTy _ _) = GT cmpTypeX _ (TyConApp _ _) (FunTy _ _) = GT +cmpTypeX _ (TyConApp _ _) (LitTy _) = GT cmpTypeX _ (ForAllTy _ _) (TyVarTy _) = GT cmpTypeX _ (ForAllTy _ _) (AppTy _ _) = GT cmpTypeX _ (ForAllTy _ _) (FunTy _ _) = GT +cmpTypeX _ (ForAllTy _ _) (LitTy _) = GT cmpTypeX _ (ForAllTy _ _) (TyConApp _ _) = GT cmpTypeX _ _ _ = LT @@ -1448,6 +1482,7 @@ subst_ty :: TvSubst -> Type -> Type subst_ty subst ty = go ty where + go (LitTy n) = n `seq` LitTy n go (TyVarTy tv) = substTyVar subst tv go (TyConApp tc tys) = let args = map go tys in args `seqList` TyConApp tc args @@ -1547,6 +1582,7 @@ typeKind (TyConApp tc tys) = kindAppResult (tyConKind tc) tys typeKind (AppTy fun arg) = kindAppResult (typeKind fun) [arg] +typeKind (LitTy l) = typeLiteralKind l typeKind (ForAllTy _ ty) = typeKind ty typeKind (TyVarTy tyvar) = tyVarKind tyvar typeKind _ty@(FunTy _arg res) @@ -1560,6 +1596,13 @@ typeKind _ty@(FunTy _arg res) where k = typeKind res + +typeLiteralKind :: TyLit -> Kind +typeLiteralKind l = + case l of + NumTyLit _ -> typeNatKind + StrTyLit _ -> typeStringKind + \end{code} Kind inference diff --git a/compiler/types/TypeRep.lhs b/compiler/types/TypeRep.lhs index 0d1fb27164..69637b39ed 100644 --- a/compiler/types/TypeRep.lhs +++ b/compiler/types/TypeRep.lhs @@ -28,6 +28,7 @@ Note [The Type-related module hierarchy] module TypeRep ( TyThing(..), Type(..), + TyLit(..), KindOrType, Kind, SuperKind, PredType, ThetaType, -- Synonyms @@ -39,7 +40,7 @@ module TypeRep ( pprType, pprParendType, pprTypeApp, pprTvBndr, pprTvBndrs, pprTyThing, pprTyThingCategory, pprEqPred, pprTheta, pprForAll, pprThetaArrowTy, pprClassPred, - pprKind, pprParendKind, + pprKind, pprParendKind, pprTyLit, Prec(..), maybeParen, pprTcApp, pprTypeNameApp, pprPrefixApp, pprArrowChain, ppr_type, @@ -123,8 +124,18 @@ data Type Var -- Type or kind variable Type -- ^ A polymorphic type + | LitTy TyLit -- ^ Type literals are simillar to type constructors. + deriving (Data.Data, Data.Typeable) + +-- NOTE: Other parts of the code assume that type literals do not contain +-- types or type variables. +data TyLit + = NumTyLit Integer + | StrTyLit FastString + deriving (Eq, Ord, Data.Data, Data.Typeable) + type KindOrType = Type -- See Note [Arguments to type constructors] -- | The key type representing kinds in the compiler. @@ -302,6 +313,7 @@ tyVarsOfType :: Type -> VarSet -- kind variable {k} tyVarsOfType (TyVarTy v) = unitVarSet v tyVarsOfType (TyConApp _ tys) = tyVarsOfTypes tys +tyVarsOfType (LitTy {}) = emptyVarSet tyVarsOfType (FunTy arg res) = tyVarsOfType arg `unionVarSet` tyVarsOfType res tyVarsOfType (AppTy fun arg) = tyVarsOfType fun `unionVarSet` tyVarsOfType arg tyVarsOfType (ForAllTy tyvar ty) = delVarSet (tyVarsOfType ty) tyvar @@ -474,6 +486,9 @@ pprType, pprParendType :: Type -> SDoc pprType ty = ppr_type TopPrec ty pprParendType ty = ppr_type TyConPrec ty +pprTyLit :: TyLit -> SDoc +pprTyLit = ppr_tylit TopPrec + pprKind, pprParendKind :: Kind -> SDoc pprKind = pprType pprParendKind = pprParendType @@ -534,6 +549,9 @@ pprThetaArrowTy preds = parens (fsep (punctuate comma (map (ppr_type TopPrec) instance Outputable Type where ppr ty = pprType ty +instance Outputable TyLit where + ppr = pprTyLit + instance Outputable name => OutputableBndr (IPName name) where pprBndr _ n = ppr n -- Simple for now pprInfixOcc n = ppr n @@ -545,6 +563,7 @@ instance Outputable name => OutputableBndr (IPName name) where ppr_type :: Prec -> Type -> SDoc ppr_type _ (TyVarTy tv) = ppr_tvar tv ppr_type p (TyConApp tc tys) = pprTcApp p ppr_type tc tys +ppr_type p (LitTy l) = ppr_tylit p l ppr_type p (AppTy t1 t2) = maybeParen p TyConPrec $ pprType t1 <+> ppr_type TyConPrec t2 @@ -579,6 +598,12 @@ ppr_tvar :: TyVar -> SDoc ppr_tvar tv -- Note [Infix type variables] = parenSymOcc (getOccName tv) (ppr tv) +ppr_tylit :: Prec -> TyLit -> SDoc +ppr_tylit _ tl = + case tl of + NumTyLit n -> integer n + StrTyLit s -> text (show s) + ------------------- pprForAll :: [TyVar] -> SDoc pprForAll [] = empty diff --git a/compiler/utils/Digraph.lhs b/compiler/utils/Digraph.lhs index 1bb460674c..a2b40152f3 100644 --- a/compiler/utils/Digraph.lhs +++ b/compiler/utils/Digraph.lhs @@ -429,12 +429,6 @@ instance Show a => Show (Tree a) where showTree :: Show a => Tree a -> String showTree = drawTree . mapTree show -instance Show a => Show (Forest a) where - showsPrec _ f s = showForest f ++ s - -showForest :: Show a => Forest a -> String -showForest = unlines . map showTree - drawTree :: Tree String -> String drawTree = unlines . draw diff --git a/compiler/utils/ListSetOps.lhs b/compiler/utils/ListSetOps.lhs index 110ba7788f..0dc873eb62 100644 --- a/compiler/utils/ListSetOps.lhs +++ b/compiler/utils/ListSetOps.lhs @@ -5,12 +5,6 @@ \section[ListSetOps]{Set-like operations on lists} \begin{code} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details module ListSetOps ( unionLists, minusList, insertList, diff --git a/compiler/utils/Outputable.lhs b/compiler/utils/Outputable.lhs index b96ae5e063..b58fcd4817 100644 --- a/compiler/utils/Outputable.lhs +++ b/compiler/utils/Outputable.lhs @@ -958,10 +958,9 @@ warnPprTrace :: Bool -> String -> Int -> SDoc -> a -> a warnPprTrace _ _file _line _msg x | opt_NoDebugOutput = x warnPprTrace False _file _line _msg x = x warnPprTrace True file line msg x - = pprDebugAndThen trace "WARNING:" doc x + = pprDebugAndThen trace str msg x where - doc = sep [hsep [text "WARNING: file", text file, text "line", int line], - msg] + str = showSDoc (hsep [text "WARNING: file", text file <> comma, text "line", int line]) assertPprPanic :: String -> Int -> SDoc -> a -- ^ Panic with an assertation failure, recording the given file and line number. diff --git a/compiler/vectorise/Vectorise/Convert.hs b/compiler/vectorise/Vectorise/Convert.hs index cebee633ee..048362d59c 100644 --- a/compiler/vectorise/Vectorise/Convert.hs +++ b/compiler/vectorise/Vectorise/Convert.hs @@ -78,10 +78,11 @@ identityConv (TyConApp tycon tys) = do { mapM_ identityConv tys ; identityConvTyCon tycon } -identityConv (TyVarTy _) = noV $ text "identityConv: type variable changes under vectorisation" -identityConv (AppTy _ _) = noV $ text "identityConv: type appl. changes under vectorisation" -identityConv (FunTy _ _) = noV $ text "identityConv: function type changes under vectorisation" -identityConv (ForAllTy _ _) = noV $ text "identityConv: quantified type changes under vectorisation" +identityConv (LitTy {}) = noV $ text "identityConv: not sure about literal types under vectorisation" +identityConv (TyVarTy {}) = noV $ text "identityConv: type variable changes under vectorisation" +identityConv (AppTy {}) = noV $ text "identityConv: type appl. changes under vectorisation" +identityConv (FunTy {}) = noV $ text "identityConv: function type changes under vectorisation" +identityConv (ForAllTy {}) = noV $ text "identityConv: quantified type changes under vectorisation" -- |Check that this type constructor is neutral under type vectorisation — i.e., it is not altered -- by vectorisation as they contain no parallel arrays. diff --git a/compiler/vectorise/Vectorise/Type/Classify.hs b/compiler/vectorise/Vectorise/Type/Classify.hs index ead7f14ea7..0cab706cf4 100644 --- a/compiler/vectorise/Vectorise/Type/Classify.hs +++ b/compiler/vectorise/Vectorise/Type/Classify.hs @@ -114,4 +114,5 @@ tyConsOfType (TyConApp tc tys) = extend (tyConsOfTypes tys) tyConsOfType (AppTy a b) = tyConsOfType a `unionUniqSets` tyConsOfType b tyConsOfType (FunTy a b) = (tyConsOfType a `unionUniqSets` tyConsOfType b) `addOneToUniqSet` funTyCon +tyConsOfType (LitTy _) = emptyUniqSet tyConsOfType (ForAllTy _ ty) = tyConsOfType ty diff --git a/compiler/vectorise/Vectorise/Type/Type.hs b/compiler/vectorise/Vectorise/Type/Type.hs index db724ad4bf..a7ec86a296 100644 --- a/compiler/vectorise/Vectorise/Type/Type.hs +++ b/compiler/vectorise/Vectorise/Type/Type.hs @@ -59,6 +59,7 @@ vectType ty | Just ty' <- coreView ty = vectType ty' vectType (TyVarTy tv) = return $ TyVarTy tv +vectType (LitTy l) = return $ LitTy l vectType (AppTy ty1 ty2) = AppTy <$> vectType ty1 <*> vectType ty2 vectType (TyConApp tc tys) = TyConApp <$> vectTyCon tc <*> mapM vectType tys vectType (FunTy ty1 ty2) diff --git a/configure.ac b/configure.ac index 4951467b4d..b796f6d441 100644 --- a/configure.ac +++ b/configure.ac @@ -159,9 +159,9 @@ fi; # GHC is passed to Cabal, so we need a native path if test "${WithGhc}" != "" then - ghc_host=`"${WithGhc}" +RTS --info | grep 'Host platform' | sed -e 's/.*, "//' -e 's/")//'` + ghc_host_os=`"${WithGhc}" +RTS --info | grep 'Host OS' | sed -e 's/.*, "//' -e 's/")//'` - if test "$ghc_host" = "i386-unknown-mingw32" + if test "$ghc_host_os" = "mingw32" then if test "${OSTYPE}" = "msys" then @@ -252,57 +252,73 @@ if test "$HostOS" = "mingw32" then test -d inplace || mkdir inplace - CC="$hardtop/inplace/mingw/bin/gcc.exe" - LD="$hardtop/inplace/mingw/bin/ld.exe" - NM="$hardtop/inplace/mingw/bin/nm.exe" - fp_prog_ar_raw="$hardtop/inplace/mingw/bin/ar.exe" - - # NB. If you update the tarballs to a new version of gcc, don't - # forget to tweak the paths in driver/gcc/gcc.c. - if ! test -d inplace/mingw || - test inplace/mingw -ot ghc-tarballs/mingw/binutils*.tar.lzma || - test inplace/mingw -ot ghc-tarballs/mingw/gcc-core*.tar.lzma || - test inplace/mingw -ot ghc-tarballs/mingw/gcc-c++*.tar.lzma || - test inplace/mingw -ot ghc-tarballs/mingw/libgcc*.tar.gz || - test inplace/mingw -ot ghc-tarballs/mingw/libgmp*.tar.gz || - test inplace/mingw -ot ghc-tarballs/mingw/libmpc*.tar.gz || - test inplace/mingw -ot ghc-tarballs/mingw/libmpfr*.tar.gz || - test inplace/mingw -ot ghc-tarballs/mingw/libstdc*.tar.lzma || - test inplace/mingw -ot ghc-tarballs/mingw/mingwrt*-dev.tar.gz || - test inplace/mingw -ot ghc-tarballs/mingw/mingwrt*-dll.tar.gz || - test inplace/mingw -ot ghc-tarballs/mingw/w32api*.tar.lzma + if test "$HostArch" = "i386" then - AC_MSG_NOTICE([Making in-tree mingw tree]) - rm -rf inplace/mingw - mkdir inplace/mingw - ( - cd inplace/mingw && - tar --lzma -xf ../../ghc-tarballs/mingw/binutils*.tar.lzma && - tar --lzma -xf ../../ghc-tarballs/mingw/gcc-core*.tar.lzma && - tar --lzma -xf ../../ghc-tarballs/mingw/gcc-c++*.tar.lzma && - tar --lzma -xf ../../ghc-tarballs/mingw/libgcc*.tar.lzma && - tar --lzma -xf ../../ghc-tarballs/mingw/libgmp*.tar.lzma && - tar --lzma -xf ../../ghc-tarballs/mingw/libmpc*.tar.lzma && - tar --lzma -xf ../../ghc-tarballs/mingw/libmpfr*.tar.lzma && - tar --lzma -xf ../../ghc-tarballs/mingw/libstdc*.tar.lzma && - tar -z -xf ../../ghc-tarballs/mingw/mingwrt*-dev.tar.gz && - tar -z -xf ../../ghc-tarballs/mingw/mingwrt*-dll.tar.gz && - tar --lzma -xf ../../ghc-tarballs/mingw/w32api*.tar.lzma && - mv bin/gcc.exe bin/realgcc.exe - ) - PATH=`pwd`/inplace/mingw/bin:$PATH inplace/mingw/bin/realgcc.exe driver/gcc/gcc.c driver/utils/cwrapper.c driver/utils/getLocation.c -Idriver/utils -o inplace/mingw/bin/gcc.exe - if ! test -e inplace/mingw/bin/gcc.exe + # NB. If you update the tarballs to a new version of gcc, don't + # forget to tweak the paths in driver/gcc/gcc.c. + if ! test -d inplace/mingw || + test inplace/mingw -ot ghc-tarballs/mingw/binutils*.tar.lzma || + test inplace/mingw -ot ghc-tarballs/mingw/gcc-core*.tar.lzma || + test inplace/mingw -ot ghc-tarballs/mingw/gcc-c++*.tar.lzma || + test inplace/mingw -ot ghc-tarballs/mingw/libgcc*.tar.gz || + test inplace/mingw -ot ghc-tarballs/mingw/libgmp*.tar.gz || + test inplace/mingw -ot ghc-tarballs/mingw/libmpc*.tar.gz || + test inplace/mingw -ot ghc-tarballs/mingw/libmpfr*.tar.gz || + test inplace/mingw -ot ghc-tarballs/mingw/libstdc*.tar.lzma || + test inplace/mingw -ot ghc-tarballs/mingw/mingwrt*-dev.tar.gz || + test inplace/mingw -ot ghc-tarballs/mingw/mingwrt*-dll.tar.gz || + test inplace/mingw -ot ghc-tarballs/mingw/w32api*.tar.lzma + then + AC_MSG_NOTICE([Making in-tree mingw tree]) + rm -rf inplace/mingw + mkdir inplace/mingw + ( + cd inplace/mingw && + tar --lzma -xf ../../ghc-tarballs/mingw/binutils*.tar.lzma && + tar --lzma -xf ../../ghc-tarballs/mingw/gcc-core*.tar.lzma && + tar --lzma -xf ../../ghc-tarballs/mingw/gcc-c++*.tar.lzma && + tar --lzma -xf ../../ghc-tarballs/mingw/libgcc*.tar.lzma && + tar --lzma -xf ../../ghc-tarballs/mingw/libgmp*.tar.lzma && + tar --lzma -xf ../../ghc-tarballs/mingw/libmpc*.tar.lzma && + tar --lzma -xf ../../ghc-tarballs/mingw/libmpfr*.tar.lzma && + tar --lzma -xf ../../ghc-tarballs/mingw/libstdc*.tar.lzma && + tar -z -xf ../../ghc-tarballs/mingw/mingwrt*-dev.tar.gz && + tar -z -xf ../../ghc-tarballs/mingw/mingwrt*-dll.tar.gz && + tar --lzma -xf ../../ghc-tarballs/mingw/w32api*.tar.lzma && + mv bin/gcc.exe bin/realgcc.exe + ) + PATH=`pwd`/inplace/mingw/bin:$PATH inplace/mingw/bin/realgcc.exe driver/gcc/gcc.c driver/utils/cwrapper.c driver/utils/getLocation.c -Idriver/utils -o inplace/mingw/bin/gcc.exe + AC_MSG_NOTICE([In-tree mingw tree created]) + fi + mingwbin="$hardtop/inplace/mingw/bin/" + else + # NB. If you update the tarballs to a new version of gcc, don't + # forget to tweak the paths in driver/gcc/gcc.c. + if ! test -d inplace/mingw || + test inplace/mingw -ot ghc-tarballs/mingw64/mingw-w64-bin_*.zip then - AC_MSG_ERROR([GHC is required unless bootstrapping from .hc files.]) + AC_MSG_NOTICE([Making in-tree mingw tree]) + rm -rf inplace/mingw + mkdir inplace/mingw + ( + cd inplace/mingw && + unzip ../../ghc-tarballs/mingw64/mingw-w64-bin_*.zip + ) + AC_MSG_NOTICE([In-tree mingw tree created]) fi - AC_MSG_NOTICE([In-tree mingw tree created]) + mingwbin="$hardtop/inplace/mingw/bin/x86_64-w64-mingw32-" fi + + CC="${mingwbin}gcc.exe" + LD="${mingwbin}ld.exe" + NM="${mingwbin}nm.exe" + fp_prog_ar_raw="${mingwbin}ar.exe" + if ! test -d inplace/perl || test inplace/perl -ot ghc-tarballs/perl/ghc-perl*.tar.gz then AC_MSG_NOTICE([Making in-tree perl tree]) rm -rf inplace/perl - mkdir inplace mkdir inplace/perl ( cd inplace/perl && @@ -447,10 +463,11 @@ dnl -------------------------------------------------------------- dnl ** Can the unix package be built? dnl -------------------------------------------------------------- -if test x"$TargetPlatform" = x"i386-unknown-mingw32"; then - GhcLibsWithUnix=NO +if test "$TargetOS" = "mingw32" +then + GhcLibsWithUnix=NO else - GhcLibsWithUnix=YES + GhcLibsWithUnix=YES fi AC_SUBST([GhcLibsWithUnix]) @@ -571,9 +588,9 @@ AC_SUBST(HaveDtrace) AC_PATH_PROG(HSCOLOUR,HsColour) # HsColour is passed to Cabal, so we need a native path -if test "x$HostPlatform" = "xi386-unknown-mingw32" && \ - test "${OSTYPE}" != "msys" && \ - test "${HSCOLOUR}" != "" +if test "$HostOS" = "mingw32" && \ + test "${OSTYPE}" != "msys" && \ + test "${HSCOLOUR}" != "" then # Canonicalise to <drive>:/path/to/gcc HSCOLOUR=`cygpath -m ${HSCOLOUR}` diff --git a/docs/coding-style.html b/docs/coding-style.html index 8fbb27688c..37aaf8dd46 100644 --- a/docs/coding-style.html +++ b/docs/coding-style.html @@ -1,12 +1,12 @@ -<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 3.2//EN"> -<HTML> -<HEAD> +<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd"> +<html> +<head> <meta http-equiv="content-type" content="text/html;charset=iso-8859-1"> - <TITLE>Style Guidelines for fptools</TITLE> -</HEAD> -<BODY> + <title>Style Guidelines for fptools</title> +</head> +<body> -<H1>Style Guidelines for fptools</h1> +<h1>Style Guidelines for fptools</h1> <h2>Comments</h2> @@ -36,7 +36,7 @@ the only Microsoft Press book that's worth reading.) <p><li> Autoconf documentation. -See also <a href="http://peti.gmd.de/autoconf-archive/">The autoconf macro archive</a> and +See also <a href="http://peti.gmd.de/autoconf-archive/">The autoconf macro archive</a> and <a href="http://www.cyclic.com/cyclic-pages/autoconf.html">Cyclic Software's description</a> <p><li> <a @@ -166,7 +166,7 @@ Avoid conditional code like this: </pre> Instead, add an appropriate test to the configure.ac script and use -the result of that test instead. +the result of that test instead. <pre> #ifdef HAVE_BSD_H @@ -260,8 +260,8 @@ typedef enum piece of incomplete/broken code. <p><li> When testing, try to make infrequent things happen often. - For example, make a context switch/gc/etc happen every time a - context switch/gc/etc can happen. The system will run like a + For example, make a context switch/gc/etc happen every time a + context switch/gc/etc can happen. The system will run like a pig but it'll catch a lot of bugs. </ul> @@ -335,7 +335,7 @@ Inline functions should be "static inline" because: gcc will delete static inlines if not used or theyre always inlined. <li> - if they're externed, we could get conflicts between 2 copies of the + if they're externed, we could get conflicts between 2 copies of the same function if, for some reason, gcc is unable to delete them. If they're static, we still get multiple copies but at least they don't conflict. </ul> @@ -379,7 +379,7 @@ in the library. </pre> <p><li> -Don't define macros that expand to a list of statements. +Don't define macros that expand to a list of statements. You could just use braces as in: <pre> @@ -393,7 +393,7 @@ You could just use braces as in: (but it's usually better to use an inline function instead - see above). <p><li> -Don't even write macros that expand to 0 statements - they can mess you +Don't even write macros that expand to 0 statements - they can mess you up as well. Use the doNothing macro instead. <pre> #define doNothing() do { } while (0) @@ -421,32 +421,32 @@ Try to use ANSI C's enum feature when defining lists of constants of the same type. Among other benefits, you'll notice that gdb uses the name instead of its (usually inscrutable) number when printing values with enum types and gdb will let you use the name in expressions you -type. +type. <p> Examples: <pre> typedef enum { /* N.B. Used as indexes into arrays */ - NO_HEAP_PROFILING, - HEAP_BY_CC, - HEAP_BY_MOD, - HEAP_BY_GRP, - HEAP_BY_DESCR, - HEAP_BY_TYPE, - HEAP_BY_TIME + NO_HEAP_PROFILING, + HEAP_BY_CC, + HEAP_BY_MOD, + HEAP_BY_GRP, + HEAP_BY_DESCR, + HEAP_BY_TYPE, + HEAP_BY_TIME } ProfilingFlags; </pre> instead of <pre> - # define NO_HEAP_PROFILING 0 /* N.B. Used as indexes into arrays */ - # define HEAP_BY_CC 1 - # define HEAP_BY_MOD 2 - # define HEAP_BY_GRP 3 - # define HEAP_BY_DESCR 4 - # define HEAP_BY_TYPE 5 - # define HEAP_BY_TIME 6 + # define NO_HEAP_PROFILING 0 /* N.B. Used as indexes into arrays */ + # define HEAP_BY_CC 1 + # define HEAP_BY_MOD 2 + # define HEAP_BY_GRP 3 + # define HEAP_BY_DESCR 4 + # define HEAP_BY_TYPE 5 + # define HEAP_BY_TIME 6 </pre> -and +and <pre> typedef enum { CCchar = 'C', diff --git a/docs/index.html.in b/docs/index.html.in index 5a65fe50a8..e85bc89a69 100644 --- a/docs/index.html.in +++ b/docs/index.html.in @@ -45,24 +45,14 @@ Documentation for the GHC API. </P> </LI> - -<!-- - <LI> - <P> - <B><A HREF="Cabal/index.html">Cabal</A></B> - </P> - <P>An infrastructure for building and distributing Haskell - software.</P> - </LI> ---> </UL> - <P>For more information, see the following:</p> - <ul> - <li><p><a href="http://www.haskell.org/ghc/">GHC Home Page</a></p></li> - <li><p><a href="http://hackage.haskell.org/trac/ghc/"> - GHC Developers Home</a></p></li> - </ul> + <P>For more information, see the following:</P> + <UL> + <LI><P><A href="http://www.haskell.org/ghc/">GHC Home Page</A></P></LI> + <LI><P><A href="http://hackage.haskell.org/trac/ghc/"> + GHC Developers Home</A></P></LI> + </UL> </BODY> </HTML> diff --git a/docs/users_guide/flags.xml b/docs/users_guide/flags.xml index 1ffd765046..73f9414ecc 100644 --- a/docs/users_guide/flags.xml +++ b/docs/users_guide/flags.xml @@ -1502,6 +1502,20 @@ </row> <row> + <entry><option>-fvectorise</option></entry> + <entry>Enable vectorisation of nested data parallelism</entry> + <entry>dynamic</entry> + <entry><option>-fno-vectorise</option></entry> + </row> + + <row> + <entry><option>-favoid-vect</option></entry> + <entry>Enable vectorisation avoidance (EXPERIMENTAL)</entry> + <entry>dynamic</entry> + <entry><option>-fno-avoid-vect</option></entry> + </row> + + <row> <entry><option>-fexcess-precision</option></entry> <entry>Enable excess intermediate precision</entry> <entry>dynamic</entry> diff --git a/docs/users_guide/glasgow_exts.xml b/docs/users_guide/glasgow_exts.xml index bcf84b4246..d7e200458d 100644 --- a/docs/users_guide/glasgow_exts.xml +++ b/docs/users_guide/glasgow_exts.xml @@ -2025,16 +2025,6 @@ The following syntax is stolen: <varlistentry> <term> - <literal>'<replaceable>varid</replaceable></literal> - </term> - <listitem><para> - Stolen by: <option>-XTemplateHaskell</option>and - <option>-XPolyKinds</option> - </para></listitem> - </varlistentry> - - <varlistentry> - <term> <literal>[:<replaceable>varid</replaceable>|</literal> <indexterm><primary>quasi-quotation</primary></indexterm> </term> @@ -5356,8 +5346,11 @@ type T1 = P -- 1 type T2 = 'P -- promoted 2 </programlisting> Note that promoted datatypes give rise to named kinds. Since these can never be -ambiguous, we do not allow quotes in kind names. +ambiguous, we do not allow quotes in kind names. </para> +<para>Just as in the case of Template Haskell (<xref linkend="th-syntax"/>), there is +no way to quote a data constructor or type constructor whose second character +is a single quote.</para> </sect3> <sect3 id="promoted-lists-and-tuples"> @@ -6871,7 +6864,7 @@ understand Template Haskell; see the <ulink url="http://haskell.org/haskellwiki/ Wiki page</ulink>. </para> - <sect2> + <sect2 id="th-syntax"> <title>Syntax</title> <para> Template Haskell has the following new syntactic @@ -6931,7 +6924,19 @@ Wiki page</ulink>. <itemizedlist> <listitem><para> <literal>'f</literal> has type <literal>Name</literal>, and names the function <literal>f</literal>. Similarly <literal>'C</literal> has type <literal>Name</literal> and names the data constructor <literal>C</literal>. - In general <literal>'</literal><replaceable>thing</replaceable> interprets <replaceable>thing</replaceable> in an expression context. + In general <literal>'</literal><replaceable>thing</replaceable> + interprets <replaceable>thing</replaceable> in an expression context.</para> + <para>A name whose second character is a single + quote (sadly) cannot be quoted in this way, + because it will be parsed instead as a quoted + character. For example, if the function is called + <literal>f'7</literal> (which is a legal Haskell + identifier), an attempt to quote it as + <literal>'f'7</literal> would be parsed as the + character literal <literal>'f'</literal> followed + by the numeric literal <literal>7</literal>. There + is no current escape mechanism in this (unusual) + situation. </para></listitem> <listitem><para> <literal>''T</literal> has type <literal>Name</literal>, and names the type constructor <literal>T</literal>. That is, <literal>''</literal><replaceable>thing</replaceable> interprets <replaceable>thing</replaceable> in a type context. diff --git a/docs/users_guide/runtime_control.xml b/docs/users_guide/runtime_control.xml index 5870092c2b..bc50f28d3c 100644 --- a/docs/users_guide/runtime_control.xml +++ b/docs/users_guide/runtime_control.xml @@ -1119,38 +1119,35 @@ $ ./prog -f +RTS -H32m -S -RTS -h foo bar For some special use cases you may want more control over which events are included. The <replaceable>flags</replaceable> is a sequence of zero or more characters indicating which classes of - events to log. Currently there are four classes of events that can + events to log. Currently these the classes of events that can be enabled/disabled: <simplelist> <member> <option>s</option> — scheduler events, including Haskell - thread creation and start/stop events + thread creation and start/stop events. Enabled by default. </member> <member> - <option>g</option> — GC events, including GC start/stop + <option>g</option> — GC events, including GC start/stop. + Enabled by default. </member> <member> - <option>p</option> — parallel sparks (sampled) + <option>p</option> — parallel sparks (sampled). + Enabled by default. </member> <member> - <option>f</option> — parallel sparks (fully accurate) + <option>f</option> — parallel sparks (fully accurate). + Disabled by default. + </member> + <member> + <option>u</option> — user events. These are events emitted + from Haskell code using functions such as + <literal>Debug.Trace.traceEvent</literal>. Enabled by default. </member> </simplelist> </para> <para> - For spark events there are two modes: sampled and fully accurate. - There are various events in the life cycle of each spark, usually - just creating and running, but there are some more exceptional - possibilities. In the sampled mode the number of occurrences of each - kind of spark event is sampled at frequent intervals. In the fully - accurate mode every spark event is logged individually. The latter - has a higher runtime overhead and is not enabled by default. - </para> - - <para> - The initial enabled event classes are 's', 'g' and 'p'. In addition - you can disable specific classes, or enable/disable all classes at + You can disable specific classes, or enable/disable all classes at once: <simplelist> <member> @@ -1166,6 +1163,16 @@ $ ./prog -f +RTS -H32m -S -RTS -h foo bar (<option>-a</option>) except for GC events (<option>g</option>). </para> + <para> + For spark events there are two modes: sampled and fully accurate. + There are various events in the life cycle of each spark, usually + just creating and running, but there are some more exceptional + possibilities. In the sampled mode the number of occurrences of each + kind of spark event is sampled at frequent intervals. In the fully + accurate mode every spark event is logged individually. The latter + has a higher runtime overhead and is not enabled by default. + </para> + <para> The format of the log file is described by the header <filename>EventLogFormat.h</filename> that comes with @@ -1173,7 +1180,7 @@ $ ./prog -f +RTS -H32m -S -RTS -h foo bar the <ulink url="http://hackage.haskell.org/package/ghc-events">ghc-events</ulink> library. To dump the contents of a <literal>.eventlog</literal> file as text, use the - tool <literal>ghc-events-show</literal> that comes with + tool <literal>ghc-events show</literal> that comes with the <ulink url="http://hackage.haskell.org/package/ghc-events">ghc-events</ulink> package. </para> diff --git a/docs/users_guide/using.xml b/docs/users_guide/using.xml index 234b64d736..9df4ee01c1 100644 --- a/docs/users_guide/using.xml +++ b/docs/users_guide/using.xml @@ -31,7 +31,8 @@ main = putStrLn "Hello, World!" <para>To compile the program, use GHC like this:</para> <screen> -$ ghc hello.hs</screen> +$ ghc hello.hs +</screen> <para>(where <literal>$</literal> represents the prompt: don't type it). GHC will compile the source @@ -58,7 +59,8 @@ $ ghc hello.hs</screen> <screen> $ ./hello -Hello World!</screen> +Hello World! +</screen> <para> If your program contains multiple modules, then you only need to @@ -118,7 +120,7 @@ ghc [argument...] <para>Sometimes it is useful to make the connection between a source file and the command-line options it requires quite tight. For instance, if a Haskell source file deliberately - uses name shadowing, it should be compiled with the + uses name shadowing, it should be compiled with the <option>-fno-warn-name-shadowing</option> option. Rather than maintaining the list of per-file options in a <filename>Makefile</filename>, it is possible to do this directly in the source file using the @@ -179,29 +181,29 @@ module X where <variablelist> <varlistentry> - <term>Mode flags</term> - <listitem> - <para>For example, <option>––make</option> or <option>-E</option>. - There may only be a single mode flag on the command line. The - available modes are listed in <xref linkend="modes"/>.</para> - </listitem> + <term>Mode flags</term> + <listitem> + <para>For example, <option>––make</option> or <option>-E</option>. + There may only be a single mode flag on the command line. The + available modes are listed in <xref linkend="modes"/>.</para> + </listitem> </varlistentry> <varlistentry> - <term>Dynamic Flags</term> - <listitem> - <para>Most non-mode flags fall into this category. A dynamic flag - may be used on the command line, in a - <literal>OPTIONS_GHC</literal> pragma in a source file, or set - using <literal>:set</literal> in GHCi.</para> - </listitem> + <term>Dynamic Flags</term> + <listitem> + <para>Most non-mode flags fall into this category. A dynamic flag + may be used on the command line, in a + <literal>OPTIONS_GHC</literal> pragma in a source file, or set + using <literal>:set</literal> in GHCi.</para> + </listitem> </varlistentry> <varlistentry> - <term>Static Flags</term> - <listitem> - <para>A few flags are "static", which means they can only be used on - the command-line, and remain in force over the entire GHC/GHCi - run.</para> - </listitem> + <term>Static Flags</term> + <listitem> + <para>A few flags are "static", which means they can only be used on + the command-line, and remain in force over the entire GHC/GHCi + run.</para> + </listitem> </varlistentry> </variablelist> @@ -227,75 +229,75 @@ module X where <variablelist> <varlistentry> - <term><filename>.hs</filename></term> - <listitem> - <para>A Haskell module.</para> - </listitem> + <term><filename>.hs</filename></term> + <listitem> + <para>A Haskell module.</para> + </listitem> </varlistentry> <varlistentry> - <term> + <term> <filename>.lhs</filename> <indexterm><primary><literal>lhs</literal> suffix</primary></indexterm> - </term> - <listitem> - <para>A “literate Haskell” module.</para> - </listitem> + </term> + <listitem> + <para>A “literate Haskell” module.</para> + </listitem> </varlistentry> <varlistentry> - <term><filename>.hi</filename></term> - <listitem> - <para>A Haskell interface file, probably - compiler-generated.</para> - </listitem> + <term><filename>.hi</filename></term> + <listitem> + <para>A Haskell interface file, probably + compiler-generated.</para> + </listitem> </varlistentry> <varlistentry> - <term><filename>.hc</filename></term> - <listitem> - <para>Intermediate C file produced by the Haskell - compiler.</para> - </listitem> + <term><filename>.hc</filename></term> + <listitem> + <para>Intermediate C file produced by the Haskell + compiler.</para> + </listitem> </varlistentry> <varlistentry> - <term><filename>.c</filename></term> - <listitem> - <para>A C file not produced by the Haskell - compiler.</para> - </listitem> + <term><filename>.c</filename></term> + <listitem> + <para>A C file not produced by the Haskell + compiler.</para> + </listitem> </varlistentry> <varlistentry> - <term><filename>.ll</filename></term> - <listitem> - <para>An llvm-intermediate-language source file, usually + <term><filename>.ll</filename></term> + <listitem> + <para>An llvm-intermediate-language source file, usually produced by the compiler.</para> - </listitem> + </listitem> </varlistentry> <varlistentry> - <term><filename>.bc</filename></term> - <listitem> - <para>An llvm-intermediate-language bitcode file, usually + <term><filename>.bc</filename></term> + <listitem> + <para>An llvm-intermediate-language bitcode file, usually produced by the compiler.</para> - </listitem> + </listitem> </varlistentry> <varlistentry> - <term><filename>.s</filename></term> - <listitem> - <para>An assembly-language source file, usually produced by + <term><filename>.s</filename></term> + <listitem> + <para>An assembly-language source file, usually produced by the compiler.</para> - </listitem> + </listitem> </varlistentry> <varlistentry> - <term><filename>.o</filename></term> - <listitem> - <para>An object file, produced by an assembler.</para> - </listitem> + <term><filename>.o</filename></term> + <listitem> + <para>An object file, produced by an assembler.</para> + </listitem> </varlistentry> </variablelist> @@ -324,164 +326,164 @@ module X where <variablelist> <varlistentry> - <term> - <cmdsynopsis><command>ghc --interactive</command> - </cmdsynopsis> + <term> + <cmdsynopsis><command>ghc --interactive</command> + </cmdsynopsis> <indexterm><primary>interactive mode</primary></indexterm> <indexterm><primary>ghci</primary></indexterm> - </term> - <listitem> - <para>Interactive mode, which is also available as - <command>ghci</command>. Interactive mode is described in - more detail in <xref linkend="ghci"/>.</para> - </listitem> + </term> + <listitem> + <para>Interactive mode, which is also available as + <command>ghci</command>. Interactive mode is described in + more detail in <xref linkend="ghci"/>.</para> + </listitem> </varlistentry> <varlistentry> - <term> - <cmdsynopsis><command>ghc ––make</command> - </cmdsynopsis> + <term> + <cmdsynopsis><command>ghc ––make</command> + </cmdsynopsis> <indexterm><primary>make mode</primary></indexterm> <indexterm><primary><option>––make</option></primary></indexterm> - </term> - <listitem> - <para>In this mode, GHC will build a multi-module Haskell - program automatically, figuring out dependencies for itself. - If you have a straightforward Haskell program, this is - likely to be much easier, and faster, than using - <command>make</command>. Make mode is described in <xref - linkend="make-mode"/>.</para> + </term> + <listitem> + <para>In this mode, GHC will build a multi-module Haskell + program automatically, figuring out dependencies for itself. + If you have a straightforward Haskell program, this is + likely to be much easier, and faster, than using + <command>make</command>. Make mode is described in <xref + linkend="make-mode"/>.</para> <para> This mode is the default if there are any Haskell source files mentioned on the command line, and in this case the <option>––make</option> option can be omitted. </para> - </listitem> + </listitem> </varlistentry> <varlistentry> - <term> - <cmdsynopsis><command>ghc -e</command> - <arg choice='plain'><replaceable>expr</replaceable></arg> + <term> + <cmdsynopsis><command>ghc -e</command> + <arg choice='plain'><replaceable>expr</replaceable></arg> </cmdsynopsis> <indexterm><primary>eval mode</primary></indexterm> - </term> - <listitem> - <para>Expression-evaluation mode. This is very similar to - interactive mode, except that there is a single expression - to evaluate (<replaceable>expr</replaceable>) which is given - on the command line. See <xref linkend="eval-mode"/> for - more details.</para> - </listitem> + </term> + <listitem> + <para>Expression-evaluation mode. This is very similar to + interactive mode, except that there is a single expression + to evaluate (<replaceable>expr</replaceable>) which is given + on the command line. See <xref linkend="eval-mode"/> for + more details.</para> + </listitem> </varlistentry> <varlistentry> - <term> + <term> <cmdsynopsis> - <command>ghc -E</command> - <command>ghc -c</command> - <command>ghc -S</command> - <command>ghc -c</command> - </cmdsynopsis> - <indexterm><primary><option>-E</option></primary></indexterm> - <indexterm><primary><option>-C</option></primary></indexterm> - <indexterm><primary><option>-S</option></primary></indexterm> - <indexterm><primary><option>-c</option></primary></indexterm> + <command>ghc -E</command> + <command>ghc -c</command> + <command>ghc -S</command> + <command>ghc -c</command> + </cmdsynopsis> + <indexterm><primary><option>-E</option></primary></indexterm> + <indexterm><primary><option>-C</option></primary></indexterm> + <indexterm><primary><option>-S</option></primary></indexterm> + <indexterm><primary><option>-c</option></primary></indexterm> </term> - <listitem> - <para>This is the traditional batch-compiler mode, in which - GHC can compile source files one at a time, or link objects - together into an executable. This mode also applies if - there is no other mode flag specified on the command line, - in which case it means that the specified files should be - compiled and then linked to form a program. See <xref - linkend="options-order"/>.</para> - </listitem> + <listitem> + <para>This is the traditional batch-compiler mode, in which + GHC can compile source files one at a time, or link objects + together into an executable. This mode also applies if + there is no other mode flag specified on the command line, + in which case it means that the specified files should be + compiled and then linked to form a program. See <xref + linkend="options-order"/>.</para> + </listitem> </varlistentry> <varlistentry> - <term> + <term> <cmdsynopsis> <command>ghc -M</command> </cmdsynopsis> <indexterm><primary>dependency-generation mode</primary></indexterm> </term> - <listitem> - <para>Dependency-generation mode. In this mode, GHC can be - used to generate dependency information suitable for use in - a <literal>Makefile</literal>. See <xref - linkend="makefile-dependencies"/>.</para> - </listitem> + <listitem> + <para>Dependency-generation mode. In this mode, GHC can be + used to generate dependency information suitable for use in + a <literal>Makefile</literal>. See <xref + linkend="makefile-dependencies"/>.</para> + </listitem> </varlistentry> <varlistentry> - <term> + <term> <cmdsynopsis> <command>ghc --mk-dll</command> </cmdsynopsis> - <indexterm><primary>DLL-creation mode</primary></indexterm> + <indexterm><primary>DLL-creation mode</primary></indexterm> </term> - <listitem> - <para>DLL-creation mode (Windows only). See <xref - linkend="win32-dlls-create"/>.</para> - </listitem> + <listitem> + <para>DLL-creation mode (Windows only). See <xref + linkend="win32-dlls-create"/>.</para> + </listitem> </varlistentry> <varlistentry> - <term> - <cmdsynopsis> + <term> + <cmdsynopsis> <command>ghc --help</command> <command>ghc -?</command> - </cmdsynopsis> + </cmdsynopsis> <indexterm><primary><option>––help</option></primary></indexterm> </term> - <listitem> - <para>Cause GHC to spew a long usage message to standard + <listitem> + <para>Cause GHC to spew a long usage message to standard output and then exit.</para> - </listitem> + </listitem> </varlistentry> <varlistentry> - <term> + <term> <cmdsynopsis> <command>ghc --show-iface <replaceable>file</replaceable></command> </cmdsynopsis> <indexterm><primary><option>––--show-iface</option></primary></indexterm> </term> - <listitem> - <para>Read the interface in - <replaceable>file</replaceable> and dump it as text to - <literal>stdout</literal>. For example <literal>ghc --show-iface M.hi</literal>.</para> - </listitem> + <listitem> + <para>Read the interface in + <replaceable>file</replaceable> and dump it as text to + <literal>stdout</literal>. For example <literal>ghc --show-iface M.hi</literal>.</para> + </listitem> </varlistentry> <varlistentry> - <term> + <term> <cmdsynopsis> <command>ghc --supported-extensions</command> <command>ghc --supported-languages</command> </cmdsynopsis> <indexterm><primary><option>––supported-extensions</option></primary><primary><option>––supported-languages</option></primary></indexterm> </term> - <listitem> - <para>Print the supported language extensions.</para> - </listitem> + <listitem> + <para>Print the supported language extensions.</para> + </listitem> </varlistentry> <varlistentry> - <term> + <term> <cmdsynopsis> <command>ghc --info</command> </cmdsynopsis> <indexterm><primary><option>––info</option></primary></indexterm> </term> - <listitem> - <para>Print information about the compiler.</para> - </listitem> + <listitem> + <para>Print information about the compiler.</para> + </listitem> </varlistentry> <varlistentry> - <term> + <term> <cmdsynopsis> <command>ghc --version</command> <command>ghc -V</command> @@ -489,40 +491,40 @@ module X where <indexterm><primary><option>-V</option></primary></indexterm> <indexterm><primary><option>––version</option></primary></indexterm> </term> - <listitem> - <para>Print a one-line string including GHC's version number.</para> - </listitem> + <listitem> + <para>Print a one-line string including GHC's version number.</para> + </listitem> </varlistentry> <varlistentry> - <term> + <term> <cmdsynopsis> <command>ghc --numeric-version</command> </cmdsynopsis> <indexterm><primary><option>––numeric-version</option></primary></indexterm> </term> - <listitem> - <para>Print GHC's numeric version number only.</para> - </listitem> + <listitem> + <para>Print GHC's numeric version number only.</para> + </listitem> </varlistentry> <varlistentry> - <term> - <cmdsynopsis> + <term> + <cmdsynopsis> <command>ghc --print-libdir</command> </cmdsynopsis> <indexterm><primary><option>––print-libdir</option></primary></indexterm> </term> - <listitem> - <para>Print the path to GHC's library directory. This is - the top of the directory tree containing GHC's libraries, - interfaces, and include files (usually something like - <literal>/usr/local/lib/ghc-5.04</literal> on Unix). This - is the value of - <literal>$libdir</literal><indexterm><primary><literal>libdir</literal></primary></indexterm> + <listitem> + <para>Print the path to GHC's library directory. This is + the top of the directory tree containing GHC's libraries, + interfaces, and include files (usually something like + <literal>/usr/local/lib/ghc-5.04</literal> on Unix). This + is the value of + <literal>$libdir</literal><indexterm><primary><literal>libdir</literal></primary></indexterm> in the package configuration file (see <xref linkend="packages"/>).</para> - </listitem> + </listitem> </varlistentry> </variablelist> @@ -565,23 +567,23 @@ ghc Main.hs <literal>Makefile</literal>s are:</para> <itemizedlist> - <listitem> - <para>GHC doesn't have to be restarted for each compilation, - which means it can cache information between compilations. - Compiling a multi-module program with <literal>ghc - ––make</literal> can be up to twice as fast as - running <literal>ghc</literal> individually on each source - file.</para> - </listitem> - <listitem> - <para>You don't have to write a <literal>Makefile</literal>.</para> + <listitem> + <para>GHC doesn't have to be restarted for each compilation, + which means it can cache information between compilations. + Compiling a multi-module program with <literal>ghc + ––make</literal> can be up to twice as fast as + running <literal>ghc</literal> individually on each source + file.</para> + </listitem> + <listitem> + <para>You don't have to write a <literal>Makefile</literal>.</para> <indexterm><primary><literal>Makefile</literal>s</primary><secondary>avoiding</secondary></indexterm> - </listitem> - <listitem> - <para>GHC re-calculates the dependencies each time it is - invoked, so the dependencies never get out of sync with the - source.</para> - </listitem> + </listitem> + <listitem> + <para>GHC re-calculates the dependencies each time it is + invoked, so the dependencies never get out of sync with the + source.</para> + </listitem> </itemizedlist> <para>Any of the command-line options described in the rest of @@ -656,65 +658,65 @@ olleh This table summarises:</para> <informaltable> - <tgroup cols="4"> - <colspec align="left"/> - <colspec align="left"/> - <colspec align="left"/> - <colspec align="left"/> - - <thead> - <row> - <entry>Phase of the compilation system</entry> - <entry>Suffix saying “start here”</entry> - <entry>Flag saying “stop after”</entry> - <entry>(suffix of) output file</entry> - </row> - </thead> - <tbody> - <row> - <entry>literate pre-processor</entry> - <entry><literal>.lhs</literal></entry> - <entry>-</entry> - <entry><literal>.hs</literal></entry> - </row> - - <row> - <entry>C pre-processor (opt.) </entry> - <entry><literal>.hs</literal> (with - <option>-cpp</option>)</entry> - <entry><option>-E</option></entry> - <entry><literal>.hspp</literal></entry> - </row> - - <row> - <entry>Haskell compiler</entry> - <entry><literal>.hs</literal></entry> - <entry><option>-C</option>, <option>-S</option></entry> - <entry><literal>.hc</literal>, <literal>.s</literal></entry> - </row> - - <row> - <entry>C compiler (opt.)</entry> - <entry><literal>.hc</literal> or <literal>.c</literal></entry> - <entry><option>-S</option></entry> - <entry><literal>.s</literal></entry> - </row> - - <row> - <entry>assembler</entry> - <entry><literal>.s</literal></entry> - <entry><option>-c</option></entry> - <entry><literal>.o</literal></entry> - </row> - - <row> - <entry>linker</entry> - <entry><replaceable>other</replaceable></entry> - <entry>-</entry> - <entry><filename>a.out</filename></entry> - </row> - </tbody> - </tgroup> + <tgroup cols="4"> + <colspec align="left"/> + <colspec align="left"/> + <colspec align="left"/> + <colspec align="left"/> + + <thead> + <row> + <entry>Phase of the compilation system</entry> + <entry>Suffix saying “start here”</entry> + <entry>Flag saying “stop after”</entry> + <entry>(suffix of) output file</entry> + </row> + </thead> + <tbody> + <row> + <entry>literate pre-processor</entry> + <entry><literal>.lhs</literal></entry> + <entry>-</entry> + <entry><literal>.hs</literal></entry> + </row> + + <row> + <entry>C pre-processor (opt.) </entry> + <entry><literal>.hs</literal> (with + <option>-cpp</option>)</entry> + <entry><option>-E</option></entry> + <entry><literal>.hspp</literal></entry> + </row> + + <row> + <entry>Haskell compiler</entry> + <entry><literal>.hs</literal></entry> + <entry><option>-C</option>, <option>-S</option></entry> + <entry><literal>.hc</literal>, <literal>.s</literal></entry> + </row> + + <row> + <entry>C compiler (opt.)</entry> + <entry><literal>.hc</literal> or <literal>.c</literal></entry> + <entry><option>-S</option></entry> + <entry><literal>.s</literal></entry> + </row> + + <row> + <entry>assembler</entry> + <entry><literal>.s</literal></entry> + <entry><option>-c</option></entry> + <entry><literal>.o</literal></entry> + </row> + + <row> + <entry>linker</entry> + <entry><replaceable>other</replaceable></entry> + <entry>-</entry> + <entry><filename>a.out</filename></entry> + </row> + </tbody> + </tgroup> </informaltable> <indexterm><primary><option>-C</option></primary></indexterm> @@ -725,7 +727,8 @@ olleh <para>Thus, a common invocation would be: </para> <screen> -ghc -c Foo.hs</screen> +ghc -c Foo.hs +</screen> <para>to compile the Haskell source file <filename>Foo.hs</filename> to an object file @@ -745,26 +748,26 @@ ghc -c Foo.hs</screen> of the compiler, dumping the result in a file.</para> <sect3 id="overriding-suffixes"> - <title>Overriding the default behaviour for a file</title> - - <para>As described above, the way in which a file is processed by GHC - depends on its suffix. This behaviour can be overridden using the - <option>-x</option> option:</para> - - <variablelist> - <varlistentry> - <term><option>-x</option> <replaceable>suffix</replaceable> - <indexterm><primary><option>-x</option></primary> - </indexterm></term> - <listitem> - <para>Causes all files following this option on the command - line to be processed as if they had the suffix - <replaceable>suffix</replaceable>. For example, to compile a - Haskell module in the file <literal>M.my-hs</literal>, - use <literal>ghc -c -x hs M.my-hs</literal>.</para> - </listitem> - </varlistentry> - </variablelist> + <title>Overriding the default behaviour for a file</title> + + <para>As described above, the way in which a file is processed by GHC + depends on its suffix. This behaviour can be overridden using the + <option>-x</option> option:</para> + + <variablelist> + <varlistentry> + <term><option>-x</option> <replaceable>suffix</replaceable> + <indexterm><primary><option>-x</option></primary> + </indexterm></term> + <listitem> + <para>Causes all files following this option on the command + line to be processed as if they had the suffix + <replaceable>suffix</replaceable>. For example, to compile a + Haskell module in the file <literal>M.my-hs</literal>, + use <literal>ghc -c -x hs M.my-hs</literal>.</para> + </listitem> + </varlistentry> + </variablelist> </sect3> </sect2> @@ -780,119 +783,125 @@ ghc -c Foo.hs</screen> and <option>--print-libdir</option> modes in <xref linkend="modes"/>.</para> <variablelist> <varlistentry> - <term> + <term> <option>-v</option> <indexterm><primary><option>-v</option></primary></indexterm> </term> - <listitem> - <para>The <option>-v</option> option makes GHC + <listitem> + <para>The <option>-v</option> option makes GHC <emphasis>verbose</emphasis>: it reports its version number and shows (on stderr) exactly how it invokes each phase of the compilation system. Moreover, it passes the <option>-v</option> flag to most phases; each reports its version number (and possibly some other information).</para> - <para>Please, oh please, use the <option>-v</option> option + <para>Please, oh please, use the <option>-v</option> option when reporting bugs! Knowing that you ran the right bits in the right order is always the first thing we want to verify.</para> - </listitem> + </listitem> </varlistentry> <varlistentry> - <term> + <term> <option>-v</option><replaceable>n</replaceable> <indexterm><primary><option>-v</option></primary></indexterm> </term> - <listitem> - <para>To provide more control over the compiler's verbosity, - the <option>-v</option> flag takes an optional numeric - argument. Specifying <option>-v</option> on its own is - equivalent to <option>-v3</option>, and the other levels - have the following meanings:</para> - - <variablelist> - <varlistentry> - <term><option>-v0</option></term> - <listitem> - <para>Disable all non-essential messages (this is the - default).</para> - </listitem> - </varlistentry> - - <varlistentry> - <term><option>-v1</option></term> - <listitem> - <para>Minimal verbosity: print one line per - compilation (this is the default when - <option>––make</option> or - <option>––interactive</option> is on).</para> - </listitem> - </varlistentry> - - <varlistentry> - <term><option>-v2</option></term> - <listitem> - <para>Print the name of each compilation phase as it - is executed. (equivalent to - <option>-dshow-passes</option>).</para> - </listitem> - </varlistentry> - - <varlistentry> - <term><option>-v3</option></term> - <listitem> - <para>The same as <option>-v2</option>, except that in + <listitem> + <para>To provide more control over the compiler's verbosity, + the <option>-v</option> flag takes an optional numeric + argument. Specifying <option>-v</option> on its own is + equivalent to <option>-v3</option>, and the other levels + have the following meanings:</para> + + <variablelist> + <varlistentry> + <term><option>-v0</option></term> + <listitem> + <para>Disable all non-essential messages (this is the + default).</para> + </listitem> + </varlistentry> + + <varlistentry> + <term><option>-v1</option></term> + <listitem> + <para>Minimal verbosity: print one line per + compilation (this is the default when + <option>––make</option> or + <option>––interactive</option> is on).</para> + </listitem> + </varlistentry> + + <varlistentry> + <term><option>-v2</option></term> + <listitem> + <para>Print the name of each compilation phase as it + is executed. (equivalent to + <option>-dshow-passes</option>).</para> + </listitem> + </varlistentry> + + <varlistentry> + <term><option>-v3</option></term> + <listitem> + <para>The same as <option>-v2</option>, except that in addition the full command line (if appropriate) for each compilation phase is also printed.</para> - </listitem> - </varlistentry> - - <varlistentry> - <term><option>-v4</option></term> - <listitem> - <para>The same as <option>-v3</option> except that the - intermediate program representation after each - compilation phase is also printed (excluding - preprocessed and C/assembly files).</para> - </listitem> - </varlistentry> - </variablelist> - </listitem> + </listitem> + </varlistentry> + + <varlistentry> + <term><option>-v4</option></term> + <listitem> + <para>The same as <option>-v3</option> except that the + intermediate program representation after each + compilation phase is also printed (excluding + preprocessed and C/assembly files).</para> + </listitem> + </varlistentry> + </variablelist> + </listitem> </varlistentry> <varlistentry> - <term><option>-ferror-spans</option> + <term><option>-ferror-spans</option> <indexterm><primary><option>-ferror-spans</option></primary> - </indexterm> + </indexterm> </term> - <listitem> - <para>Causes GHC to emit the full source span of the - syntactic entity relating to an error message. Normally, GHC - emits the source location of the start of the syntactic - entity only.</para> + <listitem> + <para>Causes GHC to emit the full source span of the + syntactic entity relating to an error message. Normally, GHC + emits the source location of the start of the syntactic + entity only.</para> - <para>For example:</para> + <para>For example:</para> -<screen>test.hs:3:6: parse error on input `where'</screen> +<screen> +test.hs:3:6: parse error on input `where' +</screen> - <para>becomes:</para> + <para>becomes:</para> -<screen>test296.hs:3:6-10: parse error on input `where'</screen> +<screen> +test296.hs:3:6-10: parse error on input `where' +</screen> - <para>And multi-line spans are possible too:</para> + <para>And multi-line spans are possible too:</para> -<screen>test.hs:(5,4)-(6,7): +<screen> +test.hs:(5,4)-(6,7): Conflicting definitions for `a' Bound at: test.hs:5:4 test.hs:6:7 - In the binding group for: a, b, a</screen> + In the binding group for: a, b, a +</screen> - <para>Note that line numbers start counting at one, but - column numbers start at zero. This choice was made to - follow existing convention (i.e. this is how Emacs does - it).</para> - </listitem> + <para>Note that line numbers start counting at one, but + column numbers start at zero. This choice was made to + follow existing convention (i.e. this is how Emacs does + it).</para> + </listitem> </varlistentry> <varlistentry> @@ -954,27 +963,27 @@ ghc -c Foo.hs</screen> <variablelist> <varlistentry> - <term><option>-W</option>:</term> - <listitem> - <indexterm><primary>-W option</primary></indexterm> - <para>Provides the standard warnings plus - <option>-fwarn-incomplete-patterns</option>, - <option>-fwarn-dodgy-exports</option>, - <option>-fwarn-dodgy-imports</option>, - <option>-fwarn-unused-matches</option>, - <option>-fwarn-unused-imports</option>, and - <option>-fwarn-unused-binds</option>.</para> - </listitem> + <term><option>-W</option>:</term> + <listitem> + <indexterm><primary>-W option</primary></indexterm> + <para>Provides the standard warnings plus + <option>-fwarn-incomplete-patterns</option>, + <option>-fwarn-dodgy-exports</option>, + <option>-fwarn-dodgy-imports</option>, + <option>-fwarn-unused-matches</option>, + <option>-fwarn-unused-imports</option>, and + <option>-fwarn-unused-binds</option>.</para> + </listitem> </varlistentry> <varlistentry> - <term><option>-Wall</option>:</term> - <listitem> - <indexterm><primary><option>-Wall</option></primary></indexterm> - <para>Turns on all warning options that indicate potentially - suspicious code. The warnings that are - <emphasis>not</emphasis> enabled by <option>-Wall</option> - are + <term><option>-Wall</option>:</term> + <listitem> + <indexterm><primary><option>-Wall</option></primary></indexterm> + <para>Turns on all warning options that indicate potentially + suspicious code. The warnings that are + <emphasis>not</emphasis> enabled by <option>-Wall</option> + are <option>-fwarn-tabs</option>, <option>-fwarn-incomplete-uni-patterns</option>, <option>-fwarn-incomplete-record-updates</option>, @@ -982,35 +991,35 @@ ghc -c Foo.hs</screen> <option>-fwarn-unrecognised-pragmas</option>, <option>-fwarn-auto-orphans</option>, <option>-fwarn-implicit-prelude</option>.</para> - </listitem> + </listitem> </varlistentry> <varlistentry> - <term><option>-w</option>:</term> - <listitem> - <indexterm><primary><option>-w</option></primary></indexterm> - <para>Turns off all warnings, including the standard ones and + <term><option>-w</option>:</term> + <listitem> + <indexterm><primary><option>-w</option></primary></indexterm> + <para>Turns off all warnings, including the standard ones and those that <literal>-Wall</literal> doesn't enable.</para> - </listitem> + </listitem> </varlistentry> <varlistentry> - <term><option>-Werror</option>:</term> - <listitem> - <indexterm><primary><option>-Werror</option></primary></indexterm> - <para>Makes any warning into a fatal error. Useful so that you don't - miss warnings when doing batch compilation. </para> - </listitem> + <term><option>-Werror</option>:</term> + <listitem> + <indexterm><primary><option>-Werror</option></primary></indexterm> + <para>Makes any warning into a fatal error. Useful so that you don't + miss warnings when doing batch compilation. </para> + </listitem> </varlistentry> <varlistentry> - <term><option>-Wwarn</option>:</term> - <listitem> - <indexterm><primary><option>-Wwarn</option></primary></indexterm> - <para>Warnings are treated only as warnings, not as errors. This is - the default, but can be useful to negate a + <term><option>-Wwarn</option>:</term> + <listitem> + <indexterm><primary><option>-Wwarn</option></primary></indexterm> + <para>Warnings are treated only as warnings, not as errors. This is + the default, but can be useful to negate a <option>-Werror</option> flag.</para> - </listitem> + </listitem> </varlistentry> </variablelist> @@ -1022,91 +1031,95 @@ ghc -c Foo.hs</screen> <variablelist> <varlistentry> - <term><option>-fdefer-type-errors</option>:</term> - <listitem> - <indexterm><primary><option>-fdefer-type-errors</option></primary> - </indexterm> - <indexterm><primary>warnings</primary></indexterm> - <para>Defer as many type errors as possible until runtime. + <term><option>-fdefer-type-errors</option>:</term> + <listitem> + <indexterm><primary><option>-fdefer-type-errors</option></primary> + </indexterm> + <indexterm><primary>warnings</primary></indexterm> + <para>Defer as many type errors as possible until runtime. At compile time you get a warning (instead of an error). At runtime, if you use a value that depends on a type error, you get a runtime error; but you can run any type-correct parts of your code just fine.</para> - </listitem> + </listitem> </varlistentry> <varlistentry> - <term><option>-fhelpful-errors</option>:</term> - <listitem> - <indexterm><primary><option>-fhelpful-errors</option></primary> - </indexterm> - <indexterm><primary>warnings</primary></indexterm> - <para>When a name or package is not found in scope, make + <term><option>-fhelpful-errors</option>:</term> + <listitem> + <indexterm><primary><option>-fhelpful-errors</option></primary> + </indexterm> + <indexterm><primary>warnings</primary></indexterm> + <para>When a name or package is not found in scope, make suggestions for the name or package you might have meant instead.</para> - <para>This option is on by default.</para> - </listitem> + <para>This option is on by default.</para> + </listitem> </varlistentry> <varlistentry> - <term><option>-fwarn-unrecognised-pragmas</option>:</term> - <listitem> - <indexterm><primary><option>-fwarn-unrecognised-pragmas</option></primary> - </indexterm> - <indexterm><primary>warnings</primary></indexterm> - <indexterm><primary>pragmas</primary></indexterm> - <para>Causes a warning to be emitted when a - pragma that GHC doesn't recognise is used. As well as pragmas + <term><option>-fwarn-unrecognised-pragmas</option>:</term> + <listitem> + <indexterm><primary><option>-fwarn-unrecognised-pragmas</option></primary> + </indexterm> + <indexterm><primary>warnings</primary></indexterm> + <indexterm><primary>pragmas</primary></indexterm> + <para>Causes a warning to be emitted when a + pragma that GHC doesn't recognise is used. As well as pragmas that GHC itself uses, GHC also recognises pragmas known to be used by other tools, e.g. <literal>OPTIONS_HUGS</literal> and <literal>DERIVE</literal>.</para> - <para>This option is on by default.</para> - </listitem> + <para>This option is on by default.</para> + </listitem> </varlistentry> <varlistentry> - <term><option>-fwarn-warnings-deprecations</option>:</term> - <listitem> - <indexterm><primary><option>-fwarn-warnings-deprecations</option></primary> - </indexterm> - <indexterm><primary>warnings</primary></indexterm> - <indexterm><primary>deprecations</primary></indexterm> - <para>Causes a warning to be emitted when a - module, function or type with a WARNING or DEPRECATED pragma + <term><option>-fwarn-warnings-deprecations</option>:</term> + <listitem> + <indexterm><primary><option>-fwarn-warnings-deprecations</option></primary> + </indexterm> + <indexterm><primary>warnings</primary></indexterm> + <indexterm><primary>deprecations</primary></indexterm> + <para>Causes a warning to be emitted when a + module, function or type with a WARNING or DEPRECATED pragma is used. See <xref linkend="warning-deprecated-pragma"/> for more details on the pragmas.</para> - <para>This option is on by default.</para> - </listitem> + <para>This option is on by default.</para> + </listitem> </varlistentry> <varlistentry> - <term><option>-fwarn-deprecated-flags</option>:</term> - <listitem> - <indexterm><primary><option>-fwarn-deprecated-flags</option></primary> - </indexterm> - <indexterm><primary>deprecated-flags</primary></indexterm> - <para>Causes a warning to be emitted when a deprecated - commandline flag is used.</para> + <term><option>-fwarn-deprecated-flags</option>:</term> + <listitem> + <indexterm><primary><option>-fwarn-deprecated-flags</option></primary> + </indexterm> + <indexterm><primary>deprecated-flags</primary></indexterm> + <para>Causes a warning to be emitted when a deprecated + commandline flag is used.</para> - <para>This option is on by default.</para> - </listitem> + <para>This option is on by default.</para> + </listitem> </varlistentry> <varlistentry> - <term><option>-fwarn-dodgy-foreign-imports</option>:</term> - <listitem> - <indexterm><primary><option>-fwarn-dodgy-foreign-imports</option></primary> - </indexterm> - <para>Causes a warning to be emitted for foreign imports of - the following form:</para> + <term><option>-fwarn-dodgy-foreign-imports</option>:</term> + <listitem> + <indexterm><primary><option>-fwarn-dodgy-foreign-imports</option></primary> + </indexterm> + <para>Causes a warning to be emitted for foreign imports of + the following form:</para> + <programlisting> foreign import "f" f :: FunPtr t </programlisting> + <para>on the grounds that it probably should be</para> + <programlisting> foreign import "&f" f :: FunPtr t </programlisting> + <para>The first form declares that `f` is a (pure) C function that takes no arguments and returns a pointer to a C function with type `t`, whereas the second form declares @@ -1114,83 +1127,83 @@ foreign import "&f" f :: FunPtr t declaration is usually a mistake, and one that is hard to debug because it results in a crash, hence this warning.</para> - </listitem> + </listitem> </varlistentry> <varlistentry> - <term><option>-fwarn-dodgy-exports</option>:</term> - <listitem> - <indexterm><primary><option>-fwarn-dodgy-exports</option></primary> - </indexterm> - <para>Causes a warning to be emitted when a datatype + <term><option>-fwarn-dodgy-exports</option>:</term> + <listitem> + <indexterm><primary><option>-fwarn-dodgy-exports</option></primary> + </indexterm> + <para>Causes a warning to be emitted when a datatype <literal>T</literal> is exported with all constructors, i.e. <literal>T(..)</literal>, but is it just a type synonym.</para> - <para>Also causes a warning to be emitted when a module is + <para>Also causes a warning to be emitted when a module is re-exported, but that module exports nothing.</para> - </listitem> + </listitem> </varlistentry> <varlistentry> - <term><option>-fwarn-dodgy-imports</option>:</term> - <listitem> - <indexterm><primary><option>-fwarn-dodgy-imports</option></primary> - </indexterm> - <para>Causes a warning to be emitted when a datatype + <term><option>-fwarn-dodgy-imports</option>:</term> + <listitem> + <indexterm><primary><option>-fwarn-dodgy-imports</option></primary> + </indexterm> + <para>Causes a warning to be emitted when a datatype <literal>T</literal> is imported with all constructors, i.e. <literal>T(..)</literal>, but has been exported abstractly, i.e. <literal>T</literal>.</para> - </listitem> + </listitem> </varlistentry> <varlistentry> - <term><option>-fwarn-lazy-unlifted-bindings</option>:</term> - <listitem> - <indexterm><primary><option>-fwarn-lazy-unlifted-bindings</option></primary> - </indexterm> - <para>Causes a warning to be emitted when an unlifted type + <term><option>-fwarn-lazy-unlifted-bindings</option>:</term> + <listitem> + <indexterm><primary><option>-fwarn-lazy-unlifted-bindings</option></primary> + </indexterm> + <para>Causes a warning to be emitted when an unlifted type is bound in a way that looks lazy, e.g. <literal>where (I# x) = ...</literal>. Use <literal>where !(I# x) = ...</literal> instead. This will be an error, rather than a warning, in GHC 7.2. </para> - </listitem> + </listitem> </varlistentry> <varlistentry> - <term><option>-fwarn-duplicate-exports</option>:</term> - <listitem> - <indexterm><primary><option>-fwarn-duplicate-exports</option></primary></indexterm> - <indexterm><primary>duplicate exports, warning</primary></indexterm> - <indexterm><primary>export lists, duplicates</primary></indexterm> + <term><option>-fwarn-duplicate-exports</option>:</term> + <listitem> + <indexterm><primary><option>-fwarn-duplicate-exports</option></primary></indexterm> + <indexterm><primary>duplicate exports, warning</primary></indexterm> + <indexterm><primary>export lists, duplicates</primary></indexterm> - <para>Have the compiler warn about duplicate entries in + <para>Have the compiler warn about duplicate entries in export lists. This is useful information if you maintain large export lists, and want to avoid the continued export of a definition after you've deleted (one) mention of it in the export list.</para> - <para>This option is on by default.</para> - </listitem> + <para>This option is on by default.</para> + </listitem> </varlistentry> <varlistentry> - <term><option>-fwarn-hi-shadowing</option>:</term> - <listitem> - <indexterm><primary><option>-fwarn-hi-shadowing</option></primary></indexterm> - <indexterm><primary>shadowing</primary> - <secondary>interface files</secondary></indexterm> - - <para>Causes the compiler to emit a warning when a module or - interface file in the current directory is shadowing one - with the same module name in a library or other - directory.</para> - </listitem> + <term><option>-fwarn-hi-shadowing</option>:</term> + <listitem> + <indexterm><primary><option>-fwarn-hi-shadowing</option></primary></indexterm> + <indexterm><primary>shadowing</primary> + <secondary>interface files</secondary></indexterm> + + <para>Causes the compiler to emit a warning when a module or + interface file in the current directory is shadowing one + with the same module name in a library or other + directory.</para> + </listitem> </varlistentry> <varlistentry> <term><option>-fwarn-identities</option>:</term> - <listitem> + <listitem> <indexterm><primary><option>-fwarn-identities</option></primary></indexterm> <para>Causes the compiler to emit a warning when a Prelude numeric conversion converts a type T to the same type T; such calls @@ -1200,7 +1213,7 @@ foreign import "&f" f :: FunPtr t <literal>fromIntegral</literal>, and <literal>realToFrac</literal>. </para> - </listitem> + </listitem> </varlistentry> <varlistentry> @@ -1229,27 +1242,29 @@ foreign import "&f" f :: FunPtr t </varlistentry> <varlistentry> - <term><option>-fwarn-incomplete-patterns</option>, + <term><option>-fwarn-incomplete-patterns</option>, <option>-fwarn-incomplete-uni-patterns</option>: </term> - <listitem> - <indexterm><primary><option>-fwarn-incomplete-patterns</option></primary></indexterm> - <indexterm><primary><option>-fwarn-incomplete-uni-patterns</option></primary></indexterm> - <indexterm><primary>incomplete patterns, warning</primary></indexterm> - <indexterm><primary>patterns, incomplete</primary></indexterm> + <listitem> + <indexterm><primary><option>-fwarn-incomplete-patterns</option></primary></indexterm> + <indexterm><primary><option>-fwarn-incomplete-uni-patterns</option></primary></indexterm> + <indexterm><primary>incomplete patterns, warning</primary></indexterm> + <indexterm><primary>patterns, incomplete</primary></indexterm> <para>The option <option>-fwarn-incomplete-patterns</option> warns about places where - a pattern-match might fail at runtime. + a pattern-match might fail at runtime. The function <function>g</function> below will fail when applied to non-empty lists, so the compiler will emit a warning about this when <option>-fwarn-incomplete-patterns</option> is enabled. + <programlisting> g [] = 2 </programlisting> - This option isn't enabled by default because it can be + + This option isn't enabled by default because it can be a bit noisy, and it doesn't always indicate a bug in the program. However, it's generally considered good practice to cover all the cases in your functions, and it is switched @@ -1258,23 +1273,25 @@ g [] = 2 <para>The flag <option>-fwarn-incomplete-uni-patterns</option> is similar, except that it applies only to lambda-expressions and pattern bindings, constructs - that only allow a single pattern: + that only allow a single pattern: + <programlisting> h = \[] -> 2 Just k = f y </programlisting> + </para> - </listitem> + </listitem> </varlistentry> <varlistentry> - <term><option>-fwarn-incomplete-record-updates</option>:</term> - <listitem> - <indexterm><primary><option>-fwarn-incomplete-record-updates</option></primary></indexterm> - <indexterm><primary>incomplete record updates, warning</primary></indexterm> - <indexterm><primary>record updates, incomplete</primary></indexterm> + <term><option>-fwarn-incomplete-record-updates</option>:</term> + <listitem> + <indexterm><primary><option>-fwarn-incomplete-record-updates</option></primary></indexterm> + <indexterm><primary>incomplete record updates, warning</primary></indexterm> + <indexterm><primary>record updates, incomplete</primary></indexterm> - <para>The function + <para>The function <function>f</function> below will fail when applied to <literal>Bar</literal>, so the compiler will emit a warning about this when <option>-fwarn-incomplete-record-updates</option> is @@ -1288,43 +1305,44 @@ f :: Foo -> Foo f foo = foo { x = 6 } </programlisting> - <para>This option isn't enabled by default because it can be + <para>This option isn't enabled by default because it can be very noisy, and it often doesn't indicate a bug in the program.</para> - </listitem> + </listitem> </varlistentry> <varlistentry> - <term> + <term> <option>-fwarn-missing-fields</option>: - <indexterm><primary><option>-fwarn-missing-fields</option></primary></indexterm> - <indexterm><primary>missing fields, warning</primary></indexterm> - <indexterm><primary>fields, missing</primary></indexterm> + <indexterm><primary><option>-fwarn-missing-fields</option></primary></indexterm> + <indexterm><primary>missing fields, warning</primary></indexterm> + <indexterm><primary>fields, missing</primary></indexterm> </term> - <listitem> + <listitem> - <para>This option is on by default, and warns you whenever + <para>This option is on by default, and warns you whenever the construction of a labelled field constructor isn't complete, missing initializers for one or more fields. While not an error (the missing fields are initialised with bottoms), it is often an indication of a programmer error.</para> - </listitem> + </listitem> </varlistentry> <varlistentry> - <term> + <term> <option>-fwarn-missing-import-lists</option>: - <indexterm><primary><option>-fwarn-import-lists</option></primary></indexterm> - <indexterm><primary>missing import lists, warning</primary></indexterm> - <indexterm><primary>import lists, missing</primary></indexterm> + <indexterm><primary><option>-fwarn-import-lists</option></primary></indexterm> + <indexterm><primary>missing import lists, warning</primary></indexterm> + <indexterm><primary>import lists, missing</primary></indexterm> </term> - <listitem> + <listitem> - <para>This flag warns if you use an unqualified + <para>This flag warns if you use an unqualified <literal>import</literal> declaration - that does not explicitly list the entities brought into scope. For - example + that does not explicitly list the entities brought into scope. For + example </para> + <programlisting> module M where import X( f ) @@ -1332,79 +1350,80 @@ module M where import qualified Z p x = f x x </programlisting> + <para> The <option>-fwarn-import-lists</option> flag will warn about the import - of <literal>Y</literal> but not <literal>X</literal> - If module <literal>Y</literal> is later changed to export (say) <literal>f</literal>, + of <literal>Y</literal> but not <literal>X</literal> + If module <literal>Y</literal> is later changed to export (say) <literal>f</literal>, then the reference to <literal>f</literal> in <literal>M</literal> will become - ambiguous. No warning is produced for the import of <literal>Z</literal> - because extending <literal>Z</literal>'s exports would be unlikely to produce - ambiguity in <literal>M</literal>. + ambiguous. No warning is produced for the import of <literal>Z</literal> + because extending <literal>Z</literal>'s exports would be unlikely to produce + ambiguity in <literal>M</literal>. </para> - </listitem> + </listitem> </varlistentry> <varlistentry> - <term><option>-fwarn-missing-methods</option>:</term> - <listitem> - <indexterm><primary><option>-fwarn-missing-methods</option></primary></indexterm> - <indexterm><primary>missing methods, warning</primary></indexterm> - <indexterm><primary>methods, missing</primary></indexterm> + <term><option>-fwarn-missing-methods</option>:</term> + <listitem> + <indexterm><primary><option>-fwarn-missing-methods</option></primary></indexterm> + <indexterm><primary>missing methods, warning</primary></indexterm> + <indexterm><primary>methods, missing</primary></indexterm> - <para>This option is on by default, and warns you whenever + <para>This option is on by default, and warns you whenever an instance declaration is missing one or more methods, and the corresponding class declaration has no default declaration for them.</para> - <para>The warning is suppressed if the method name - begins with an underscore. Here's an example where this is useful: - <programlisting> - class C a where - _simpleFn :: a -> String - complexFn :: a -> a -> String - complexFn x y = ... _simpleFn ... - </programlisting> - The idea is that: (a) users of the class will only call <literal>complexFn</literal>; - never <literal>_simpleFn</literal>; and (b) - instance declarations can define either <literal>complexFn</literal> or <literal>_simpleFn</literal>. - </para> - </listitem> - </varlistentry> - - <varlistentry> - <term><option>-fwarn-missing-signatures</option>:</term> - <listitem> - <indexterm><primary><option>-fwarn-missing-signatures</option></primary></indexterm> - <indexterm><primary>type signatures, missing</primary></indexterm> - - <para>If you would like GHC to check that every top-level + <para>The warning is suppressed if the method name + begins with an underscore. Here's an example where this is useful: + <programlisting> + class C a where + _simpleFn :: a -> String + complexFn :: a -> a -> String + complexFn x y = ... _simpleFn ... + </programlisting> + The idea is that: (a) users of the class will only call <literal>complexFn</literal>; + never <literal>_simpleFn</literal>; and (b) + instance declarations can define either <literal>complexFn</literal> or <literal>_simpleFn</literal>. + </para> + </listitem> + </varlistentry> + + <varlistentry> + <term><option>-fwarn-missing-signatures</option>:</term> + <listitem> + <indexterm><primary><option>-fwarn-missing-signatures</option></primary></indexterm> + <indexterm><primary>type signatures, missing</primary></indexterm> + + <para>If you would like GHC to check that every top-level function/value has a type signature, use the <option>-fwarn-missing-signatures</option> option. As part of - the warning GHC also reports the inferred type. The + the warning GHC also reports the inferred type. The option is off by default.</para> - </listitem> + </listitem> </varlistentry> <varlistentry> - <term><option>-fwarn-missing-local-sigs</option>:</term> - <listitem> - <indexterm><primary><option>-fwarn-missing-local-sigs</option></primary></indexterm> - <indexterm><primary>type signatures, missing</primary></indexterm> + <term><option>-fwarn-missing-local-sigs</option>:</term> + <listitem> + <indexterm><primary><option>-fwarn-missing-local-sigs</option></primary></indexterm> + <indexterm><primary>type signatures, missing</primary></indexterm> - <para>If you use the + <para>If you use the <option>-fwarn-missing-local-sigs</option> flag GHC will warn you about any polymorphic local bindings. As part of - the warning GHC also reports the inferred type. The + the warning GHC also reports the inferred type. The option is off by default.</para> - </listitem> + </listitem> </varlistentry> <varlistentry> - <term><option>-fwarn-name-shadowing</option>:</term> - <listitem> - <indexterm><primary><option>-fwarn-name-shadowing</option></primary></indexterm> - <indexterm><primary>shadowing, warning</primary></indexterm> + <term><option>-fwarn-name-shadowing</option>:</term> + <listitem> + <indexterm><primary><option>-fwarn-name-shadowing</option></primary></indexterm> + <indexterm><primary>shadowing, warning</primary></indexterm> - <para>This option causes a warning to be emitted whenever an + <para>This option causes a warning to be emitted whenever an inner-scope value has the same name as an outer-scope value, i.e. the inner value shadows the outer one. This can catch typographical errors that turn into hard-to-find bugs, e.g., @@ -1415,46 +1434,46 @@ module M where f x = do { _ignore <- this; _ignore <- that; return (the other) } </programlisting> </para> - </listitem> - </varlistentry> - - <varlistentry> - <term><option>-fwarn-orphans, -fwarn-auto-orphans</option>:</term> - <listitem> - <indexterm><primary><option>-fwarn-orphans</option></primary></indexterm> - <indexterm><primary><option>-fwarn-auto-orphans</option></primary></indexterm> - <indexterm><primary>orphan instances, warning</primary></indexterm> - <indexterm><primary>orphan rules, warning</primary></indexterm> - - <para>These flags cause a warning to be emitted whenever the - module contains an "orphan" instance declaration or rewrite rule. - An instance declaration is an orphan if it appears in a module in - which neither the class nor the type being instanced are declared - in the same module. A rule is an orphan if it is a rule for a - function declared in another module. A module containing any - orphans is called an orphan module.</para> - <para>The trouble with orphans is that GHC must pro-actively read the interface - files for all orphan modules, just in case their instances or rules - play a role, whether or not the module's interface would otherwise - be of any use. See <xref linkend="orphan-modules"/> for details. + </listitem> + </varlistentry> + + <varlistentry> + <term><option>-fwarn-orphans, -fwarn-auto-orphans</option>:</term> + <listitem> + <indexterm><primary><option>-fwarn-orphans</option></primary></indexterm> + <indexterm><primary><option>-fwarn-auto-orphans</option></primary></indexterm> + <indexterm><primary>orphan instances, warning</primary></indexterm> + <indexterm><primary>orphan rules, warning</primary></indexterm> + + <para>These flags cause a warning to be emitted whenever the + module contains an "orphan" instance declaration or rewrite rule. + An instance declaration is an orphan if it appears in a module in + which neither the class nor the type being instanced are declared + in the same module. A rule is an orphan if it is a rule for a + function declared in another module. A module containing any + orphans is called an orphan module.</para> + <para>The trouble with orphans is that GHC must pro-actively read the interface + files for all orphan modules, just in case their instances or rules + play a role, whether or not the module's interface would otherwise + be of any use. See <xref linkend="orphan-modules"/> for details. </para> <para>The flag <option>-fwarn-orphans</option> warns about user-written orphan rules or instances. The flag <option>-fwarn-auto-orphans</option> warns about automatically-generated orphan rules, notably as a result of specialising functions, for type classes (<literal>Specialise</literal>) or argument values (<literal>SpecConstr</literal>).</para> - </listitem> + </listitem> </varlistentry> <varlistentry> - <term> + <term> <option>-fwarn-overlapping-patterns</option>: <indexterm><primary><option>-fwarn-overlapping-patterns</option></primary></indexterm> <indexterm><primary>overlapping patterns, warning</primary></indexterm> <indexterm><primary>patterns, overlapping</primary></indexterm> </term> - <listitem> - <para>By default, the compiler will warn you if a set of + <listitem> + <para>By default, the compiler will warn you if a set of patterns are overlapping, e.g.,</para> <programlisting> @@ -1464,31 +1483,31 @@ f (_:xs) = 1 f "2" = 2 </programlisting> - <para>where the last pattern match in <function>f</function> + <para>where the last pattern match in <function>f</function> won't ever be reached, as the second pattern overlaps it. More often than not, redundant patterns is a programmer mistake/error, so this option is enabled by default.</para> - </listitem> + </listitem> </varlistentry> <varlistentry> - <term><option>-fwarn-tabs</option>:</term> - <listitem> - <indexterm><primary><option>-fwarn-tabs</option></primary></indexterm> - <indexterm><primary>tabs, warning</primary></indexterm> - <para>Have the compiler warn if there are tabs in your source + <term><option>-fwarn-tabs</option>:</term> + <listitem> + <indexterm><primary><option>-fwarn-tabs</option></primary></indexterm> + <indexterm><primary>tabs, warning</primary></indexterm> + <para>Have the compiler warn if there are tabs in your source file.</para> - <para>This warning is off by default.</para> - </listitem> + <para>This warning is off by default.</para> + </listitem> </varlistentry> <varlistentry> - <term><option>-fwarn-type-defaults</option>:</term> - <listitem> - <indexterm><primary><option>-fwarn-type-defaults</option></primary></indexterm> - <indexterm><primary>defaulting mechanism, warning</primary></indexterm> - <para>Have the compiler warn/inform you where in your source + <term><option>-fwarn-type-defaults</option>:</term> + <listitem> + <indexterm><primary><option>-fwarn-type-defaults</option></primary></indexterm> + <indexterm><primary>defaulting mechanism, warning</primary></indexterm> + <para>Have the compiler warn/inform you where in your source the Haskell defaulting mechanism for numeric types kicks in. This is useful information when converting code from a context that assumed one default into one with another, @@ -1500,124 +1519,124 @@ f "2" = 2 differences in performance and behaviour, hence the usefulness of being non-silent about this.</para> - <para>This warning is off by default.</para> - </listitem> + <para>This warning is off by default.</para> + </listitem> </varlistentry> <varlistentry> - <term><option>-fwarn-monomorphism-restriction</option>:</term> - <listitem> - <indexterm><primary><option>-fwarn-monomorphism-restriction</option></primary></indexterm> - <indexterm><primary>monomorphism restriction, warning</primary></indexterm> - <para>Have the compiler warn/inform you where in your source + <term><option>-fwarn-monomorphism-restriction</option>:</term> + <listitem> + <indexterm><primary><option>-fwarn-monomorphism-restriction</option></primary></indexterm> + <indexterm><primary>monomorphism restriction, warning</primary></indexterm> + <para>Have the compiler warn/inform you where in your source the Haskell Monomorphism Restriction is applied. If applied silently - the MR can give rise to unexpected behaviour, so it can be helpful - to have an explicit warning that it is being applied.</para> + the MR can give rise to unexpected behaviour, so it can be helpful + to have an explicit warning that it is being applied.</para> - <para>This warning is off by default.</para> - </listitem> + <para>This warning is off by default.</para> + </listitem> </varlistentry> <varlistentry> - <term><option>-fwarn-unused-binds</option>:</term> - <listitem> - <indexterm><primary><option>-fwarn-unused-binds</option></primary></indexterm> - <indexterm><primary>unused binds, warning</primary></indexterm> - <indexterm><primary>binds, unused</primary></indexterm> - <para>Report any function definitions (and local bindings) + <term><option>-fwarn-unused-binds</option>:</term> + <listitem> + <indexterm><primary><option>-fwarn-unused-binds</option></primary></indexterm> + <indexterm><primary>unused binds, warning</primary></indexterm> + <indexterm><primary>binds, unused</primary></indexterm> + <para>Report any function definitions (and local bindings) which are unused. For top-level functions, the warning is only given if the binding is not exported.</para> - <para>A definition is regarded as "used" if (a) it is exported, or (b) it is - mentioned in the right hand side of another definition that is used, or (c) the - function it defines begins with an underscore. The last case provides a - way to suppress unused-binding warnings selectively. </para> - <para> Notice that a variable - is reported as unused even if it appears in the right-hand side of another - unused binding. </para> - </listitem> + <para>A definition is regarded as "used" if (a) it is exported, or (b) it is + mentioned in the right hand side of another definition that is used, or (c) the + function it defines begins with an underscore. The last case provides a + way to suppress unused-binding warnings selectively. </para> + <para> Notice that a variable + is reported as unused even if it appears in the right-hand side of another + unused binding. </para> + </listitem> </varlistentry> <varlistentry> - <term><option>-fwarn-unused-imports</option>:</term> - <listitem> - <indexterm><primary><option>-fwarn-unused-imports</option></primary></indexterm> - <indexterm><primary>unused imports, warning</primary></indexterm> - <indexterm><primary>imports, unused</primary></indexterm> - - <para>Report any modules that are explicitly imported but - never used. However, the form <literal>import M()</literal> is - never reported as an unused import, because it is a useful idiom - for importing instance declarations, which are anonymous in Haskell.</para> - </listitem> + <term><option>-fwarn-unused-imports</option>:</term> + <listitem> + <indexterm><primary><option>-fwarn-unused-imports</option></primary></indexterm> + <indexterm><primary>unused imports, warning</primary></indexterm> + <indexterm><primary>imports, unused</primary></indexterm> + + <para>Report any modules that are explicitly imported but + never used. However, the form <literal>import M()</literal> is + never reported as an unused import, because it is a useful idiom + for importing instance declarations, which are anonymous in Haskell.</para> + </listitem> </varlistentry> <varlistentry> - <term><option>-fwarn-unused-matches</option>:</term> - <listitem> - <indexterm><primary><option>-fwarn-unused-matches</option></primary></indexterm> - <indexterm><primary>unused matches, warning</primary></indexterm> - <indexterm><primary>matches, unused</primary></indexterm> + <term><option>-fwarn-unused-matches</option>:</term> + <listitem> + <indexterm><primary><option>-fwarn-unused-matches</option></primary></indexterm> + <indexterm><primary>unused matches, warning</primary></indexterm> + <indexterm><primary>matches, unused</primary></indexterm> - <para>Report all unused variables which arise from pattern + <para>Report all unused variables which arise from pattern matches, including patterns consisting of a single variable. For instance <literal>f x y = []</literal> would report <varname>x</varname> and <varname>y</varname> as unused. The warning is suppressed if the variable name begins with an underscore, thus: - <programlisting> - f _x = True - </programlisting> + <programlisting> + f _x = True + </programlisting> </para> - </listitem> + </listitem> </varlistentry> <varlistentry> - <term><option>-fwarn-unused-do-bind</option>:</term> - <listitem> - <indexterm><primary><option>-fwarn-unused-do-bind</option></primary></indexterm> - <indexterm><primary>unused do binding, warning</primary></indexterm> - <indexterm><primary>do binding, unused</primary></indexterm> + <term><option>-fwarn-unused-do-bind</option>:</term> + <listitem> + <indexterm><primary><option>-fwarn-unused-do-bind</option></primary></indexterm> + <indexterm><primary>unused do binding, warning</primary></indexterm> + <indexterm><primary>do binding, unused</primary></indexterm> - <para>Report expressions occurring in <literal>do</literal> and <literal>mdo</literal> blocks - that appear to silently throw information away. + <para>Report expressions occurring in <literal>do</literal> and <literal>mdo</literal> blocks + that appear to silently throw information away. For instance <literal>do { mapM popInt xs ; return 10 }</literal> would report the first statement in the <literal>do</literal> block as suspicious, as it has the type <literal>StackM [Int]</literal> and not <literal>StackM ()</literal>, but that <literal>[Int]</literal> value is not bound to anything. The warning is suppressed by explicitly mentioning in the source code that your program is throwing something away: - <programlisting> - do { _ <- mapM popInt xs ; return 10 } - </programlisting> - Of course, in this particular situation you can do even better: - <programlisting> - do { mapM_ popInt xs ; return 10 } - </programlisting> + <programlisting> + do { _ <- mapM popInt xs ; return 10 } + </programlisting> + Of course, in this particular situation you can do even better: + <programlisting> + do { mapM_ popInt xs ; return 10 } + </programlisting> </para> - </listitem> + </listitem> </varlistentry> <varlistentry> - <term><option>-fwarn-wrong-do-bind</option>:</term> - <listitem> - <indexterm><primary><option>-fwarn-wrong-do-bind</option></primary></indexterm> - <indexterm><primary>apparently erroneous do binding, warning</primary></indexterm> - <indexterm><primary>do binding, apparently erroneous</primary></indexterm> + <term><option>-fwarn-wrong-do-bind</option>:</term> + <listitem> + <indexterm><primary><option>-fwarn-wrong-do-bind</option></primary></indexterm> + <indexterm><primary>apparently erroneous do binding, warning</primary></indexterm> + <indexterm><primary>do binding, apparently erroneous</primary></indexterm> - <para>Report expressions occurring in <literal>do</literal> and <literal>mdo</literal> blocks - that appear to lack a binding. + <para>Report expressions occurring in <literal>do</literal> and <literal>mdo</literal> blocks + that appear to lack a binding. For instance <literal>do { return (popInt 10) ; return 10 }</literal> would report the first statement in the <literal>do</literal> block as suspicious, as it has the type <literal>StackM (StackM Int)</literal> (which consists of two nested applications of the same monad constructor), but which is not then "unpacked" by binding the result. The warning is suppressed by explicitly mentioning in the source code that your program is throwing something away: - <programlisting> - do { _ <- return (popInt 10) ; return 10 } - </programlisting> - For almost all sensible programs this will indicate a bug, and you probably intended to write: - <programlisting> - do { popInt 10 ; return 10 } - </programlisting> + <programlisting> + do { _ <- return (popInt 10) ; return 10 } + </programlisting> + For almost all sensible programs this will indicate a bug, and you probably intended to write: + <programlisting> + do { popInt 10 ; return 10 } + </programlisting> </para> - </listitem> + </listitem> </varlistentry> </variablelist> @@ -1665,69 +1684,69 @@ f "2" = 2 <variablelist> - <varlistentry> - <term> + <varlistentry> + <term> No <option>-O*</option>-type option specified: <indexterm><primary>-O* not specified</primary></indexterm> </term> - <listitem> - <para>This is taken to mean: “Please compile + <listitem> + <para>This is taken to mean: “Please compile quickly; I'm not over-bothered about compiled-code quality.” So, for example: <command>ghc -c Foo.hs</command></para> - </listitem> - </varlistentry> + </listitem> + </varlistentry> - <varlistentry> - <term> + <varlistentry> + <term> <option>-O0</option>: <indexterm><primary><option>-O0</option></primary></indexterm> </term> - <listitem> - <para>Means “turn off all optimisation”, - reverting to the same settings as if no - <option>-O</option> options had been specified. Saying - <option>-O0</option> can be useful if - eg. <command>make</command> has inserted a - <option>-O</option> on the command line already.</para> - </listitem> - </varlistentry> - - <varlistentry> - <term> + <listitem> + <para>Means “turn off all optimisation”, + reverting to the same settings as if no + <option>-O</option> options had been specified. Saying + <option>-O0</option> can be useful if + eg. <command>make</command> has inserted a + <option>-O</option> on the command line already.</para> + </listitem> + </varlistentry> + + <varlistentry> + <term> <option>-O</option> or <option>-O1</option>: <indexterm><primary>-O option</primary></indexterm> <indexterm><primary>-O1 option</primary></indexterm> <indexterm><primary>optimise</primary><secondary>normally</secondary></indexterm> </term> - <listitem> - <para>Means: “Generate good-quality code without + <listitem> + <para>Means: “Generate good-quality code without taking too long about it.” Thus, for example: <command>ghc -c -O Main.lhs</command></para> - </listitem> - </varlistentry> + </listitem> + </varlistentry> - <varlistentry> - <term> + <varlistentry> + <term> <option>-O2</option>: <indexterm><primary>-O2 option</primary></indexterm> <indexterm><primary>optimise</primary><secondary>aggressively</secondary></indexterm> </term> - <listitem> - <para>Means: “Apply every non-dangerous + <listitem> + <para>Means: “Apply every non-dangerous optimisation, even if it means significantly longer compile times.”</para> - <para>The avoided “dangerous” optimisations + <para>The avoided “dangerous” optimisations are those that can make runtime or space <emphasis>worse</emphasis> if you're unlucky. They are normally turned on or off individually.</para> - <para>At the moment, <option>-O2</option> is + <para>At the moment, <option>-O2</option> is <emphasis>unlikely</emphasis> to produce better code than <option>-O</option>.</para> - </listitem> - </varlistentry> + </listitem> + </varlistentry> </variablelist> <para>We don't use a <option>-O*</option> flag for day-to-day @@ -1755,88 +1774,133 @@ f "2" = 2 interest:</para> <variablelist> - <varlistentry> - <term><option>-fexcess-precision</option>:</term> - <listitem> - <indexterm><primary><option>-fexcess-precision</option></primary></indexterm> - <para>When this option is given, intermediate floating - point values can have a <emphasis>greater</emphasis> - precision/range than the final type. Generally this is a - good thing, but some programs may rely on the exact - precision/range of - <literal>Float</literal>/<literal>Double</literal> values - and should not use this option for their compilation.</para> - </listitem> - </varlistentry> - - <varlistentry> - <term><option>-fignore-asserts</option>:</term> - <listitem> - <indexterm><primary><option>-fignore-asserts</option></primary></indexterm> - <para>Causes GHC to ignore uses of the function - <literal>Exception.assert</literal> in source code (in - other words, rewriting <literal>Exception.assert p - e</literal> to <literal>e</literal> (see <xref - linkend="assertions"/>). This flag is turned on by - <option>-O</option>. - </para> - </listitem> - </varlistentry> - - <varlistentry> - <term> - <option>-fignore-interface-pragmas</option> - <indexterm><primary><option>-fignore-interface-pragmas</option></primary></indexterm> - </term> - <listitem> - <para>Tells GHC to ignore all inessential information when reading interface files. - That is, even if <filename>M.hi</filename> contains unfolding or strictness information - for a function, GHC will ignore that information.</para> - </listitem> - </varlistentry> - - <varlistentry> - <term> - <option>-fliberate-case</option> - <indexterm><primary><option>-fliberate-case</option></primary></indexterm> - </term> - <listitem> - <para>Turn on the liberate-case transformation.</para> - </listitem> - </varlistentry> - - <varlistentry> - <term> + <varlistentry> + <term> <option>-fno-cse</option> <indexterm><primary><option>-fno-cse</option></primary></indexterm> </term> - <listitem> - <para>Turns off the common-sub-expression elimination optimisation. - Can be useful if you have some <literal>unsafePerformIO</literal> - expressions that you don't want commoned-up.</para> - </listitem> - </varlistentry> - - <varlistentry> - <term> + <listitem> + <para>Turns off the common-sub-expression elimination optimisation. + Can be useful if you have some <literal>unsafePerformIO</literal> + expressions that you don't want commoned-up.</para> + </listitem> + </varlistentry> + + <varlistentry> + <term> + <option>-fstrictness</option> + <indexterm><primary><option></option></primary></indexterm> + </term> + <listitem> + <para> + </para> + TODO: Document optimisation + </listitem> + </varlistentry> + + <varlistentry> + <term> <option>-fno-strictness</option> <indexterm><primary><option>-fno-strictness</option></primary></indexterm> </term> - <listitem> - <para>Turns off the strictness analyser; sometimes it eats - too many cycles.</para> - </listitem> - </varlistentry> - - <varlistentry> - <term> + <listitem> + <para>Turns off the strictness analyser; sometimes it eats + too many cycles.</para> + TODO: Maybe document positive cases and remove all negative cases? + </listitem> + </varlistentry> + + <varlistentry> + <term> + <option>-funbox-strict-fields</option>: + <indexterm><primary><option>-funbox-strict-fields</option></primary></indexterm> + <indexterm><primary>strict constructor fields</primary></indexterm> + <indexterm><primary>constructor fields, strict</primary></indexterm> + </term> + <listitem> + <para>This option causes all constructor fields which are marked + strict (i.e. “!”) to be unpacked if possible. It is + equivalent to adding an <literal>UNPACK</literal> pragma to every + strict constructor field (see <xref linkend="unpack-pragma"/>). + </para> + + <para>This option is a bit of a sledgehammer: it might sometimes + make things worse. Selectively unboxing fields by using + <literal>UNPACK</literal> pragmas might be better. An alternative + is to use <option>-funbox-strict-fields</option> to turn on + unboxing by default but disable it for certain constructor + fields using the <literal>NOUNPACK</literal> pragma (see + <xref linkend="nounpack-pragma"/>).</para> + </listitem> + </varlistentry> + + <varlistentry> + <term> + <option>-fspec-constr</option> + <indexterm><primary><option>-fspec-constr</option></primary></indexterm> + </term> + <listitem> + <para>Turn on call-pattern specialisation.</para> + TODO: Document optimisation + </listitem> + </varlistentry> + + <varlistentry> + <term> + <option>-fno-specialise</option> + <indexterm><primary><option>-fno-specialise</option></primary></indexterm> + </term> + <listitem> + <para>Turns off the automatic specialisation of overloaded functions.</para> + TODO: Document optimisation, probably change to a positive, not a -fno-* description. + </listitem> + </varlistentry> + + <varlistentry> + <term> + <option>-fstatic-argument-transformation</option> + <indexterm><primary><option>-fstatic-argument-transformation</option></primary></indexterm> + </term> + <listitem> + <para>Turn on the static argument transformation.</para> + TODO: Document optimisation + </listitem> + </varlistentry> + + <varlistentry> + <term> + <option>-ffloat-in</option> + <indexterm><primary><option></option></primary></indexterm> + </term> + <listitem> + <para> + </para> + TODO: Document optimisation + </listitem> + </varlistentry> + + <varlistentry> + <term> + <option>-fno-float-in</option> + <indexterm><primary><option>-fno-float-in</option></primary></indexterm> + </term> + <listitem> + <para>Turns off the float-in transformation.</para> + TODO: Maybe document positive cases and remove all negative cases? + </listitem> + </varlistentry> + + <varlistentry> + <term> <option>-fno-full-laziness</option> <indexterm><primary><option>-fno-full-laziness</option></primary></indexterm> </term> - <listitem> - <para>Turns off the full laziness optimisation (also known as - let-floating). Full laziness increases sharing, which can lead - to increased memory residency.</para> + <listitem> + <para>Turns off the full laziness optimisation (also known as + let-floating). Full laziness increases sharing, which can lead + to increased memory residency.</para> + + TODO: Document optimisation <para>NOTE: GHC doesn't implement complete full-laziness. When optimisation in on, and @@ -1847,186 +1911,304 @@ f "2" = 2 implementation would do, the difference is that GHC doesn't consistently apply full-laziness, so don't rely on it.</para> - </listitem> - </varlistentry> + </listitem> + </varlistentry> - <varlistentry> - <term> - <option>-fno-float-in</option> - <indexterm><primary><option>-fno-float-in</option></primary></indexterm> + <varlistentry> + <term> + <option>-fdo-lambda-eta-expansion</option> + <indexterm><primary><option></option></primary></indexterm> </term> - <listitem> - <para>Turns off the float-in transformation.</para> - </listitem> - </varlistentry> + <listitem> + <para> + </para> + TODO: Document optimisation + </listitem> + </varlistentry> - <varlistentry> - <term> - <option>-fno-specialise</option> - <indexterm><primary><option>-fno-specialise</option></primary></indexterm> + <varlistentry> + <term> + <option>-fdo-eta-reduction</option> + <indexterm><primary><option></option></primary></indexterm> + </term> + <listitem> + <para> + </para> + TODO: Document optimisation + </listitem> + </varlistentry> + + <varlistentry> + <term> + <option>-fcase-merge</option> + <indexterm><primary><option></option></primary></indexterm> + </term> + <listitem> + <para> + </para> + TODO: Document optimisation + </listitem> + </varlistentry> + + <varlistentry> + <term> + <option>-fliberate-case</option> + <indexterm><primary><option>-fliberate-case</option></primary></indexterm> + </term> + <listitem> + <para>Turn on the liberate-case transformation.</para> + TODO: Document optimisation + </listitem> + </varlistentry> + + <varlistentry> + <term> + <option>-fdicts-cheap</option> + <indexterm><primary><option></option></primary></indexterm> </term> - <listitem> - <para>Turns off the automatic specialisation of overloaded functions.</para> - </listitem> - </varlistentry> + <listitem> + <para> + </para> + TODO: Document optimisation + </listitem> + </varlistentry> - <varlistentry> - <term> + <varlistentry> + <term> + <option>-feager-blackholing</option> + <indexterm><primary><option></option></primary></indexterm> + </term> + <listitem> + <para> + </para> + TODO: Document optimisation + </listitem> + </varlistentry> + + <varlistentry> + <term> <option>-fno-state-hack</option> <indexterm><primary><option>-fno-state-hack</option></primary></indexterm> </term> - <listitem> - <para>Turn off the "state hack" whereby any lambda with a - <literal>State#</literal> token as argument is considered to be - single-entry, hence it is considered OK to inline things inside - it. This can improve performance of IO and ST monad code, but it - runs the risk of reducing sharing.</para> - </listitem> - </varlistentry> - - <varlistentry> - <term> + <listitem> + <para>Turn off the "state hack" whereby any lambda with a + <literal>State#</literal> token as argument is considered to be + single-entry, hence it is considered OK to inline things inside + it. This can improve performance of IO and ST monad code, but it + runs the risk of reducing sharing.</para> + </listitem> + </varlistentry> + + <varlistentry> + <term> <option>-fpedantic-bottoms</option> <indexterm><primary><option>-fpedantic-bottoms</option></primary></indexterm> </term> - <listitem> - <para>Make GHC be more precise about its treatment of bottom (but see also - <option>-fno-state-hack</option>). In particular, stop GHC - eta-expanding through a case expression, which is good for - performance, but bad if you are using <literal>seq</literal> on - partial applications.</para> - </listitem> - </varlistentry> - - <varlistentry> - <term> - <option>-fomit-interface-pragmas</option> - <indexterm><primary><option>-fomit-interface-pragmas</option></primary></indexterm> - </term> - <listitem> - <para>Tells GHC to omit all inessential information from the interface file - generated for the module being compiled (say M). This means that a module - importing M will see only the <emphasis>types</emphasis> of the functions that M exports, but not - their unfoldings, strictness info, etc. Hence, for example, - no function exported by M will be inlined - into an importing module. The benefit is that modules that import M will - need to be recompiled less often (only when M's exports change their type, - not when they change their implementation). - </para> - </listitem> - </varlistentry> - - <varlistentry> - <term> + <listitem> + <para>Make GHC be more precise about its treatment of bottom (but see also + <option>-fno-state-hack</option>). In particular, stop GHC + eta-expanding through a case expression, which is good for + performance, but bad if you are using <literal>seq</literal> on + partial applications.</para> + </listitem> + </varlistentry> + + <varlistentry> + <term> <option>-fsimpl-tick-factor=<replaceable>n</replaceable></option> <indexterm><primary><option>-fsimpl-tick-factor</option></primary></indexterm> </term> - <listitem> - <para>GHC's optimiser can diverge if you write rewrite rules (<xref linkend="rewrite-rules"/>) - that don't terminate, or (less satisfactorily) if you - code up recursion through data types - (<xref linkend="bugs-ghc"/>). To avoid making the compiler fall into an infinite - loop, the optimiser carries a "tick count" and stops inlining and applying rewrite rules - when this count is exceeded. The limit is set as a multiple of the program size, so - bigger programs get more ticks. The <option>-fsimpl-tick-factor</option> flag lets - you change the multiplier. The default is 100; numbers larger than 100 give more ticks, - and numbers smaller than 100 give fewer.</para> + <listitem> + <para>GHC's optimiser can diverge if you write rewrite rules (<xref linkend="rewrite-rules"/>) + that don't terminate, or (less satisfactorily) if you + code up recursion through data types + (<xref linkend="bugs-ghc"/>). To avoid making the compiler fall into an infinite + loop, the optimiser carries a "tick count" and stops inlining and applying rewrite rules + when this count is exceeded. The limit is set as a multiple of the program size, so + bigger programs get more ticks. The <option>-fsimpl-tick-factor</option> flag lets + you change the multiplier. The default is 100; numbers larger than 100 give more ticks, + and numbers smaller than 100 give fewer.</para> + <para>If the tick-count expires, GHC summarises what simplifier steps it has done; you can use <option>-fddump-simpl-stats</option> to generate a much more detailed list. Usually that identifies the loop quite accurately, because some numbers are very large. - </para> - </listitem> - </varlistentry> + </para> + </listitem> + </varlistentry> - <varlistentry> - <term> - <option>-fstatic-argument-transformation</option> - <indexterm><primary><option>-fstatic-argument-transformation</option></primary></indexterm> + <varlistentry> + <term> + <option>-funfolding-creation-threshold=<replaceable>n</replaceable></option>: + <indexterm><primary><option>-funfolding-creation-threshold</option></primary></indexterm> + <indexterm><primary>inlining, controlling</primary></indexterm> + <indexterm><primary>unfolding, controlling</primary></indexterm> </term> - <listitem> - <para>Turn on the static argument transformation.</para> - </listitem> - </varlistentry> + <listitem> + <para>(Default: 45) Governs the maximum size that GHC will allow a + function unfolding to be. (An unfolding has a “size” + that reflects the cost in terms of “code bloat” of + expanding (aka inlining) that unfolding at a call site. A bigger + function would be assigned a bigger cost.) </para> + + <para>Consequences: (a) nothing larger than this will be + inlined (unless it has an INLINE pragma); (b) nothing + larger than this will be spewed into an interface + file. </para> + + <para>Increasing this figure is more likely to result in longer + compile times than faster code. The + <option>-funfolding-use-threshold</option> is more useful. + </para> + </listitem> + </varlistentry> - <varlistentry> - <term> - <option>-fspec-constr</option> - <indexterm><primary><option>-fspec-constr</option></primary></indexterm> + <varlistentry> + <term> + <option>-funfolding-use-threshold=<replaceable>n</replaceable></option> + <indexterm><primary><option>-funfolding-use-threshold</option></primary></indexterm> + <indexterm><primary>inlining, controlling</primary></indexterm> + <indexterm><primary>unfolding, controlling</primary></indexterm> </term> - <listitem> - <para>Turn on call-pattern specialisation.</para> - </listitem> - </varlistentry> + <listitem> + <para>(Default: 8) This is the magic cut-off figure for unfolding + (aka inlining): below this size, a function definition will be + unfolded at the call-site, any bigger and it won't. The size + computed for a function depends on two things: the actual size of + the expression minus any discounts that + apply (see <option>-funfolding-con-discount</option>).</para> - <varlistentry> - <term> - <option>-funbox-strict-fields</option>: - <indexterm><primary><option>-funbox-strict-fields</option></primary></indexterm> - <indexterm><primary>strict constructor fields</primary></indexterm> - <indexterm><primary>constructor fields, strict</primary></indexterm> + <para>The difference between this and + <option>-funfolding-creation-threshold</option> is that this one + determines if a function definition will be inlined at a call + site. The other option determines if a function definition will + be kept around to begin with for potential inlining.</para> + + TODO: Is above para correct? + </listitem> + </varlistentry> + + <varlistentry> + <term> + <option>-fexpose-all-unfoldings</option> + <indexterm><primary><option></option></primary></indexterm> </term> - <listitem> - <para>This option causes all constructor fields which are - marked strict (i.e. “!”) to be unboxed or - unpacked if possible. It is equivalent to adding an - <literal>UNPACK</literal> pragma to every strict - constructor field (see <xref - linkend="unpack-pragma"/>).</para> - - <para>This option is a bit of a sledgehammer: it might - sometimes make things worse. Selectively unboxing fields - by using <literal>UNPACK</literal> pragmas might be - better. An alternative is to use - <option>-funbox-strict-fields</option> to turn on - unboxing by default but disable it for certain constructor - fields using the <literal>NOUNPACK</literal> pragma - (see <xref linkend="nounpack-pragma"/>). - </para> - </listitem> - </varlistentry> + <listitem> + <para> + </para> + TODO: Document optimisation + </listitem> + </varlistentry> - <varlistentry> - <term> - <option>-funfolding-creation-threshold=<replaceable>n</replaceable></option>: - <indexterm><primary><option>-funfolding-creation-threshold</option></primary></indexterm> - <indexterm><primary>inlining, controlling</primary></indexterm> - <indexterm><primary>unfolding, controlling</primary></indexterm> + <varlistentry> + <term> + <option>-fvectorise</option> + <indexterm><primary><option></option></primary></indexterm> </term> - <listitem> - <para>(Default: 45) Governs the maximum size that GHC will - allow a function unfolding to be. (An unfolding has a - “size” that reflects the cost in terms of - “code bloat” of expanding that unfolding - at a call site. A bigger function would be assigned a - bigger cost.) </para> - - <para> Consequences: (a) nothing larger than this will be - inlined (unless it has an INLINE pragma); (b) nothing - larger than this will be spewed into an interface - file. </para> - - - <para> Increasing this figure is more likely to result in longer - compile times than faster code. The next option is more - useful:</para> - </listitem> - </varlistentry> - - <varlistentry> - <term><option>-funfolding-use-threshold=<replaceable>n</replaceable></option></term> - <listitem> - <indexterm><primary><option>-funfolding-use-threshold</option></primary></indexterm> - <indexterm><primary>inlining, controlling</primary></indexterm> - <indexterm><primary>unfolding, controlling</primary></indexterm> - - <para>(Default: 8) This is the magic cut-off figure for - unfolding: below this size, a function definition will be - unfolded at the call-site, any bigger and it won't. The - size computed for a function depends on two things: the - actual size of the expression minus any discounts that - apply (see <option>-funfolding-con-discount</option>).</para> - </listitem> - </varlistentry> + <listitem> + <para> + </para> + TODO: Document optimisation + </listitem> + </varlistentry> + + <varlistentry> + <term> + <option>-favoid-vect</option> + <indexterm><primary><option></option></primary></indexterm> + </term> + <listitem> + <para> + </para> + TODO: Document optimisation + </listitem> + </varlistentry> + + <varlistentry> + <term> + <option>-fregs-graph</option> + <indexterm><primary><option></option></primary></indexterm> + </term> + <listitem> + <para> + </para> + TODO: Document optimisation + </listitem> + </varlistentry> + + <varlistentry> + <term> + <option>-fregs-iterative</option> + <indexterm><primary><option></option></primary></indexterm> + </term> + <listitem> + <para> + </para> + TODO: Document optimisation + </listitem> + </varlistentry> + + <varlistentry> + <term> + <option>-fexcess-precision</option> + <indexterm><primary><option>-fexcess-precision</option></primary></indexterm> + </term> + <listitem> + <para>When this option is given, intermediate floating + point values can have a <emphasis>greater</emphasis> + precision/range than the final type. Generally this is a + good thing, but some programs may rely on the exact + precision/range of + <literal>Float</literal>/<literal>Double</literal> values + and should not use this option for their compilation.</para> + </listitem> + </varlistentry> + + <varlistentry> + <term> + <option>-fignore-asserts</option> + <indexterm><primary><option>-fignore-asserts</option></primary></indexterm> + </term> + <listitem> + <para>Causes GHC to ignore uses of the function + <literal>Exception.assert</literal> in source code (in + other words, rewriting <literal>Exception.assert p + e</literal> to <literal>e</literal> (see <xref + linkend="assertions"/>). This flag is turned on by + <option>-O</option>. + </para> + </listitem> + </varlistentry> + + <varlistentry> + <term> + <option>-fignore-interface-pragmas</option> + <indexterm><primary><option>-fignore-interface-pragmas</option></primary></indexterm> + </term> + <listitem> + <para>Tells GHC to ignore all inessential information when reading interface files. + That is, even if <filename>M.hi</filename> contains unfolding or strictness information + for a function, GHC will ignore that information.</para> + </listitem> + </varlistentry> + + <varlistentry> + <term> + <option>-fomit-interface-pragmas</option> + <indexterm><primary><option>-fomit-interface-pragmas</option></primary></indexterm> + </term> + <listitem> + <para>Tells GHC to omit all inessential information from the + interface file generated for the module being compiled (say M). + This means that a module importing M will see only the + <emphasis>types</emphasis> of the functions that M exports, but + not their unfoldings, strictness info, etc. Hence, for example, + no function exported by M will be inlined into an importing module. + The benefit is that modules that import M will need to be + recompiled less often (only when M's exports change their type, not + when they change their implementation).</para> + </listitem> + </varlistentry> + </variablelist> </sect2> @@ -2047,7 +2229,7 @@ f "2" = 2 special option or libraries compiled in a certain way. To get access to the support libraries for Concurrent Haskell, just import <ulink - url="&libraryBaseLocation;/Control-Concurrent.html"><literal>Control.Concurrent</literal></ulink>. More information on Concurrent Haskell is provided in the documentation for that module.</para> + url="&libraryBaseLocation;/Control-Concurrent.html"><literal>Control.Concurrent</literal></ulink>. More information on Concurrent Haskell is provided in the documentation for that module.</para> <para> Optionally, the program may be linked with @@ -2083,17 +2265,17 @@ f "2" = 2 <variablelist> <varlistentry> - <term><option>-C<replaceable>s</replaceable></option></term> - <listitem> - <para><indexterm><primary><option>-C<replaceable>s</replaceable></option></primary><secondary>RTS option</secondary></indexterm> - Sets the context switch interval to <replaceable>s</replaceable> - seconds. A context switch will occur at the next heap block - allocation after the timer expires (a heap block allocation occurs - every 4k of allocation). With <option>-C0</option> or - <option>-C</option>, context switches will occur as often as - possible (at every heap block allocation). By default, context - switches occur every 20ms.</para> - </listitem> + <term><option>-C<replaceable>s</replaceable></option></term> + <listitem> + <para><indexterm><primary><option>-C<replaceable>s</replaceable></option></primary><secondary>RTS option</secondary></indexterm> + Sets the context switch interval to <replaceable>s</replaceable> + seconds. A context switch will occur at the next heap block + allocation after the timer expires (a heap block allocation occurs + every 4k of allocation). With <option>-C0</option> or + <option>-C</option>, context switches will occur as often as + possible (at every heap block allocation). By default, context + switches occur every 20ms.</para> + </listitem> </varlistentry> </variablelist> </sect1> @@ -2122,16 +2304,16 @@ f "2" = 2 is also possible to obtain performance improvements with parallelism on programs that do not use concurrency. This section describes how to use GHC to compile and run parallel programs, in <xref - linkend="lang-parallel" /> we describe the language features that affect + linkend="lang-parallel" /> we describe the language features that affect parallelism.</para> <sect2 id="parallel-compile-options"> <title>Compile-time options for SMP parallelism</title> <para>In order to make use of multiple CPUs, your program must be - linked with the <option>-threaded</option> option (see <xref - linkend="options-linker" />). Additionally, the following - compiler options affect parallelism:</para> + linked with the <option>-threaded</option> option (see <xref + linkend="options-linker" />). Additionally, the following + compiler options affect parallelism:</para> <variablelist> <varlistentry> @@ -2179,18 +2361,18 @@ f "2" = 2 program, or use the RTS <option>-N</option> option.</para> <variablelist> - <varlistentry> - <term><option>-N<optional><replaceable>x</replaceable></optional></option></term> - <listitem> - <para><indexterm><primary><option>-N<replaceable>x</replaceable></option></primary><secondary>RTS option</secondary></indexterm> - Use <replaceable>x</replaceable> simultaneous threads when - running the program. Normally <replaceable>x</replaceable> - should be chosen to match the number of CPU cores on the - machine<footnote><para>Whether hyperthreading cores should be counted or not is an - open question; please feel free to experiment and let us know what - results you find.</para></footnote>. For example, - on a dual-core machine we would probably use - <literal>+RTS -N2 -RTS</literal>.</para> + <varlistentry> + <term><option>-N<optional><replaceable>x</replaceable></optional></option></term> + <listitem> + <para><indexterm><primary><option>-N<replaceable>x</replaceable></option></primary><secondary>RTS option</secondary></indexterm> + Use <replaceable>x</replaceable> simultaneous threads when + running the program. Normally <replaceable>x</replaceable> + should be chosen to match the number of CPU cores on the + machine<footnote><para>Whether hyperthreading cores should be counted or not is an + open question; please feel free to experiment and let us know what + results you find.</para></footnote>. For example, + on a dual-core machine we would probably use + <literal>+RTS -N2 -RTS</literal>.</para> <para>Omitting <replaceable>x</replaceable>, i.e. <literal>+RTS -N -RTS</literal>, lets the runtime @@ -2211,30 +2393,30 @@ f "2" = 2 via <literal>Control.Concurrent.getNumCapabilities</literal>, and it may be changed while the program is running by calling <literal>Control.Concurrent.setNumCapabilities</literal>.</para> - </listitem> - </varlistentry> + </listitem> + </varlistentry> </variablelist> <para>The following options affect the way the runtime schedules threads on CPUs:</para> <variablelist> - <varlistentry> - <term><option>-qa</option></term> + <varlistentry> + <term><option>-qa</option></term> <indexterm><primary><option>-qa</option></primary><secondary>RTS option</secondary></indexterm> - <listitem> + <listitem> <para>Use the OS's affinity facilities to try to pin OS threads to CPU cores. This is an experimental feature, and may or may not be useful. Please let us know whether it helps for you!</para> </listitem> </varlistentry> - <varlistentry> - <term><option>-qm</option></term> + <varlistentry> + <term><option>-qm</option></term> <indexterm><primary><option>-qm</option></primary><secondary>RTS option</secondary></indexterm> - <listitem> + <listitem> <para>Disable automatic migration for load balancing. Normally the runtime will automatically try to schedule threads across the available CPUs to make use of idle @@ -2257,12 +2439,12 @@ f "2" = 2 <title>Hints for using SMP parallelism</title> <para>Add the <literal>-s</literal> RTS option when - running the program to see timing stats, which will help to tell you - whether your program got faster by using more CPUs or not. If the user - time is greater than - the elapsed time, then the program used more than one CPU. You should - also run the program without <literal>-N</literal> for - comparison.</para> + running the program to see timing stats, which will help to tell you + whether your program got faster by using more CPUs or not. If the user + time is greater than + the elapsed time, then the program used more than one CPU. You should + also run the program without <literal>-N</literal> for + comparison.</para> <para>The output of <literal>+RTS -s</literal> tells you how many “sparks” were created and executed during the @@ -2291,19 +2473,19 @@ f "2" = 2 <variablelist> <varlistentry> - <term><option>-msse2</option>:</term> - <listitem> + <term><option>-msse2</option>:</term> + <listitem> <para> - (x86 only, added in GHC 7.0.1) Use the SSE2 registers and - instruction set to implement floating point operations when using - the <link linkend="native-code-gen">native code generator</link>. - This gives a substantial performance improvement for floating - point, but the resulting compiled code - will only run on processors that support SSE2 (Intel Pentium 4 and - later, or AMD Athlon 64 and later). The - <link linkend="llvm-code-gen">LLVM backend</link> will also use SSE2 - if your processor supports it but detects this automatically so no - flag is required. + (x86 only, added in GHC 7.0.1) Use the SSE2 registers and + instruction set to implement floating point operations when using + the <link linkend="native-code-gen">native code generator</link>. + This gives a substantial performance improvement for floating + point, but the resulting compiled code + will only run on processors that support SSE2 (Intel Pentium 4 and + later, or AMD Athlon 64 and later). The + <link linkend="llvm-code-gen">LLVM backend</link> will also use SSE2 + if your processor supports it but detects this automatically so no + flag is required. </para> <para> SSE2 is unconditionally used on x86-64 platforms. @@ -2312,17 +2494,17 @@ f "2" = 2 </varlistentry> <varlistentry> - <term><option>-msse4.2</option>:</term> - <listitem> + <term><option>-msse4.2</option>:</term> + <listitem> <para> - (x86 only, added in GHC 7.4.1) Use the SSE4.2 instruction set to - implement some floating point and bit operations when using the - <link linkend="native-code-gen">native code generator</link>. The - resulting compiled code will only run on processors that - support SSE4.2 (Intel Core i7 and later). The - <link linkend="llvm-code-gen">LLVM backend</link> will also use - SSE4.2 if your processor supports it but detects this automatically - so no flag is required. + (x86 only, added in GHC 7.4.1) Use the SSE4.2 instruction set to + implement some floating point and bit operations when using the + <link linkend="native-code-gen">native code generator</link>. The + resulting compiled code will only run on processors that + support SSE4.2 (Intel Core i7 and later). The + <link linkend="llvm-code-gen">LLVM backend</link> will also use + SSE4.2 if your processor supports it but detects this automatically + so no flag is required. </para> </listitem> </varlistentry> @@ -2354,15 +2536,15 @@ f "2" = 2 <variablelist> - <varlistentry> - <term> + <varlistentry> + <term> <option>-fext-core</option> <indexterm><primary><option>-fext-core</option></primary></indexterm> </term> - <listitem> - <para>Generate <literal>.hcr</literal> files.</para> - </listitem> - </varlistentry> + <listitem> + <para>Generate <literal>.hcr</literal> files.</para> + </listitem> + </varlistentry> </variablelist> diff --git a/docs/vh/vh.xml b/docs/vh/vh.xml index 0e0f8f55a0..5c25e3109c 100644 --- a/docs/vh/vh.xml +++ b/docs/vh/vh.xml @@ -2,318 +2,311 @@ <!DOCTYPE article PUBLIC "-//OASIS//DTD DocBook XML V4.5//EN" "http://www.oasis-open.org/docbook/xml/4.5/docbookx.dtd" [ ]> - - <article id="visual-haskell"> - - <articleinfo> - - <title>Visual Haskell User's Guide</title> - <author> - <firstname>Simon</firstname> - <surname>Marlow</surname> - <email>simonmar@microsoft.com</email> - </author> - <author> - <firstname>Krasimir</firstname> - <surname>Angelov</surname> - <email>kr.angelov@gmail.com</email> - </author> - -<!-- - <abstract> - <para></para> - </abstract> ---> - - </articleinfo> - - <section id="sec-introduction"> - <title>Introduction</title> - - <para>Visual Haskell is a plugin for Microsoft's Visual Studio - development environment to support development of Haskell software. - Like the other Visual languages, Visual Haskell integrates with the - Visual Studio editor to provide interactive features to aid Haskell - development, and it enables the construction of projects consisting of - multiple Haskell modules.</para> - - <section id="sec-obtaining"> - <title>Installing Visual Haskell</title> - - <para>In order to use Visual Haskell, you need <ulink url="http://msdn.microsoft.com/vstudio/productinfo/">Visual Studio .NET - 2003</ulink>. Right now, this is the only supported version of Visual - Studio - unfortunately we haven't yet added support for the 2005 - Beta. The Express languages (Visual C++ Express etc.) also will not - work, because they don't have support for plugins.</para> - - <para>You don't need to install GHC separately: Visual Haskell - is bundled with a complete GHC distribution, and various other tools - (Happy, Alex, Haddock).</para> - - <para>The latest Visual Haskell installer can be obtained from - here:</para> - - <para><ulink - url="http://www.haskell.org/visualhaskell/"><literal>http://www.haskell.org/visualhaskell/</literal></ulink></para> - </section> - - <section id="release-notes"> - <title>Release Notes</title> - - <section> - <title>Version 0.0, first release</title> - - <para>This release is a technology preview, and should be considered - alpha quality. It works for us, but you are fairly likely to - encounter problems. If you're willing to try it out and report - bugs, we'd be grateful for the feedback.</para> - - <itemizedlist> - <listitem> - <para>This release of Visual Haskell is bundled with a - development snapshot of GHC, version 6.5 from around 14 - September 2005. This version of GHC is used to provide the - interactive editing features, and will be used to compile all - code inside Visual Haskell. It is possible that in future - releases we may be able to relax this tight coupling between - Visual Haskell and the bundled GHC.</para> - - <para>Please note that future releases of Visual - Haskell will update the compiler, and hence the - packages, and so may break your code. Also note that because - the bundled GHC is not a released version, it may have bugs and - quirks itself: please report them as usual to - <email>glasgow-haskell-bugs@haskell.org</email>.</para> - </listitem> - - <listitem> - <para>We're not making source code for the plugin generally - available at this time, due to licensing restrictions on the - Visual Studio APIs that the plugin uses (for more - information see <ulink - url="http://msdn.microsoft.com/vstudio/extend/">Visual Studio - Extensibility Center</ulink>). If you're interested in - contributing to Visual Haskell, please get in touch with the - authors.</para> - </listitem> - </itemizedlist> - </section> +<article id="visual-haskell"> + + <articleinfo> + + <title>Visual Haskell User's Guide</title> + <author> + <firstname>Simon</firstname> + <surname>Marlow</surname> + <email>simonmar@microsoft.com</email> + </author> + <author> + <firstname>Krasimir</firstname> + <surname>Angelov</surname> + <email>kr.angelov@gmail.com</email> + </author> + + </articleinfo> + + <section id="sec-introduction"> + <title>Introduction</title> + + <para>Visual Haskell is a plugin for Microsoft's Visual Studio + development environment to support development of Haskell software. + Like the other Visual languages, Visual Haskell integrates with the + Visual Studio editor to provide interactive features to aid Haskell + development, and it enables the construction of projects consisting of + multiple Haskell modules.</para> + + <section id="sec-obtaining"> + <title>Installing Visual Haskell</title> + + <para>In order to use Visual Haskell, you need <ulink url="http://msdn.microsoft.com/vstudio/productinfo/">Visual Studio .NET + 2003</ulink>. Right now, this is the only supported version of Visual + Studio - unfortunately we haven't yet added support for the 2005 + Beta. The Express languages (Visual C++ Express etc.) also will not + work, because they don't have support for plugins.</para> + + <para>You don't need to install GHC separately: Visual Haskell + is bundled with a complete GHC distribution, and various other tools + (Happy, Alex, Haddock).</para> + + <para>The latest Visual Haskell installer can be obtained from + here:</para> + + <para><ulink + url="http://www.haskell.org/visualhaskell/"><literal>http://www.haskell.org/visualhaskell/</literal></ulink></para> </section> - <section id="sec-bugs"> - <title>Getting support, reporting bugs</title> - <para>Please report bugs to - <email>glasgow-haskell-bugs@haskell.org</email> (subscribe <ulink url="http://www.haskell.org/mailman/listinfo/glasgow-haskell-bugs">here</ulink>), clearly indicating - that your bug report relates to Visual Haskell, and giving as much - information as possible so that we can reproduce the bug. Even if - you can't reproduce the bug reliably, it is still useful to report - what you've seen.</para> - - <para>For help and support, use the - <email>glasgow-haskell-users@haskell.org</email> (subscribe <ulink - url="http://www.haskell.org/mailman/listinfo/glasgow-haskell-users">here</ulink>) mailing list.</para> - </section> - - <section id="sec-license"> - <title>License</title> - - <blockquote> - <para>Copyright © Microsoft Corporation. All rights reserved.</para> - <para>Copyright © The University of Glasgow. All rights reserved.</para> - <para>Copyright © Krasimir Angelov. All rights reserved.</para> - - <para>Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions - are met:</para> - - <itemizedlist> - <listitem> - <para>Redistributions of source code must retain the above - copyright notice, this list of conditions and the following - disclaimer.</para> - </listitem> - - <listitem> - <para>Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution.</para> - </listitem> - - <listitem> - <para>The names of the copyright holders may not be used to endorse - or promote products derived from this software without specific - prior written permission.</para> - </listitem> - </itemizedlist> - - <para>THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS - "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT - LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS - FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE - COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, - SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT - LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF - USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED - AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN - ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE - POSSIBILITY OF SUCH DAMAGE.</para> - </blockquote> - </section> + <section id="release-notes"> + <title>Release Notes</title> + <section> + <title>Version 0.0, first release</title> + + <para>This release is a technology preview, and should be considered + alpha quality. It works for us, but you are fairly likely to + encounter problems. If you're willing to try it out and report + bugs, we'd be grateful for the feedback.</para> + + <itemizedlist> + <listitem> + <para>This release of Visual Haskell is bundled with a + development snapshot of GHC, version 6.5 from around 14 + September 2005. This version of GHC is used to provide the + interactive editing features, and will be used to compile all + code inside Visual Haskell. It is possible that in future + releases we may be able to relax this tight coupling between + Visual Haskell and the bundled GHC.</para> + + <para>Please note that future releases of Visual + Haskell will update the compiler, and hence the + packages, and so may break your code. Also note that because + the bundled GHC is not a released version, it may have bugs and + quirks itself: please report them as usual to + <email>glasgow-haskell-bugs@haskell.org</email>.</para> + </listitem> + + <listitem> + <para>We're not making source code for the plugin generally + available at this time, due to licensing restrictions on the + Visual Studio APIs that the plugin uses (for more + information see <ulink + url="http://msdn.microsoft.com/vstudio/extend/">Visual Studio + Extensibility Center</ulink>). If you're interested in + contributing to Visual Haskell, please get in touch with the + authors.</para> + </listitem> + </itemizedlist> + </section> + </section> + + <section id="sec-bugs"> + <title>Getting support, reporting bugs</title> + <para>Please report bugs to + <email>glasgow-haskell-bugs@haskell.org</email> (subscribe <ulink url="http://www.haskell.org/mailman/listinfo/glasgow-haskell-bugs">here</ulink>), clearly indicating + that your bug report relates to Visual Haskell, and giving as much + information as possible so that we can reproduce the bug. Even if + you can't reproduce the bug reliably, it is still useful to report + what you've seen.</para> + + <para>For help and support, use the + <email>glasgow-haskell-users@haskell.org</email> (subscribe <ulink + url="http://www.haskell.org/mailman/listinfo/glasgow-haskell-users">here</ulink>) mailing list.</para> </section> - <section id="sec-using"> - <title>Using Visual Haskell</title> + <section id="sec-license"> + <title>License</title> - <section> - <title>Overview of features</title> - - <para>The following features are provided in the Visual Studio editor - when editing Haskell code:</para> - - <itemizedlist> - <listitem> - <para>Automatic checking of code as you type, and visual indication - of parse errors, scoping errors and type errors.</para> - </listitem> - - <listitem> - <para>Quick info: hovering the mouse over an identifier pops up - an information box, including the type of the identifier.</para> - </listitem> - - <listitem> - <para>A drop-down bar at the top of the editing window lists the - top-level declarations in the module, and allows quick navigation - to a declaration.</para> - </listitem> - - <listitem> - <para>Name completion for identifiers in scope: press Ctrl+Space - after a partial identifier to see the completions.</para> - </listitem> - - <listitem> - <para>Go to declaration: right clicking on an identifier and - selecting "Go to declaration" will jump the cursor to the - declaration of the identifier. This works for locally-defined - identifiers and those defined in another module of the project; it - does not work for library functions currently.</para> - </listitem> - </itemizedlist> - - <para>The following features are provided by the project system for - constructing Haskell projects:</para> + <blockquote> + <para>Copyright © Microsoft Corporation. All rights reserved.</para> + <para>Copyright © The University of Glasgow. All rights reserved.</para> + <para>Copyright © Krasimir Angelov. All rights reserved.</para> - <itemizedlist> - <listitem> - <para>Multi-module Haskell projects are fully supported, based on the - <ulink url="http://www.haskell.org/cabal">Cabal</ulink> - infrastructure. A project in Visual Haskell <emphasis>is</emphasis> - a Cabal package, and vice-versa. A Visual Studio project can be - taken to a machine without Visual Haskell and built/installed as a - normal Cabal package, and an existing Cabal package can be edited - directly in Visual Haskell<footnote><para>This works as long as the - Cabal package is using Cabal's simple build system; Cabal - packages using their own build systems cannot be edited in Visual - Haskell.</para> - </footnote>.</para> - </listitem> - - <listitem> - <para>Editing of most of the package meta-data is supported through - the project property pages.</para> - </listitem> - - <listitem> - <para>The interactive editing features work across multiple modules in - a project. When one module is edited, changes are automatically - propagated to dependent modules, even if the edited module has not yet - been saved.</para> - </listitem> - - <listitem> - <para>Building is supported through the Cabal build system, and build - errors are communicated back to the editor and placed in the task - list. Use any of the Visual Studio build commands (e.g. Build - Project from the context menu on the project, or Ctrl-Shift-B to - build the whole solution).</para> - </listitem> + <para>Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met:</para> + <itemizedlist> + <listitem> + <para>Redistributions of source code must retain the above + copyright notice, this list of conditions and the following + disclaimer.</para> + </listitem> + + <listitem> + <para>Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution.</para> + </listitem> + + <listitem> + <para>The names of the copyright holders may not be used to endorse + or promote products derived from this software without specific + prior written permission.</para> + </listitem> </itemizedlist> - - <para>Additionally, Visual Haskell is bundled with a large collection of - documentation: the GHC manual, the hierarchical libraries reference, and - other material all of which can be browsed within Visual Studio - itself.</para> - </section> - <section> - <title>Getting Started</title> - - <para>After installing Visual Haskell, start up Visual Studio as you - would normally, and observe that on the splash screen where it lists - the supported languages you should now see an icon for Visual - Haskell (if you don't see this, something has gone wrong... please let - us know).</para> - - <para>Firstly, take a look at the bundled documentation. Go to - Help->Contents, and you should see the “Visual Haskell Help - Collection”, which contains a large collection of GHC and - Haskell-related documentaiton, including this document.</para> - - <para>To start using Visual Haskell right away, create a new - project (File->New->Project...). Select one of the Haskell - project types (Console Application or Library Package), and hit Ok. - The project will be created for you, and an example module - added: <literal>Main.hs</literal> for an application, or - <literal>Module1.hs</literal> for a library.</para> - - <para>You can now start adding code to - <literal>Main.hs</literal>, or adding new modules. To add a new - module, right-click on the <literal>src</literal> directory, and - select Add->New Item. Visual Haskell supports hierarchical - modules too: you can add new folders using the same Add menu to - create new nodes in the hierarchy.</para> - - <para>If you have any errors in your code, they will be underlined with - a red squiggly line. Select the Tasks window (usually a tab near the - bottom of the Visual Studio window) to see the error messages, and - click on an error message to jump to it in the editor.</para> - - <para>To build the program, hit Ctrl-Shift-B, or select one of the - options from the Build menu.</para> - </section> + <para>THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS + FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE + COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT + LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF + USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED + AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN + ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + POSSIBILITY OF SUCH DAMAGE.</para> + </blockquote> + </section> + + </section> + + <section id="sec-using"> + <title>Using Visual Haskell</title> <section> - <title>Editing Haskell code</title> - - <para>(ToDo: more detail here)</para> - - <para>Your module must be plain Haskell (<literal>.hs</literal>) for the interactive features to - fully work. If your module is pre-processed with CPP or Literate - Haskell, then Visual Haskell will only check the module when it is - saved; between saves the source will not be checked for errors and - the type information will not be updated. If the source file is - pre-processed with Happy or another pre-processor, then you may have - to build the project before the type information will be updated - (because the pre-processor is only run as part of the build - process). Pre-processed source files work fine in a multi-module - setting; you can have modules which depend on a pre-processed module - and full interactive checking will still be available in those - modules.</para> - - <para>Because Visual Haskell is using GHC as a backend for its - interactive editing features, it supports the full GHC language, - including all extensions.</para> - </section> + <title>Overview of features</title> - <section> - <title>Using Projects</title> - <para>(ToDo: more detail here)</para> - </section> + <para>The following features are provided in the Visual Studio editor + when editing Haskell code:</para> + + <itemizedlist> + <listitem> + <para>Automatic checking of code as you type, and visual indication + of parse errors, scoping errors and type errors.</para> + </listitem> + + <listitem> + <para>Quick info: hovering the mouse over an identifier pops up + an information box, including the type of the identifier.</para> + </listitem> + + <listitem> + <para>A drop-down bar at the top of the editing window lists the + top-level declarations in the module, and allows quick navigation + to a declaration.</para> + </listitem> + + <listitem> + <para>Name completion for identifiers in scope: press Ctrl+Space + after a partial identifier to see the completions.</para> + </listitem> + + <listitem> + <para>Go to declaration: right clicking on an identifier and + selecting "Go to declaration" will jump the cursor to the + declaration of the identifier. This works for locally-defined + identifiers and those defined in another module of the project; it + does not work for library functions currently.</para> + </listitem> + </itemizedlist> + <para>The following features are provided by the project system for + constructing Haskell projects:</para> + + <itemizedlist> + <listitem> + <para>Multi-module Haskell projects are fully supported, based on the + <ulink url="http://www.haskell.org/cabal">Cabal</ulink> + infrastructure. A project in Visual Haskell <emphasis>is</emphasis> + a Cabal package, and vice-versa. A Visual Studio project can be + taken to a machine without Visual Haskell and built/installed as a + normal Cabal package, and an existing Cabal package can be edited + directly in Visual Haskell<footnote><para>This works as long as the + Cabal package is using Cabal's simple build system; Cabal + packages using their own build systems cannot be edited in Visual + Haskell.</para> + </footnote>.</para> + </listitem> + + <listitem> + <para>Editing of most of the package meta-data is supported through + the project property pages.</para> + </listitem> + + <listitem> + <para>The interactive editing features work across multiple modules in + a project. When one module is edited, changes are automatically + propagated to dependent modules, even if the edited module has not yet + been saved.</para> + </listitem> + + <listitem> + <para>Building is supported through the Cabal build system, and build + errors are communicated back to the editor and placed in the task + list. Use any of the Visual Studio build commands (e.g. Build + Project from the context menu on the project, or Ctrl-Shift-B to + build the whole solution).</para> + </listitem> + + </itemizedlist> + + <para>Additionally, Visual Haskell is bundled with a large collection of + documentation: the GHC manual, the hierarchical libraries reference, and + other material all of which can be browsed within Visual Studio + itself.</para> + </section> + + <section> + <title>Getting Started</title> + + <para>After installing Visual Haskell, start up Visual Studio as you + would normally, and observe that on the splash screen where it lists + the supported languages you should now see an icon for Visual + Haskell (if you don't see this, something has gone wrong... please let + us know).</para> + + <para>Firstly, take a look at the bundled documentation. Go to + Help->Contents, and you should see the “Visual Haskell Help + Collection”, which contains a large collection of GHC and + Haskell-related documentaiton, including this document.</para> + + <para>To start using Visual Haskell right away, create a new + project (File->New->Project...). Select one of the Haskell + project types (Console Application or Library Package), and hit Ok. + The project will be created for you, and an example module + added: <literal>Main.hs</literal> for an application, or + <literal>Module1.hs</literal> for a library.</para> + + <para>You can now start adding code to + <literal>Main.hs</literal>, or adding new modules. To add a new + module, right-click on the <literal>src</literal> directory, and + select Add->New Item. Visual Haskell supports hierarchical + modules too: you can add new folders using the same Add menu to + create new nodes in the hierarchy.</para> + + <para>If you have any errors in your code, they will be underlined with + a red squiggly line. Select the Tasks window (usually a tab near the + bottom of the Visual Studio window) to see the error messages, and + click on an error message to jump to it in the editor.</para> + + <para>To build the program, hit Ctrl-Shift-B, or select one of the + options from the Build menu.</para> + </section> + + <section> + <title>Editing Haskell code</title> + + <para>(ToDo: more detail here)</para> + + <para>Your module must be plain Haskell (<literal>.hs</literal>) for + the interactive features to fully work. If your module is + pre-processed with CPP or Literate Haskell, then Visual Haskell will + only check the module when it is saved; between saves the source will + not be checked for errors and the type information will not be + updated. If the source file is + pre-processed with Happy or another pre-processor, then you may have + to build the project before the type information will be updated + (because the pre-processor is only run as part of the build process). + Pre-processed source files work fine in a multi-module setting; you + can have modules which depend on a pre-processed module and full + interactive checking will still be available in those modules.</para> + + <para>Because Visual Haskell is using GHC as a backend for its + interactive editing features, it supports the full GHC language, + including all extensions.</para> </section> - </article> + + <section> + <title>Using Projects</title> + <para>(ToDo: more detail here)</para> + </section> + + </section> +</article> diff --git a/driver/ghci/ghc.mk b/driver/ghci/ghc.mk index 51203ab4d5..88c6aafeca 100644 --- a/driver/ghci/ghc.mk +++ b/driver/ghci/ghc.mk @@ -34,14 +34,14 @@ driver/ghci_dist_PROG = ghci$(exeext) driver/ghci_dist_INSTALL = YES driver/ghci_dist_OTHER_OBJS = driver/ghci/ghci.res -$(eval $(call build-prog,driver/ghci,dist,0)) +$(eval $(call build-prog,driver/ghci,dist,1)) driver/ghci_dist_PROG_VER = ghci-$(ProjectVersion)$(exeext) INSTALL_BINS += driver/ghci/dist/build/tmp/$(driver/ghci_dist_PROG_VER) driver/ghci/ghci.res : driver/ghci/ghci.rc driver/ghci/ghci.ico - $(INPLACE_MINGW)/bin/windres --preprocessor="$(CPP) -xc -DRC_INVOKED" -o driver/ghci/ghci.res -i driver/ghci/ghci.rc -O coff + "$(WINDRES)" --preprocessor="$(CPP) -xc -DRC_INVOKED" -o driver/ghci/ghci.res -i driver/ghci/ghci.rc -O coff driver/ghci/dist/build/tmp/$(driver/ghci_dist_PROG_VER) : driver/ghci/dist/build/tmp/$(driver/ghci_dist_PROG) "$(CP)" $< $@ diff --git a/driver/utils/cwrapper.c b/driver/utils/cwrapper.c index 911290224c..5105924b74 100644 --- a/driver/utils/cwrapper.c +++ b/driver/utils/cwrapper.c @@ -31,7 +31,7 @@ char *mkString(const char *fmt, ...) { va_end(argp); if (i < 0) { - die("snprintf 0 failed: errno %d: %s\n", errno, strerror(errno)); + die("vsnprintf 0 failed: errno %d: %s\n", errno, strerror(errno)); } p = malloc(i + 1); @@ -42,8 +42,8 @@ char *mkString(const char *fmt, ...) { va_start(argp, fmt); j = vsnprintf(p, i + 1, fmt, argp); va_end(argp); - if (i < 0) { - die("snprintf with %d failed: errno %d: %s\n", + if (j < 0) { + die("vsnprintf with %d failed: errno %d: %s\n", i + 1, errno, strerror(errno)); } diff --git a/ghc/GhciTags.hs b/ghc/GhciTags.hs index a3ad646309..d37b93fb3f 100644 --- a/ghc/GhciTags.hs +++ b/ghc/GhciTags.hs @@ -6,13 +6,6 @@ -- ----------------------------------------------------------------------------- -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSp --- for details - {-# OPTIONS_GHC -fno-warn-name-shadowing #-} module GhciTags ( createCTagsWithLineNumbersCmd, @@ -65,12 +58,12 @@ ghciCreateTagsFile kind file = do createTagsFile kind file -- ToDo: --- - remove restriction that all modules must be interpreted --- (problem: we don't know source locations for entities unless --- we compiled the module. +-- - remove restriction that all modules must be interpreted +-- (problem: we don't know source locations for entities unless +-- we compiled the module. -- --- - extract createTagsFile so it can be used from the command-line --- (probably need to fix first problem before this is useful). +-- - extract createTagsFile so it can be used from the command-line +-- (probably need to fix first problem before this is useful). -- createTagsFile :: TagsKind -> FilePath -> GHCi () createTagsFile tagskind tagsFile = do diff --git a/ghc/ghc.mk b/ghc/ghc.mk index ede5687dc6..a13f03b875 100644 --- a/ghc/ghc.mk +++ b/ghc/ghc.mk @@ -22,6 +22,15 @@ ghc_stage2_CONFIGURE_OPTS += --flags=ghci ghc_stage3_CONFIGURE_OPTS += --flags=ghci endif +ifeq "$(compiler_stage1_VERSION_MUNGED)" "YES" +# If we munge the stage1 version, and we're using a devel snapshot for +# stage0, then stage1 may actually have an earlier version than stage0 +# (e.g. boot with ghc-7.5.20120316, building ghc-7.5). We therefore +# need to tell Cabal to use version 7.5 of the ghc package when building +# in ghc/stage1 +ghc_stage1_CONFIGURE_OPTS += --constraint "ghc == $(compiler_stage1_MUNGED_VERSION)" +endif + ghc_stage1_MORE_HC_OPTS = $(GhcStage1HcOpts) ghc_stage2_MORE_HC_OPTS = $(GhcStage2HcOpts) ghc_stage3_MORE_HC_OPTS = $(GhcStage3HcOpts) diff --git a/includes/Cmm.h b/includes/Cmm.h index 11c02b4e3e..f582ca9771 100644 --- a/includes/Cmm.h +++ b/includes/Cmm.h @@ -383,7 +383,7 @@ // allocate() - this includes many of the primops. #define MAYBE_GC(liveness,reentry) \ if (bdescr_link(CurrentNursery) == NULL || \ - generation_n_new_large_words(W_[g0]) >= CLong[large_alloc_lim]) { \ + generation_n_new_large_words(W_[g0]) >= TO_W_(CLong[large_alloc_lim])) { \ R9 = liveness; \ R10 = reentry; \ HpAlloc = 0; \ diff --git a/includes/HaskellConstants.hs b/includes/HaskellConstants.hs index e38e896ba0..fc541c58b7 100644 --- a/includes/HaskellConstants.hs +++ b/includes/HaskellConstants.hs @@ -54,7 +54,7 @@ mAX_SPEC_AP_SIZE = MAX_SPEC_AP_SIZE mIN_PAYLOAD_SIZE ::Int mIN_PAYLOAD_SIZE = MIN_PAYLOAD_SIZE -mIN_INTLIKE, mAX_INTLIKE :: Int +mIN_INTLIKE, mAX_INTLIKE :: Int mIN_INTLIKE = MIN_INTLIKE mAX_INTLIKE = MAX_INTLIKE @@ -68,7 +68,7 @@ mUT_ARR_PTRS_CARD_BITS = MUT_ARR_PTRS_CARD_BITS -- A section of code-generator-related MAGIC CONSTANTS. mAX_Vanilla_REG :: Int -mAX_Vanilla_REG = MAX_VANILLA_REG +mAX_Vanilla_REG = MAX_VANILLA_REG mAX_Float_REG :: Int mAX_Float_REG = MAX_FLOAT_REG @@ -86,7 +86,7 @@ mAX_Real_Float_REG :: Int mAX_Real_Float_REG = MAX_REAL_FLOAT_REG mAX_Real_Double_REG :: Int -mAX_Real_Double_REG = MAX_REAL_DOUBLE_REG +mAX_Real_Double_REG = MAX_REAL_DOUBLE_REG mAX_Real_Long_REG :: Int #ifdef MAX_REAL_LONG_REG @@ -176,6 +176,12 @@ mAX_PTR_TAG = tAG_MASK cINT_SIZE :: Int cINT_SIZE = SIZEOF_INT +cLONG_SIZE :: Int +cLONG_SIZE = SIZEOF_LONG + +cLONG_LONG_SIZE :: Int +cLONG_LONG_SIZE = SIZEOF_LONG_LONG + -- Size of a storage manager block (in bytes). bLOCK_SIZE :: Int diff --git a/includes/MachDeps.h b/includes/MachDeps.h index f97d3e87d4..24c1e32362 100644 --- a/includes/MachDeps.h +++ b/includes/MachDeps.h @@ -47,14 +47,14 @@ #define SIZEOF_HSINT SIZEOF_VOID_P #define ALIGNMENT_HSINT ALIGNMENT_VOID_P -#define SIZEOF_HSWORD SIZEOF_VOID_P -#define ALIGNMENT_HSWORD ALIGNMENT_VOID_P +#define SIZEOF_HSWORD SIZEOF_VOID_P +#define ALIGNMENT_HSWORD ALIGNMENT_VOID_P -#define SIZEOF_HSDOUBLE SIZEOF_DOUBLE -#define ALIGNMENT_HSDOUBLE ALIGNMENT_DOUBLE +#define SIZEOF_HSDOUBLE SIZEOF_DOUBLE +#define ALIGNMENT_HSDOUBLE ALIGNMENT_DOUBLE -#define SIZEOF_HSFLOAT SIZEOF_FLOAT -#define ALIGNMENT_HSFLOAT ALIGNMENT_FLOAT +#define SIZEOF_HSFLOAT SIZEOF_FLOAT +#define ALIGNMENT_HSFLOAT ALIGNMENT_FLOAT #define SIZEOF_HSPTR SIZEOF_VOID_P #define ALIGNMENT_HSPTR ALIGNMENT_VOID_P @@ -83,19 +83,18 @@ #define SIZEOF_WORD32 SIZEOF_UNSIGNED_INT #define ALIGNMENT_WORD32 ALIGNMENT_UNSIGNED_INT -#if HAVE_LONG_LONG && SIZEOF_VOID_P < 8 -/* assume long long is 64 bits */ -#define SIZEOF_INT64 SIZEOF_LONG_LONG -#define ALIGNMENT_INT64 ALIGNMENT_LONG_LONG -#define SIZEOF_WORD64 SIZEOF_UNSIGNED_LONG_LONG -#define ALIGNMENT_WORD64 ALIGNMENT_UNSIGNED_LONG_LONG -#elif SIZEOF_LONG == 8 +#if SIZEOF_LONG == 8 #define SIZEOF_INT64 SIZEOF_LONG #define ALIGNMENT_INT64 ALIGNMENT_LONG #define SIZEOF_WORD64 SIZEOF_UNSIGNED_LONG #define ALIGNMENT_WORD64 ALIGNMENT_UNSIGNED_LONG +#elif HAVE_LONG_LONG && SIZEOF_LONG_LONG == 8 +#define SIZEOF_INT64 SIZEOF_LONG_LONG +#define ALIGNMENT_INT64 ALIGNMENT_LONG_LONG +#define SIZEOF_WORD64 SIZEOF_UNSIGNED_LONG_LONG +#define ALIGNMENT_WORD64 ALIGNMENT_UNSIGNED_LONG_LONG #else -#error GHC untested on this architecture: sizeof(void *) < 8 and no long longs. +#error Cannot find a 64bit type. #endif #ifndef WORD_SIZE_IN_BITS diff --git a/includes/Rts.h b/includes/Rts.h index 3360eda323..c1f4f05bea 100644 --- a/includes/Rts.h +++ b/includes/Rts.h @@ -17,6 +17,13 @@ extern "C" { #endif +/* We include windows.h very early, as on Win64 the CONTEXT type has + fields "R8", "R9" and "R10", which goes bad if we've already + #define'd those names for our own purposes (in stg/Regs.h) */ +#if defined(HAVE_WINDOWS_H) +#include <windows.h> +#endif + #ifndef IN_STG_CODE #define IN_STG_CODE 0 #endif @@ -136,6 +143,24 @@ void _assertFail(const char *filename, unsigned int linenum) #define USED_IF_NOT_THREADS #endif +#if SIZEOF_VOID_P == 8 +# if SIZEOF_LONG == 8 +# define FMT_SizeT "lu" +# elif SIZEOF_LONG_LONG == 8 +# define FMT_SizeT "llu" +# else +# error Cannot find format specifier for size_t size type +# endif +#elif SIZEOF_VOID_P == 4 +# if SIZEOF_INT == 4 +# define FMT_SizeT "u" +# else +# error Cannot find format specifier for size_t size type +# endif +#else +# error Cannot handle this word size +#endif + /* * Getting printf formats right for platform-dependent typedefs */ diff --git a/includes/RtsAPI.h b/includes/RtsAPI.h index e3b3f7d5f5..7f41ebc421 100644 --- a/includes/RtsAPI.h +++ b/includes/RtsAPI.h @@ -232,7 +232,7 @@ SchedulerStatus rts_getSchedStatus (Capability *cap); // Note that RtsAPI.h is also included by foreign export stubs in // the base package itself. // -#if defined(mingw32_HOST_OS) && defined(__PIC__) && !defined(COMPILING_BASE_PACKAGE) +#if defined(mingw32_HOST_OS) && defined(i386_HOST_ARCH) && defined(__PIC__) && !defined(COMPILING_BASE_PACKAGE) __declspec(dllimport) extern StgWord base_GHCziTopHandler_runIO_closure[]; __declspec(dllimport) extern StgWord base_GHCziTopHandler_runNonIO_closure[]; #else diff --git a/includes/Stg.h b/includes/Stg.h index 4faed91c42..76067de451 100644 --- a/includes/Stg.h +++ b/includes/Stg.h @@ -257,7 +257,7 @@ typedef StgFunPtr F_; INLINE_HEADER void ASSIGN_FLT (W_ [], StgFloat); INLINE_HEADER StgFloat PK_FLT (W_ []); -#if ALIGNMENT_FLOAT <= ALIGNMENT_LONG +#if ALIGNMENT_FLOAT <= ALIGNMENT_VOID_P INLINE_HEADER void ASSIGN_FLT(W_ p_dest[], StgFloat src) { *(StgFloat *)p_dest = src; } INLINE_HEADER StgFloat PK_FLT (W_ p_src[]) { return *(StgFloat *)p_src; } @@ -278,9 +278,9 @@ INLINE_HEADER StgFloat PK_FLT(W_ p_src[]) return(y.f); } -#endif /* ALIGNMENT_FLOAT > ALIGNMENT_LONG */ +#endif /* ALIGNMENT_FLOAT > ALIGNMENT_VOID_P */ -#if ALIGNMENT_DOUBLE <= ALIGNMENT_LONG +#if ALIGNMENT_DOUBLE <= ALIGNMENT_VOID_P INLINE_HEADER void ASSIGN_DBL (W_ [], StgDouble); INLINE_HEADER StgDouble PK_DBL (W_ []); @@ -288,7 +288,7 @@ INLINE_HEADER StgDouble PK_DBL (W_ []); INLINE_HEADER void ASSIGN_DBL(W_ p_dest[], StgDouble src) { *(StgDouble *)p_dest = src; } INLINE_HEADER StgDouble PK_DBL (W_ p_src[]) { return *(StgDouble *)p_src; } -#else /* ALIGNMENT_DOUBLE > ALIGNMENT_LONG */ +#else /* ALIGNMENT_DOUBLE > ALIGNMENT_VOID_P */ /* Sparc uses two floating point registers to hold a double. We can * write ASSIGN_DBL and PK_DBL by directly accessing the registers diff --git a/includes/mkDerivedConstants.c b/includes/mkDerivedConstants.c index 2e09409654..6f2e6de87e 100644 --- a/includes/mkDerivedConstants.c +++ b/includes/mkDerivedConstants.c @@ -30,7 +30,7 @@ #define str(a,b) #a "_" #b #define OFFSET(s_type, field) ((size_t)&(((s_type*)0)->field)) -#define FIELD_SIZE(s_type, field) ((unsigned long)sizeof(((s_type*)0)->field)) +#define FIELD_SIZE(s_type, field) ((size_t)sizeof(((s_type*)0)->field)) #define TYPE_SIZE(type) (sizeof(type)) #pragma GCC poison sizeof @@ -38,17 +38,17 @@ #if defined(GEN_HASKELL) #define def_offset(str, offset) \ printf("oFFSET_" str " :: Int\n"); \ - printf("oFFSET_" str " = %lu\n", (unsigned long)offset); + printf("oFFSET_" str " = %" FMT_SizeT "\n", (size_t)offset); #else #define def_offset(str, offset) \ - printf("#define OFFSET_" str " %lu\n", (unsigned long)offset); + printf("#define OFFSET_" str " %" FMT_SizeT "\n", (size_t)offset); #endif #if defined(GEN_HASKELL) #define ctype(type) /* nothing */ #else #define ctype(type) \ - printf("#define SIZEOF_" #type " %lu\n", (unsigned long)TYPE_SIZE(type)); + printf("#define SIZEOF_" #type " %" FMT_SizeT "\n", (size_t)TYPE_SIZE(type)); #endif #if defined(GEN_HASKELL) @@ -63,7 +63,7 @@ */ #define field_type_(str, s_type, field) \ printf("#define REP_" str " b"); \ - printf("%lu\n", FIELD_SIZE(s_type, field) * 8); + printf("%" FMT_SizeT "\n", FIELD_SIZE(s_type, field) * 8); #define field_type_gcptr_(str, s_type, field) \ printf("#define REP_" str " gcptr\n"); #endif @@ -95,17 +95,17 @@ #if defined(GEN_HASKELL) #define def_size(str, size) \ printf("sIZEOF_" str " :: Int\n"); \ - printf("sIZEOF_" str " = %lu\n", (unsigned long)size); + printf("sIZEOF_" str " = %" FMT_SizeT "\n", (size_t)size); #else #define def_size(str, size) \ - printf("#define SIZEOF_" str " %lu\n", (unsigned long)size); + printf("#define SIZEOF_" str " %" FMT_SizeT "\n", (size_t)size); #endif #if defined(GEN_HASKELL) #define def_closure_size(str, size) /* nothing */ #else #define def_closure_size(str, size) \ - printf("#define SIZEOF_" str " (SIZEOF_StgHeader+%lu)\n", (unsigned long)size); + printf("#define SIZEOF_" str " (SIZEOF_StgHeader+%" FMT_SizeT ")\n", (size_t)size); #endif #define struct_size(s_type) \ @@ -193,9 +193,9 @@ main(int argc, char *argv[]) #ifndef GEN_HASKELL printf("/* This file is created automatically. Do not edit by hand.*/\n\n"); - printf("#define STD_HDR_SIZE %lu\n", (unsigned long)sizeofW(StgHeader) - sizeofW(StgProfHeader)); + printf("#define STD_HDR_SIZE %" FMT_SizeT "\n", (size_t)sizeofW(StgHeader) - sizeofW(StgProfHeader)); /* grrr.. PROFILING is on so we need to subtract sizeofW(StgProfHeader) */ - printf("#define PROF_HDR_SIZE %lu\n", (unsigned long)sizeofW(StgProfHeader)); + printf("#define PROF_HDR_SIZE %" FMT_SizeT "\n", (size_t)sizeofW(StgProfHeader)); printf("#define BLOCK_SIZE %u\n", BLOCK_SIZE); printf("#define MBLOCK_SIZE %u\n", MBLOCK_SIZE); diff --git a/includes/rts/Constants.h b/includes/rts/Constants.h index e6e4a51080..cd741be7e0 100644 --- a/includes/rts/Constants.h +++ b/includes/rts/Constants.h @@ -35,7 +35,7 @@ -------------------------------------------------------------------------- */ /* We have some pre-compiled selector thunks defined in rts/StgStdThunks.hc. - * This constant defines the highest selectee index that we can replace with a + * This constant defines the highest selectee index that we can replace with a * reference to the pre-compiled code. */ @@ -44,7 +44,7 @@ /* Vector-apply thunks. These thunks just push their free variables * on the stack and enter the first one. They're a bit like PAPs, but * don't have a dynamic size. We've pre-compiled a few to save - * space. + * space. */ #define MAX_SPEC_AP_SIZE 7 @@ -55,16 +55,16 @@ #define MAX_SPEC_FUN_SIZE 2 #define MAX_SPEC_CONSTR_SIZE 2 -/* Range of built-in table of static small int-like and char-like closures. - * +/* Range of built-in table of static small int-like and char-like closures. + * * NB. This corresponds with the number of actual INTLIKE/CHARLIKE * closures defined in rts/StgMiscClosures.cmm. */ -#define MAX_INTLIKE 16 -#define MIN_INTLIKE (-16) +#define MAX_INTLIKE 16 +#define MIN_INTLIKE (-16) -#define MAX_CHARLIKE 255 -#define MIN_CHARLIKE 0 +#define MAX_CHARLIKE 255 +#define MIN_CHARLIKE 0 /* Each byte in the card table for an StgMutaArrPtrs covers * (1<<MUT_ARR_PTRS_CARD_BITS) elements in the array. To find a good @@ -92,16 +92,16 @@ Tags for indirection nodes and ``other'' (probably unevaluated) nodes; normal-form values of algebraic data types will have tags 0, 1, ... - + @INFO_IND_TAG@ is different from @INFO_OTHER_TAG@ just so we can count how often we bang into indirection nodes; that's all. (WDP 95/11) ToDo: find out if we need any of this. -------------------------------------------------------------------------- */ -#define INFO_OTHER_TAG (-1) -#define INFO_IND_TAG (-2) -#define INFO_FIRST_TAG 0 +#define INFO_OTHER_TAG (-1) +#define INFO_IND_TAG (-2) +#define INFO_FIRST_TAG 0 /* ----------------------------------------------------------------------------- How much C stack to reserve for local temporaries when in the STG @@ -113,11 +113,11 @@ /* ----------------------------------------------------------------------------- How much Haskell stack space to reserve for the saving of registers etc. in the case of a stack/heap overflow. - + This must be large enough to accomodate the largest stack frame pushed in one of the heap check fragments in HeapStackCheck.hc (ie. currently the generic heap checks - 3 words for StgRetDyn, - 18 words for the saved registers, see StgMacros.h). + 18 words for the saved registers, see StgMacros.h). In the event of an unboxed tuple or let-no-escape stack/heap check failure, there will be other words on the stack which are covered @@ -168,8 +168,8 @@ -------------------------------------------------------------------------- */ /* - An LDV word is divided into 3 parts: state bits (LDV_STATE_MASK), creation - time bits (LDV_CREATE_MASK), and last use time bits (LDV_LAST_MASK). + An LDV word is divided into 3 parts: state bits (LDV_STATE_MASK), creation + time bits (LDV_CREATE_MASK), and last use time bits (LDV_LAST_MASK). */ #if SIZEOF_VOID_P == 8 #define LDV_SHIFT 30 @@ -180,7 +180,7 @@ #define LDV_STATE_USE 0x1000000000000000 #else #define LDV_SHIFT 15 -#define LDV_STATE_MASK 0x40000000 +#define LDV_STATE_MASK 0x40000000 #define LDV_CREATE_MASK 0x3FFF8000 #define LDV_LAST_MASK 0x00007FFF #define LDV_STATE_CREATE 0x00000000 @@ -195,9 +195,9 @@ * Constants for the what_next field of a TSO, which indicates how it * is to be run. */ -#define ThreadRunGHC 1 /* return to address on top of stack */ -#define ThreadInterpret 2 /* interpret this thread */ -#define ThreadKilled 3 /* thread has died, don't run it */ +#define ThreadRunGHC 1 /* return to address on top of stack */ +#define ThreadInterpret 2 /* interpret this thread */ +#define ThreadKilled 3 /* thread has died, don't run it */ #define ThreadComplete 4 /* thread has finished */ /* @@ -228,7 +228,7 @@ /* Involved in a message sent to tso->msg_cap */ #define BlockedOnMsgThrowTo 12 -/* The thread is not on any run queues, but can be woken up +/* The thread is not on any run queues, but can be woken up by tryWakeupThread() */ #define ThreadMigrating 13 @@ -237,13 +237,13 @@ * stopped for one reason or another. See typedef StgThreadReturnCode * in TSO.h. */ -#define HeapOverflow 1 /* might also be StackOverflow */ +#define HeapOverflow 1 /* might also be StackOverflow */ #define StackOverflow 2 #define ThreadYielding 3 #define ThreadBlocked 4 #define ThreadFinished 5 -/* +/* * Flags for the tso->flags field. */ @@ -262,7 +262,7 @@ */ #define TSO_BLOCKEX 4 #define TSO_INTERRUPTIBLE 8 -#define TSO_STOPPED_ON_BREAKPOINT 16 +#define TSO_STOPPED_ON_BREAKPOINT 16 /* * Used by the sanity checker to check whether TSOs are on the correct @@ -281,7 +281,7 @@ RET_DYN stack frames -------------------------------------------------------------------------- */ -/* VERY MAGIC CONSTANTS! +/* VERY MAGIC CONSTANTS! * must agree with code in HeapStackCheck.c, stg_gen_chk, and * RESERVED_STACK_WORDS in Constants.h. */ diff --git a/includes/stg/DLL.h b/includes/stg/DLL.h index 7d4096025d..b7030b0e88 100644 --- a/includes/stg/DLL.h +++ b/includes/stg/DLL.h @@ -14,7 +14,7 @@ #ifndef __STGDLL_H__ #define __STGDLL_H__ 1 -#if defined(__PIC__) && defined(mingw32_HOST_OS) +#if defined(__PIC__) && defined(mingw32_HOST_OS) && defined(i386_HOST_ARCH) # define DLL_IMPORT_DATA_REF(x) (_imp__##x) # define DLL_IMPORT_DATA_VARNAME(x) *_imp__##x # if __GNUC__ && !defined(__declspec) @@ -45,7 +45,7 @@ #else #define DLL_IMPORT #define DLL_IMPORT_RTS DLLIMPORT -# if defined(__PIC__) && defined(mingw32_HOST_OS) +# if defined(__PIC__) && defined(mingw32_HOST_OS) && defined(i386_HOST_ARCH) # define DLL_IMPORT_DATA_VAR(x) _imp__##x # else # define DLL_IMPORT_DATA_VAR(x) x diff --git a/includes/stg/MachRegs.h b/includes/stg/MachRegs.h index 34685a3410..91c1f89022 100644 --- a/includes/stg/MachRegs.h +++ b/includes/stg/MachRegs.h @@ -19,7 +19,7 @@ * only in here please. */ -/* +/* * Defining NO_REGS causes no global registers to be used. NO_REGS is * typically defined by GHC, via a command-line option passed to gcc, * when the -funregisterised flag is given. @@ -55,7 +55,7 @@ /* ---------------------------------------------------------------------------- Caller saves and callee-saves regs. - + Caller-saves regs have to be saved around C-calls made from STG land, so this file defines CALLER_SAVES_<reg> for each <reg> that is designated caller-saves in that machine's C calling convention. @@ -91,21 +91,21 @@ #ifndef not_doing_dynamic_linking #define REG_Base ebx #endif -#define REG_Sp ebp +#define REG_Sp ebp #ifndef STOLEN_X86_REGS #define STOLEN_X86_REGS 4 #endif #if STOLEN_X86_REGS >= 3 -# define REG_R1 esi +# define REG_R1 esi #endif #if STOLEN_X86_REGS >= 4 # define REG_Hp edi #endif -#define MAX_REAL_VANILLA_REG 1 /* always, since it defines the entry conv */ +#define MAX_REAL_VANILLA_REG 1 /* always, since it defines the entry conv */ #define MAX_REAL_FLOAT_REG 0 #define MAX_REAL_DOUBLE_REG 0 #define MAX_REAL_LONG_REG 0 @@ -115,22 +115,22 @@ /* ----------------------------------------------------------------------------- The x86-64 register mapping - %rax caller-saves, don't steal this one - %rbx YES + %rax caller-saves, don't steal this one + %rbx YES %rcx arg reg, caller-saves - %rdx arg reg, caller-saves - %rsi arg reg, caller-saves - %rdi arg reg, caller-saves - %rbp YES (our *prime* register) - %rsp (unavailable - stack pointer) + %rdx arg reg, caller-saves + %rsi arg reg, caller-saves + %rdi arg reg, caller-saves + %rbp YES (our *prime* register) + %rsp (unavailable - stack pointer) %r8 arg reg, caller-saves - %r9 arg reg, caller-saves + %r9 arg reg, caller-saves %r10 caller-saves - %r11 caller-saves - %r12 YES - %r13 YES - %r14 YES - %r15 YES + %r11 caller-saves + %r12 YES + %r13 YES + %r14 YES + %r15 YES %xmm0-7 arg regs, caller-saves %xmm8-15 caller-saves @@ -164,8 +164,10 @@ #define REG_D1 xmm5 #define REG_D2 xmm6 +#if !defined(mingw32_HOST_OS) #define CALLER_SAVES_R3 #define CALLER_SAVES_R4 +#endif #define CALLER_SAVES_R5 #define CALLER_SAVES_R6 @@ -175,7 +177,9 @@ #define CALLER_SAVES_F4 #define CALLER_SAVES_D1 +#if !defined(mingw32_HOST_OS) #define CALLER_SAVES_D2 +#endif #define MAX_REAL_VANILLA_REG 6 #define MAX_REAL_FLOAT_REG 4 @@ -187,30 +191,30 @@ /* ----------------------------------------------------------------------------- The PowerPC register mapping - 0 system glue? (caller-save, volatile) - 1 SP (callee-save, non-volatile) + 0 system glue? (caller-save, volatile) + 1 SP (callee-save, non-volatile) 2 AIX, powerpc64-linux: RTOC (a strange special case) - darwin: + darwin: (caller-save, volatile) powerpc32-linux: reserved for use by system - - 3-10 args/return (caller-save, volatile) - 11,12 system glue? (caller-save, volatile) + + 3-10 args/return (caller-save, volatile) + 11,12 system glue? (caller-save, volatile) 13 on 64-bit: reserved for thread state pointer on 32-bit: (callee-save, non-volatile) - 14-31 (callee-save, non-volatile) - - f0 (caller-save, volatile) - f1-f13 args/return (caller-save, volatile) - f14-f31 (callee-save, non-volatile) - + 14-31 (callee-save, non-volatile) + + f0 (caller-save, volatile) + f1-f13 args/return (caller-save, volatile) + f14-f31 (callee-save, non-volatile) + \tr{14}--\tr{31} are wonderful callee-save registers on all ppc OSes. \tr{0}--\tr{12} are caller-save registers. - + \tr{%f14}--\tr{%f31} are callee-save floating-point registers. - + We can do the Whole Business with callee-save registers only! -------------------------------------------------------------------------- */ @@ -218,41 +222,41 @@ #define REG(x) __asm__(#x) -#define REG_R1 r14 -#define REG_R2 r15 -#define REG_R3 r16 -#define REG_R4 r17 -#define REG_R5 r18 -#define REG_R6 r19 -#define REG_R7 r20 -#define REG_R8 r21 +#define REG_R1 r14 +#define REG_R2 r15 +#define REG_R3 r16 +#define REG_R4 r17 +#define REG_R5 r18 +#define REG_R6 r19 +#define REG_R7 r20 +#define REG_R8 r21 #if darwin_REGS -#define REG_F1 f14 -#define REG_F2 f15 -#define REG_F3 f16 -#define REG_F4 f17 +#define REG_F1 f14 +#define REG_F2 f15 +#define REG_F3 f16 +#define REG_F4 f17 -#define REG_D1 f18 -#define REG_D2 f19 +#define REG_D1 f18 +#define REG_D2 f19 #else -#define REG_F1 fr14 -#define REG_F2 fr15 -#define REG_F3 fr16 -#define REG_F4 fr17 +#define REG_F1 fr14 +#define REG_F2 fr15 +#define REG_F3 fr16 +#define REG_F4 fr17 -#define REG_D1 fr18 -#define REG_D2 fr19 +#define REG_D1 fr18 +#define REG_D2 fr19 #endif -#define REG_Sp r22 -#define REG_SpLim r24 +#define REG_Sp r22 +#define REG_SpLim r24 -#define REG_Hp r25 +#define REG_Hp r25 #define REG_Base r27 @@ -269,46 +273,46 @@ Threaded World, we essentially ``shut down'' the register-window mechanism---the window doesn't move at all while in this World. It *does* move, of course, if we call out to arbitrary~C... - + The %i, %l, and %o registers (8 each) are the input, local, and output registers visible in one register window. The 8 %g (global) registers are visible all the time. - + zero: always zero scratch: volatile across C-fn calls. used by linker. app: usable by application system: reserved for system - + alloc: allocated to in the register allocator, intra-closure only - + GHC usage v8 ABI v9 ABI Global - %g0 zero zero zero - %g1 alloc scratch scrach - %g2 alloc app app - %g3 alloc app app - %g4 alloc app scratch - %g5 system scratch + %g0 zero zero zero + %g1 alloc scratch scrach + %g2 alloc app app + %g3 alloc app app + %g4 alloc app scratch + %g5 system scratch %g6 system system %g7 system system Output: can be zapped by callee - %o0-o5 alloc caller saves + %o0-o5 alloc caller saves %o6 C stack ptr %o7 C ret addr - + Local: maintained by register windowing mechanism - %l0 alloc - %l1 R1 - %l2 R2 - %l3 R3 - %l4 R4 - %l5 R5 - %l6 alloc - %l7 alloc + %l0 alloc + %l1 R1 + %l2 R2 + %l3 R3 + %l4 R4 + %l5 R5 + %l6 alloc + %l7 alloc Input - %i0 Sp + %i0 Sp %i1 Base %i2 SpLim %i3 Hp @@ -316,11 +320,11 @@ %i5 R6 %i6 C frame ptr %i7 C ret addr - + The paired nature of the floating point registers causes complications for the native code generator. For convenience, we pretend that the first 22 fp regs %f0 .. %f21 are actually 11 double regs, and the remaining 10 are - float (single) regs. The NCG acts accordingly. That means that the + float (single) regs. The NCG acts accordingly. That means that the following FP assignment is rather fragile, and should only be changed with extreme care. The current scheme is: @@ -362,42 +366,33 @@ #define CALLER_SAVES_D1 #define CALLER_SAVES_D2 -#define REG_R1 l1 -#define REG_R2 l2 -#define REG_R3 l3 -#define REG_R4 l4 -#define REG_R5 l5 -#define REG_R6 i5 +#define REG_R1 l1 +#define REG_R2 l2 +#define REG_R3 l3 +#define REG_R4 l4 +#define REG_R5 l5 +#define REG_R6 i5 -#define REG_F1 f22 -#define REG_F2 f23 -#define REG_F3 f24 -#define REG_F4 f25 +#define REG_F1 f22 +#define REG_F2 f23 +#define REG_F3 f24 +#define REG_F4 f25 -/* for each of the double arg regs, +/* for each of the double arg regs, Dn_2 is the high half. */ - -#define REG_D1 f2 -#define REG_D1_2 f3 -#define REG_D2 f4 -#define REG_D2_2 f5 +#define REG_D1 f2 +#define REG_D1_2 f3 -#define REG_Sp i0 -#define REG_SpLim i2 +#define REG_D2 f4 +#define REG_D2_2 f5 -#define REG_Hp i3 +#define REG_Sp i0 +#define REG_SpLim i2 -#define REG_Base i1 +#define REG_Hp i3 -/* -#define NCG_SpillTmp_I1 g1 -#define NCG_SpillTmp_I2 g2 -#define NCG_SpillTmp_F1 f26 -#define NCG_SpillTmp_F2 f27 -#define NCG_SpillTmp_D1 f6 -#define NCG_SpillTmp_D2 f8 -*/ +#define REG_Base i1 #define NCG_FirstFloatReg f22 @@ -545,7 +540,7 @@ * optimise certain code paths using this predicate). */ #if MAX_REAL_VANILLA_REG < 2 -#define NO_ARG_REGS +#define NO_ARG_REGS #else #undef NO_ARG_REGS #endif diff --git a/mk/config.mk.in b/mk/config.mk.in index 2b5bd46aba..2482da869d 100644 --- a/mk/config.mk.in +++ b/mk/config.mk.in @@ -622,6 +622,12 @@ ifeq "$(CrossCompiling)" "YES" SRC_HSC2HS_OPTS += --cross-compile endif +ifeq "$(TARGETPLATFORM)" "i386-unknown-mingw32" +WINDRES = $(INPLACE_MINGW)/bin/windres +else ifeq "$(TARGETPLATFORM)" "x86_64-unknown-mingw32" +WINDRES = $(INPLACE_MINGW)/bin/x86_64-w64-mingw32-windres +endif + #----------------------------------------------------------------------------- # Mingwex Library # diff --git a/mk/validate-settings.mk b/mk/validate-settings.mk index 3467fba750..119dce10bb 100644 --- a/mk/validate-settings.mk +++ b/mk/validate-settings.mk @@ -9,7 +9,7 @@ SRC_CC_OPTS += -Wall $(WERROR) # Debian doesn't turn -Werror=unused-but-set-variable on by default, so # we turn it on explicitly for consistency with other users ifeq "$(GccLT46)" "NO" -SRC_CC_OPTS += -Werror=unused-but-set-variable +SRC_CC_OPTS += -Werror=unused-but-set-variable # gcc 4.6 gives 3 warning for giveCapabilityToTask not being inlined SRC_CC_OPTS += -Wno-error=inline endif diff --git a/rts/Adjustor.c b/rts/Adjustor.c index 0f038c4396..a8bf2a283f 100644 --- a/rts/Adjustor.c +++ b/rts/Adjustor.c @@ -111,7 +111,7 @@ createAdjustor (int cconv, arg_types[i] = char_to_ffi_type(typeString[i+1]); } switch (cconv) { -#ifdef mingw32_HOST_OS +#if defined(mingw32_HOST_OS) && defined(i386_HOST_ARCH) case 0: /* stdcall */ abi = FFI_STDCALL; break; @@ -321,10 +321,10 @@ static int totalArgumentSize(char *typeString) void* createAdjustor(int cconv, StgStablePtr hptr, - StgFunPtr wptr, - char *typeString + StgFunPtr wptr, + char *typeString #if !defined(powerpc_HOST_ARCH) && !defined(powerpc64_HOST_ARCH) && !defined(x86_64_HOST_ARCH) - STG_UNUSED + STG_UNUSED #endif ) { @@ -339,29 +339,29 @@ createAdjustor(int cconv, StgStablePtr hptr, the following assembly language snippet (offset and machine code prefixed): - <0>: 58 popl %eax # temp. remove ret addr.. - <1>: 68 fd fc fe fa pushl 0xfafefcfd # constant is large enough to - # hold a StgStablePtr - <6>: 50 pushl %eax # put back ret. addr - <7>: b8 fa ef ff 00 movl $0x00ffeffa, %eax # load up wptr - <c>: ff e0 jmp %eax # and jump to it. - # the callee cleans up the stack + <0>: 58 popl %eax # temp. remove ret addr.. + <1>: 68 fd fc fe fa pushl 0xfafefcfd # constant is large enough to + # hold a StgStablePtr + <6>: 50 pushl %eax # put back ret. addr + <7>: b8 fa ef ff 00 movl $0x00ffeffa, %eax # load up wptr + <c>: ff e0 jmp %eax # and jump to it. + # the callee cleans up the stack */ adjustor = allocateExec(14,&code); { - unsigned char *const adj_code = (unsigned char *)adjustor; - adj_code[0x00] = (unsigned char)0x58; /* popl %eax */ + unsigned char *const adj_code = (unsigned char *)adjustor; + adj_code[0x00] = (unsigned char)0x58; /* popl %eax */ - adj_code[0x01] = (unsigned char)0x68; /* pushl hptr (which is a dword immediate ) */ - *((StgStablePtr*)(adj_code + 0x02)) = (StgStablePtr)hptr; + adj_code[0x01] = (unsigned char)0x68; /* pushl hptr (which is a dword immediate ) */ + *((StgStablePtr*)(adj_code + 0x02)) = (StgStablePtr)hptr; - adj_code[0x06] = (unsigned char)0x50; /* pushl %eax */ + adj_code[0x06] = (unsigned char)0x50; /* pushl %eax */ - adj_code[0x07] = (unsigned char)0xb8; /* movl $wptr, %eax */ - *((StgFunPtr*)(adj_code + 0x08)) = (StgFunPtr)wptr; + adj_code[0x07] = (unsigned char)0xb8; /* movl $wptr, %eax */ + *((StgFunPtr*)(adj_code + 0x08)) = (StgFunPtr)wptr; - adj_code[0x0c] = (unsigned char)0xff; /* jmp %eax */ - adj_code[0x0d] = (unsigned char)0xe0; + adj_code[0x0c] = (unsigned char)0xff; /* jmp %eax */ + adj_code[0x0d] = (unsigned char)0xe0; } #endif break; @@ -405,13 +405,137 @@ createAdjustor(int cconv, StgStablePtr hptr, } #elif defined(x86_64_HOST_ARCH) + +# if defined(mingw32_HOST_OS) /* stack at call: argn - ... - arg7 + ... + arg5 return address - %rdi,%rsi,%rdx,%rcx,%r8,%r9 = arg0..arg6 + %rcx,%rdx,%r8,%r9 = arg1..arg4 + + if there are <4 integer args, then we can just push the + StablePtr into %rcx and shuffle the other args up. + + If there are >=4 integer args, then we have to flush one arg + to the stack, and arrange to adjust the stack ptr on return. + The stack will be rearranged to this: + + argn + ... + arg5 + return address *** <-- dummy arg in stub fn. + arg4 + obscure_ccall_ret_code + + This unfortunately means that the type of the stub function + must have a dummy argument for the original return address + pointer inserted just after the 4th integer argument. + + Code for the simple case: + + 0: 4d 89 c1 mov %r8,%r9 + 3: 49 89 d0 mov %rdx,%r8 + 6: 48 89 ca mov %rcx,%rdx + 9: f2 0f 10 da movsd %xmm2,%xmm3 + d: f2 0f 10 d1 movsd %xmm1,%xmm2 + 11: f2 0f 10 c8 movsd %xmm0,%xmm1 + 15: 48 8b 0d 0c 00 00 00 mov 0xc(%rip),%rcx # 28 <.text+0x28> + 1c: ff 25 0e 00 00 00 jmpq *0xe(%rip) # 30 <.text+0x30> + 22: 90 nop + [...] + + + And the version for >=4 integer arguments: + (note: replace 2-6 with nops if the 4th argument is not a floating + point argument). + + 0: 41 51 push %r9 + 2: f2 0f 11 1c 24 movsd %xmm3,(%rsp) + 7: ff 35 23 00 00 00 pushq 0x23(%rip) # 30 <.text+0x30> + d: 4d 89 c1 mov %r8,%r9 + 10: 49 89 d0 mov %rdx,%r8 + 13: 48 89 ca mov %rcx,%rdx + 16: f2 0f 10 da movsd %xmm2,%xmm3 + 1a: f2 0f 10 d1 movsd %xmm1,%xmm2 + 1e: f2 0f 10 c8 movsd %xmm0,%xmm1 + 22: 48 8b 0d 0f 00 00 00 mov 0xf(%rip),%rcx # 38 <.text+0x38> + 29: ff 25 11 00 00 00 jmpq *0x11(%rip) # 40 <.text+0x40> + 2f: 90 nop + [...] + + */ + { + int i = 0; + int fourthFloating; + char *c; + StgWord8 *adj_code; + + // determine whether we have 4 or more integer arguments, + // and therefore need to flush one to the stack. + for (c = typeString; *c != '\0'; c++) { + i++; + if (i == 4) { + fourthFloating = (*c == 'f' || *c == 'd'); + break; + } + } + + if (i < 4) { + adjustor = allocateExec(0x38,&code); + adj_code = (StgWord8*)adjustor; + + *(StgInt32 *)adj_code = 0x49c1894d; + *(StgInt32 *)(adj_code+0x4) = 0x8948d089; + *(StgInt32 *)(adj_code+0x8) = 0x100ff2ca; + *(StgInt32 *)(adj_code+0xc) = 0x100ff2da; + *(StgInt32 *)(adj_code+0x10) = 0x100ff2d1; + *(StgInt32 *)(adj_code+0x14) = 0x0d8b48c8; + *(StgInt32 *)(adj_code+0x18) = 0x0000000c; + + *(StgInt32 *)(adj_code+0x1c) = 0x000e25ff; + *(StgInt32 *)(adj_code+0x20) = 0x00000000; + *(StgInt64 *)(adj_code+0x28) = (StgInt64)hptr; + *(StgInt64 *)(adj_code+0x30) = (StgInt64)wptr; + } + else + { + adjustor = allocateExec(0x48,&code); + adj_code = (StgWord8*)adjustor; + + if (fourthFloating) { + *(StgInt32 *)adj_code = 0x0ff25141; + *(StgInt32 *)(adj_code+0x4) = 0xff241c11; + } + else { + *(StgInt32 *)adj_code = 0x90905141; + *(StgInt32 *)(adj_code+0x4) = 0xff909090; + } + *(StgInt32 *)(adj_code+0x8) = 0x00002335; + *(StgInt32 *)(adj_code+0xc) = 0xc1894d00; + *(StgInt32 *)(adj_code+0x10) = 0x48d08949; + *(StgInt32 *)(adj_code+0x14) = 0x0ff2ca89; + *(StgInt32 *)(adj_code+0x18) = 0x0ff2da10; + *(StgInt32 *)(adj_code+0x1c) = 0x0ff2d110; + *(StgInt32 *)(adj_code+0x20) = 0x8b48c810; + *(StgInt32 *)(adj_code+0x24) = 0x00000f0d; + *(StgInt32 *)(adj_code+0x28) = 0x1125ff00; + *(StgInt32 *)(adj_code+0x2c) = 0x00000000; + + *(StgInt64 *)(adj_code+0x30) = (StgInt64)obscure_ccall_ret_code; + *(StgInt64 *)(adj_code+0x38) = (StgInt64)hptr; + *(StgInt64 *)(adj_code+0x40) = (StgInt64)wptr; + } + } +# else + /* + stack at call: + argn + ... + arg7 + return address + %rdi,%rsi,%rdx,%rcx,%r8,%r9 = arg1..arg6 if there are <6 integer args, then we can just push the StablePtr into %edi and shuffle the other args up. @@ -421,11 +545,11 @@ createAdjustor(int cconv, StgStablePtr hptr, The stack will be rearranged to this: argn - ... - arg7 - return address *** <-- dummy arg in stub fn. - arg6 - obscure_ccall_ret_code + ... + arg7 + return address *** <-- dummy arg in stub fn. + arg6 + obscure_ccall_ret_code This unfortunately means that the type of the stub function must have a dummy argument for the original return address @@ -463,51 +587,54 @@ createAdjustor(int cconv, StgStablePtr hptr, */ { - int i = 0; - char *c; - StgWord8 *adj_code; - - // determine whether we have 6 or more integer arguments, - // and therefore need to flush one to the stack. - for (c = typeString; *c != '\0'; c++) { - if (*c != 'f' && *c != 'd') i++; - if (i == 6) break; - } - - if (i < 6) { - adjustor = allocateExec(0x30,&code); + int i = 0; + char *c; + StgWord8 *adj_code; + + // determine whether we have 6 or more integer arguments, + // and therefore need to flush one to the stack. + for (c = typeString; *c != '\0'; c++) { + if (*c != 'f' && *c != 'd') i++; + if (i == 6) break; + } + + if (i < 6) { + adjustor = allocateExec(0x30,&code); adj_code = (StgWord8*)adjustor; - *(StgInt32 *)adj_code = 0x49c1894d; - *(StgInt32 *)(adj_code+0x4) = 0x8948c889; - *(StgInt32 *)(adj_code+0x8) = 0xf28948d1; - *(StgInt32 *)(adj_code+0xc) = 0x48fe8948; - *(StgInt32 *)(adj_code+0x10) = 0x000a3d8b; - *(StgInt32 *)(adj_code+0x14) = 0x25ff0000; - *(StgInt32 *)(adj_code+0x18) = 0x0000000c; - *(StgInt64 *)(adj_code+0x20) = (StgInt64)hptr; - *(StgInt64 *)(adj_code+0x28) = (StgInt64)wptr; - } - else - { - adjustor = allocateExec(0x40,&code); + *(StgInt32 *)adj_code = 0x49c1894d; + *(StgInt32 *)(adj_code+0x4) = 0x8948c889; + *(StgInt32 *)(adj_code+0x8) = 0xf28948d1; + *(StgInt32 *)(adj_code+0xc) = 0x48fe8948; + *(StgInt32 *)(adj_code+0x10) = 0x000a3d8b; + *(StgInt32 *)(adj_code+0x14) = 0x25ff0000; + *(StgInt32 *)(adj_code+0x18) = 0x0000000c; + *(StgInt64 *)(adj_code+0x20) = (StgInt64)hptr; + *(StgInt64 *)(adj_code+0x28) = (StgInt64)wptr; + } + else + { + adjustor = allocateExec(0x40,&code); adj_code = (StgWord8*)adjustor; - *(StgInt32 *)adj_code = 0x35ff5141; - *(StgInt32 *)(adj_code+0x4) = 0x00000020; - *(StgInt32 *)(adj_code+0x8) = 0x49c1894d; - *(StgInt32 *)(adj_code+0xc) = 0x8948c889; - *(StgInt32 *)(adj_code+0x10) = 0xf28948d1; - *(StgInt32 *)(adj_code+0x14) = 0x48fe8948; - *(StgInt32 *)(adj_code+0x18) = 0x00123d8b; - *(StgInt32 *)(adj_code+0x1c) = 0x25ff0000; - *(StgInt32 *)(adj_code+0x20) = 0x00000014; - - *(StgInt64 *)(adj_code+0x28) = (StgInt64)obscure_ccall_ret_code; - *(StgInt64 *)(adj_code+0x30) = (StgInt64)hptr; - *(StgInt64 *)(adj_code+0x38) = (StgInt64)wptr; - } + *(StgInt32 *)adj_code = 0x35ff5141; + *(StgInt32 *)(adj_code+0x4) = 0x00000020; + *(StgInt32 *)(adj_code+0x8) = 0x49c1894d; + *(StgInt32 *)(adj_code+0xc) = 0x8948c889; + *(StgInt32 *)(adj_code+0x10) = 0xf28948d1; + *(StgInt32 *)(adj_code+0x14) = 0x48fe8948; + *(StgInt32 *)(adj_code+0x18) = 0x00123d8b; + *(StgInt32 *)(adj_code+0x1c) = 0x25ff0000; + *(StgInt32 *)(adj_code+0x20) = 0x00000014; + + *(StgInt64 *)(adj_code+0x28) = (StgInt64)obscure_ccall_ret_code; + *(StgInt64 *)(adj_code+0x30) = (StgInt64)hptr; + *(StgInt64 *)(adj_code+0x38) = (StgInt64)wptr; + } } +# endif + + #elif defined(sparc_HOST_ARCH) /* Magic constant computed by inspecting the code length of the following assembly language snippet (offset and machine code prefixed): @@ -579,14 +706,14 @@ createAdjustor(int cconv, StgStablePtr hptr, (offset and machine code prefixed; note that the machine code shown is longwords stored in little-endian order): - <00>: 46520414 mov a2, a4 - <04>: 46100412 mov a0, a2 - <08>: a61b0020 ldq a0, 0x20(pv) # load up hptr - <0c>: 46730415 mov a3, a5 - <10>: a77b0028 ldq pv, 0x28(pv) # load up wptr - <14>: 46310413 mov a1, a3 - <18>: 6bfb---- jmp (pv), <hint> # jump to wptr (with hint) - <1c>: 00000000 # padding for alignment + <00>: 46520414 mov a2, a4 + <04>: 46100412 mov a0, a2 + <08>: a61b0020 ldq a0, 0x20(pv) # load up hptr + <0c>: 46730415 mov a3, a5 + <10>: a77b0028 ldq pv, 0x28(pv) # load up wptr + <14>: 46310413 mov a1, a3 + <18>: 6bfb---- jmp (pv), <hint> # jump to wptr (with hint) + <1c>: 00000000 # padding for alignment <20>: [8 bytes for hptr quadword] <28>: [8 bytes for wptr quadword] @@ -617,19 +744,19 @@ TODO: Depending on how much allocation overhead stgMallocBytes uses for ASSERT(((StgWord64)wptr & 3) == 0); adjustor = allocateExec(48,&code); { - StgWord64 *const code = (StgWord64 *)adjustor; + StgWord64 *const code = (StgWord64 *)adjustor; - code[0] = 0x4610041246520414L; - code[1] = 0x46730415a61b0020L; - code[2] = 0x46310413a77b0028L; - code[3] = 0x000000006bfb0000L - | (((StgWord32*)(wptr) - (StgWord32*)(code) - 3) & 0x3fff); + code[0] = 0x4610041246520414L; + code[1] = 0x46730415a61b0020L; + code[2] = 0x46310413a77b0028L; + code[3] = 0x000000006bfb0000L + | (((StgWord32*)(wptr) - (StgWord32*)(code) - 3) & 0x3fff); - code[4] = (StgWord64)hptr; - code[5] = (StgWord64)wptr; + code[4] = (StgWord64)hptr; + code[5] = (StgWord64)wptr; - /* Ensure that instruction cache is consistent with our new code */ - __asm__ volatile("call_pal %0" : : "i" (PAL_imb)); + /* Ensure that instruction cache is consistent with our new code */ + __asm__ volatile("call_pal %0" : : "i" (PAL_imb)); } #elif defined(powerpc_HOST_ARCH) && defined(linux_HOST_OS) @@ -959,82 +1086,82 @@ TODO: Depending on how much allocation overhead stgMallocBytes uses for The function descriptor we create contains the gp of the target function so gp is already loaded correctly. - [MLX] alloc r16=ar.pfs,10,2,0 - movl r17=wptr - [MII] st8.spill [r12]=r38,8 // spill in6 (out4) - mov r41=r37 // out7 = in5 (out3) - mov r40=r36;; // out6 = in4 (out2) - [MII] st8.spill [r12]=r39 // spill in7 (out5) - mov.sptk b6=r17,50 - mov r38=r34;; // out4 = in2 (out0) - [MII] mov r39=r35 // out5 = in3 (out1) - mov r37=r33 // out3 = in1 (loc1) - mov r36=r32 // out2 = in0 (loc0) - [MLX] adds r12=-24,r12 // update sp - movl r34=hptr;; // out0 = hptr - [MIB] mov r33=r16 // loc1 = ar.pfs - mov r32=b0 // loc0 = retaddr - br.call.sptk.many b0=b6;; - - [MII] adds r12=-16,r12 - mov b0=r32 - mov.i ar.pfs=r33 - [MFB] nop.m 0x0 - nop.f 0x0 - br.ret.sptk.many b0;; + [MLX] alloc r16=ar.pfs,10,2,0 + movl r17=wptr + [MII] st8.spill [r12]=r38,8 // spill in6 (out4) + mov r41=r37 // out7 = in5 (out3) + mov r40=r36;; // out6 = in4 (out2) + [MII] st8.spill [r12]=r39 // spill in7 (out5) + mov.sptk b6=r17,50 + mov r38=r34;; // out4 = in2 (out0) + [MII] mov r39=r35 // out5 = in3 (out1) + mov r37=r33 // out3 = in1 (loc1) + mov r36=r32 // out2 = in0 (loc0) + [MLX] adds r12=-24,r12 // update sp + movl r34=hptr;; // out0 = hptr + [MIB] mov r33=r16 // loc1 = ar.pfs + mov r32=b0 // loc0 = retaddr + br.call.sptk.many b0=b6;; + + [MII] adds r12=-16,r12 + mov b0=r32 + mov.i ar.pfs=r33 + [MFB] nop.m 0x0 + nop.f 0x0 + br.ret.sptk.many b0;; */ /* These macros distribute a long constant into the two words of an MLX bundle */ -#define BITS(val,start,count) (((val) >> (start)) & ((1 << (count))-1)) -#define MOVL_LOWORD(val) (BITS(val,22,18) << 46) -#define MOVL_HIWORD(val) ( (BITS(val,0,7) << 36) \ - | (BITS(val,7,9) << 50) \ - | (BITS(val,16,5) << 45) \ - | (BITS(val,21,1) << 44) \ - | (BITS(val,40,23)) \ - | (BITS(val,63,1) << 59)) +#define BITS(val,start,count) (((val) >> (start)) & ((1 << (count))-1)) +#define MOVL_LOWORD(val) (BITS(val,22,18) << 46) +#define MOVL_HIWORD(val) ( (BITS(val,0,7) << 36) \ + | (BITS(val,7,9) << 50) \ + | (BITS(val,16,5) << 45) \ + | (BITS(val,21,1) << 44) \ + | (BITS(val,40,23)) \ + | (BITS(val,63,1) << 59)) { - StgStablePtr stable; - IA64FunDesc *wdesc = (IA64FunDesc *)wptr; - StgWord64 wcode = wdesc->ip; - IA64FunDesc *fdesc; - StgWord64 *code; - - /* we allocate on the Haskell heap since malloc'd memory isn't - * executable - argh */ - /* Allocated memory is word-aligned (8 bytes) but functions on ia64 - * must be aligned to 16 bytes. We allocate an extra 8 bytes of - * wiggle room so that we can put the code on a 16 byte boundary. */ - adjustor = stgAllocStable(sizeof(IA64FunDesc)+18*8+8, &stable); - - fdesc = (IA64FunDesc *)adjustor; - code = (StgWord64 *)(fdesc + 1); - /* add 8 bytes to code if needed to align to a 16-byte boundary */ - if ((StgWord64)code & 15) code++; - fdesc->ip = (StgWord64)code; - fdesc->gp = wdesc->gp; - - code[0] = 0x0000058004288004 | MOVL_LOWORD(wcode); - code[1] = 0x6000000220000000 | MOVL_HIWORD(wcode); - code[2] = 0x029015d818984001; - code[3] = 0x8401200500420094; - code[4] = 0x886011d8189c0001; - code[5] = 0x84011004c00380c0; - code[6] = 0x0250210046013800; - code[7] = 0x8401000480420084; - code[8] = 0x0000233f19a06005 | MOVL_LOWORD((StgWord64)hptr); - code[9] = 0x6000000440000000 | MOVL_HIWORD((StgWord64)hptr); - code[10] = 0x0200210020010811; - code[11] = 0x1080006800006200; - code[12] = 0x0000210018406000; - code[13] = 0x00aa021000038005; - code[14] = 0x000000010000001d; - code[15] = 0x0084000880000200; - - /* save stable pointers in convenient form */ - code[16] = (StgWord64)hptr; - code[17] = (StgWord64)stable; + StgStablePtr stable; + IA64FunDesc *wdesc = (IA64FunDesc *)wptr; + StgWord64 wcode = wdesc->ip; + IA64FunDesc *fdesc; + StgWord64 *code; + + /* we allocate on the Haskell heap since malloc'd memory isn't + * executable - argh */ + /* Allocated memory is word-aligned (8 bytes) but functions on ia64 + * must be aligned to 16 bytes. We allocate an extra 8 bytes of + * wiggle room so that we can put the code on a 16 byte boundary. */ + adjustor = stgAllocStable(sizeof(IA64FunDesc)+18*8+8, &stable); + + fdesc = (IA64FunDesc *)adjustor; + code = (StgWord64 *)(fdesc + 1); + /* add 8 bytes to code if needed to align to a 16-byte boundary */ + if ((StgWord64)code & 15) code++; + fdesc->ip = (StgWord64)code; + fdesc->gp = wdesc->gp; + + code[0] = 0x0000058004288004 | MOVL_LOWORD(wcode); + code[1] = 0x6000000220000000 | MOVL_HIWORD(wcode); + code[2] = 0x029015d818984001; + code[3] = 0x8401200500420094; + code[4] = 0x886011d8189c0001; + code[5] = 0x84011004c00380c0; + code[6] = 0x0250210046013800; + code[7] = 0x8401000480420084; + code[8] = 0x0000233f19a06005 | MOVL_LOWORD((StgWord64)hptr); + code[9] = 0x6000000440000000 | MOVL_HIWORD((StgWord64)hptr); + code[10] = 0x0200210020010811; + code[11] = 0x1080006800006200; + code[12] = 0x0000210018406000; + code[13] = 0x00aa021000038005; + code[14] = 0x000000010000001d; + code[15] = 0x0084000880000200; + + /* save stable pointers in convenient form */ + code[16] = (StgWord64)hptr; + code[17] = (StgWord64)stable; } #else barf("adjustor creation not supported on this platform"); diff --git a/rts/HeapStackCheck.cmm b/rts/HeapStackCheck.cmm index 74545af149..90691fa091 100644 --- a/rts/HeapStackCheck.cmm +++ b/rts/HeapStackCheck.cmm @@ -676,13 +676,11 @@ INFO_TABLE_RET( stg_block_async, RET_SMALL, W_ unused ) W_ len, errC; ares = Sp(1); - len = StgAsyncIOResult_len(ares); - errC = StgAsyncIOResult_errCode(ares); + len = TO_W_(StgAsyncIOResult_len(ares)); + errC = TO_W_(StgAsyncIOResult_errCode(ares)); foreign "C" free(ares "ptr"); - R1 = len; - Sp_adj(1); - Sp(0) = errC; - jump %ENTRY_CODE(Sp(1)); + Sp_adj(2); + RET_NN(len, errC); } stg_block_async diff --git a/rts/Interpreter.c b/rts/Interpreter.c index 2eac1cd834..a18e7caa8d 100644 --- a/rts/Interpreter.c +++ b/rts/Interpreter.c @@ -31,9 +31,11 @@ // When building the RTS in the non-dyn way on Windows, we don't // want declspec(__dllimport__) on the front of function prototypes // from libffi. -#if defined(mingw32_HOST_OS) && !defined(__PIC__) +#if defined(mingw32_HOST_OS) +#if (defined(i386_HOST_ARCH) && !defined(__PIC__)) || defined(x86_64_HOST_ARCH) # define LIBFFI_NOT_DLL #endif +#endif #include "ffi.h" diff --git a/rts/Linker.c b/rts/Linker.c index 9fb3f68fb9..6fd36d8bd8 100644 --- a/rts/Linker.c +++ b/rts/Linker.c @@ -396,10 +396,7 @@ typedef struct _RtsSymbolVal { SymI_HasProto(utime) \ SymI_HasProto(waitpid) -#elif !defined(mingw32_HOST_OS) -#define RTS_MINGW_ONLY_SYMBOLS /**/ -#define RTS_CYGWIN_ONLY_SYMBOLS /**/ -#else /* defined(mingw32_HOST_OS) */ +#elif defined(mingw32_HOST_OS) #define RTS_POSIX_ONLY_SYMBOLS /**/ #define RTS_CYGWIN_ONLY_SYMBOLS /**/ @@ -415,6 +412,12 @@ typedef struct _RtsSymbolVal { #define RTS___MINGW_VFPRINTF_SYM /**/ #endif +#if defined(i386_HOST_ARCH) +#define RTS_MINGW32_ONLY(X) X +#else +#define RTS_MINGW32_ONLY(X) /**/ +#endif + /* These are statically linked from the mingw libraries into the ghc executable, so we have to employ this hack. */ #define RTS_MINGW_ONLY_SYMBOLS \ @@ -444,7 +447,7 @@ typedef struct _RtsSymbolVal { SymI_HasProto(strcpy) \ SymI_HasProto(strncpy) \ SymI_HasProto(abort) \ - SymI_NeedsProto(_alloca) \ + RTS_MINGW32_ONLY(SymI_NeedsProto(_alloca)) \ SymI_HasProto(isxdigit) \ SymI_HasProto(isupper) \ SymI_HasProto(ispunct) \ @@ -495,21 +498,25 @@ typedef struct _RtsSymbolVal { SymI_HasProto(rts_InstallConsoleEvent) \ SymI_HasProto(rts_ConsoleHandlerDone) \ SymI_NeedsProto(mktime) \ - SymI_NeedsProto(_imp___timezone) \ - SymI_NeedsProto(_imp___tzname) \ - SymI_NeedsProto(_imp__tzname) \ - SymI_NeedsProto(_imp___iob) \ - SymI_NeedsProto(_imp___osver) \ + RTS_MINGW32_ONLY(SymI_NeedsProto(_imp___timezone)) \ + RTS_MINGW32_ONLY(SymI_NeedsProto(_imp___tzname)) \ + RTS_MINGW32_ONLY(SymI_NeedsProto(_imp__tzname)) \ + RTS_MINGW32_ONLY(SymI_NeedsProto(_imp___iob)) \ + RTS_MINGW32_ONLY(SymI_NeedsProto(_imp___osver)) \ SymI_NeedsProto(localtime) \ SymI_NeedsProto(gmtime) \ SymI_NeedsProto(opendir) \ SymI_NeedsProto(readdir) \ SymI_NeedsProto(rewinddir) \ - SymI_NeedsProto(_imp____mb_cur_max) \ - SymI_NeedsProto(_imp___pctype) \ - SymI_NeedsProto(__chkstk) \ + RTS_MINGW32_ONLY(SymI_NeedsProto(_imp____mb_cur_max)) \ + RTS_MINGW32_ONLY(SymI_NeedsProto(_imp___pctype)) \ + RTS_MINGW32_ONLY(SymI_NeedsProto(__chkstk)) \ RTS_MINGW_GETTIMEOFDAY_SYM \ SymI_NeedsProto(closedir) + +#else +#define RTS_MINGW_ONLY_SYMBOLS /**/ +#define RTS_CYGWIN_ONLY_SYMBOLS /**/ #endif @@ -742,7 +749,7 @@ typedef struct _RtsSymbolVal { // We don't do this when compiling to Windows DLLs at the moment because // it doesn't support cross package data references well. // -#if defined(__PIC__) && defined(mingw32_HOST_OS) +#if defined(__PIC__) && defined(mingw32_HOST_OS) && defined(i386_HOST_ARCH) #define RTS_INTCHAR_SYMBOLS #else #define RTS_INTCHAR_SYMBOLS \ @@ -1069,7 +1076,7 @@ typedef struct _RtsSymbolVal { /* entirely bogus claims about types of these symbols */ #define SymI_NeedsProto(vvv) extern void vvv(void); -#if defined(__PIC__) && defined(mingw32_HOST_OS) +#if defined(__PIC__) && defined(mingw32_HOST_OS) && defined(i386_HOST_ARCH) #define SymE_HasProto(vvv) SymE_HasProto(vvv); #define SymE_NeedsProto(vvv) extern void _imp__ ## vvv (void); #else diff --git a/rts/PrimOps.cmm b/rts/PrimOps.cmm index 4cb3b8d85c..e368ed195b 100644 --- a/rts/PrimOps.cmm +++ b/rts/PrimOps.cmm @@ -35,7 +35,7 @@ import base_ControlziExceptionziBase_nestedAtomically_closure; import EnterCriticalSection; import LeaveCriticalSection; import ghczmprim_GHCziTypes_False_closure; -#if !defined(mingw32_HOST_OS) +#if defined(GhcUnregisterised) || !defined(mingw32_HOST_OS) import sm_mutex; #endif diff --git a/rts/RtsMain.c b/rts/RtsMain.c index e89445db25..435df420c5 100644 --- a/rts/RtsMain.c +++ b/rts/RtsMain.c @@ -108,11 +108,11 @@ int hs_main (int argc, char *argv[], // program args progmain_closure = main_closure; rtsconfig = rts_config; -#if defined(mingw32_HOST_OS) +#if defined(mingw32_HOST_OS) && defined(i386_HOST_ARCH) BEGIN_CATCH #endif real_main(); -#if defined(mingw32_HOST_OS) +#if defined(mingw32_HOST_OS) && defined(i386_HOST_ARCH) END_CATCH #endif } diff --git a/rts/Schedule.c b/rts/Schedule.c index e17116bc07..7dca76438b 100644 --- a/rts/Schedule.c +++ b/rts/Schedule.c @@ -611,7 +611,7 @@ schedulePreLoop(void) { // initialisation for scheduler - what cannot go into initScheduler() -#if defined(mingw32_HOST_OS) +#if defined(mingw32_HOST_OS) && !defined(GhcUnregisterised) win32AllocStack(); #endif } diff --git a/rts/StgCRun.c b/rts/StgCRun.c index 3654b3336a..b4c15e8722 100644 --- a/rts/StgCRun.c +++ b/rts/StgCRun.c @@ -33,6 +33,14 @@ /* include Stg.h first because we want real machine regs in here: we * have to get the value of R1 back from Stg land to C land intact. */ + +/* We include windows.h very early, as on Win64 the CONTEXT type has + fields "R8", "R9" and "R10", which goes bad if we've already + #define'd those names for our own purposes (in stg/Regs.h) */ +#if defined(HAVE_WINDOWS_H) +#include <windows.h> +#endif + #define IN_STGCRUN 1 #include "Stg.h" #include "Rts.h" @@ -90,6 +98,18 @@ StgFunPtr StgReturn(void) #define STG_RETURN "StgReturn" #endif +#if defined(mingw32_HOST_OS) +// On windows the stack has to be allocated 4k at a time, otherwise +// we get a segfault. The C compiler knows how to do this (it calls +// _alloca()), so we make sure that we can allocate as much stack as +// we need: +StgWord8 *win32AllocStack(void) +{ + StgWord8 stack[RESERVED_C_STACK_BYTES + 16 + 12]; + return stack; +} +#endif + /* ----------------------------------------------------------------------------- x86 architecture -------------------------------------------------------------------------- */ @@ -203,18 +223,6 @@ StgRunIsImplementedInAssembler(void) ); } -#if defined(mingw32_HOST_OS) -// On windows the stack has to be allocated 4k at a time, otherwise -// we get a segfault. The C compiler knows how to do this (it calls -// _alloca()), so we make sure that we can allocate as much stack as -// we need: -StgWord8 *win32AllocStack(void) -{ - StgWord8 stack[RESERVED_C_STACK_BYTES + 16 + 12]; - return stack; -} -#endif - #endif /* ---------------------------------------------------------------------------- @@ -239,23 +247,36 @@ StgRunIsImplementedInAssembler(void) */ ".globl " STG_RUN "\n" STG_RUN ":\n\t" - "subq %0, %%rsp\n\t" + "subq %1, %%rsp\n\t" "movq %%rsp, %%rax\n\t" - "addq %0-48, %%rax\n\t" + "subq %0, %%rsp\n\t" "movq %%rbx,0(%%rax)\n\t" "movq %%rbp,8(%%rax)\n\t" "movq %%r12,16(%%rax)\n\t" "movq %%r13,24(%%rax)\n\t" "movq %%r14,32(%%rax)\n\t" "movq %%r15,40(%%rax)\n\t" +#if defined(mingw32_HOST_OS) + "movq %%rdi,48(%%rax)\n\t" + "movq %%rsi,56(%%rax)\n\t" + "movq %%xmm6,64(%%rax)\n\t" +#endif /* * Set BaseReg */ +#if defined(mingw32_HOST_OS) + "movq %%rdx,%%r13\n\t" +#else "movq %%rsi,%%r13\n\t" +#endif /* * grab the function argument from the stack, and jump to it. */ +#if defined(mingw32_HOST_OS) + "movq %%rcx,%%rax\n\t" +#else "movq %%rdi,%%rax\n\t" +#endif "jmp *%%rax\n\t" ".globl " STG_RETURN "\n" @@ -266,18 +287,30 @@ StgRunIsImplementedInAssembler(void) /* * restore callee-saves registers. (Don't stomp on %%rax!) */ + "addq %0, %%rsp\n\t" "movq %%rsp, %%rdx\n\t" - "addq %0-48, %%rdx\n\t" + "addq %1, %%rsp\n\t" "movq 0(%%rdx),%%rbx\n\t" /* restore the registers saved above */ "movq 8(%%rdx),%%rbp\n\t" "movq 16(%%rdx),%%r12\n\t" "movq 24(%%rdx),%%r13\n\t" "movq 32(%%rdx),%%r14\n\t" "movq 40(%%rdx),%%r15\n\t" - "addq %0, %%rsp\n\t" +#if defined(mingw32_HOST_OS) + "movq 48(%%rdx),%%rdi\n\t" + "movq 56(%%rdx),%%rsi\n\t" + "movq 64(%%rdx),%%xmm6\n\t" +#endif "retq" - : : "i"(RESERVED_C_STACK_BYTES + 48 /*stack frame size*/)); + : + : "i"(RESERVED_C_STACK_BYTES), +#if defined(mingw32_HOST_OS) + "i"(80 /*stack frame size; 8 too large to make the alignment right*/) +#else + "i"(48 /*stack frame size*/) +#endif + ); /* * See Note [Stack Alignment on X86] */ diff --git a/rts/StgMiscClosures.cmm b/rts/StgMiscClosures.cmm index e4b128f96e..763c85b3b6 100644 --- a/rts/StgMiscClosures.cmm +++ b/rts/StgMiscClosures.cmm @@ -576,7 +576,7 @@ INFO_TABLE_CONSTR(stg_MVAR_TSO_QUEUE,2,0,0,PRIM,"MVAR_TSO_QUEUE","MVAR_TSO_QUEUE replace them with references to the static objects. ------------------------------------------------------------------------- */ -#if defined(__PIC__) && defined(mingw32_HOST_OS) +#if defined(__PIC__) && defined(mingw32_HOST_OS) && defined(i386_HOST_ARCH) /* * When sticking the RTS in a Windows DLL, we delay populating the * Charlike and Intlike tables until load-time, which is only @@ -601,7 +601,7 @@ INFO_TABLE_CONSTR(stg_MVAR_TSO_QUEUE,2,0,0,PRIM,"MVAR_TSO_QUEUE","MVAR_TSO_QUEUE * on the fact that static closures live in the data section. */ -#if !(defined(__PIC__) && defined(mingw32_HOST_OS)) +#if !(defined(__PIC__) && defined(mingw32_HOST_OS) && defined(i386_HOST_ARCH)) section "data" { stg_CHARLIKE_closure: CHARLIKE_HDR(0) @@ -899,4 +899,4 @@ section "data" { INTLIKE_HDR(16) /* MAX_INTLIKE == 16 */ } -#endif // !(defined(__PIC__) && defined(mingw32_HOST_OS)) +#endif // !(defined(__PIC__) && defined(mingw32_HOST_OS) && defined(i386_HOST_ARCH)) diff --git a/rts/Trace.c b/rts/Trace.c index df5147ca05..e3934d668e 100644 --- a/rts/Trace.c +++ b/rts/Trace.c @@ -309,7 +309,10 @@ void traceCapsetEvent_ (EventTypeNum tag, StgWord info) { #ifdef DEBUG - if (RtsFlags.TraceFlags.tracing == TRACE_STDERR) { + if (RtsFlags.TraceFlags.tracing == TRACE_STDERR && TRACE_sched) + // When events go to stderr, it is annoying to see the capset + // events every time, so we only emit them with -Ds. + { ACQUIRE_LOCK(&trace_utx); tracePreface(); diff --git a/rts/ghc.mk b/rts/ghc.mk index fc634c7ff2..95faea8f77 100644 --- a/rts/ghc.mk +++ b/rts/ghc.mk @@ -28,7 +28,7 @@ all_rts : $(ALL_RTS_LIBS) ALL_DIRS = hooks parallel sm eventlog -ifeq "$(HOSTPLATFORM)" "i386-unknown-mingw32" +ifeq "$(HostOS_CPP)" "mingw32" ALL_DIRS += win32 else ALL_DIRS += posix @@ -311,6 +311,11 @@ rts/RtsUtils_CC_OPTS += -DTargetVendor=\"$(TargetVendor_CPP)\" rts/RtsUtils_CC_OPTS += -DGhcUnregisterised=\"$(GhcUnregisterised)\" rts/RtsUtils_CC_OPTS += -DGhcEnableTablesNextToCode=\"$(GhcEnableTablesNextToCode)\" +ifeq "$(GhcUnregisterised)" "YES" +rts/PrimOps_HC_OPTS += -DGhcUnregisterised=1 +rts/Schedule_CC_OPTS += -DGhcUnregisterised=1 +endif + # Compile various performance-critical pieces *without* -fPIC -dynamic # even when building a shared library. If we don't do this, then the # GC runs about 50% slower on x86 due to the overheads of PIC. The diff --git a/rts/win32/AwaitEvent.c b/rts/win32/AwaitEvent.c index 1b92c4386f..af9c658e02 100644 --- a/rts/win32/AwaitEvent.c +++ b/rts/win32/AwaitEvent.c @@ -27,13 +27,11 @@ static nat workerWaitingForRequests = 0; void awaitEvent(rtsBool wait) { - int ret; - do { /* Try to de-queue completed IO requests */ workerWaitingForRequests = 1; - ret = awaitRequests(wait); + awaitRequests(wait); workerWaitingForRequests = 0; // If a signal was raised, we need to service it diff --git a/rts/win32/ThrIOManager.c b/rts/win32/ThrIOManager.c index bad621ced6..9561ea6aea 100644 --- a/rts/win32/ThrIOManager.c +++ b/rts/win32/ThrIOManager.c @@ -152,7 +152,7 @@ ioManagerStart (void) Capability *cap;
if (io_manager_event == INVALID_HANDLE_VALUE) {
cap = rts_lock();
-#if defined(mingw32_HOST_OS) && defined(__PIC__)
+#if defined(mingw32_HOST_OS) && defined(i386_HOST_ARCH) && defined(__PIC__)
rts_evalIO(&cap,_imp__base_GHCziConcziIO_ensureIOManagerIsRunning_closure,NULL);
#else
rts_evalIO(&cap,&base_GHCziConcziIO_ensureIOManagerIsRunning_closure,NULL);
diff --git a/rts/win32/seh_excn.c b/rts/win32/seh_excn.c index 5da7579b10..da5f64d812 100644 --- a/rts/win32/seh_excn.c +++ b/rts/win32/seh_excn.c @@ -1,9 +1,11 @@ +#include "ghcconfig.h" #include "seh_excn.h" /* * Exception / signal handlers. */ -#if defined(__MINGW32__) +#if defined(mingw32_HOST_OS) +#if defined(i386_HOST_ARCH) jmp_buf seh_unwind_to; unsigned long seh_excn_code; /* variable used to communicate what kind of exception we've caught;nice. */ @@ -39,4 +41,5 @@ catchDivZero(struct _EXCEPTION_RECORD* rec, return ExceptionContinueSearch; } #endif +#endif diff --git a/rules/distdir-way-opts.mk b/rules/distdir-way-opts.mk index 7b516371e2..2e5f76462b 100644 --- a/rules/distdir-way-opts.mk +++ b/rules/distdir-way-opts.mk @@ -28,40 +28,40 @@ define distdir-way-opts # args: $1 = dir, $2 = distdir, $3 = way, $4 = stage # Variable Purpose Defined by # -------------- ------------------------------ -------------- # $1_PACKAGE Package name for this dir, $1/$2/ghc.mk -# if it is a package -# +# if it is a package +# # CONF_HC_OPTS GHC options from ./configure mk/config.mk.in -# +# # CONF_HC_OPTS_STAGE$4 GHC options from ./configure mk/config.mk.in -# specific to stage $4 -# +# specific to stage $4 +# # WAY_$3_HC_OPTS GHC options specific to way $3 mk/ways.mk -# +# # SRC_HC_OPTS source-tree-wide GHC options mk/config.mk.in # mk/build.mk # mk/validate.mk -# +# # EXTRA_HC_OPTS for supplying extra options on make EXTRA_HC_OPTS=... -# the command line -# +# the command line +# # $1_HC_OPTS GHC options specific to this $1/$2/package-data.mk # dir -# +# # $1_$2_HC_OPTS GHC options specific to this $1/$2/package-data.mk # dir and distdir -# +# # $1_$2_$3_HC_OPTS GHC options specific to this $1/$2/package-data.mk # dir, distdir and way -# +# # $1_$2_MORE_HC_OPTS GHC options for this dir/distdir ??? -# +# # $1_$2_EXTRA_HC_OPTS GHC options for this dir/distdir mk/build.mk -# +# # $1_$2_HC_PKGCONF -package-conf flag if necessary rules/package-config.mk -# +# # $1_$2_HS_SRC_DIRS dirs relative to $1 containing $1/$2/package-data.mk -# source files -# +# source files +# # $1_$2_CPP_OPTS CPP options $1/$2/package-data.mk # # <file>_HC_OPTS GHC options for this source $1/$2/ghc.mk diff --git a/utils/fingerprint/fingerprint.py b/utils/fingerprint/fingerprint.py index 5a753279e6..b0e599d03b 100755 --- a/utils/fingerprint/fingerprint.py +++ b/utils/fingerprint/fingerprint.py @@ -55,7 +55,7 @@ def fingerprint(source=None): `sync-all` command will be run to get the current fingerprint. """ if source is None: - sync_all = ["./sync-all", "log", "HEAD^..", "--pretty=oneline"] + sync_all = ["./sync-all", "log", "-1", "--pretty=oneline"] source = Popen(sync_all, stdout=PIPE).stdout lib = "" diff --git a/utils/genapply/GenApply.hs b/utils/genapply/GenApply.hs index b255b92d28..d00324f173 100644 --- a/utils/genapply/GenApply.hs +++ b/utils/genapply/GenApply.hs @@ -17,7 +17,7 @@ module Main(main) where import Text.PrettyPrint import Data.Word import Data.Bits -import Data.List ( intersperse ) +import Data.List ( intersperse ) import System.Exit import System.Environment import System.IO @@ -26,12 +26,12 @@ import System.IO -- Argument kinds (rougly equivalent to PrimRep) data ArgRep - = N -- non-ptr - | P -- ptr - | V -- void - | F -- float - | D -- double - | L -- long (64-bit) + = N -- non-ptr + | P -- ptr + | V -- void + | F -- float + | D -- double + | L -- long (64-bit) -- size of a value in *words* argSize :: ArgRep -> Int @@ -93,12 +93,12 @@ saveRegOffs = vcat . map (uncurry assign_reg_to_stk) -- a bit like assignRegs in CgRetConv.lhs assignRegs - :: RegStatus -- are we registerised? - -> Int -- Sp of first arg - -> [ArgRep] -- args - -> ([(Reg,Int)], -- regs and offsets to load - [ArgRep], -- left-over args - Int) -- Sp of left-over args + :: RegStatus -- are we registerised? + -> Int -- Sp of first arg + -> [ArgRep] -- args + -> ([(Reg,Int)], -- regs and offsets to load + [ArgRep], -- left-over args + Int) -- Sp of left-over args assignRegs regstatus sp args = assign sp args (availableRegs regstatus) [] assign sp [] regs doc = (doc, [], sp) @@ -106,7 +106,7 @@ assign sp (V : args) regs doc = assign sp args regs doc assign sp (arg : args) regs doc = case findAvailableReg arg regs of Just (reg, regs') -> assign (sp + argSize arg) args regs' - ((reg, sp) : doc) + ((reg, sp) : doc) Nothing -> (doc, (arg:args), sp) findAvailableReg N (vreg:vregs, fregs, dregs, lregs) = @@ -139,8 +139,8 @@ loadSpWordOff rep off = text rep <> text "[Sp+WDS(" <> int off <> text ")]" mkBitmap :: [ArgRep] -> Word32 mkBitmap args = foldr f 0 args where f arg bm | isPtr arg = bm `shiftL` 1 - | otherwise = (bm `shiftL` size) .|. ((1 `shiftL` size) - 1) - where size = argSize arg + | otherwise = (bm `shiftL` size) .|. ((1 `shiftL` size) - 1) + where size = argSize arg -- ----------------------------------------------------------------------------- -- Generating the application functions @@ -174,113 +174,113 @@ mkApplyInfoName args = mkApplyName args <> text "_info" mb_tag_node arity | Just tag <- tagForArity arity = mkTagStmt tag <> semi - | otherwise = empty + | otherwise = empty mkTagStmt tag = text ("R1 = R1 + "++ show tag) genMkPAP regstatus macro jump ticker disamb - no_load_regs -- don't load argumnet regs before jumping - args_in_regs -- arguments are already in regs - is_pap args all_args_size fun_info_label + no_load_regs -- don't load argumnet regs before jumping + args_in_regs -- arguments are already in regs + is_pap args all_args_size fun_info_label is_fun_case = smaller_arity_cases $$ exact_arity_case $$ larger_arity_case - + where n_args = length args - -- offset of arguments on the stack at slow apply calls. + -- offset of arguments on the stack at slow apply calls. stk_args_slow_offset = 1 stk_args_offset - | args_in_regs = 0 - | otherwise = stk_args_slow_offset + | args_in_regs = 0 + | otherwise = stk_args_slow_offset -- The SMALLER ARITY cases: --- if (arity == 1) { --- Sp[0] = Sp[1]; --- Sp[1] = (W_)&stg_ap_1_info; --- JMP_(GET_ENTRY(R1.cl)); +-- if (arity == 1) { +-- Sp[0] = Sp[1]; +-- Sp[1] = (W_)&stg_ap_1_info; +-- JMP_(GET_ENTRY(R1.cl)); smaller_arity_cases = vcat [ smaller_arity i | i <- [1..n_args-1] ] smaller_arity arity = text "if (arity == " <> int arity <> text ") {" $$ nest 4 (vcat [ - -- text "TICK_SLOW_CALL_" <> text ticker <> text "_TOO_MANY();", - - -- load up regs for the call, if necessary - load_regs, - - -- If we have more args in registers than are required - -- for the call, then we must save some on the stack, - -- and set up the stack for the follow-up call. - -- If the extra arguments are on the stack, then we must - -- instead shuffle them down to make room for the info - -- table for the follow-on call. - if overflow_regs - then save_extra_regs - else shuffle_extra_args, - - -- for a PAP, we have to arrange that the stack contains a - -- return address in the even that stg_PAP_entry fails its - -- heap check. See stg_PAP_entry in Apply.hc for details. - if is_pap - then text "R2 = " <> mkApplyInfoName this_call_args <> semi - - else empty, + -- text "TICK_SLOW_CALL_" <> text ticker <> text "_TOO_MANY();", + + -- load up regs for the call, if necessary + load_regs, + + -- If we have more args in registers than are required + -- for the call, then we must save some on the stack, + -- and set up the stack for the follow-up call. + -- If the extra arguments are on the stack, then we must + -- instead shuffle them down to make room for the info + -- table for the follow-on call. + if overflow_regs + then save_extra_regs + else shuffle_extra_args, + + -- for a PAP, we have to arrange that the stack contains a + -- return address in the even that stg_PAP_entry fails its + -- heap check. See stg_PAP_entry in Apply.hc for details. + if is_pap + then text "R2 = " <> mkApplyInfoName this_call_args <> semi + + else empty, if is_fun_case then mb_tag_node arity else empty, if overflow_regs then text "jump_SAVE_CCCS" <> parens (text jump) <> semi else text "jump " <> text jump <> semi ]) $$ - text "}" - - where - -- offsets in case we need to save regs: - (reg_locs, _, _) - = assignRegs regstatus stk_args_offset args - - -- register assignment for *this function call* - (reg_locs', reg_call_leftovers, reg_call_sp_stk_args) - = assignRegs regstatus stk_args_offset (take arity args) - - load_regs - | no_load_regs || args_in_regs = empty - | otherwise = loadRegOffs reg_locs' - - (this_call_args, rest_args) = splitAt arity args - - -- the offset of the stack args from initial Sp - sp_stk_args - | args_in_regs = stk_args_offset - | no_load_regs = stk_args_offset - | otherwise = reg_call_sp_stk_args - - -- the stack args themselves - this_call_stack_args - | args_in_regs = reg_call_leftovers -- sp offsets are wrong - | no_load_regs = this_call_args - | otherwise = reg_call_leftovers - - stack_args_size = sum (map argSize this_call_stack_args) - - overflow_regs = args_in_regs && length reg_locs > length reg_locs' - - save_extra_regs - = -- we have extra arguments in registers to save - let - extra_reg_locs = drop (length reg_locs') (reverse reg_locs) - adj_reg_locs = [ (reg, off - adj + 1) | - (reg,off) <- extra_reg_locs ] - adj = case extra_reg_locs of - (reg, fst_off):_ -> fst_off - size = snd (last adj_reg_locs) - in - text "Sp_adj(" <> int (-size - 1) <> text ");" $$ - saveRegOffs adj_reg_locs $$ - loadSpWordOff "W_" 0 <> text " = " <> - mkApplyInfoName rest_args <> semi + text "}" + + where + -- offsets in case we need to save regs: + (reg_locs, _, _) + = assignRegs regstatus stk_args_offset args + + -- register assignment for *this function call* + (reg_locs', reg_call_leftovers, reg_call_sp_stk_args) + = assignRegs regstatus stk_args_offset (take arity args) + + load_regs + | no_load_regs || args_in_regs = empty + | otherwise = loadRegOffs reg_locs' + + (this_call_args, rest_args) = splitAt arity args + + -- the offset of the stack args from initial Sp + sp_stk_args + | args_in_regs = stk_args_offset + | no_load_regs = stk_args_offset + | otherwise = reg_call_sp_stk_args + + -- the stack args themselves + this_call_stack_args + | args_in_regs = reg_call_leftovers -- sp offsets are wrong + | no_load_regs = this_call_args + | otherwise = reg_call_leftovers + + stack_args_size = sum (map argSize this_call_stack_args) + + overflow_regs = args_in_regs && length reg_locs > length reg_locs' + + save_extra_regs + = -- we have extra arguments in registers to save + let + extra_reg_locs = drop (length reg_locs') (reverse reg_locs) + adj_reg_locs = [ (reg, off - adj + 1) | + (reg,off) <- extra_reg_locs ] + adj = case extra_reg_locs of + (reg, fst_off):_ -> fst_off + size = snd (last adj_reg_locs) + in + text "Sp_adj(" <> int (-size - 1) <> text ");" $$ + saveRegOffs adj_reg_locs $$ + loadSpWordOff "W_" 0 <> text " = " <> + mkApplyInfoName rest_args <> semi shuffle_extra_args = vcat [text "#ifdef PROFILING", @@ -310,52 +310,52 @@ genMkPAP regstatus macro jump ticker disamb shuffle_down j i = loadSpWordOff "W_" (i-j) <> text " = " <> - loadSpWordOff "W_" i <> semi + loadSpWordOff "W_" i <> semi -- The EXACT ARITY case -- --- if (arity == 1) { --- Sp++; --- JMP_(GET_ENTRY(R1.cl)); +-- if (arity == 1) { +-- Sp++; +-- JMP_(GET_ENTRY(R1.cl)); exact_arity_case - = text "if (arity == " <> int n_args <> text ") {" $$ - let - (reg_doc, sp') - | no_load_regs || args_in_regs = (empty, stk_args_offset) - | otherwise = loadRegArgs regstatus stk_args_offset args - in - nest 4 (vcat [ --- text "TICK_SLOW_CALL_" <> text ticker <> text "_CORRECT();", - reg_doc, - text "Sp_adj(" <> int sp' <> text ");", + = text "if (arity == " <> int n_args <> text ") {" $$ + let + (reg_doc, sp') + | no_load_regs || args_in_regs = (empty, stk_args_offset) + | otherwise = loadRegArgs regstatus stk_args_offset args + in + nest 4 (vcat [ +-- text "TICK_SLOW_CALL_" <> text ticker <> text "_CORRECT();", + reg_doc, + text "Sp_adj(" <> int sp' <> text ");", if is_pap then text "R2 = " <> fun_info_label <> semi else empty, if is_fun_case then mb_tag_node n_args else empty, - text "jump " <> text jump <> semi - ]) + text "jump " <> text jump <> semi + ]) -- The LARGER ARITY cases: -- --- } else /* arity > 1 */ { --- BUILD_PAP(1,0,(W_)&stg_ap_v_info); --- } +-- } else /* arity > 1 */ { +-- BUILD_PAP(1,0,(W_)&stg_ap_v_info); +-- } larger_arity_case = - text "} else {" $$ - let - save_regs - | args_in_regs = - text "Sp_adj(" <> int (-sp_offset) <> text ");" $$ - saveRegOffs reg_locs - | otherwise = - empty - in - nest 4 (vcat [ --- text "TICK_SLOW_CALL_" <> text ticker <> text "_TOO_FEW();", - save_regs, + text "} else {" $$ + let + save_regs + | args_in_regs = + text "Sp_adj(" <> int (-sp_offset) <> text ");" $$ + saveRegOffs reg_locs + | otherwise = + empty + in + nest 4 (vcat [ +-- text "TICK_SLOW_CALL_" <> text ticker <> text "_TOO_FEW();", + save_regs, -- Before building the PAP, tag the function closure pointer if is_fun_case then vcat [ @@ -365,18 +365,18 @@ genMkPAP regstatus macro jump ticker disamb ] else empty , - text macro <> char '(' <> int n_args <> comma <> - int all_args_size <> - text "," <> fun_info_label <> - text "," <> text disamb <> - text ");" - ]) $$ - char '}' - where - -- offsets in case we need to save regs: - (reg_locs, leftovers, sp_offset) - = assignRegs regstatus stk_args_slow_offset args - -- BUILD_PAP assumes args start at offset 1 + text macro <> char '(' <> int n_args <> comma <> + int all_args_size <> + text "," <> fun_info_label <> + text "," <> text disamb <> + text ");" + ]) $$ + char '}' + where + -- offsets in case we need to save regs: + (reg_locs, leftovers, sp_offset) + = assignRegs regstatus stk_args_slow_offset args + -- BUILD_PAP assumes args start at offset 1 -- Note [jump_SAVE_CCCS] @@ -413,44 +413,44 @@ tagForArity i | i < tAG_BITS_MAX = Just i enterFastPathHelper tag regstatus no_load_regs args_in_regs args = vcat [text "if (GETTAG(R1)==" <> int tag <> text ") {", - reg_doc, + reg_doc, text " Sp_adj(" <> int sp' <> text ");", -- enter, but adjust offset with tag - text " jump " <> text "%GET_ENTRY(R1-" <> int tag <> text ");", + text " jump " <> text "%GET_ENTRY(R1-" <> int tag <> text ");", text "}" ] -- I don't totally understand this code, I copied it from -- exact_arity_case -- TODO: refactor where - -- offset of arguments on the stack at slow apply calls. + -- offset of arguments on the stack at slow apply calls. stk_args_slow_offset = 1 stk_args_offset - | args_in_regs = 0 - | otherwise = stk_args_slow_offset + | args_in_regs = 0 + | otherwise = stk_args_slow_offset (reg_doc, sp') - | no_load_regs || args_in_regs = (empty, stk_args_offset) - | otherwise = loadRegArgs regstatus stk_args_offset args + | no_load_regs || args_in_regs = (empty, stk_args_offset) + | otherwise = loadRegArgs regstatus stk_args_offset args tickForArity arity | True = empty | Just tag <- tagForArity arity = vcat [ - text "W_[TOTAL_CALLS] = W_[TOTAL_CALLS] + 1;", - text "W_[SLOW_CALLS_" <> int arity <> text "] = W_[SLOW_CALLS_" <> int arity <> text "] + 1;", - text "if (TO_W_(StgFunInfoExtra_arity(%FUN_INFO(%INFO_PTR(UNTAG(R1))))) == " <> int arity <> text " ) {", - text " W_[RIGHT_ARITY_" <> int arity <> text "] = W_[RIGHT_ARITY_" <> int arity <> text "] + 1;", - text " if (GETTAG(R1)==" <> int tag <> text ") {", - text " W_[TAGGED_PTR_" <> int arity <> text "] = W_[TAGGED_PTR_" <> int arity <> text "] + 1;", - text " } else {", - -- force a halt when not tagged! --- text " W_[0]=0;", - text " }", - text "}" - ] + text "W_[TOTAL_CALLS] = W_[TOTAL_CALLS] + 1;", + text "W_[SLOW_CALLS_" <> int arity <> text "] = W_[SLOW_CALLS_" <> int arity <> text "] + 1;", + text "if (TO_W_(StgFunInfoExtra_arity(%FUN_INFO(%INFO_PTR(UNTAG(R1))))) == " <> int arity <> text " ) {", + text " W_[RIGHT_ARITY_" <> int arity <> text "] = W_[RIGHT_ARITY_" <> int arity <> text "] + 1;", + text " if (GETTAG(R1)==" <> int tag <> text ") {", + text " W_[TAGGED_PTR_" <> int arity <> text "] = W_[TAGGED_PTR_" <> int arity <> text "] + 1;", + text " } else {", + -- force a halt when not tagged! +-- text " W_[0]=0;", + text " }", + text "}" + ] tickForArity _ = text "W_[TOTAL_CALLS] = W_[TOTAL_CALLS] + 1;" -- ----------------------------------------------------------------------------- @@ -488,45 +488,45 @@ genApply regstatus args = -- print "static void *lbls[] =" -- print " { [FUN] &&fun_lbl," -- print " [FUN_1_0] &&fun_lbl," --- print " [FUN_0_1] &&fun_lbl," --- print " [FUN_2_0] &&fun_lbl," --- print " [FUN_1_1] &&fun_lbl," --- print " [FUN_0_2] &&fun_lbl," +-- print " [FUN_0_1] &&fun_lbl," +-- print " [FUN_2_0] &&fun_lbl," +-- print " [FUN_1_1] &&fun_lbl," +-- print " [FUN_0_2] &&fun_lbl," -- print " [FUN_STATIC] &&fun_lbl," -- print " [PAP] &&pap_lbl," -- print " [THUNK] &&thunk_lbl," --- print " [THUNK_1_0] &&thunk_lbl," --- print " [THUNK_0_1] &&thunk_lbl," --- print " [THUNK_2_0] &&thunk_lbl," --- print " [THUNK_1_1] &&thunk_lbl," --- print " [THUNK_0_2] &&thunk_lbl," +-- print " [THUNK_1_0] &&thunk_lbl," +-- print " [THUNK_0_1] &&thunk_lbl," +-- print " [THUNK_2_0] &&thunk_lbl," +-- print " [THUNK_1_1] &&thunk_lbl," +-- print " [THUNK_0_2] &&thunk_lbl," -- print " [THUNK_STATIC] &&thunk_lbl," -- print " [THUNK_SELECTOR] &&thunk_lbl," --- print " [IND] &&ind_lbl," +-- print " [IND] &&ind_lbl," -- print " [IND_STATIC] &&ind_lbl," --- print " [IND_PERM] &&ind_lbl," +-- print " [IND_PERM] &&ind_lbl," -- print " };" tickForArity (length args), text "", text "IF_DEBUG(apply,foreign \"C\" debugBelch(\"" <> fun_ret_label <> - text "... \"); foreign \"C\" printClosure(R1 \"ptr\"));", + text "... \"); foreign \"C\" printClosure(R1 \"ptr\"));", text "IF_DEBUG(sanity,foreign \"C\" checkStackFrame(Sp+WDS(" <> int (1 + all_args_size) - <> text ")\"ptr\"));", + <> text ")\"ptr\"));", -- text "IF_DEBUG(sanity,checkStackChunk(Sp+" <> int (1 + all_args_size) <> --- text ", CurrentTSO->stack + CurrentTSO->stack_size));", +-- text ", CurrentTSO->stack + CurrentTSO->stack_size));", -- text "TICK_SLOW_CALL(" <> int (length args) <> text ");", let do_assert [] _ = [] - do_assert (arg:args) offset - | isPtr arg = this : rest - | otherwise = rest - where this = text "ASSERT(LOOKS_LIKE_CLOSURE_PTR(Sp(" - <> int offset <> text ")));" - rest = do_assert args (offset + argSize arg) + do_assert (arg:args) offset + | isPtr arg = this : rest + | otherwise = rest + where this = text "ASSERT(LOOKS_LIKE_CLOSURE_PTR(Sp(" + <> int offset <> text ")));" + rest = do_assert args (offset + argSize arg) in vcat (do_assert args 1), @@ -543,20 +543,20 @@ genApply regstatus args = -- print " goto *lbls[info->type];"; -- else: text "switch [INVALID_OBJECT .. N_CLOSURE_TYPES] (TO_W_(%INFO_TYPE(%STD_INFO(info)))) {", - nest 4 (vcat [ + nest 4 (vcat [ -- if fast == 1: -- print " bco_lbl:" -- else: - text "case BCO: {", - nest 4 (vcat [ - text "arity = TO_W_(StgBCO_arity(R1));", - text "ASSERT(arity > 0);", - genMkPAP regstatus "BUILD_PAP" "ENTRY_LBL(stg_BCO)" "FUN" "BCO" - True{-stack apply-} False{-args on stack-} False{-not a PAP-} - args all_args_size fun_info_label {- tag stmt -}False - ]), - text "}", + text "case BCO: {", + nest 4 (vcat [ + text "arity = TO_W_(StgBCO_arity(R1));", + text "ASSERT(arity > 0);", + genMkPAP regstatus "BUILD_PAP" "ENTRY_LBL(stg_BCO)" "FUN" "BCO" + True{-stack apply-} False{-args on stack-} False{-not a PAP-} + args all_args_size fun_info_label {- tag stmt -}False + ]), + text "}", -- if fast == 1: -- print " fun_lbl:" @@ -568,38 +568,38 @@ genApply regstatus args = text " FUN_1_1,", text " FUN_0_2,", text " FUN_STATIC: {", - nest 4 (vcat [ - text "arity = TO_W_(StgFunInfoExtra_arity(%FUN_INFO(info)));", - text "ASSERT(arity > 0);", + nest 4 (vcat [ + text "arity = TO_W_(StgFunInfoExtra_arity(%FUN_INFO(info)));", + text "ASSERT(arity > 0);", genMkPAP regstatus "BUILD_PAP" "%GET_ENTRY(UNTAG(R1))" "FUN" "FUN" - False{-reg apply-} False{-args on stack-} False{-not a PAP-} - args all_args_size fun_info_label {- tag stmt -}True - ]), - text "}", + False{-reg apply-} False{-args on stack-} False{-not a PAP-} + args all_args_size fun_info_label {- tag stmt -}True + ]), + text "}", -- if fast == 1: -- print " pap_lbl:" -- else: - text "case PAP: {", - nest 4 (vcat [ - text "arity = TO_W_(StgPAP_arity(R1));", - text "ASSERT(arity > 0);", - genMkPAP regstatus "NEW_PAP" "stg_PAP_apply" "PAP" "PAP" - True{-stack apply-} False{-args on stack-} True{-is a PAP-} - args all_args_size fun_info_label {- tag stmt -}False - ]), - text "}", + text "case PAP: {", + nest 4 (vcat [ + text "arity = TO_W_(StgPAP_arity(R1));", + text "ASSERT(arity > 0);", + genMkPAP regstatus "NEW_PAP" "stg_PAP_apply" "PAP" "PAP" + True{-stack apply-} False{-args on stack-} True{-is a PAP-} + args all_args_size fun_info_label {- tag stmt -}False + ]), + text "}", - text "", + text "", -- if fast == 1: -- print " thunk_lbl:" -- else: - text "case AP,", - text " AP_STACK,", - text " BLACKHOLE,", - text " WHITEHOLE,", + text "case AP,", + text " AP_STACK,", + text " BLACKHOLE,", + text " WHITEHOLE,", text " THUNK,", text " THUNK_1_0,", text " THUNK_0_1,", @@ -608,18 +608,18 @@ genApply regstatus args = text " THUNK_0_2,", text " THUNK_STATIC,", text " THUNK_SELECTOR: {", - nest 4 (vcat [ + nest 4 (vcat [ -- text "TICK_SLOW_CALL_UNEVALD(" <> int (length args) <> text ");", - text "Sp(0) = " <> fun_info_label <> text ";", - -- CAREFUL! in SMP mode, the info table may already have been - -- overwritten by an indirection, so we must enter the original - -- info pointer we read, don't read it again, because it might - -- not be enterable any more. + text "Sp(0) = " <> fun_info_label <> text ";", + -- CAREFUL! in SMP mode, the info table may already have been + -- overwritten by an indirection, so we must enter the original + -- info pointer we read, don't read it again, because it might + -- not be enterable any more. text "jump_SAVE_CCCS(%ENTRY_CODE(info));", -- see Note [jump_SAVE_CCCS] text "" - ]), - text "}", + ]), + text "}", -- if fast == 1: -- print " ind_lbl:" @@ -627,13 +627,13 @@ genApply regstatus args = text "case IND,", text " IND_STATIC,", text " IND_PERM: {", - nest 4 (vcat [ - text "R1 = StgInd_indirectee(R1);", + nest 4 (vcat [ + text "R1 = StgInd_indirectee(R1);", -- An indirection node might contain a tagged pointer - text "goto again;" - ]), - text "}", - text "", + text "goto again;" + ]), + text "}", + text "", -- if fast == 0: @@ -642,8 +642,8 @@ genApply regstatus args = text "foreign \"C\" barf(\"" <> fun_ret_label <> text "\") never returns;" ), text "}" - - ]), + + ]), text "}" ]), text "}" @@ -675,7 +675,7 @@ genApplyFast regstatus args = text "R1 = UNTAG(R1);", text "info = %GET_STD_INFO(R1);", text "switch [INVALID_OBJECT .. N_CLOSURE_TYPES] (TO_W_(%INFO_TYPE(info))) {", - nest 4 (vcat [ + nest 4 (vcat [ text "case FUN,", text " FUN_1_0,", text " FUN_0_1,", @@ -683,29 +683,29 @@ genApplyFast regstatus args = text " FUN_1_1,", text " FUN_0_2,", text " FUN_STATIC: {", - nest 4 (vcat [ - text "arity = TO_W_(StgFunInfoExtra_arity(%GET_FUN_INFO(R1)));", - text "ASSERT(arity > 0);", + nest 4 (vcat [ + text "arity = TO_W_(StgFunInfoExtra_arity(%GET_FUN_INFO(R1)));", + text "ASSERT(arity > 0);", genMkPAP regstatus "BUILD_PAP" "%GET_ENTRY(UNTAG(R1))" "FUN" "FUN" - False{-reg apply-} True{-args in regs-} False{-not a PAP-} - args all_args_size fun_info_label {- tag stmt -}True - ]), - char '}', - - text "default: {", - let - (reg_locs, leftovers, sp_offset) = assignRegs regstatus 1 args - -- leave a one-word space on the top of the stack when - -- calling the slow version - in - nest 4 (vcat [ - text "Sp_adj" <> parens (int (-sp_offset)) <> semi, - saveRegOffs reg_locs, - text "jump" <+> fun_ret_label <> semi - ]), - char '}' - ]), - char '}' + False{-reg apply-} True{-args in regs-} False{-not a PAP-} + args all_args_size fun_info_label {- tag stmt -}True + ]), + char '}', + + text "default: {", + let + (reg_locs, leftovers, sp_offset) = assignRegs regstatus 1 args + -- leave a one-word space on the top of the stack when + -- calling the slow version + in + nest 4 (vcat [ + text "Sp_adj" <> parens (int (-sp_offset)) <> semi, + saveRegOffs reg_locs, + text "jump" <+> fun_ret_label <> semi + ]), + char '}' + ]), + char '}' ]), char '}' ] @@ -719,7 +719,7 @@ genApplyFast regstatus args = -- available) and jump to the function's entry code. -- -- On entry: R1 points to the function closure --- arguments are on the stack starting at Sp +-- arguments are on the stack starting at Sp -- -- Invariant: the list of arguments never contains void. Since we're only -- interested in loading arguments off the stack here, we can ignore @@ -738,9 +738,9 @@ genStackApply regstatus args = where (assign_regs, sp') = loadRegArgs regstatus 0 args body = vcat [assign_regs, - text "Sp_adj" <> parens (int sp') <> semi, - text "jump %GET_ENTRY(UNTAG(R1));" - ] + text "Sp_adj" <> parens (int sp') <> semi, + text "jump %GET_ENTRY(UNTAG(R1));" + ] -- ----------------------------------------------------------------------------- -- Stack save entry points. @@ -762,15 +762,15 @@ genStackSave regstatus args = ] where body = vcat [text "Sp_adj" <> parens (int (-sp_offset)) <> semi, - saveRegOffs reg_locs, - text "Sp(2) = R1;", - text "Sp(1) =" <+> int stk_args <> semi, - text "Sp(0) = stg_gc_fun_info;", - text "jump stg_gc_noregs;" - ] + saveRegOffs reg_locs, + text "Sp(2) = R1;", + text "Sp(1) =" <+> int stk_args <> semi, + text "Sp(0) = stg_gc_fun_info;", + text "jump stg_gc_noregs;" + ] std_frame_size = 3 -- the std bits of the frame. See StgRetFun in Closures.h, - -- and the comment on stg_fun_gc_gen in HeapStackCheck.hc. + -- and the comment on stg_fun_gc_gen in HeapStackCheck.hc. (reg_locs, leftovers, sp_offset) = assignRegs regstatus std_frame_size args -- number of words of arguments on the stack. @@ -782,51 +782,51 @@ genStackSave regstatus args = main = do args <- getArgs regstatus <- case args of - [] -> return Registerised - ["-u"] -> return Unregisterised - _other -> do hPutStrLn stderr "syntax: genapply [-u]" - exitWith (ExitFailure 1) + [] -> return Registerised + ["-u"] -> return Unregisterised + _other -> do hPutStrLn stderr "syntax: genapply [-u]" + exitWith (ExitFailure 1) let the_code = vcat [ - text "// DO NOT EDIT!", - text "// Automatically generated by GenApply.hs", - text "", - text "#include \"Cmm.h\"", - text "#include \"AutoApply.h\"", - text "", - - vcat (intersperse (text "") $ - map (genApply regstatus) applyTypes), - vcat (intersperse (text "") $ - map (genStackFns regstatus) stackApplyTypes), - - vcat (intersperse (text "") $ - map (genApplyFast regstatus) applyTypes), - - genStackApplyArray stackApplyTypes, - genStackSaveArray stackApplyTypes, - genBitmapArray stackApplyTypes, - - text "" -- add a newline at the end of the file - ] + text "// DO NOT EDIT!", + text "// Automatically generated by GenApply.hs", + text "", + text "#include \"Cmm.h\"", + text "#include \"AutoApply.h\"", + text "", + + vcat (intersperse (text "") $ + map (genApply regstatus) applyTypes), + vcat (intersperse (text "") $ + map (genStackFns regstatus) stackApplyTypes), + + vcat (intersperse (text "") $ + map (genApplyFast regstatus) applyTypes), + + genStackApplyArray stackApplyTypes, + genStackSaveArray stackApplyTypes, + genBitmapArray stackApplyTypes, + + text "" -- add a newline at the end of the file + ] -- in putStr (render the_code) -- These have been shown to cover about 99% of cases in practice... applyTypes = [ - [V], - [F], - [D], - [L], - [N], - [P], - [P,V], - [P,P], - [P,P,V], - [P,P,P], - [P,P,P,V], - [P,P,P,P], - [P,P,P,P,P], - [P,P,P,P,P,P] + [V], + [F], + [D], + [L], + [N], + [P], + [P,V], + [P,P], + [P,P,V], + [P,P,P], + [P,P,P,V], + [P,P,P,P], + [P,P,P,P,P], + [P,P,P,P,P,P] ] -- No need for V args in the stack apply cases. @@ -834,29 +834,29 @@ applyTypes = [ -- between N and P (they both live in the same register), only the bitmap -- changes, so we could share the apply/save code between lots of cases. stackApplyTypes = [ - [], - [N], - [P], - [F], - [D], - [L], - [N,N], - [N,P], - [P,N], - [P,P], - [N,N,N], - [N,N,P], - [N,P,N], - [N,P,P], - [P,N,N], - [P,N,P], - [P,P,N], - [P,P,P], - [P,P,P,P], - [P,P,P,P,P], - [P,P,P,P,P,P], - [P,P,P,P,P,P,P], - [P,P,P,P,P,P,P,P] + [], + [N], + [P], + [F], + [D], + [L], + [N,N], + [N,P], + [P,N], + [P,P], + [N,N,N], + [N,N,P], + [N,P,N], + [N,P,P], + [P,N,N], + [P,N,P], + [P,P,N], + [P,P,P], + [P,P,P,P], + [P,P,P,P,P], + [P,P,P,P,P,P], + [P,P,P,P,P,P,P], + [P,P,P,P,P,P,P,P] ] genStackFns regstatus args @@ -897,7 +897,7 @@ genBitmapArray types = ] where gen_bitmap ty = text "W_" <+> int bitmap_val <> semi - where bitmap_val = - (fromIntegral (mkBitmap ty) `shiftL` BITMAP_BITS_SHIFT) - .|. sum (map argSize ty) + where bitmap_val = + (fromIntegral (mkBitmap ty) `shiftL` BITMAP_BITS_SHIFT) + .|. sum (map argSize ty) diff --git a/utils/genprimopcode/Main.hs b/utils/genprimopcode/Main.hs index 7ac32f6124..4635e84149 100644 --- a/utils/genprimopcode/Main.hs +++ b/utils/genprimopcode/Main.hs @@ -1,11 +1,4 @@ {-# OPTIONS -cpp #-} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - ------------------------------------------------------------------ -- A primop-table mangling program -- ------------------------------------------------------------------ @@ -79,15 +72,15 @@ main = getArgs >>= \args -> "--make-haskell-wrappers" -> putStr (gen_wrappers p_o_specs) - + "--make-haskell-source" -> putStr (gen_hs_source p_o_specs) "--make-ext-core-source" -> putStr (gen_ext_core_source entries) - "--make-latex-doc" - -> putStr (gen_latex_doc p_o_specs) + "--make-latex-doc" + -> putStr (gen_latex_doc p_o_specs) _ -> error "Should not happen, known_args out of sync?" ) @@ -122,81 +115,81 @@ gen_hs_source (Info defaults entries) = ++ "consumed by haddock.\n" ++ "-}\n" ++ "\n" - ++ "-----------------------------------------------------------------------------\n" - ++ "-- |\n" - ++ "-- Module : GHC.Prim\n" - ++ "-- \n" - ++ "-- Maintainer : cvs-ghc@haskell.org\n" - ++ "-- Stability : internal\n" - ++ "-- Portability : non-portable (GHC extensions)\n" - ++ "--\n" - ++ "-- GHC\'s primitive types and operations.\n" - ++ "-- Use GHC.Exts from the base package instead of importing this\n" - ++ "-- module directly.\n" - ++ "--\n" - ++ "-----------------------------------------------------------------------------\n" - ++ "module GHC.Prim (\n" - ++ unlines (map (("\t" ++) . hdr) entries) - ++ ") where\n" + ++ "-----------------------------------------------------------------------------\n" + ++ "-- |\n" + ++ "-- Module : GHC.Prim\n" + ++ "-- \n" + ++ "-- Maintainer : cvs-ghc@haskell.org\n" + ++ "-- Stability : internal\n" + ++ "-- Portability : non-portable (GHC extensions)\n" + ++ "--\n" + ++ "-- GHC\'s primitive types and operations.\n" + ++ "-- Use GHC.Exts from the base package instead of importing this\n" + ++ "-- module directly.\n" + ++ "--\n" + ++ "-----------------------------------------------------------------------------\n" + ++ "module GHC.Prim (\n" + ++ unlines (map (("\t" ++) . hdr) entries) + ++ ") where\n" ++ "\n" ++ "import GHC.Types\n" ++ "\n" ++ "{-\n" - ++ unlines (map opt defaults) + ++ unlines (map opt defaults) ++ "-}\n" - ++ unlines (concatMap ent entries) ++ "\n\n\n" - where opt (OptionFalse n) = n ++ " = False" - opt (OptionTrue n) = n ++ " = True" - opt (OptionString n v) = n ++ " = { " ++ v ++ "}" + ++ unlines (concatMap ent entries) ++ "\n\n\n" + where opt (OptionFalse n) = n ++ " = False" + opt (OptionTrue n) = n ++ " = True" + opt (OptionString n v) = n ++ " = { " ++ v ++ "}" opt (OptionInteger n v) = n ++ " = " ++ show v - hdr s@(Section {}) = sec s - hdr (PrimOpSpec { name = n }) = wrapOp n ++ "," - hdr (PseudoOpSpec { name = n }) = wrapOp n ++ "," - hdr (PrimTypeSpec { ty = TyApp n _ }) = wrapTy n ++ "," - hdr (PrimTypeSpec {}) = error "Illegal type spec" + hdr s@(Section {}) = sec s + hdr (PrimOpSpec { name = n }) = wrapOp n ++ "," + hdr (PseudoOpSpec { name = n }) = wrapOp n ++ "," + hdr (PrimTypeSpec { ty = TyApp n _ }) = wrapTy n ++ "," + hdr (PrimTypeSpec {}) = error "Illegal type spec" - ent (Section {}) = [] - ent o@(PrimOpSpec {}) = spec o - ent o@(PrimTypeSpec {}) = spec o - ent o@(PseudoOpSpec {}) = spec o + ent (Section {}) = [] + ent o@(PrimOpSpec {}) = spec o + ent o@(PrimTypeSpec {}) = spec o + ent o@(PseudoOpSpec {}) = spec o - sec s = "\n-- * " ++ escape (title s) ++ "\n" - ++ (unlines $ map ("-- " ++ ) $ lines $ unlatex $ escape $ "|" ++ desc s) ++ "\n" + sec s = "\n-- * " ++ escape (title s) ++ "\n" + ++ (unlines $ map ("-- " ++ ) $ lines $ unlatex $ escape $ "|" ++ desc s) ++ "\n" - spec o = comm : decls - where decls = case o of - PrimOpSpec { name = n, ty = t } -> + spec o = comm : decls + where decls = case o of + PrimOpSpec { name = n, ty = t } -> [ wrapOp n ++ " :: " ++ pprTy t, wrapOp n ++ " = let x = x in x" ] - PseudoOpSpec { name = n, ty = t } -> + PseudoOpSpec { name = n, ty = t } -> [ wrapOp n ++ " :: " ++ pprTy t, wrapOp n ++ " = let x = x in x" ] - PrimTypeSpec { ty = t } -> + PrimTypeSpec { ty = t } -> [ "data " ++ pprTy t ] - Section { } -> [] - - comm = case (desc o) of - [] -> "" - d -> "\n" ++ (unlines $ map ("-- " ++ ) $ lines $ unlatex $ escape $ "|" ++ d) - - wrapOp nm | isAlpha (head nm) = nm - | otherwise = "(" ++ nm ++ ")" - wrapTy nm | isAlpha (head nm) = nm - | otherwise = "(" ++ nm ++ ")" - unlatex s = case s of - '\\':'t':'e':'x':'t':'t':'t':'{':cs -> markup "@" "@" cs - '{':'\\':'t':'t':cs -> markup "@" "@" cs - '{':'\\':'i':'t':cs -> markup "/" "/" cs - c : cs -> c : unlatex cs - [] -> [] - markup s t xs = s ++ mk (dropWhile isSpace xs) - where mk "" = t - mk ('\n':cs) = ' ' : mk cs - mk ('}':cs) = t ++ unlatex cs - mk (c:cs) = c : mk cs - escape = concatMap (\c -> if c `elem` special then '\\':c:[] else c:[]) - where special = "/'`\"@<" + Section { } -> [] + + comm = case (desc o) of + [] -> "" + d -> "\n" ++ (unlines $ map ("-- " ++ ) $ lines $ unlatex $ escape $ "|" ++ d) + + wrapOp nm | isAlpha (head nm) = nm + | otherwise = "(" ++ nm ++ ")" + wrapTy nm | isAlpha (head nm) = nm + | otherwise = "(" ++ nm ++ ")" + unlatex s = case s of + '\\':'t':'e':'x':'t':'t':'t':'{':cs -> markup "@" "@" cs + '{':'\\':'t':'t':cs -> markup "@" "@" cs + '{':'\\':'i':'t':cs -> markup "/" "/" cs + c : cs -> c : unlatex cs + [] -> [] + markup s t xs = s ++ mk (dropWhile isSpace xs) + where mk "" = t + mk ('\n':cs) = ' ' : mk cs + mk ('}':cs) = t ++ unlatex cs + mk (c:cs) = c : mk cs + escape = concatMap (\c -> if c `elem` special then '\\':c:[] else c:[]) + where special = "/'`\"@<" pprTy :: Ty -> String pprTy = pty @@ -333,167 +326,167 @@ gen_ext_core_source entries = gen_latex_doc :: Info -> String gen_latex_doc (Info defaults entries) = "\\primopdefaults{" - ++ mk_options defaults - ++ "}\n" + ++ mk_options defaults + ++ "}\n" ++ (concat (map mk_entry entries)) where mk_entry (PrimOpSpec {cons=constr,name=n,ty=t,cat=c,desc=d,opts=o}) = - "\\primopdesc{" - ++ latex_encode constr ++ "}{" - ++ latex_encode n ++ "}{" - ++ latex_encode (zencode n) ++ "}{" - ++ latex_encode (show c) ++ "}{" - ++ latex_encode (mk_source_ty t) ++ "}{" - ++ latex_encode (mk_core_ty t) ++ "}{" - ++ d ++ "}{" - ++ mk_options o - ++ "}\n" + "\\primopdesc{" + ++ latex_encode constr ++ "}{" + ++ latex_encode n ++ "}{" + ++ latex_encode (zencode n) ++ "}{" + ++ latex_encode (show c) ++ "}{" + ++ latex_encode (mk_source_ty t) ++ "}{" + ++ latex_encode (mk_core_ty t) ++ "}{" + ++ d ++ "}{" + ++ mk_options o + ++ "}\n" mk_entry (Section {title=ti,desc=d}) = - "\\primopsection{" - ++ latex_encode ti ++ "}{" - ++ d ++ "}\n" + "\\primopsection{" + ++ latex_encode ti ++ "}{" + ++ d ++ "}\n" mk_entry (PrimTypeSpec {ty=t,desc=d,opts=o}) = - "\\primtypespec{" - ++ latex_encode (mk_source_ty t) ++ "}{" - ++ latex_encode (mk_core_ty t) ++ "}{" - ++ d ++ "}{" - ++ mk_options o - ++ "}\n" + "\\primtypespec{" + ++ latex_encode (mk_source_ty t) ++ "}{" + ++ latex_encode (mk_core_ty t) ++ "}{" + ++ d ++ "}{" + ++ mk_options o + ++ "}\n" mk_entry (PseudoOpSpec {name=n,ty=t,desc=d,opts=o}) = - "\\pseudoopspec{" - ++ latex_encode (zencode n) ++ "}{" - ++ latex_encode (mk_source_ty t) ++ "}{" - ++ latex_encode (mk_core_ty t) ++ "}{" - ++ d ++ "}{" - ++ mk_options o - ++ "}\n" - mk_source_ty typ = pty typ - where pty (TyF t1 t2) = pbty t1 ++ " -> " ++ pty t2 - pty t = pbty t - pbty (TyApp tc ts) = tc ++ (concat (map (' ':) (map paty ts))) - pbty (TyUTup ts) = "(# " ++ (concat (intersperse "," (map pty ts))) ++ " #)" - pbty t = paty t - paty (TyVar tv) = tv - paty t = "(" ++ pty t ++ ")" - - mk_core_ty typ = foralls ++ (pty typ) - where pty (TyF t1 t2) = pbty t1 ++ " -> " ++ pty t2 - pty t = pbty t - pbty (TyApp tc ts) = (zencode tc) ++ (concat (map (' ':) (map paty ts))) - pbty (TyUTup ts) = (zencode (utuplenm (length ts))) ++ (concat ((map (' ':) (map paty ts)))) - pbty t = paty t - paty (TyVar tv) = zencode tv - paty (TyApp tc []) = zencode tc - paty t = "(" ++ pty t ++ ")" - utuplenm 1 = "(# #)" - utuplenm n = "(#" ++ (replicate (n-1) ',') ++ "#)" - foralls = if tvars == [] then "" else "%forall " ++ (tbinds tvars) - tvars = tvars_of typ - tbinds [] = ". " - tbinds ("o":tbs) = "(o::?) " ++ (tbinds tbs) - tbinds (tv:tbs) = tv ++ " " ++ (tbinds tbs) - tvars_of (TyF t1 t2) = tvars_of t1 `union` tvars_of t2 - tvars_of (TyApp _ ts) = foldl union [] (map tvars_of ts) - tvars_of (TyUTup ts) = foldr union [] (map tvars_of ts) - tvars_of (TyVar tv) = [tv] - + "\\pseudoopspec{" + ++ latex_encode (zencode n) ++ "}{" + ++ latex_encode (mk_source_ty t) ++ "}{" + ++ latex_encode (mk_core_ty t) ++ "}{" + ++ d ++ "}{" + ++ mk_options o + ++ "}\n" + mk_source_ty typ = pty typ + where pty (TyF t1 t2) = pbty t1 ++ " -> " ++ pty t2 + pty t = pbty t + pbty (TyApp tc ts) = tc ++ (concat (map (' ':) (map paty ts))) + pbty (TyUTup ts) = "(# " ++ (concat (intersperse "," (map pty ts))) ++ " #)" + pbty t = paty t + paty (TyVar tv) = tv + paty t = "(" ++ pty t ++ ")" + + mk_core_ty typ = foralls ++ (pty typ) + where pty (TyF t1 t2) = pbty t1 ++ " -> " ++ pty t2 + pty t = pbty t + pbty (TyApp tc ts) = (zencode tc) ++ (concat (map (' ':) (map paty ts))) + pbty (TyUTup ts) = (zencode (utuplenm (length ts))) ++ (concat ((map (' ':) (map paty ts)))) + pbty t = paty t + paty (TyVar tv) = zencode tv + paty (TyApp tc []) = zencode tc + paty t = "(" ++ pty t ++ ")" + utuplenm 1 = "(# #)" + utuplenm n = "(#" ++ (replicate (n-1) ',') ++ "#)" + foralls = if tvars == [] then "" else "%forall " ++ (tbinds tvars) + tvars = tvars_of typ + tbinds [] = ". " + tbinds ("o":tbs) = "(o::?) " ++ (tbinds tbs) + tbinds (tv:tbs) = tv ++ " " ++ (tbinds tbs) + tvars_of (TyF t1 t2) = tvars_of t1 `union` tvars_of t2 + tvars_of (TyApp _ ts) = foldl union [] (map tvars_of ts) + tvars_of (TyUTup ts) = foldr union [] (map tvars_of ts) + tvars_of (TyVar tv) = [tv] + mk_options o = - "\\primoptions{" - ++ mk_has_side_effects o ++ "}{" - ++ mk_out_of_line o ++ "}{" - ++ mk_commutable o ++ "}{" - ++ mk_needs_wrapper o ++ "}{" - ++ mk_can_fail o ++ "}{" - ++ latex_encode (mk_strictness o) ++ "}{" - ++ "}" - - mk_has_side_effects o = mk_bool_opt o "has_side_effects" "Has side effects." "Has no side effects." - mk_out_of_line o = mk_bool_opt o "out_of_line" "Implemented out of line." "Implemented in line." - mk_commutable o = mk_bool_opt o "commutable" "Commutable." "Not commutable." - mk_needs_wrapper o = mk_bool_opt o "needs_wrapper" "Needs wrapper." "Needs no wrapper." - mk_can_fail o = mk_bool_opt o "can_fail" "Can fail." "Cannot fail." - - mk_bool_opt o opt_name if_true if_false = - case lookup_attrib opt_name o of - Just (OptionTrue _) -> if_true - Just (OptionFalse _) -> if_false - Just (OptionString _ _) -> error "String value for boolean option" + "\\primoptions{" + ++ mk_has_side_effects o ++ "}{" + ++ mk_out_of_line o ++ "}{" + ++ mk_commutable o ++ "}{" + ++ mk_needs_wrapper o ++ "}{" + ++ mk_can_fail o ++ "}{" + ++ latex_encode (mk_strictness o) ++ "}{" + ++ "}" + + mk_has_side_effects o = mk_bool_opt o "has_side_effects" "Has side effects." "Has no side effects." + mk_out_of_line o = mk_bool_opt o "out_of_line" "Implemented out of line." "Implemented in line." + mk_commutable o = mk_bool_opt o "commutable" "Commutable." "Not commutable." + mk_needs_wrapper o = mk_bool_opt o "needs_wrapper" "Needs wrapper." "Needs no wrapper." + mk_can_fail o = mk_bool_opt o "can_fail" "Can fail." "Cannot fail." + + mk_bool_opt o opt_name if_true if_false = + case lookup_attrib opt_name o of + Just (OptionTrue _) -> if_true + Just (OptionFalse _) -> if_false + Just (OptionString _ _) -> error "String value for boolean option" Just (OptionInteger _ _) -> error "Integer value for boolean option" Nothing -> "" - - mk_strictness o = - case lookup_attrib "strictness" o of - Just (OptionString _ s) -> s -- for now - Just _ -> error "Boolean value for strictness" - Nothing -> "" - - zencode xs = - case maybe_tuple xs of - Just n -> n -- Tuples go to Z2T etc - Nothing -> concat (map encode_ch xs) - where - maybe_tuple "(# #)" = Just("Z1H") - maybe_tuple ('(' : '#' : cs) = case count_commas (0::Int) cs of - (n, '#' : ')' : _) -> Just ('Z' : shows (n+1) "H") - _ -> Nothing - maybe_tuple "()" = Just("Z0T") - maybe_tuple ('(' : cs) = case count_commas (0::Int) cs of - (n, ')' : _) -> Just ('Z' : shows (n+1) "T") - _ -> Nothing - maybe_tuple _ = Nothing - - count_commas :: Int -> String -> (Int, String) - count_commas n (',' : cs) = count_commas (n+1) cs - count_commas n cs = (n,cs) - - unencodedChar :: Char -> Bool -- True for chars that don't need encoding - unencodedChar 'Z' = False - unencodedChar 'z' = False - unencodedChar c = isAlphaNum c - - encode_ch :: Char -> String - encode_ch c | unencodedChar c = [c] -- Common case first - - -- Constructors - encode_ch '(' = "ZL" -- Needed for things like (,), and (->) - encode_ch ')' = "ZR" -- For symmetry with ( - encode_ch '[' = "ZM" - encode_ch ']' = "ZN" - encode_ch ':' = "ZC" - encode_ch 'Z' = "ZZ" - - -- Variables - encode_ch 'z' = "zz" - encode_ch '&' = "za" - encode_ch '|' = "zb" - encode_ch '^' = "zc" - encode_ch '$' = "zd" - encode_ch '=' = "ze" - encode_ch '>' = "zg" - encode_ch '#' = "zh" - encode_ch '.' = "zi" - encode_ch '<' = "zl" - encode_ch '-' = "zm" - encode_ch '!' = "zn" - encode_ch '+' = "zp" - encode_ch '\'' = "zq" - encode_ch '\\' = "zr" - encode_ch '/' = "zs" - encode_ch '*' = "zt" - encode_ch '_' = "zu" - encode_ch '%' = "zv" - encode_ch c = 'z' : shows (ord c) "U" - - latex_encode [] = [] - latex_encode (c:cs) | c `elem` "#$%&_^{}" = "\\" ++ c:(latex_encode cs) - latex_encode ('~':cs) = "\\verb!~!" ++ (latex_encode cs) - latex_encode ('\\':cs) = "$\\backslash$" ++ (latex_encode cs) - latex_encode (c:cs) = c:(latex_encode cs) + + mk_strictness o = + case lookup_attrib "strictness" o of + Just (OptionString _ s) -> s -- for now + Just _ -> error "Boolean value for strictness" + Nothing -> "" + + zencode xs = + case maybe_tuple xs of + Just n -> n -- Tuples go to Z2T etc + Nothing -> concat (map encode_ch xs) + where + maybe_tuple "(# #)" = Just("Z1H") + maybe_tuple ('(' : '#' : cs) = case count_commas (0::Int) cs of + (n, '#' : ')' : _) -> Just ('Z' : shows (n+1) "H") + _ -> Nothing + maybe_tuple "()" = Just("Z0T") + maybe_tuple ('(' : cs) = case count_commas (0::Int) cs of + (n, ')' : _) -> Just ('Z' : shows (n+1) "T") + _ -> Nothing + maybe_tuple _ = Nothing + + count_commas :: Int -> String -> (Int, String) + count_commas n (',' : cs) = count_commas (n+1) cs + count_commas n cs = (n,cs) + + unencodedChar :: Char -> Bool -- True for chars that don't need encoding + unencodedChar 'Z' = False + unencodedChar 'z' = False + unencodedChar c = isAlphaNum c + + encode_ch :: Char -> String + encode_ch c | unencodedChar c = [c] -- Common case first + + -- Constructors + encode_ch '(' = "ZL" -- Needed for things like (,), and (->) + encode_ch ')' = "ZR" -- For symmetry with ( + encode_ch '[' = "ZM" + encode_ch ']' = "ZN" + encode_ch ':' = "ZC" + encode_ch 'Z' = "ZZ" + + -- Variables + encode_ch 'z' = "zz" + encode_ch '&' = "za" + encode_ch '|' = "zb" + encode_ch '^' = "zc" + encode_ch '$' = "zd" + encode_ch '=' = "ze" + encode_ch '>' = "zg" + encode_ch '#' = "zh" + encode_ch '.' = "zi" + encode_ch '<' = "zl" + encode_ch '-' = "zm" + encode_ch '!' = "zn" + encode_ch '+' = "zp" + encode_ch '\'' = "zq" + encode_ch '\\' = "zr" + encode_ch '/' = "zs" + encode_ch '*' = "zt" + encode_ch '_' = "zu" + encode_ch '%' = "zv" + encode_ch c = 'z' : shows (ord c) "U" + + latex_encode [] = [] + latex_encode (c:cs) | c `elem` "#$%&_^{}" = "\\" ++ c:(latex_encode cs) + latex_encode ('~':cs) = "\\verb!~!" ++ (latex_encode cs) + latex_encode ('\\':cs) = "$\\backslash$" ++ (latex_encode cs) + latex_encode (c:cs) = c:(latex_encode cs) gen_wrappers :: Info -> String gen_wrappers (Info _ entries) = "{-# LANGUAGE NoImplicitPrelude, UnboxedTuples #-}\n" - -- Dependencies on Prelude must be explicit in libraries/base, but we - -- don't need the Prelude here so we add NoImplicitPrelude. + -- Dependencies on Prelude must be explicit in libraries/base, but we + -- don't need the Prelude here so we add NoImplicitPrelude. ++ "module GHC.PrimopWrappers where\n" ++ "import qualified GHC.Prim\n" ++ "import GHC.Types (Bool)\n" @@ -646,7 +639,7 @@ ppType (TyApp "RealWorld" []) = "realWorldTy" ppType (TyApp "ThreadId#" []) = "threadIdPrimTy" ppType (TyApp "ForeignObj#" []) = "foreignObjPrimTy" ppType (TyApp "BCO#" []) = "bcoPrimTy" -ppType (TyApp "()" []) = "unitTy" -- unitTy is TysWiredIn's name for () +ppType (TyApp "()" []) = "unitTy" -- unitTy is TysWiredIn's name for () ppType (TyVar "a") = "alphaTy" ppType (TyVar "b") = "betaTy" diff --git a/utils/genprimopcode/Parser.y b/utils/genprimopcode/Parser.y index 5773abb4fe..b55ff1ed1c 100644 --- a/utils/genprimopcode/Parser.y +++ b/utils/genprimopcode/Parser.y @@ -1,4 +1,3 @@ - { {-# LANGUAGE BangPatterns #-} -- required for versions of Happy before 1.18.6 {-# OPTIONS -w -Wwarn #-} diff --git a/utils/genprimopcode/ParserM.hs b/utils/genprimopcode/ParserM.hs index 514ed3ec2f..faedab9165 100644 --- a/utils/genprimopcode/ParserM.hs +++ b/utils/genprimopcode/ParserM.hs @@ -1,4 +1,3 @@ - module ParserM ( -- Parser Monad ParserM(..), AlexInput, run_parser, diff --git a/utils/genprimopcode/Syntax.hs b/utils/genprimopcode/Syntax.hs index b20712b62d..10dda25c2e 100644 --- a/utils/genprimopcode/Syntax.hs +++ b/utils/genprimopcode/Syntax.hs @@ -1,11 +1,3 @@ - -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module Syntax where import Data.List @@ -25,17 +17,17 @@ data Entry name :: String, -- name in prog text ty :: Ty, -- type cat :: Category, -- category - desc :: String, -- description + desc :: String, -- description opts :: [Option] } -- default overrides | PseudoOpSpec { name :: String, -- name in prog text ty :: Ty, -- type - desc :: String, -- description + desc :: String, -- description opts :: [Option] } -- default overrides | PrimTypeSpec { ty :: Ty, -- name in prog text - desc :: String, -- description + desc :: String, -- description opts :: [Option] } -- default overrides - | Section { title :: String, -- section title - desc :: String } -- description + | Section { title :: String, -- section title + desc :: String } -- description deriving Show is_primop :: Entry -> Bool @@ -89,7 +81,7 @@ myseqAll [] x = x sanityTop :: Info -> () sanityTop (Info defs entries) = let opt_names = map get_attrib_name defs - primops = filter is_primop entries + primops = filter is_primop entries in if length opt_names /= length (nub opt_names) then error ("non-unique default attribute names: " ++ show opt_names ++ "\n") diff --git a/utils/hp2ps/Key.c b/utils/hp2ps/Key.c index 5fa76ab6d7..eda839597a 100644 --- a/utils/hp2ps/Key.c +++ b/utils/hp2ps/Key.c @@ -1,11 +1,14 @@ #include "Main.h" #include <stdio.h> #include <math.h> +#include <string.h> +#include <stdlib.h> #include "Defines.h" #include "Dimensions.h" #include "HpFile.h" #include "Shade.h" #include "PsFile.h" +#include "Utilities.h" /* own stuff */ #include "Key.h" @@ -36,7 +39,18 @@ void Key(void) } } - +static void +escape(char *result, const char *name) +{ + while (*name != '\0') + { + if (*name == '\\') + { + *result++ = '\\'; + } + *result++ = *name++; + } +} static void KeyEntry(floatish centreline, char *name, floatish colour) @@ -65,5 +79,9 @@ KeyEntry(floatish centreline, char *name, floatish colour) fprintf(psfp, "HE%d setfont\n", NORMAL_FONT); fprintf(psfp, "%f %f moveto\n", kstart + (floatish) KEY_BOX_WIDTH + 2 * borderspace, namebase); - fprintf(psfp, "(%s) show\n", name); + // escape backslashes in 'name' + char *escaped_name = (char*) xmalloc(strlen(name) * 2 + 1); + escape(escaped_name, name); + fprintf(psfp, "(%s) show\n", escaped_name); + free(escaped_name); } |