diff options
| author | Adam Gundry <adam@well-typed.com> | 2014-11-18 10:17:22 +0000 |
|---|---|---|
| committer | Adam Gundry <adam@well-typed.com> | 2014-11-18 10:17:22 +0000 |
| commit | 7b24febb2afc92289846a1ff7593d9a4ae2b61d1 (patch) | |
| tree | 218fb067524582677b40ced852d2c2808885c1df | |
| parent | c0f657fd2549719b2959dbf93fcd744c02427a5c (diff) | |
| parent | b9096df6a9733e38e15361e79973ef5659fc5c22 (diff) | |
| download | haskell-wip/tc-plugins-amg.tar.gz | |
Merge remote-tracking branch 'origin/master' into wip/tc-plugins-amgwip/tc-plugins-amg
266 files changed, 9565 insertions, 1085 deletions
@@ -1,44 +1,66 @@ # see 'man git-shortlog' for more details # formats: Proper Name [<proper@email.xx> [Commit Name]] <commit@email.xx> # +Aaron Tomb <atomb@galois.com> <atomb@soe.ucsc.edu> Alastair Reid <alastair@reid-consulting-uk.ltd.uk> areid <unknown> Alastair Reid <alastair@reid-consulting-uk.ltd.uk> reid <unknown> Alexey Rodriguez <mrchebas@gmail.com> Alexey Rodriguez <mrchebas@gmail.com> mrchebas@gmail.com <unknown> +Andrew Farmer <afarmer@ittc.ku.edu> <anfarmer@ku.edu> Andrew Pimlott <andrew.pimlott.ctr@metnet.navy.mil> andrew.pimlott.ctr@metnet.navy.mil <unknown> Andrew Tolmach <apt@cs.pdx.edu> apt <unknown> André Santos <alms@di.ufpe.br> andre <unknown> Andy Adams-Moran <andy.adamsmoran@gmail.com> moran <unknown> -Andy Gill <andy@galois.com> andy@galois.com <unknown> -Andy Gill <andy@galois.com> andy@unsafeperformio.com <unknown> +Andy Gill <andygill@ku.edu> <andy@galois.com> Andy Gill <andygill@ku.edu> andy <unknown> +Andy Gill <andygill@ku.edu> andy@galois.com <unknown> +Andy Gill <andygill@ku.edu> andy@unsafeperformio.com <unknown> Andy Gill <andygill@ku.edu> andygill@ku.edu <unknown> Audrey Tang <audreyt@audreyt.org> audreyt@audreyt.org <unknown> +Austin Seipp <austin@well-typed.com> <as@hacks.yi.org> +Austin Seipp <austin@well-typed.com> <as@nijoruj.org> +Austin Seipp <austin@well-typed.com> <aseipp@pobox.com> +Austin Seipp <austin@well-typed.com> <mad.one@gmail.com> Bas van Dijk <v.dijk.bas@gmail.com> basvandijk@home.nl <unknown> Bas van Dijk <v.dijk.bas@gmail.com> v.dijk.bas@gmail.com <unknown> Ben Gamari <bgamari.foss@gmail.com> <ben@panda.(none)> +Ben Gamari <bgamari.foss@gmail.com> <ben@panda1.milkyway> +Ben Lippmeier <benl@ouroborus.net> +Ben Lippmeier <benl@ouroborus.net> <Ben.Lippmeier@anu.edu.au> Ben Lippmeier <benl@ouroborus.net> Ben.Lippmeier.anu.edu.au <unknown> Ben Lippmeier <benl@ouroborus.net> Ben.Lippmeier@anu.edu.au <unknown> Ben Lippmeier <benl@ouroborus.net> benl@cse.unsw.edu.au <unknown> Ben Lippmeier <benl@ouroborus.net> benl@ouroborus.net <unknown> Bernie Pope <bjpop@csse.unimelb.edu.au> bjpop@csse.unimelb.edu.au <unknown> +Björn Bringert <bjorn@bringert.net> Björn Bringert <bjorn@bringert.net> bjorn@bringert.net <unknown> Björn Bringert <bjorn@bringert.net> bringert@cs.chalmers.se <unknown> Boris Lykah <lykahb@gmail.com> lykahb@gmail.com <unknown> +Brent Yorgey <byorgey@gmail.com> <byorgey@LVN513-12.cis.upenn.edu> +Brian Smith <brianlsmith@gmail.com> Brian Smith <brianlsmith@gmail.com> brianlsmith@gmail.com <unknown> +Cain Norris <ghc@cainnorris.net> ghc@cainnorris.net <unknown> Chris Rodrigues <red5_2@hotmail.com> red5_2@hotmail.com <unknown> Chris Smith <cdsmith@twu.net> cdsmith@twu.net <unknown> Christoph Bauer <ich@christoph-bauer.net> ich@christoph-bauer.net <unknown> +Claus Reinke <claus.reinke@talk21.com> Claus Reinke <claus.reinke@talk21.com> claus.reinke@talk21.com <unknown> +Colin McQuillan <m.niloc@gmail.com> Colin McQuillan <m.niloc@gmail.com> m.niloc@gmail.com <unknown> +Colin Watson <cjwatson@debian.org> <cjwatson@canonical.com> Daan Leijen <daan@microsoft.com> daan <unknown> +Daniel Fischer <daniel.is.fischer@googlemail.com> <daniel.is.fischer@web.de> Daniel Franke <df@dfranke.us> df@dfranke.us <unknown> Daniel Rogers <daniel@phasevelocity.org> daniel@phasevelocity.org <unknown> +David Feuer <david.feuer@gmail.com> <David.Feuer@gmail.com> David M Peixotto <dmp@rice.edu> dmp@rice.edu <unknown> +David Terei <code@davidterei.com> <davidterei@gmail.com> +David Waern <davve@dtek.chalmers.se> +David Waern <davve@dtek.chalmers.se> <david.waern@gmail.com> David Waern <davve@dtek.chalmers.se> <waern@ubuntu.(none)> David Waern <davve@dtek.chalmers.se> davve@dtek.chalmers.se <unknown> +Dimitrios Vytiniotis <dimitris@microsoft.com> Dimitrios Vytiniotis <dimitris@microsoft.com> <dimitris@MSRC-1361792.europe.corp.microsoft.com> -Dimitrios Vytiniotis <dimitris@microsoft.com> <dimitris@microsoft.com> Dimitrios Vytiniotis <dimitris@microsoft.com> dimitris@microsoft.com <unknown> Don Stewart <dons@galois.com> <dons@cse.unsw.edu.au> Don Stewart <dons@galois.com> dons <unknown> @@ -46,93 +68,139 @@ Don Stewart <dons@galois.com> dons@cse.unsw.edu.au Don Syme <dsyme@microsoft.com> dsyme <unknown> Donnie Jones <donnie@darthik.com> donnie@darthik.com <unknown> Duncan Coutts <duncan@well-typed.com> <duncan.coutts@worc.ox.ac.uk> +Duncan Coutts <duncan@well-typed.com> <duncan@community.haskell.org> Duncan Coutts <duncan@well-typed.com> <duncan@haskell.org> +Edward Z. Yang <ezyang@cs.stanford.edu> <ezyang@mit.edu> Evan Hauck <khyperia@live.com> +Gabor Pali <pali.gabor@gmail.com> <pgj@FreeBSD.org> Gabriele Keller <keller@cse.unsw.edu.au> keller <unknown> Gabriele Keller <keller@cse.unsw.edu.au> keller@.cse.unsw.edu.au <unknown> Gabriele Keller <keller@cse.unsw.edu.au> keller@cse.unsw.edu.au <unknown> -Geoffrey Mainland <mainland@eecs.harvard.edu> mainland@eecs.harvard.edu <unknown> +Geoffrey Mainland <mainland@cs.drexel.edu> <gmainlan@microsoft.com> +Geoffrey Mainland <mainland@cs.drexel.edu> <mainland@apeiron.net> +Geoffrey Mainland <mainland@cs.drexel.edu> mainland@eecs.harvard.edu <unknown> +Gergő Érdi <gergo@erdi.hu> +Gregory Wright <gwright@antiope.com> Gregory Wright <gwright@antiope.com> gwright@antiope.com <unknown> Gábor Lehel <illissius@gmail.com> illissius@gmail.com <unknown> Hans-Wolfgang Loidl <hwloidl@macs.hw.ac.uk> hwloidl <unknown> +Heinrich Hördegen <hoerdegen@energiefluss.info> +Howard B. Golden <howard_b_golden@yahoo.com> Howard B. Golden <howard_b_golden@yahoo.com> howard_b_golden@yahoo.com <unknown> +Ian Lynagh <igloo@earth.li> <ian@.(none)> +Ian Lynagh <igloo@earth.li> <ian@well-typed.com> Ian Lynagh <igloo@earth.li> igloo <unknown> -Ian Lynagh <igloo@earth.li> unknown <ian@.(none)> Iavor S. Diatchki <iavor.diatchki@gmail.com> <diatchki@Perun.(none)> +Iavor S. Diatchki <iavor.diatchki@gmail.com> <diatchki@galois.com> Iavor S. Diatchki <iavor.diatchki@gmail.com> iavor.diatchki@gmail.com <unknown> Isaac Potoczny-Jones <ijones@syntaxpolice.org> ijones@syntaxpolice.org <unknown> +Jean-Philippe Bernardy <jeanphilippe.bernardy@gmail.com> jeanphilippe.bernardy@gmail.com <unknown> Jeff Lewis <jeff@galconn.com> lewie <unknown> +Joachim Breitner <mail@joachim-breitner.de> <breitner@kit.edu> Jochem Berndsen <jochemberndsen@dse.nl> jochemberndsen@dse.nl <unknown> John Dias <dias@cs.tufts.edu> dias@cs.tufts.edu <unknown> John Dias <dias@cs.tufts.edu> dias@eecs.harvard.edu <unknown> John Dias <dias@cs.tufts.edu> dias@eecs.tufts.edu <unknown> John McCall <rjmccall@gmail.com> rjmccall@gmail.com <unknown> -Jose Pedro Magalhaes <jpm@cs.uu.nl> <jpm@cs.uu.nl> +Jon Fairbairn <jon.fairbairn@cl.cam.ac.uk> jon.fairbairn@cl.cam.ac.uk <unknown> +Jose Pedro Magalhaes <jpm@cs.ox.ac.uk> <jpm@cs.uu.nl> +Jose Pedro Magalhaes <jpm@cs.ox.ac.uk> jpm@cs.uu.nl <unknown> Josef Svenningsson <josef.svenningsson@gmail.com> josefs <unknown> -Jost Berthold <berthold@mathematik.uni-marburg.de> berthold@mathematik.uni-marburg.de <unknown> +Jost Berthold <jb.diku@gmail.com> <berthold@mathematik.uni-marburg.de> +Jost Berthold <jb.diku@gmail.com> berthold@mathematik.uni-marburg.de <unknown> Juan J. Quintela <quintela@fi.udc.es> quintela <unknown> Judah Jacobson <judah.jacobson@gmail.com> judah.jacobson@gmail.com <unknown> Julian Seward <jseward@acm.org> sewardj <unknown> +Karel Gardas <karel.gardas@centrum.cz> <karel.gardas@centrumcz> +Karel Gardas <karel.gardas@centrum.cz> <kgardas@objectsecurity.com> Keith Wansbrough <keith.wansbrough@cl.cam.ac.uk> keithw <unknown> Keith Wansbrough <keith.wansbrough@cl.cam.ac.uk> kw <unknown> Keith Wansbrough <keith.wansbrough@cl.cam.ac.uk> kw217 <unknown> Ken Shan <ken@digitas.harvard.edu> ken <unknown> +Kevin G Donnelly <kevind@bu.edu> <kevind@bu.edu> Kevin G Donnelly <kevind@bu.edu> kevind@bu.edu <unknown> Kevin Glynn <glynn@info.ucl.ac.be> kglynn <unknown> Krasimir Angelov <kr.angelov@gmail.com> kr.angelov@gmail.com <unknown> Krasimir Angelov <kr.angelov@gmail.com> krasimir <unknown> +Lennart Augustsson <lennart@augustsson.net> Lennart Augustsson <lennart@augustsson.net> lennart.augustsson@credit-suisse.com <unknown> Lennart Augustsson <lennart@augustsson.net> lennart@augustsson.net <unknown> +Lennart Kolmodin <kolmodin@gmail.com> <kolmodin@dtek.chalmers.se> +Lennart Kolmodin <kolmodin@gmail.com> <kolmodin@google.com> Levent Erkök <erkokl@gmail.com> erkok <unknown> +Luke Iannini <lukexipd@gmail.com> <lukexi@me.com> Malcolm Wallace <Malcolm.Wallace@cs.york.ac.uk> Malcolm.Wallace@cs.york.ac.uk <unknown> +Malcolm Wallace <Malcolm.Wallace@cs.york.ac.uk> Malcolm.Wallace@me.com <unknown> Malcolm Wallace <Malcolm.Wallace@cs.york.ac.uk> malcolm <unknown> Manuel M T Chakravarty <chak@cse.unsw.edu.au> chak <unknown> Marc Weber <marco-oweber@gmx.de> marco-oweber@gmx.de <unknown> Marcin 'Qrczak' Kowalczyk <qrczak@knm.org.pl> qrczak <unknown> +Marco Túlio Gontijo e Silva <marcot@marcot.eti.br> <marcot@debian.org> Matt Chapman <matthewc@cse.unsw.edu.au> matthewc <unknown> Matthias Kilian <kili@outback.escape.de> kili@outback.escape.de <unknown> +Michael D. Adams <t-madams@microsoft.com> <adamsmd@cs.indiana.edu> Michael Weber <michaelw@debian.org> michaelw <unknown> Mike Thomas <mthomas@gil.com.au> mthomas <unknown> +Mikolaj Konarski <mikolaj@well-typed.com> <mikolaj.konarski@gmail.com> +Nathan Huesken <nathan.huesken@posteo.de> Neil Mitchell <ndmitchell@gmail.com> <http://www.cs.york.ac.uk/~ndm/> Neil Mitchell <ndmitchell@gmail.com> Neil Mitchell <unknown> Nicholas Nethercote <njn25@cam.ac.uk> njn <unknown> Norman Ramsey <nr@eecs.harvard.edu> nr@eecs.harvard.edu <unknown> PHO <pho@cielonegro.org> pho@cielonegro.org <unknown> +Pepe Iborra <mnislaih@gmail.com> +Pepe Iborra <mnislaih@gmail.com> <pepeiborra@gmail.com> +Pepe Iborra <mnislaih@gmail.com> mnislaih@gmail.com <unknown> Pepe Iborra <mnislaih@gmail.com> pepe <unknown> -Pepe Iborra <pepeiborra@gmail.com> pepeiborra@gmail.com <unknown> +Pepe Iborra <mnislaih@gmail.com> pepeiborra@gmail.com <unknown> Peter Jonsson <t-peterj@microsoft.com> t-peterj@microsoft.com <unknown> +Peter Trommler <ptrommler@acm.org> <ptrommler@scm.org> Peter Wortmann <scpmw@leeds.ac.uk> <peter@grayson-heights-pc028-118.student-halls.leeds.ac.uk> Peter Wortmann <scpmw@leeds.ac.uk> scpmw@leeds.ac.uk <unknown> Reuben Thomas <rrt@sc3d.org> rrt <unknown> +Richard Eisenberg <eir@cis.upenn.edu> <eir@seas.upenn.edu> Roman Leshchinskiy <rl@cse.unsw.edu.au> rl@cse.unsw.edu.au <unknown> Ross Paterson <ross@soi.city.ac.uk> ross <unknown> Ryan Lortie <desrt@desrt.ca> desrt <unknown> +Sam Anklesaria <amsay@amsay.net> Sam Anklesaria <amsay@amsay.net> amsay@amsay.net <unknown> Sean Seefried <sean.seefried@gmail.com> sseefried <unknown> +Sergei Trofimovich <slyfox@gentoo.org> <slyfox at gentoo.org> +Sergei Trofimovich <slyfox@gentoo.org> <slyfox@community.haskell.org> +Sergei Trofimovich <slyfox@gentoo.org> <slyfox@inbox.ru> Shae Matijs Erisson <shae@ScannedInAvian.com> shae@ScannedInAvian.com <unknown> Sigbjorn Finne <sof@galois.com> sof <unknown> Sigbjorn Finne <sof@galois.com> sof@galois.com <unknown> +Simon Hengel <sol@typeful.net> <simon.hengel@wiktory.org> Simon Marlow <marlowsd@gmail.com> <simonmar-work@simonmar-laptop.(none)> Simon Marlow <marlowsd@gmail.com> <simonmar@microsoft.com> Simon Marlow <marlowsd@gmail.com> <simonmarhaskell@gmail.com> Simon Marlow <marlowsd@gmail.com> simonm <unknown> Simon Marlow <marlowsd@gmail.com> simonmar <unknown> Simon Marlow <marlowsd@gmail.com> simonmar@microsoft.com <unknown> +Simon Peyton Jones <simonpj@microsoft.com> Simon Peyton Jones <simonpj@microsoft.com> <simonpj@.europe.corp.microsoft.com> Simon Peyton Jones <simonpj@microsoft.com> <simonpj@MSRC-4971295.europe.corp.microsoft.com> Simon Peyton Jones <simonpj@microsoft.com> <simonpj@cam-04-unx.europe.corp.microsoft.com> -Simon Peyton Jones <simonpj@microsoft.com> <simonpj@microsoft.com> +Simon Peyton Jones <simonpj@microsoft.com> <simonpj@microsof.com> Simon Peyton Jones <simonpj@microsoft.com> <simonpj@static.144-76-175-55.clients.your-server.de> Simon Peyton Jones <simonpj@microsoft.com> simonpj <unknown> +Simon Peyton Jones <simonpj@microsoft.com> simonpj@microsoft <unknown> Simon Peyton Jones <simonpj@microsoft.com> simonpj@microsoft.com <unknown> +Spencer Janssen <spencer@well-typed.com> <sjanssen@cse.unl.edu> +Stephen Blackheath <stephen@blacksapphire.com> <docks.cattlemen.stephen@blacksapphire.com> +Stephen Blackheath <stephen@blacksapphire.com> <effusively.proffer.stephen@blacksapphire.com> +Stephen Blackheath <stephen@blacksapphire.com> <oversensitive.pastors.stephen@blacksapphire.com> Sven Panne <sven.panne@aedion.de> panne <unknown> Sven Panne <sven.panne@aedion.de> sven.panne@aedion.de <unknown> Sébastien Carlier <sebc@posse42.net> sebc <unknown> Thorkil Naur <naur@post11.tele.dk> naur@post11.tele.dk <unknown> +Tim Harris <tharris@microsoft.com> Tim Harris <tharris@microsoft.com> tharris <unknown> Tim Harris <tharris@microsoft.com> tharris@microsoft.com <unknown> Tobias Gedell <d99getob@dtek.chalmers.se> tgedell <unknown> Tom Schrijvers <tom.schrijvers@cs.kuleuven.be> tom.schrijvers@cs.kuleuven.be <unknown> +Volker Stolz <stolz@i2.informatik.rwth-aachen.de> Volker Stolz <stolz@i2.informatik.rwth-aachen.de> stolz <unknown> Will Partain <partain@dcs.gla.ac.uk> partain <unknown> Wolfgang Thaller <wolfgang.thaller@gmx.net> wolfgang <unknown> diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs index 9fc728b3f6..b32a2b7bfc 100644 --- a/compiler/basicTypes/MkId.lhs +++ b/compiler/basicTypes/MkId.lhs @@ -1146,17 +1146,14 @@ coerceId = pcMiscPrelId coerceName ty info where info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma `setUnfoldingInfo` mkCompulsoryUnfolding rhs - kv = kKiVar - k = mkTyVarTy kv - a:b:_ = tyVarList k - [aTy,bTy] = map mkTyVarTy [a,b] - eqRTy = mkTyConApp coercibleTyCon [k, aTy, bTy] - eqRPrimTy = mkTyConApp eqReprPrimTyCon [k, aTy, bTy] - ty = mkForAllTys [kv, a, b] (mkFunTys [eqRTy, aTy] bTy) - - [eqR,x,eq] = mkTemplateLocals [eqRTy, aTy,eqRPrimTy] - rhs = mkLams [kv,a,b,eqR,x] $ - mkWildCase (Var eqR) eqRTy bTy $ + eqRTy = mkTyConApp coercibleTyCon [liftedTypeKind, alphaTy, betaTy] + eqRPrimTy = mkTyConApp eqReprPrimTyCon [liftedTypeKind, alphaTy, betaTy] + ty = mkForAllTys [alphaTyVar, betaTyVar] $ + mkFunTys [eqRTy, alphaTy] betaTy + + [eqR,x,eq] = mkTemplateLocals [eqRTy, alphaTy, eqRPrimTy] + rhs = mkLams [alphaTyVar, betaTyVar, eqR, x] $ + mkWildCase (Var eqR) eqRTy betaTy $ [(DataAlt coercibleDataCon, [eq], Cast (Var x) (CoVarCo eq))] \end{code} diff --git a/compiler/basicTypes/Module.lhs b/compiler/basicTypes/Module.lhs index edd2986ed3..57f02d9b2a 100644 --- a/compiler/basicTypes/Module.lhs +++ b/compiler/basicTypes/Module.lhs @@ -380,7 +380,12 @@ integerPackageKey, primPackageKey, thPackageKey, dphSeqPackageKey, dphParPackageKey, mainPackageKey, thisGhcPackageKey, interactivePackageKey :: PackageKey primPackageKey = fsToPackageKey (fsLit "ghc-prim") -integerPackageKey = fsToPackageKey (fsLit cIntegerLibrary) +integerPackageKey = fsToPackageKey (fsLit n) + where + n = case cIntegerLibraryType of + IntegerGMP -> "integer-gmp" + IntegerGMP2 -> "integer-gmp" + IntegerSimple -> "integer-simple" basePackageKey = fsToPackageKey (fsLit "base") rtsPackageKey = fsToPackageKey (fsLit "rts") thPackageKey = fsToPackageKey (fsLit "template-haskell") diff --git a/compiler/basicTypes/PatSyn.lhs b/compiler/basicTypes/PatSyn.lhs index 89c4374388..c651080244 100644 --- a/compiler/basicTypes/PatSyn.lhs +++ b/compiler/basicTypes/PatSyn.lhs @@ -14,7 +14,8 @@ module PatSyn ( -- ** Type deconstruction patSynName, patSynArity, patSynIsInfix, patSynArgs, patSynTyDetails, patSynType, - patSynWrapper, patSynMatcher, + patSynMatcher, + patSynWrapper, patSynWorker, patSynExTyVars, patSynSig, patSynInstArgTys, patSynInstResTy, tidyPatSynIds @@ -36,6 +37,7 @@ import HsBinds( HsPatSynDetails(..) ) import qualified Data.Data as Data import qualified Data.Typeable import Data.Function +import Control.Arrow (second) \end{code} @@ -109,6 +111,37 @@ Injectivity of bidirectional pattern synonyms is checked in tcPatToExpr which walks the pattern and returns its corresponding expression when available. +Note [Wrapper/worker for pattern synonyms with unboxed type] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +For bidirectional pattern synonyms that have no arguments and have +an unboxed type, we add an extra level of indirection, since $WP would +otherwise be a top-level declaration with an unboxed type. In this case, +a separate worker function is generated that has an extra Void# argument, +and the wrapper redirects to it via a compulsory unfolding (that just +applies it on Void#). Example: + + pattern P = 0# + + $WP :: Int# + $WP unfolded to ($wP Void#) + + $wP :: Void# -> Int# + $wP _ = 0# + +To make things more uniform, we always store two `Id`s in `PatSyn` for +the wrapper and the worker, with the following behaviour: + + if `psWrapper` == Just (`wrapper`, `worker`), then + + * `wrapper` should always be used when compiling the pattern synonym + in an expression context (and its type is as prescribed) + * `worker` is always an `Id` with a binding that needs to be exported + as part of the definition of the pattern synonym + +If a separate worker is not needed (because the pattern synonym has arguments +or has a non-unboxed type), the two `Id`s are the same. + %************************************************************************ %* * \subsection{Pattern synonyms} @@ -149,12 +182,14 @@ data PatSyn -- -> (Void# -> r) -- -> r - psWrapper :: Maybe Id + psWrapper :: Maybe (Id, Id) -- Nothing => uni-directional pattern synonym - -- Just wid => bi-direcitonal + -- Just (wrapper, worker) => bi-direcitonal -- Wrapper function, of type -- forall univ_tvs, ex_tvs. (prov_theta, req_theta) -- => arg_tys -> res_ty + -- + -- See Note [Wrapper/worker for pattern synonyms with unboxed type] } deriving Data.Typeable.Typeable \end{code} @@ -215,7 +250,7 @@ mkPatSyn :: Name -> [Type] -- ^ Original arguments -> Type -- ^ Original result type -> Id -- ^ Name of matcher - -> Maybe Id -- ^ Name of wrapper + -> Maybe (Id, Id) -- ^ Name of wrapper/worker -> PatSyn mkPatSyn name declared_infix (univ_tvs, req_theta) @@ -276,14 +311,17 @@ patSynSig (MkPatSyn { psUnivTyVars = univ_tvs, psExTyVars = ex_tvs = (univ_tvs, ex_tvs, prov, req, arg_tys, res_ty) patSynWrapper :: PatSyn -> Maybe Id -patSynWrapper = psWrapper +patSynWrapper = fmap fst . psWrapper + +patSynWorker :: PatSyn -> Maybe Id +patSynWorker = fmap snd . psWrapper patSynMatcher :: PatSyn -> Id patSynMatcher = psMatcher tidyPatSynIds :: (Id -> Id) -> PatSyn -> PatSyn tidyPatSynIds tidy_fn ps@(MkPatSyn { psMatcher = match_id, psWrapper = mb_wrap_id }) - = ps { psMatcher = tidy_fn match_id, psWrapper = fmap tidy_fn mb_wrap_id } + = ps { psMatcher = tidy_fn match_id, psWrapper = fmap (second tidy_fn) mb_wrap_id } patSynInstArgTys :: PatSyn -> [Type] -> [Type] -- Return the types of the argument patterns diff --git a/compiler/basicTypes/RdrName.lhs b/compiler/basicTypes/RdrName.lhs index d4afaf10fc..b9e3fcbd6a 100644 --- a/compiler/basicTypes/RdrName.lhs +++ b/compiler/basicTypes/RdrName.lhs @@ -157,9 +157,14 @@ setRdrNameSpace :: RdrName -> NameSpace -> RdrName setRdrNameSpace (Unqual occ) ns = Unqual (setOccNameSpace ns occ) setRdrNameSpace (Qual m occ) ns = Qual m (setOccNameSpace ns occ) setRdrNameSpace (Orig m occ) ns = Orig m (setOccNameSpace ns occ) -setRdrNameSpace (Exact n) ns = ASSERT( isExternalName n ) - Orig (nameModule n) - (setOccNameSpace ns (nameOccName n)) +setRdrNameSpace (Exact n) ns + | isExternalName n + = Orig (nameModule n) occ + | otherwise -- This can happen when quoting and then splicing a fixity + -- declaration for a type + = Exact $ mkSystemNameAt (nameUnique n) occ (nameSrcSpan n) + where + occ = setOccNameSpace ns (nameOccName n) -- demoteRdrName lowers the NameSpace of RdrName. -- see Note [Demotion] in OccName diff --git a/compiler/basicTypes/SrcLoc.lhs b/compiler/basicTypes/SrcLoc.lhs index 6b464542a5..c7e1fbea9f 100644 --- a/compiler/basicTypes/SrcLoc.lhs +++ b/compiler/basicTypes/SrcLoc.lhs @@ -99,11 +99,11 @@ data RealSrcLoc = SrcLoc FastString -- A precise location (file name) {-# UNPACK #-} !Int -- line number, begins at 1 {-# UNPACK #-} !Int -- column number, begins at 1 - deriving Show data SrcLoc = RealSrcLoc {-# UNPACK #-}!RealSrcLoc | UnhelpfulLoc FastString -- Just a general indication + deriving Show \end{code} %************************************************************************ @@ -259,8 +259,7 @@ data RealSrcSpan srcSpanLine :: {-# UNPACK #-} !Int, srcSpanCol :: {-# UNPACK #-} !Int } - deriving (Eq, Typeable, Show) -- Show is used by Lexer.x, because we - -- derive Show for Token + deriving (Eq, Typeable) data SrcSpan = RealSrcSpan !RealSrcSpan @@ -433,6 +432,21 @@ instance Ord SrcSpan where (srcSpanStart a `compare` srcSpanStart b) `thenCmp` (srcSpanEnd a `compare` srcSpanEnd b) +instance Show RealSrcLoc where + show (SrcLoc filename row col) + = "SrcLoc " ++ show filename ++ " " ++ show row ++ " " ++ show col + +-- Show is used by Lexer.x, because we derive Show for Token +instance Show RealSrcSpan where + show (SrcSpanOneLine file l sc ec) + = "SrcSpanOneLine " ++ show file ++ " " + ++ intercalate " " (map show [l,sc,ec]) + show (SrcSpanMultiLine file sl sc el ec) + = "SrcSpanMultiLine " ++ show file ++ " " + ++ intercalate " " (map show [sl,sc,el,ec]) + show (SrcSpanPoint file l c) + = "SrcSpanPoint " ++ show file ++ " " ++ intercalate " " (map show [l,c]) + instance Outputable RealSrcSpan where ppr span = pprUserRealSpan True span diff --git a/compiler/cmm/CmmLayoutStack.hs b/compiler/cmm/CmmLayoutStack.hs index 188233d1ea..c9399b3ba1 100644 --- a/compiler/cmm/CmmLayoutStack.hs +++ b/compiler/cmm/CmmLayoutStack.hs @@ -992,9 +992,12 @@ lowerSafeForeignCall dflags block id <- newTemp (bWord dflags) new_base <- newTemp (cmmRegType dflags (CmmGlobal BaseReg)) let (caller_save, caller_load) = callerSaveVolatileRegs dflags - load_tso <- newTemp (gcWord dflags) load_stack <- newTemp (gcWord dflags) - let suspend = saveThreadState dflags <*> + tso <- newTemp (gcWord dflags) + cn <- newTemp (bWord dflags) + bdfree <- newTemp (bWord dflags) + bdstart <- newTemp (bWord dflags) + let suspend = saveThreadState dflags tso cn <*> caller_save <*> mkMiddle (callSuspendThread dflags id intrbl) midCall = mkUnsafeCall tgt res args @@ -1003,7 +1006,7 @@ lowerSafeForeignCall dflags block -- might now have a different Capability! mkAssign (CmmGlobal BaseReg) (CmmReg (CmmLocal new_base)) <*> caller_load <*> - loadThreadState dflags load_tso load_stack + loadThreadState dflags tso load_stack cn bdfree bdstart (_, regs, copyout) = copyOutOflow dflags NativeReturn Jump (Young succ) diff --git a/compiler/cmm/CmmMachOp.hs b/compiler/cmm/CmmMachOp.hs index b84cb40c69..e9215d5021 100644 --- a/compiler/cmm/CmmMachOp.hs +++ b/compiler/cmm/CmmMachOp.hs @@ -3,7 +3,7 @@ module CmmMachOp ( MachOp(..) , pprMachOp, isCommutableMachOp, isAssociativeMachOp - , isComparisonMachOp, machOpResultType + , isComparisonMachOp, maybeIntComparison, machOpResultType , machOpArgReps, maybeInvertComparison -- MachOp builders @@ -11,9 +11,11 @@ module CmmMachOp , mo_wordSRem, mo_wordSNeg, mo_wordUQuot, mo_wordURem , mo_wordSGe, mo_wordSLe, mo_wordSGt, mo_wordSLt, mo_wordUGe , mo_wordULe, mo_wordUGt, mo_wordULt - , mo_wordAnd, mo_wordOr, mo_wordXor, mo_wordNot, mo_wordShl, mo_wordSShr, mo_wordUShr + , mo_wordAnd, mo_wordOr, mo_wordXor, mo_wordNot + , mo_wordShl, mo_wordSShr, mo_wordUShr , mo_u_8To32, mo_s_8To32, mo_u_16To32, mo_s_16To32 - , mo_u_8ToWord, mo_s_8ToWord, mo_u_16ToWord, mo_s_16ToWord, mo_u_32ToWord, mo_s_32ToWord + , mo_u_8ToWord, mo_s_8ToWord, mo_u_16ToWord, mo_s_16ToWord + , mo_u_32ToWord, mo_s_32ToWord , mo_32To8, mo_32To16, mo_WordTo8, mo_WordTo16, mo_WordTo32, mo_WordTo64 -- CallishMachOp @@ -260,6 +262,7 @@ isAssociativeMachOp mop = MO_Xor {} -> True _other -> False + -- ---------------------------------------------------------------------------- -- isComparisonMachOp @@ -290,6 +293,25 @@ isComparisonMachOp mop = MO_F_Lt {} -> True _other -> False +{- | +Returns @Just w@ if the operation is an integer comparison with width +@w@, or @Nothing@ otherwise. +-} +maybeIntComparison :: MachOp -> Maybe Width +maybeIntComparison mop = + case mop of + MO_Eq w -> Just w + MO_Ne w -> Just w + MO_S_Ge w -> Just w + MO_S_Le w -> Just w + MO_S_Gt w -> Just w + MO_S_Lt w -> Just w + MO_U_Ge w -> Just w + MO_U_Le w -> Just w + MO_U_Gt w -> Just w + MO_U_Lt w -> Just w + _ -> Nothing + -- ----------------------------------------------------------------------------- -- Inverting conditions diff --git a/compiler/cmm/Hoopl/Dataflow.hs b/compiler/cmm/Hoopl/Dataflow.hs index f5511515a9..4fbf42e607 100644 --- a/compiler/cmm/Hoopl/Dataflow.hs +++ b/compiler/cmm/Hoopl/Dataflow.hs @@ -3,7 +3,6 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE Trustworthy #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fprof-auto-top #-} diff --git a/compiler/codeGen/StgCmmForeign.hs b/compiler/codeGen/StgCmmForeign.hs index eb1c7da76d..c2e276ed0b 100644 --- a/compiler/codeGen/StgCmmForeign.hs +++ b/compiler/codeGen/StgCmmForeign.hs @@ -9,12 +9,15 @@ ----------------------------------------------------------------------------- module StgCmmForeign ( - cgForeignCall, loadThreadState, saveThreadState, + cgForeignCall, emitPrimCall, emitCCall, emitForeignCall, -- For CmmParse - emitSaveThreadState, -- will be needed by the Cmm parser - emitLoadThreadState, -- ditto - emitCloseNursery, emitOpenNursery + emitSaveThreadState, + saveThreadState, + emitLoadThreadState, + loadThreadState, + emitOpenNursery, + emitCloseNursery, ) where #include "HsVersions.h" @@ -271,94 +274,221 @@ maybe_assign_temp e = do -- This stuff can't be done in suspendThread/resumeThread, because it -- refers to global registers which aren't available in the C world. -saveThreadState :: DynFlags -> CmmAGraph -saveThreadState dflags = - -- CurrentTSO->stackobj->sp = Sp; - mkStore (cmmOffset dflags (CmmLoad (cmmOffset dflags stgCurrentTSO (tso_stackobj dflags)) (bWord dflags)) (stack_SP dflags)) stgSp - <*> closeNursery dflags - -- and save the current cost centre stack in the TSO when profiling: - <*> if gopt Opt_SccProfilingOn dflags then - mkStore (cmmOffset dflags stgCurrentTSO (tso_CCCS dflags)) curCCS - else mkNop - emitSaveThreadState :: FCode () emitSaveThreadState = do dflags <- getDynFlags - emit (saveThreadState dflags) + tso <- newTemp (gcWord dflags) + cn <- newTemp (bWord dflags) + emit $ saveThreadState dflags tso cn + + +-- saveThreadState must be usable from the stack layout pass, where we +-- don't have FCode. Therefore it takes LocalRegs as arguments, so +-- the caller can create these. +saveThreadState :: DynFlags -> LocalReg -> LocalReg -> CmmAGraph +saveThreadState dflags tso cn = + catAGraphs [ + -- tso = CurrentTSO; + mkAssign (CmmLocal tso) stgCurrentTSO, + -- tso->stackobj->sp = Sp; + mkStore (cmmOffset dflags (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal tso)) (tso_stackobj dflags)) (bWord dflags)) (stack_SP dflags)) stgSp, + closeNursery dflags tso cn, + -- and save the current cost centre stack in the TSO when profiling: + if gopt Opt_SccProfilingOn dflags then + mkStore (cmmOffset dflags (CmmReg (CmmLocal tso)) (tso_CCCS dflags)) curCCS + else mkNop + ] emitCloseNursery :: FCode () emitCloseNursery = do - df <- getDynFlags - emit (closeNursery df) + dflags <- getDynFlags + tso <- newTemp (gcWord dflags) + cn <- newTemp (bWord dflags) + emit $ mkAssign (CmmLocal tso) stgCurrentTSO <*> + closeNursery dflags tso cn + +{- +Closing the nursery corresponds to the following code: + + tso = CurrentTSO; + cn = CurrentNuresry; - -- CurrentNursery->free = Hp+1; -closeNursery :: DynFlags -> CmmAGraph -closeNursery dflags = mkStore (nursery_bdescr_free dflags) (cmmOffsetW dflags stgHp 1) + // Update the allocation limit for the current thread. We don't + // check to see whether it has overflowed at this point, that check is + // made when we run out of space in the current heap block (stg_gc_noregs) + // and in the scheduler when context switching (schedulePostRunThread). + tso->alloc_limit -= Hp + WDS(1) - cn->start; -loadThreadState :: DynFlags -> LocalReg -> LocalReg -> CmmAGraph -loadThreadState dflags tso stack = do + // Set cn->free to the next unoccupied word in the block + cn->free = Hp + WDS(1); +-} + +closeNursery :: DynFlags -> LocalReg -> LocalReg -> CmmAGraph +closeNursery df tso cn = + let + tsoreg = CmmLocal tso + cnreg = CmmLocal cn + in catAGraphs [ - -- tso = CurrentTSO; - mkAssign (CmmLocal tso) stgCurrentTSO, - -- stack = tso->stackobj; - mkAssign (CmmLocal stack) (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal tso)) (tso_stackobj dflags)) (bWord dflags)), - -- Sp = stack->sp; - mkAssign sp (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal stack)) (stack_SP dflags)) (bWord dflags)), - -- SpLim = stack->stack + RESERVED_STACK_WORDS; - mkAssign spLim (cmmOffsetW dflags (cmmOffset dflags (CmmReg (CmmLocal stack)) (stack_STACK dflags)) - (rESERVED_STACK_WORDS dflags)), - -- HpAlloc = 0; - -- HpAlloc is assumed to be set to non-zero only by a failed - -- a heap check, see HeapStackCheck.cmm:GC_GENERIC - mkAssign hpAlloc (zeroExpr dflags), - - openNursery dflags, - -- and load the current cost centre stack from the TSO when profiling: - if gopt Opt_SccProfilingOn dflags then - storeCurCCS - (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal tso)) (tso_CCCS dflags)) (ccsType dflags)) - else mkNop] + mkAssign cnreg stgCurrentNursery, + + -- CurrentNursery->free = Hp+1; + mkStore (nursery_bdescr_free df cnreg) (cmmOffsetW df stgHp 1), + + let alloc = + CmmMachOp (mo_wordSub df) + [ cmmOffsetW df stgHp 1 + , CmmLoad (nursery_bdescr_start df cnreg) (bWord df) + ] + + alloc_limit = cmmOffset df (CmmReg tsoreg) (tso_alloc_limit df) + in + + -- tso->alloc_limit += alloc + mkStore alloc_limit (CmmMachOp (MO_Sub W64) + [ CmmLoad alloc_limit b64 + , CmmMachOp (mo_WordTo64 df) [alloc] ]) + ] emitLoadThreadState :: FCode () emitLoadThreadState = do dflags <- getDynFlags - load_tso <- newTemp (gcWord dflags) - load_stack <- newTemp (gcWord dflags) - emit $ loadThreadState dflags load_tso load_stack + tso <- newTemp (gcWord dflags) + stack <- newTemp (gcWord dflags) + cn <- newTemp (bWord dflags) + bdfree <- newTemp (bWord dflags) + bdstart <- newTemp (bWord dflags) + emit $ loadThreadState dflags tso stack cn bdfree bdstart + +-- loadThreadState must be usable from the stack layout pass, where we +-- don't have FCode. Therefore it takes LocalRegs as arguments, so +-- the caller can create these. +loadThreadState :: DynFlags + -> LocalReg -> LocalReg -> LocalReg -> LocalReg -> LocalReg + -> CmmAGraph +loadThreadState dflags tso stack cn bdfree bdstart = + catAGraphs [ + -- tso = CurrentTSO; + mkAssign (CmmLocal tso) stgCurrentTSO, + -- stack = tso->stackobj; + mkAssign (CmmLocal stack) (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal tso)) (tso_stackobj dflags)) (bWord dflags)), + -- Sp = stack->sp; + mkAssign sp (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal stack)) (stack_SP dflags)) (bWord dflags)), + -- SpLim = stack->stack + RESERVED_STACK_WORDS; + mkAssign spLim (cmmOffsetW dflags (cmmOffset dflags (CmmReg (CmmLocal stack)) (stack_STACK dflags)) + (rESERVED_STACK_WORDS dflags)), + -- HpAlloc = 0; + -- HpAlloc is assumed to be set to non-zero only by a failed + -- a heap check, see HeapStackCheck.cmm:GC_GENERIC + mkAssign hpAlloc (zeroExpr dflags), + openNursery dflags tso cn bdfree bdstart, + -- and load the current cost centre stack from the TSO when profiling: + if gopt Opt_SccProfilingOn dflags + then storeCurCCS + (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal tso)) + (tso_CCCS dflags)) (ccsType dflags)) + else mkNop + ] + emitOpenNursery :: FCode () emitOpenNursery = do - df <- getDynFlags - emit (openNursery df) - -openNursery :: DynFlags -> CmmAGraph -openNursery dflags = catAGraphs [ - -- Hp = CurrentNursery->free - 1; - mkAssign hp (cmmOffsetW dflags (CmmLoad (nursery_bdescr_free dflags) (bWord dflags)) (-1)), - - -- HpLim = CurrentNursery->start + - -- CurrentNursery->blocks*BLOCK_SIZE_W - 1; - mkAssign hpLim - (cmmOffsetExpr dflags - (CmmLoad (nursery_bdescr_start dflags) (bWord dflags)) - (cmmOffset dflags - (CmmMachOp (mo_wordMul dflags) [ - CmmMachOp (MO_SS_Conv W32 (wordWidth dflags)) - [CmmLoad (nursery_bdescr_blocks dflags) b32], - mkIntExpr dflags (bLOCK_SIZE dflags) - ]) - (-1) - ) - ) + dflags <- getDynFlags + tso <- newTemp (gcWord dflags) + cn <- newTemp (bWord dflags) + bdfree <- newTemp (bWord dflags) + bdstart <- newTemp (bWord dflags) + emit $ mkAssign (CmmLocal tso) stgCurrentTSO <*> + openNursery dflags tso cn bdfree bdstart + +{- +Opening the nursery corresponds to the following code: + + tso = CurrentTSO; + cn = CurrentNursery; + bdfree = CurrentNuresry->free; + bdstart = CurrentNuresry->start; + + // We *add* the currently occupied portion of the nursery block to + // the allocation limit, because we will subtract it again in + // closeNursery. + tso->alloc_limit += bdfree - bdstart; + + // Set Hp to the last occupied word of the heap block. Why not the + // next unocupied word? Doing it this way means that we get to use + // an offset of zero more often, which might lead to slightly smaller + // code on some architectures. + Hp = bdfree - WDS(1); + + // Set HpLim to the end of the current nursery block (note that this block + // might be a block group, consisting of several adjacent blocks. + HpLim = bdstart + CurrentNursery->blocks*BLOCK_SIZE_W - 1; +-} + +openNursery :: DynFlags + -> LocalReg -> LocalReg -> LocalReg -> LocalReg + -> CmmAGraph +openNursery df tso cn bdfree bdstart = + let + tsoreg = CmmLocal tso + cnreg = CmmLocal cn + bdfreereg = CmmLocal bdfree + bdstartreg = CmmLocal bdstart + in + -- These assignments are carefully ordered to reduce register + -- pressure and generate not completely awful code on x86. To see + -- what code we generate, look at the assembly for + -- stg_returnToStackTop in rts/StgStartup.cmm. + catAGraphs [ + mkAssign cnreg stgCurrentNursery, + mkAssign bdfreereg (CmmLoad (nursery_bdescr_free df cnreg) (bWord df)), + + -- Hp = CurrentNursery->free - 1; + mkAssign hp (cmmOffsetW df (CmmReg bdfreereg) (-1)), + + mkAssign bdstartreg (CmmLoad (nursery_bdescr_start df cnreg) (bWord df)), + + -- HpLim = CurrentNursery->start + + -- CurrentNursery->blocks*BLOCK_SIZE_W - 1; + mkAssign hpLim + (cmmOffsetExpr df + (CmmReg bdstartreg) + (cmmOffset df + (CmmMachOp (mo_wordMul df) [ + CmmMachOp (MO_SS_Conv W32 (wordWidth df)) + [CmmLoad (nursery_bdescr_blocks df cnreg) b32], + mkIntExpr df (bLOCK_SIZE df) + ]) + (-1) + ) + ), + + -- alloc = bd->free - bd->start + let alloc = + CmmMachOp (mo_wordSub df) [CmmReg bdfreereg, CmmReg bdstartreg] + + alloc_limit = cmmOffset df (CmmReg tsoreg) (tso_alloc_limit df) + in + + -- tso->alloc_limit += alloc + mkStore alloc_limit (CmmMachOp (MO_Add W64) + [ CmmLoad alloc_limit b64 + , CmmMachOp (mo_WordTo64 df) [alloc] ]) + ] -nursery_bdescr_free, nursery_bdescr_start, nursery_bdescr_blocks :: DynFlags -> CmmExpr -nursery_bdescr_free dflags = cmmOffset dflags stgCurrentNursery (oFFSET_bdescr_free dflags) -nursery_bdescr_start dflags = cmmOffset dflags stgCurrentNursery (oFFSET_bdescr_start dflags) -nursery_bdescr_blocks dflags = cmmOffset dflags stgCurrentNursery (oFFSET_bdescr_blocks dflags) +nursery_bdescr_free, nursery_bdescr_start, nursery_bdescr_blocks + :: DynFlags -> CmmReg -> CmmExpr +nursery_bdescr_free dflags cn = + cmmOffset dflags (CmmReg cn) (oFFSET_bdescr_free dflags) +nursery_bdescr_start dflags cn = + cmmOffset dflags (CmmReg cn) (oFFSET_bdescr_start dflags) +nursery_bdescr_blocks dflags cn = + cmmOffset dflags (CmmReg cn) (oFFSET_bdescr_blocks dflags) -tso_stackobj, tso_CCCS, stack_STACK, stack_SP :: DynFlags -> ByteOff +tso_stackobj, tso_CCCS, tso_alloc_limit, stack_STACK, stack_SP :: DynFlags -> ByteOff tso_stackobj dflags = closureField dflags (oFFSET_StgTSO_stackobj dflags) +tso_alloc_limit dflags = closureField dflags (oFFSET_StgTSO_alloc_limit dflags) tso_CCCS dflags = closureField dflags (oFFSET_StgTSO_cccs dflags) stack_STACK dflags = closureField dflags (oFFSET_StgStack_stack dflags) stack_SP dflags = closureField dflags (oFFSET_StgStack_sp dflags) diff --git a/compiler/coreSyn/CorePrep.lhs b/compiler/coreSyn/CorePrep.lhs index 374b98ece9..537cc01b43 100644 --- a/compiler/coreSyn/CorePrep.lhs +++ b/compiler/coreSyn/CorePrep.lhs @@ -1123,7 +1123,8 @@ lookupIntegerSDataConName :: DynFlags -> HscEnv -> IO (Maybe DataCon) lookupIntegerSDataConName dflags hsc_env = case cIntegerLibraryType of IntegerGMP -> guardIntegerUse dflags $ liftM Just $ initTcForLookup hsc_env (tcLookupDataCon integerSDataConName) - + IntegerGMP2-> guardIntegerUse dflags $ liftM Just $ + initTcForLookup hsc_env (tcLookupDataCon integerSDataConName) IntegerSimple -> return Nothing -- | Helper for 'lookupMkIntegerName' and 'lookupIntegerSDataConName' diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs index 6844f48970..ce2d5a5d4a 100644 --- a/compiler/deSugar/DsExpr.lhs +++ b/compiler/deSugar/DsExpr.lhs @@ -46,12 +46,14 @@ import MkCore import DynFlags import CostCentre import Id +import Unique import Module import VarSet import VarEnv import ConLike import DataCon import TysWiredIn +import PrelNames ( seqIdKey ) import BasicTypes import Maybes import SrcLoc @@ -191,7 +193,12 @@ dsLExpr (L loc e) = putSrcSpanDs loc $ dsExpr e dsExpr :: HsExpr Id -> DsM CoreExpr dsExpr (HsPar e) = dsLExpr e dsExpr (ExprWithTySigOut e _) = dsLExpr e -dsExpr (HsVar var) = return (varToCoreExpr var) -- See Note [Desugaring vars] +dsExpr (HsVar var) -- See Note [Unfolding while desugaring] + | unfold_var = return $ unfoldingTemplate unfolding + | otherwise = return (varToCoreExpr var) -- See Note [Desugaring vars] + where + unfold_var = isCompulsoryUnfolding unfolding && not (var `hasKey` seqIdKey) + unfolding = idUnfolding var dsExpr (HsIPVar _) = panic "dsExpr: HsIPVar" dsExpr (HsLit lit) = dsLit lit dsExpr (HsOverLit lit) = dsOverLit lit @@ -220,6 +227,19 @@ dsExpr (HsApp fun arg) dsExpr (HsUnboundVar _) = panic "dsExpr: HsUnboundVar" \end{code} +Note [Unfolding while desugaring] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Variables with compulsory unfolding must be substituted at desugaring +time. This is needed to preserve the let/app invariant in cases where +the unfolding changes whether wrapping in a case is needed. +Suppose we have a call like this: + I# x +where 'x' has an unfolding like this: + f void# +In this case, 'mkCoreAppDs' needs to see 'f void#', not 'x', to be +able to do the right thing. + + Note [Desugaring vars] ~~~~~~~~~~~~~~~~~~~~~~ In one situation we can get a *coercion* variable in a HsVar, namely diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index 24785c257f..083c466baa 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -137,26 +137,26 @@ repTopDs group@(HsGroup { hs_valds = valds -- only "T", not "Foo:T" where Foo is the current module decls <- addBinds ss ( - do { val_ds <- rep_val_binds valds - ; _ <- mapM no_splice splcds - ; tycl_ds <- mapM repTyClD (tyClGroupConcat tyclds) - ; role_ds <- mapM repRoleD (concatMap group_roles tyclds) - ; inst_ds <- mapM repInstD instds - ; _ <- mapM no_standalone_deriv derivds - ; fix_ds <- mapM repFixD fixds - ; _ <- mapM no_default_decl defds - ; for_ds <- mapM repForD fords - ; _ <- mapM no_warn warnds - ; ann_ds <- mapM repAnnD annds - ; rule_ds <- mapM repRuleD ruleds - ; _ <- mapM no_vect vects - ; _ <- mapM no_doc docs + do { val_ds <- rep_val_binds valds + ; _ <- mapM no_splice splcds + ; tycl_ds <- mapM repTyClD (tyClGroupConcat tyclds) + ; role_ds <- mapM repRoleD (concatMap group_roles tyclds) + ; inst_ds <- mapM repInstD instds + ; deriv_ds <- mapM repStandaloneDerivD derivds + ; fix_ds <- mapM repFixD fixds + ; _ <- mapM no_default_decl defds + ; for_ds <- mapM repForD fords + ; _ <- mapM no_warn warnds + ; ann_ds <- mapM repAnnD annds + ; rule_ds <- mapM repRuleD ruleds + ; _ <- mapM no_vect vects + ; _ <- mapM no_doc docs -- more needed ; return (de_loc $ sort_by_loc $ val_ds ++ catMaybes tycl_ds ++ role_ds ++ fix_ds ++ inst_ds ++ rule_ds ++ for_ds - ++ ann_ds) }) ; + ++ ann_ds ++ deriv_ds) }) ; decl_ty <- lookupType decQTyConName ; let { core_list = coreList' decl_ty decls } ; @@ -169,8 +169,6 @@ repTopDs group@(HsGroup { hs_valds = valds where no_splice (L loc _) = notHandledL loc "Splices within declaration brackets" empty - no_standalone_deriv (L loc (DerivDecl { deriv_type = deriv_ty })) - = notHandledL loc "Standalone-deriving" (ppr deriv_ty) no_default_decl (L loc decl) = notHandledL loc "Default declarations" (ppr decl) no_warn (L loc (Warning thing _)) @@ -422,6 +420,18 @@ repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds where Just (tvs, cxt, cls, tys) = splitLHsInstDeclTy_maybe ty +repStandaloneDerivD :: LDerivDecl Name -> DsM (SrcSpan, Core TH.DecQ) +repStandaloneDerivD (L loc (DerivDecl { deriv_type = ty })) + = do { dec <- addTyVarBinds tvs $ \_ -> + do { cxt' <- repContext cxt + ; cls_tcon <- repTy (HsTyVar (unLoc cls)) + ; cls_tys <- repLTys tys + ; inst_ty <- repTapps cls_tcon cls_tys + ; repDeriv cxt' inst_ty } + ; return (loc, dec) } + where + Just (tvs, cxt, cls, tys) = splitLHsInstDeclTy_maybe ty + repTyFamInstD :: TyFamInstDecl Name -> DsM (Core TH.DecQ) repTyFamInstD decl@(TyFamInstDecl { tfid_eqn = eqn }) = do { let tc_name = tyFamInstDeclLName decl @@ -662,10 +672,9 @@ rep_sigs' sigs = do { sigs1 <- mapM rep_sig sigs ; return (concat sigs1) } rep_sig :: LSig Name -> DsM [(SrcSpan, Core TH.DecQ)] -rep_sig (L loc (TypeSig nms ty)) = mapM (rep_ty_sig loc ty) nms +rep_sig (L loc (TypeSig nms ty)) = mapM (rep_ty_sig sigDName loc ty) nms rep_sig (L _ (PatSynSig {})) = notHandled "Pattern type signatures" empty -rep_sig (L _ (GenericSig nm _)) = notHandled "Default type signatures" msg - where msg = text "Illegal default signature for" <+> quotes (ppr nm) +rep_sig (L loc (GenericSig nms ty)) = mapM (rep_ty_sig defaultSigDName loc ty) nms rep_sig d@(L _ (IdSig {})) = pprPanic "rep_sig IdSig" (ppr d) rep_sig (L _ (FixSig {})) = return [] -- fixity sigs at top level rep_sig (L loc (InlineSig nm ispec)) = rep_inline nm ispec loc @@ -673,12 +682,12 @@ rep_sig (L loc (SpecSig nm ty ispec)) = rep_specialise nm ty ispec loc rep_sig (L loc (SpecInstSig ty)) = rep_specialiseInst ty loc rep_sig (L _ (MinimalSig {})) = notHandled "MINIMAL pragmas" empty -rep_ty_sig :: SrcSpan -> LHsType Name -> Located Name +rep_ty_sig :: Name -> SrcSpan -> LHsType Name -> Located Name -> DsM (SrcSpan, Core TH.DecQ) -rep_ty_sig loc (L _ ty) nm +rep_ty_sig mk_sig loc (L _ ty) nm = do { nm1 <- lookupLOcc nm ; ty1 <- rep_ty ty - ; sig <- repProto nm1 ty1 + ; sig <- repProto mk_sig nm1 ty1 ; return (loc, sig) } where -- We must special-case the top-level explicit for-all of a TypeSig @@ -693,7 +702,6 @@ rep_ty_sig loc (L _ ty) nm rep_ty ty = repTy ty - rep_inline :: Located Name -> InlinePragma -- Never defaultInlinePragma -> SrcSpan @@ -1741,6 +1749,9 @@ repClass :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr] repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC fds) (MkC ds) = rep2 classDName [cxt, cls, tvs, fds, ds] +repDeriv :: Core TH.CxtQ -> Core TH.TypeQ -> DsM (Core TH.DecQ) +repDeriv (MkC cxt) (MkC ty) = rep2 standaloneDerivDName [cxt, ty] + repPragInl :: Core TH.Name -> Core TH.Inline -> Core TH.RuleMatch -> Core TH.Phases -> DsM (Core TH.DecQ) repPragInl (MkC nm) (MkC inline) (MkC rm) (MkC phases) @@ -1807,8 +1818,8 @@ repRoleAnnotD (MkC n) (MkC roles) = rep2 roleAnnotDName [n, roles] repFunDep :: Core [TH.Name] -> Core [TH.Name] -> DsM (Core TH.FunDep) repFunDep (MkC xs) (MkC ys) = rep2 funDepName [xs, ys] -repProto :: Core TH.Name -> Core TH.TypeQ -> DsM (Core TH.DecQ) -repProto (MkC s) (MkC ty) = rep2 sigDName [s, ty] +repProto :: Name -> Core TH.Name -> Core TH.TypeQ -> DsM (Core TH.DecQ) +repProto mk_sig (MkC s) (MkC ty) = rep2 mk_sig [s, ty] repCtxt :: Core [TH.PredQ] -> DsM (Core TH.CxtQ) repCtxt (MkC tys) = rep2 cxtName [tys] @@ -2105,9 +2116,9 @@ templateHaskellNames = [ bindSName, letSName, noBindSName, parSName, -- Dec funDName, valDName, dataDName, newtypeDName, tySynDName, - classDName, instanceDName, sigDName, forImpDName, + classDName, instanceDName, standaloneDerivDName, sigDName, forImpDName, pragInlDName, pragSpecDName, pragSpecInlDName, pragSpecInstDName, - pragRuleDName, pragAnnDName, + pragRuleDName, pragAnnDName, defaultSigDName, familyNoKindDName, familyKindDName, dataInstDName, newtypeInstDName, tySynInstDName, closedTypeFamilyKindDName, closedTypeFamilyNoKindDName, infixLDName, infixRDName, infixNDName, @@ -2333,7 +2344,7 @@ parSName = libFun (fsLit "parS") parSIdKey funDName, valDName, dataDName, newtypeDName, tySynDName, classDName, instanceDName, sigDName, forImpDName, pragInlDName, pragSpecDName, pragSpecInlDName, pragSpecInstDName, pragRuleDName, pragAnnDName, - familyNoKindDName, + familyNoKindDName, standaloneDerivDName, defaultSigDName, familyKindDName, dataInstDName, newtypeInstDName, tySynInstDName, closedTypeFamilyKindDName, closedTypeFamilyNoKindDName, infixLDName, infixRDName, infixNDName, roleAnnotDName :: Name @@ -2344,7 +2355,10 @@ newtypeDName = libFun (fsLit "newtypeD") newtypeDIdKey tySynDName = libFun (fsLit "tySynD") tySynDIdKey classDName = libFun (fsLit "classD") classDIdKey instanceDName = libFun (fsLit "instanceD") instanceDIdKey +standaloneDerivDName + = libFun (fsLit "standaloneDerivD") standaloneDerivDIdKey sigDName = libFun (fsLit "sigD") sigDIdKey +defaultSigDName = libFun (fsLit "defaultSigD") defaultSigDIdKey forImpDName = libFun (fsLit "forImpD") forImpDIdKey pragInlDName = libFun (fsLit "pragInlD") pragInlDIdKey pragSpecDName = libFun (fsLit "pragSpecD") pragSpecDIdKey @@ -2696,8 +2710,8 @@ parSIdKey = mkPreludeMiscIdUnique 323 funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey, classDIdKey, instanceDIdKey, sigDIdKey, forImpDIdKey, pragInlDIdKey, pragSpecDIdKey, pragSpecInlDIdKey, pragSpecInstDIdKey, pragRuleDIdKey, - pragAnnDIdKey, familyNoKindDIdKey, familyKindDIdKey, - dataInstDIdKey, newtypeInstDIdKey, tySynInstDIdKey, + pragAnnDIdKey, familyNoKindDIdKey, familyKindDIdKey, defaultSigDIdKey, + dataInstDIdKey, newtypeInstDIdKey, tySynInstDIdKey, standaloneDerivDIdKey, closedTypeFamilyKindDIdKey, closedTypeFamilyNoKindDIdKey, infixLDIdKey, infixRDIdKey, infixNDIdKey, roleAnnotDIdKey :: Unique funDIdKey = mkPreludeMiscIdUnique 330 @@ -2726,6 +2740,8 @@ infixLDIdKey = mkPreludeMiscIdUnique 352 infixRDIdKey = mkPreludeMiscIdUnique 353 infixNDIdKey = mkPreludeMiscIdUnique 354 roleAnnotDIdKey = mkPreludeMiscIdUnique 355 +standaloneDerivDIdKey = mkPreludeMiscIdUnique 356 +defaultSigDIdKey = mkPreludeMiscIdUnique 357 -- type Cxt = ... cxtIdKey :: Unique diff --git a/compiler/deSugar/DsMonad.lhs b/compiler/deSugar/DsMonad.lhs index c017a7cc01..1c707c4afc 100644 --- a/compiler/deSugar/DsMonad.lhs +++ b/compiler/deSugar/DsMonad.lhs @@ -221,7 +221,7 @@ initDs hsc_env mod rdr_env type_env fam_inst_env thing_inside } where -- Extend the global environment with a 'GlobalRdrEnv' containing the exported entities of - -- * 'Data.Array.Parallel' iff '-XParallalArrays' specified (see also 'checkLoadDAP'). + -- * 'Data.Array.Parallel' iff '-XParallelArrays' specified (see also 'checkLoadDAP'). -- * 'Data.Array.Parallel.Prim' iff '-fvectorise' specified. loadDAP thing_inside = do { dapEnv <- loadOneModule dATA_ARRAY_PARALLEL_NAME checkLoadDAP paErr diff --git a/compiler/ghc.mk b/compiler/ghc.mk index b5f5dbce8f..fb8aa730e8 100644 --- a/compiler/ghc.mk +++ b/compiler/ghc.mk @@ -53,8 +53,10 @@ compiler/stage%/build/Config.hs : mk/config.mk mk/project.mk | $$(dir $$@)/. @echo >> $@ @echo '#include "ghc_boot_platform.h"' >> $@ @echo >> $@ - @echo 'data IntegerLibrary = IntegerGMP | IntegerSimple' >> $@ - @echo ' deriving Eq' >> $@ + @echo 'data IntegerLibrary = IntegerGMP' >> $@ + @echo ' | IntegerGMP2' >> $@ + @echo ' | IntegerSimple' >> $@ + @echo ' deriving Eq' >> $@ @echo >> $@ @echo 'cBuildPlatformString :: String' >> $@ @echo 'cBuildPlatformString = BuildPlatform_NAME' >> $@ @@ -84,6 +86,8 @@ compiler/stage%/build/Config.hs : mk/config.mk mk/project.mk | $$(dir $$@)/. @echo 'cIntegerLibraryType :: IntegerLibrary' >> $@ ifeq "$(INTEGER_LIBRARY)" "integer-gmp" @echo 'cIntegerLibraryType = IntegerGMP' >> $@ +else ifeq "$(INTEGER_LIBRARY)" "integer-gmp2" + @echo 'cIntegerLibraryType = IntegerGMP2' >> $@ else ifeq "$(INTEGER_LIBRARY)" "integer-simple" @echo 'cIntegerLibraryType = IntegerSimple' >> $@ else ifneq "$(CLEANING)" "YES" @@ -570,6 +574,7 @@ compiler_stage2_dll0_MODULES = \ StringBuffer \ TcEvidence \ TcIface \ + TcMType \ TcRnMonad \ TcRnTypes \ TcType \ diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs index 43d9bfb4e9..9ad594c698 100644 --- a/compiler/hsSyn/Convert.lhs +++ b/compiler/hsSyn/Convert.lhs @@ -6,7 +6,6 @@ This module converts Template Haskell syntax into HsSyn \begin{code} -{-# LANGUAGE MagicHash #-} {-# LANGUAGE CPP #-} module Convert( convertToHsExpr, convertToPat, convertToHsDecls, @@ -44,7 +43,6 @@ import Control.Applicative (Applicative(..)) import Data.Maybe( catMaybes ) import Language.Haskell.TH as TH hiding (sigP) import Language.Haskell.TH.Syntax as TH -import GHC.Exts ------------------------------------------------------------------- -- The external interface @@ -172,7 +170,11 @@ cvtDec (TH.SigD nm typ) ; returnJustL $ Hs.SigD (TypeSig [nm'] ty') } cvtDec (TH.InfixD fx nm) - = do { nm' <- vNameL nm + -- fixity signatures are allowed for variables, constructors, and types + -- the renamer automatically looks for types during renaming, even when + -- the RdrName says it's a variable or a constructor. So, just assume + -- it's a variable or constructor and proceed. + = do { nm' <- vcNameL nm ; returnJustL (Hs.SigD (FixSig (FixitySig nm' (cvtFixity fx)))) } cvtDec (PragmaD prag) @@ -303,6 +305,18 @@ cvtDec (TH.RoleAnnotD tc roles) = do { tc' <- tconNameL tc ; let roles' = map (noLoc . cvtRole) roles ; returnJustL $ Hs.RoleAnnotD (RoleAnnotDecl tc' roles') } + +cvtDec (TH.StandaloneDerivD cxt ty) + = do { cxt' <- cvtContext cxt + ; L loc ty' <- cvtType ty + ; let inst_ty' = L loc $ mkImplicitHsForAllTy cxt' $ L loc ty' + ; returnJustL $ DerivD $ + DerivDecl { deriv_type = inst_ty', deriv_overlap_mode = Nothing } } + +cvtDec (TH.DefaultSigD nm typ) + = do { nm' <- vNameL nm + ; ty' <- cvtType typ + ; returnJustL $ Hs.SigD $ GenericSig [nm'] ty' } ---------------- cvtTySynEqn :: Located RdrName -> TySynEqn -> CvtM (LTyFamInstEqn RdrName) cvtTySynEqn tc (TySynEqn lhs rhs) @@ -521,7 +535,7 @@ cvtPragmaD (AnnP target exp) n' <- tconName n return (TypeAnnProvenance n') ValueAnnotation n -> do - n' <- if isVarName n then vName n else cName n + n' <- vcName n return (ValueAnnProvenance n') ; returnJustL $ Hs.AnnD $ HsAnnotation target' exp' } @@ -1071,9 +1085,10 @@ cvtFractionalLit r = FL { fl_text = show (fromRational r :: Double), fl_value = -------------------------------------------------------------------- -- variable names -vNameL, cNameL, tconNameL :: TH.Name -> CvtM (Located RdrName) -vName, cName, tName, tconName :: TH.Name -> CvtM RdrName +vNameL, cNameL, vcNameL, tconNameL :: TH.Name -> CvtM (Located RdrName) +vName, cName, vcName, tName, tconName :: TH.Name -> CvtM RdrName +-- Variable names vNameL n = wrapL (vName n) vName n = cvtName OccName.varName n @@ -1081,6 +1096,10 @@ vName n = cvtName OccName.varName n cNameL n = wrapL (cName n) cName n = cvtName OccName.dataName n +-- Variable *or* constructor names; check by looking at the first char +vcNameL n = wrapL (vcName n) +vcName n = if isVarName n then vName n else cName n + -- Type variable names tName n = cvtName OccName.tvName n @@ -1181,8 +1200,8 @@ mk_mod mod = mkModuleName (TH.modString mod) mk_pkg :: TH.PkgName -> PackageKey mk_pkg pkg = stringToPackageKey (TH.pkgString pkg) -mk_uniq :: Int# -> Unique -mk_uniq u = mkUniqueGrimily (I# u) +mk_uniq :: Int -> Unique +mk_uniq u = mkUniqueGrimily u \end{code} Note [Binders in Template Haskell] diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs index 12e2388684..df2406fcd3 100644 --- a/compiler/hsSyn/HsUtils.lhs +++ b/compiler/hsSyn/HsUtils.lhs @@ -28,7 +28,7 @@ module HsUtils( mkHsOpApp, mkHsDo, mkHsComp, mkHsWrapPat, mkHsWrapPatCo, mkLHsPar, mkHsCmdCast, - nlHsTyApp, nlHsVar, nlHsLit, nlHsApp, nlHsApps, nlHsIntLit, nlHsVarApps, + nlHsTyApp, nlHsTyApps, nlHsVar, nlHsLit, nlHsApp, nlHsApps, nlHsIntLit, nlHsVarApps, nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList, mkLHsTupleExpr, mkLHsVarTuple, missingTupArg, toHsType, toHsKind, @@ -177,6 +177,9 @@ mkSimpleHsAlt pat expr nlHsTyApp :: name -> [Type] -> LHsExpr name nlHsTyApp fun_id tys = noLoc (HsWrap (mkWpTyApps tys) (HsVar fun_id)) +nlHsTyApps :: name -> [Type] -> [LHsExpr name] -> LHsExpr name +nlHsTyApps fun_id tys xs = foldl nlHsApp (nlHsTyApp fun_id tys) xs + --------- Adding parens --------- mkLHsPar :: LHsExpr name -> LHsExpr name -- Wrap in parens if hsExprNeedsParens says it needs them diff --git a/compiler/iface/BuildTyCl.lhs b/compiler/iface/BuildTyCl.lhs index d90e63c972..106a15fc9a 100644 --- a/compiler/iface/BuildTyCl.lhs +++ b/compiler/iface/BuildTyCl.lhs @@ -179,7 +179,7 @@ mkDataConStupidTheta tycon arg_tys univ_tvs ------------------------------------------------------ buildPatSyn :: Name -> Bool - -> Id -> Maybe Id + -> Id -> Maybe (Id, Id) -> ([TyVar], ThetaType) -- ^ Univ and req -> ([TyVar], ThetaType) -- ^ Ex and prov -> [Type] -- ^ Argument types diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs index 5cfe773dc8..c2b7c5276b 100644 --- a/compiler/iface/IfaceSyn.lhs +++ b/compiler/iface/IfaceSyn.lhs @@ -128,7 +128,7 @@ data IfaceDecl | IfacePatSyn { ifName :: IfaceTopBndr, -- Name of the pattern synonym ifPatIsInfix :: Bool, ifPatMatcher :: IfExtName, - ifPatWrapper :: Maybe IfExtName, + ifPatWorker :: Maybe IfExtName, -- Everything below is redundant, -- but needed to implement pprIfaceDecl ifPatUnivTvs :: [IfaceTvBndr], @@ -759,15 +759,15 @@ pprIfaceDecl ss (IfaceSyn { ifName = tycon, ifTyVars = tyvars $$ ppShowIface ss (ptext (sLit "axiom") <+> ppr ax) pp_branches _ = Outputable.empty -pprIfaceDecl _ (IfacePatSyn { ifName = name, ifPatWrapper = wrapper, +pprIfaceDecl _ (IfacePatSyn { ifName = name, ifPatWorker = worker, ifPatIsInfix = is_infix, ifPatUnivTvs = _univ_tvs, ifPatExTvs = _ex_tvs, ifPatProvCtxt = prov_ctxt, ifPatReqCtxt = req_ctxt, ifPatArgs = args, ifPatTy = ty }) - = pprPatSynSig name has_wrap args' ty' (pprCtxt prov_ctxt) (pprCtxt req_ctxt) + = pprPatSynSig name is_bidirectional args' ty' (pprCtxt prov_ctxt) (pprCtxt req_ctxt) where - has_wrap = isJust wrapper + is_bidirectional = isJust worker args' = case (is_infix, args) of (True, [left_ty, right_ty]) -> InfixPatSyn (pprParendIfaceType left_ty) (pprParendIfaceType right_ty) @@ -1131,7 +1131,7 @@ freeNamesIfDecl d@IfaceAxiom{} = fnList freeNamesIfAxBranch (ifAxBranches d) freeNamesIfDecl d@IfacePatSyn{} = unitNameSet (ifPatMatcher d) &&& - maybe emptyNameSet unitNameSet (ifPatWrapper d) &&& + maybe emptyNameSet unitNameSet (ifPatWorker d) &&& freeNamesIfTvBndrs (ifPatUnivTvs d) &&& freeNamesIfTvBndrs (ifPatExTvs d) &&& freeNamesIfContext (ifPatProvCtxt d) &&& diff --git a/compiler/iface/LoadIface.lhs b/compiler/iface/LoadIface.lhs index faaea6c456..3b2f7f25c9 100644 --- a/compiler/iface/LoadIface.lhs +++ b/compiler/iface/LoadIface.lhs @@ -92,7 +92,7 @@ loadSrcInterface doc mod want_boot maybe_pkg Failed err -> failWithTc err Succeeded iface -> return iface } --- | Like loadSrcInterface, but returns a MaybeErr +-- | Like 'loadSrcInterface', but returns a 'MaybeErr'. loadSrcInterface_maybe :: SDoc -> ModuleName -> IsBootInterface -- {-# SOURCE #-} ? @@ -111,7 +111,10 @@ loadSrcInterface_maybe doc mod want_boot maybe_pkg Found _ mod -> initIfaceTcRn $ loadInterface doc mod (ImportByUser want_boot) err -> return (Failed (cannotFindInterface (hsc_dflags hsc_env) mod err)) } --- | Load interface for a module. +-- | Load interface directly for a fully qualified 'Module'. (This is a fairly +-- rare operation, but in particular it is used to load orphan modules +-- in order to pull their instances into the global package table and to +-- handle some operations in GHCi). loadModuleInterface :: SDoc -> Module -> TcM ModIface loadModuleInterface doc mod = initIfaceTcRn (loadSysInterface doc mod) diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index 78111b299e..95fe479447 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -1534,7 +1534,7 @@ patSynToIfaceDecl :: PatSyn -> IfaceDecl patSynToIfaceDecl ps = IfacePatSyn { ifName = getOccName . getName $ ps , ifPatMatcher = matcher - , ifPatWrapper = wrapper + , ifPatWorker = worker , ifPatIsInfix = patSynIsInfix ps , ifPatUnivTvs = toIfaceTvBndrs univ_tvs' , ifPatExTvs = toIfaceTvBndrs ex_tvs' @@ -1549,7 +1549,7 @@ patSynToIfaceDecl ps (env2, ex_tvs') = tidyTyVarBndrs env1 ex_tvs matcher = idName (patSynMatcher ps) - wrapper = fmap idName (patSynWrapper ps) + worker = fmap idName (patSynWorker ps) -------------------------- diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index 65345ec3c8..85ea0f94cc 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -14,7 +14,8 @@ module TcIface ( tcIfaceDecl, tcIfaceInst, tcIfaceFamInst, tcIfaceRules, tcIfaceVectInfo, tcIfaceAnnotations, tcIfaceExpr, -- Desired by HERMIT (Trac #7683) - tcIfaceGlobal + tcIfaceGlobal, + mkPatSynWrapperId, mkPatSynWorkerId -- Have to be here to avoid circular import ) where #include "HsVersions.h" @@ -27,7 +28,8 @@ import BuildTyCl import TcRnMonad import TcType import Type -import Coercion +import TcMType +import Coercion hiding (substTy) import TypeRep import HscTypes import Annotations @@ -37,7 +39,7 @@ import CoreSyn import CoreUtils import CoreUnfold import CoreLint -import MkCore ( castBottomExpr ) +import MkCore import Id import MkId import IdInfo @@ -75,6 +77,7 @@ import qualified Data.Map as Map #if __GLASGOW_HASKELL__ < 709 import Data.Traversable ( traverse ) #endif +import Data.Traversable ( for ) \end{code} This module takes @@ -181,9 +184,9 @@ We need to make sure that we have at least *read* the interface files for any module with an instance decl or RULE that we might want. * If the instance decl is an orphan, we have a whole separate mechanism - (loadOprhanModules) + (loadOrphanModules) -* If the instance decl not an orphan, then the act of looking at the +* If the instance decl is not an orphan, then the act of looking at the TyCon or Class will force in the defining module for the TyCon/Class, and hence the instance decl @@ -582,7 +585,7 @@ tc_iface_decl _ _ (IfaceAxiom { ifName = ax_occ, ifTyCon = tc tc_iface_decl _ _ (IfacePatSyn{ ifName = occ_name , ifPatMatcher = matcher_name - , ifPatWrapper = wrapper_name + , ifPatWorker = worker_name , ifPatIsInfix = is_infix , ifPatUnivTvs = univ_tvs , ifPatExTvs = ex_tvs @@ -593,10 +596,7 @@ tc_iface_decl _ _ (IfacePatSyn{ ifName = occ_name = do { name <- lookupIfaceTop occ_name ; traceIf (ptext (sLit "tc_iface_decl") <+> ppr name) ; matcher <- tcExt "Matcher" matcher_name - ; wrapper <- case wrapper_name of - Nothing -> return Nothing - Just wn -> do { wid <- tcExt "Wrapper" wn - ; return (Just wid) } + ; worker <- traverse (tcExt "Worker") worker_name ; bindIfaceTyVars univ_tvs $ \univ_tvs -> do { bindIfaceTyVars ex_tvs $ \ex_tvs -> do { patsyn <- forkM (mk_doc name) $ @@ -604,6 +604,14 @@ tc_iface_decl _ _ (IfacePatSyn{ ifName = occ_name ; req_theta <- tcIfaceCtxt req_ctxt ; pat_ty <- tcIfaceType pat_ty ; arg_tys <- mapM tcIfaceType args + ; wrapper <- for worker $ \worker_id -> do + { wrapper_id <- mkPatSynWrapperId (noLoc name) + (univ_tvs ++ ex_tvs) + (req_theta ++ prov_theta) + arg_tys pat_ty + worker_id + ; return (wrapper_id, worker_id) + } ; return $ buildPatSyn name is_infix matcher wrapper (univ_tvs, req_theta) (ex_tvs, prov_theta) arg_tys pat_ty } @@ -1520,3 +1528,41 @@ bindIfaceTyVars_AT (b@(tv_occ,_) : bs) thing_inside bindIfaceTyVars_AT bs $ \bs' -> thing_inside (b':bs') } \end{code} + +%************************************************************************ +%* * + PatSyn wrapper/worker helpers +%* * +%************************************************************************ + +\begin{code} +-- These are here (and not in TcPatSyn) just to avoid circular imports. + +mkPatSynWrapperId :: Located Name + -> [TyVar] -> ThetaType -> [Type] -> Type + -> Id + -> TcRnIf gbl lcl Id +mkPatSynWrapperId name qtvs theta arg_tys pat_ty worker_id + | need_dummy_arg = do + { wrapper_id <- mkPatSynWorkerId name mkDataConWrapperOcc qtvs theta arg_tys pat_ty + ; let unfolding = mkCoreApp (Var worker_id) (Var voidPrimId) + wrapper_id' = setIdUnfolding wrapper_id $ mkCompulsoryUnfolding unfolding + ; return wrapper_id' } + | otherwise = return worker_id -- No indirection needed + where + need_dummy_arg = null arg_tys && isUnLiftedType pat_ty + +mkPatSynWorkerId :: Located Name -> (OccName -> OccName) + -> [TyVar] -> ThetaType -> [Type] -> Type + -> TcRnIf gbl loc Id +mkPatSynWorkerId (L loc name) mk_occ_name qtvs theta arg_tys pat_ty + = do { worker_name <- newImplicitBinder name mk_occ_name + ; (subst, worker_tvs) <- tcInstSigTyVarsLoc loc qtvs + ; let worker_theta = substTheta subst theta + pat_ty' = substTy subst pat_ty + arg_tys' = map (substTy subst) arg_tys + worker_tau = mkFunTys arg_tys' pat_ty' + -- TODO: just substitute worker_sigma... + worker_sigma = mkSigmaTy worker_tvs worker_theta worker_tau + ; return $ mkVanillaGlobal worker_name worker_sigma } +\end{code} diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 0c6639a048..043174f3b0 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -482,6 +482,7 @@ data WarningFlag = | Opt_WarnAlternativeLayoutRuleTransitional | Opt_WarnUnsafe | Opt_WarnSafe + | Opt_WarnTrustworthySafe | Opt_WarnPointlessPragmas | Opt_WarnUnsupportedCallingConventions | Opt_WarnUnsupportedLlvmVersion @@ -778,6 +779,7 @@ data DynFlags = DynFlags { pkgTrustOnLoc :: SrcSpan, warnSafeOnLoc :: SrcSpan, warnUnsafeOnLoc :: SrcSpan, + trustworthyOnLoc :: SrcSpan, -- Don't change this without updating extensionFlags: extensions :: [OnOff ExtensionFlag], -- extensionFlags should always be equal to @@ -1466,6 +1468,7 @@ defaultDynFlags mySettings = pkgTrustOnLoc = noSrcSpan, warnSafeOnLoc = noSrcSpan, warnUnsafeOnLoc = noSrcSpan, + trustworthyOnLoc = noSrcSpan, extensions = [], extensionFlags = flattenExtensionFlags Nothing [], @@ -1758,11 +1761,15 @@ setSafeHaskell s = updM f where f dfs = do let sf = safeHaskell dfs safeM <- combineSafeFlags sf s - return $ case (s == Sf_Safe || s == Sf_Unsafe) of - True -> dfs { safeHaskell = safeM, safeInfer = False } + case s of + Sf_Safe -> return $ dfs { safeHaskell = safeM, safeInfer = False } -- leave safe inferrence on in Trustworthy mode so we can warn -- if it could have been inferred safe. - False -> dfs { safeHaskell = safeM } + Sf_Trustworthy -> do + l <- getCurLoc + return $ dfs { safeHaskell = safeM, trustworthyOnLoc = l } + -- leave safe inference on in Unsafe mode as well. + _ -> return $ dfs { safeHaskell = safeM } -- | Are all direct imports required to be safe for this Safe Haskell mode? -- Direct imports are when the code explicitly imports a module @@ -2663,6 +2670,7 @@ fWarningFlags = [ ( "warn-overlapping-patterns", Opt_WarnOverlappingPatterns, nop ), ( "warn-pointless-pragmas", Opt_WarnPointlessPragmas, nop ), ( "warn-safe", Opt_WarnSafe, setWarnSafe ), + ( "warn-trustworthy-safe", Opt_WarnTrustworthySafe, nop ), ( "warn-tabs", Opt_WarnTabs, nop ), ( "warn-type-defaults", Opt_WarnTypeDefaults, nop ), ( "warn-typed-holes", Opt_WarnTypedHoles, nop ), diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs index bec66f858a..c9baa5ac3e 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -412,19 +412,27 @@ tcRnModule' hsc_env sum save_rn_syntax mod = do -- end of the safe haskell line, how to respond to user? if not (safeHaskellOn dflags) || (safeInferOn dflags && not allSafeOK) -- if safe Haskell off or safe infer failed, mark unsafe - then markUnsafe tcg_res emptyBag + then markUnsafeInfer tcg_res emptyBag -- module (could be) safe, throw warning if needed else do tcg_res' <- hscCheckSafeImports tcg_res safe <- liftIO $ readIORef (tcg_safeInfer tcg_res') - when (safe && wopt Opt_WarnSafe dflags) - (logWarnings $ unitBag $ mkPlainWarnMsg dflags - (warnSafeOnLoc dflags) $ errSafe tcg_res') + when safe $ do + case wopt Opt_WarnSafe dflags of + True -> (logWarnings $ unitBag $ mkPlainWarnMsg dflags + (warnSafeOnLoc dflags) $ errSafe tcg_res') + False | safeHaskell dflags == Sf_Trustworthy && + wopt Opt_WarnTrustworthySafe dflags -> + (logWarnings $ unitBag $ mkPlainWarnMsg dflags + (trustworthyOnLoc dflags) $ errTwthySafe tcg_res') + False -> return () return tcg_res' where pprMod t = ppr $ moduleName $ tcg_mod t errSafe t = quotes (pprMod t) <+> text "has been inferred as safe!" + errTwthySafe t = quotes (pprMod t) + <+> text "is marked as Trustworthy but has been inferred as safe!" -- | Convert a typechecked module to Core hscDesugar :: HscEnv -> ModSummary -> TcGblEnv -> IO ModGuts @@ -762,6 +770,18 @@ hscFileFrontEnd mod_summary = do -- * For modules explicitly marked -XSafe, we throw the errors. -- * For unmarked modules (inference mode), we drop the errors -- and mark the module as being Unsafe. +-- +-- It used to be that we only did safe inference on modules that had no Safe +-- Haskell flags, but now we perform safe inference on all modules as we want +-- to allow users to set the `--fwarn-safe`, `--fwarn-unsafe` and +-- `--fwarn-trustworthy-safe` flags on Trustworthy and Unsafe modules so that a +-- user can ensure their assumptions are correct and see reasons for why a +-- module is safe or unsafe. +-- +-- This is tricky as we must be careful when we should throw an error compared +-- to just warnings. For checking safe imports we manage it as two steps. First +-- we check any imports that are required to be safe, then we check all other +-- imports to see if we can infer them to be safe. -- | Check that the safe imports of the module being compiled are valid. @@ -772,21 +792,24 @@ hscCheckSafeImports :: TcGblEnv -> Hsc TcGblEnv hscCheckSafeImports tcg_env = do dflags <- getDynFlags tcg_env' <- checkSafeImports dflags tcg_env - case safeLanguageOn dflags of - True -> do - -- XSafe: we nuke user written RULES - logWarnings $ warns dflags (tcg_rules tcg_env') - return tcg_env' { tcg_rules = [] } - False - -- SafeInferred: user defined RULES, so not safe - | safeInferOn dflags && not (null $ tcg_rules tcg_env') - -> markUnsafe tcg_env' $ warns dflags (tcg_rules tcg_env') - - -- Trustworthy OR SafeInferred: with no RULES - | otherwise - -> return tcg_env' + checkRULES dflags tcg_env' where + checkRULES dflags tcg_env' = do + case safeLanguageOn dflags of + True -> do + -- XSafe: we nuke user written RULES + logWarnings $ warns dflags (tcg_rules tcg_env') + return tcg_env' { tcg_rules = [] } + False + -- SafeInferred: user defined RULES, so not safe + | safeInferOn dflags && not (null $ tcg_rules tcg_env') + -> markUnsafeInfer tcg_env' $ warns dflags (tcg_rules tcg_env') + + -- Trustworthy OR SafeInferred: with no RULES + | otherwise + -> return tcg_env' + warns dflags rules = listToBag $ map (warnRules dflags) rules warnRules dflags (L loc (HsRule n _ _ _ _ _ _)) = mkPlainWarnMsg dflags loc $ @@ -808,51 +831,55 @@ hscCheckSafeImports tcg_env = do checkSafeImports :: DynFlags -> TcGblEnv -> Hsc TcGblEnv checkSafeImports dflags tcg_env = do + imps <- mapM condense imports' + let (safeImps, regImps) = partition (\(_,_,s) -> s) imps + -- We want to use the warning state specifically for detecting if safe -- inference has failed, so store and clear any existing warnings. oldErrs <- getWarnings clearWarnings - imps <- mapM condense imports' - pkgs <- mapM checkSafe imps - - -- grab any safe haskell specific errors and restore old warnings - errs <- getWarnings + -- Check safe imports are correct + safePkgs <- mapM checkSafe safeImps + safeErrs <- getWarnings clearWarnings - logWarnings oldErrs + -- Check non-safe imports are correct if inferring safety -- See the Note [Safe Haskell Inference] - case (not $ isEmptyBag errs) of - - -- We have errors! - True -> - -- did we fail safe inference or fail -XSafe? - case safeInferOn dflags of - True -> markUnsafe tcg_env errs - False -> liftIO . throwIO . mkSrcErr $ errs - - -- All good matey! - False -> do - when (packageTrustOn dflags) $ checkPkgTrust dflags pkg_reqs - -- add in trusted package requirements for this module - let new_trust = emptyImportAvails { imp_trust_pkgs = catMaybes pkgs } - return tcg_env { tcg_imports = imp_info `plusImportAvails` new_trust } + (infErrs, infPkgs) <- case (safeInferOn dflags) of + False -> return (emptyBag, []) + True -> do infPkgs <- mapM checkSafe regImps + infErrs <- getWarnings + clearWarnings + return (infErrs, infPkgs) + + -- restore old errors + logWarnings oldErrs + + case (isEmptyBag safeErrs) of + -- Failed safe check + False -> liftIO . throwIO . mkSrcErr $ safeErrs + + -- Passed safe check + True -> do + let infPassed = isEmptyBag infErrs + tcg_env' <- case (not infPassed) of + True -> markUnsafeInfer tcg_env infErrs + False -> return tcg_env + when (packageTrustOn dflags) $ checkPkgTrust dflags pkgReqs + let newTrust = pkgTrustReqs safePkgs infPkgs infPassed + return tcg_env' { tcg_imports = impInfo `plusImportAvails` newTrust } where - imp_info = tcg_imports tcg_env -- ImportAvails - imports = imp_mods imp_info -- ImportedMods + impInfo = tcg_imports tcg_env -- ImportAvails + imports = imp_mods impInfo -- ImportedMods imports' = moduleEnvToList imports -- (Module, [ImportedModsVal]) - pkg_reqs = imp_trust_pkgs imp_info -- [PackageKey] + pkgReqs = imp_trust_pkgs impInfo -- [PackageKey] condense :: (Module, [ImportedModsVal]) -> Hsc (Module, SrcSpan, IsSafeImport) condense (_, []) = panic "HscMain.condense: Pattern match failure!" condense (m, x:xs) = do (_,_,l,s) <- foldlM cond' x xs - -- we turn all imports into safe ones when - -- inference mode is on. - let s' = if safeInferOn dflags && - safeHaskell dflags == Sf_None - then True else s - return (m, l, s') + return (m, l, s) -- ImportedModsVal = (ModuleName, Bool, SrcSpan, IsSafeImport) cond' :: ImportedModsVal -> ImportedModsVal -> Hsc ImportedModsVal @@ -865,8 +892,17 @@ checkSafeImports dflags tcg_env = return v1 -- easier interface to work with - checkSafe (_, _, False) = return Nothing - checkSafe (m, l, True ) = fst `fmap` hscCheckSafe' dflags m l + checkSafe (m, l, _) = fst `fmap` hscCheckSafe' dflags m l + + -- what pkg's to add to our trust requirements + pkgTrustReqs req inf infPassed | safeInferOn dflags + && safeHaskell dflags == Sf_None && infPassed + = emptyImportAvails { + imp_trust_pkgs = catMaybes req ++ catMaybes inf + } + pkgTrustReqs _ _ _ | safeHaskell dflags == Sf_Unsafe + = emptyImportAvails + pkgTrustReqs req _ _ = emptyImportAvails { imp_trust_pkgs = catMaybes req } -- | Check that a module is safe to import. -- @@ -1000,11 +1036,16 @@ checkPkgTrust dflags pkgs = -- | Set module to unsafe and (potentially) wipe trust information. -- --- Make sure to call this method to set a module to inferred unsafe, --- it should be a central and single failure method. We only wipe the trust --- information when we aren't in a specific Safe Haskell mode. -markUnsafe :: TcGblEnv -> WarningMessages -> Hsc TcGblEnv -markUnsafe tcg_env whyUnsafe = do +-- Make sure to call this method to set a module to inferred unsafe, it should +-- be a central and single failure method. We only wipe the trust information +-- when we aren't in a specific Safe Haskell mode. +-- +-- While we only use this for recording that a module was inferred unsafe, we +-- may call it on modules using Trustworthy or Unsafe flags so as to allow +-- warning flags for safety to function correctly. See Note [Safe Haskell +-- Inference]. +markUnsafeInfer :: TcGblEnv -> WarningMessages -> Hsc TcGblEnv +markUnsafeInfer tcg_env whyUnsafe = do dflags <- getDynFlags when (wopt Opt_WarnUnsafe dflags) diff --git a/compiler/main/PackageConfig.hs b/compiler/main/PackageConfig.hs index 3f2bf1680b..b94ea65a65 100644 --- a/compiler/main/PackageConfig.hs +++ b/compiler/main/PackageConfig.hs @@ -75,6 +75,25 @@ instance Outputable SourcePackageId where instance Outputable PackageName where ppr (PackageName str) = ftext str +-- | Pretty-print an 'ExposedModule' in the same format used by the textual +-- installed package database. +pprExposedModule :: (Outputable a, Outputable b) => ExposedModule a b -> SDoc +pprExposedModule (ExposedModule exposedName exposedReexport exposedSignature) = + sep [ ppr exposedName + , case exposedReexport of + Just m -> sep [text "from", pprOriginalModule m] + Nothing -> empty + , case exposedSignature of + Just m -> sep [text "is", pprOriginalModule m] + Nothing -> empty + ] + +-- | Pretty-print an 'OriginalModule' in the same format used by the textual +-- installed package database. +pprOriginalModule :: (Outputable a, Outputable b) => OriginalModule a b -> SDoc +pprOriginalModule (OriginalModule originalPackageId originalModuleName) = + ppr originalPackageId <> char ':' <> ppr originalModuleName + defaultPackageConfig :: PackageConfig defaultPackageConfig = emptyInstalledPackageInfo @@ -101,9 +120,11 @@ pprPackageConfig InstalledPackageInfo {..} = field "id" (ppr installedPackageId), field "key" (ppr packageKey), field "exposed" (ppr exposed), - field "exposed-modules" (fsep (map ppr exposedModules)), + field "exposed-modules" + (if all isExposedModule exposedModules + then fsep (map pprExposedModule exposedModules) + else pprWithCommas pprExposedModule exposedModules), field "hidden-modules" (fsep (map ppr hiddenModules)), - field "reexported-modules" (fsep (map ppr haddockHTMLs)), field "trusted" (ppr trusted), field "import-dirs" (fsep (map text importDirs)), field "library-dirs" (fsep (map text libraryDirs)), @@ -122,6 +143,8 @@ pprPackageConfig InstalledPackageInfo {..} = ] where field name body = text name <> colon <+> nest 4 body + isExposedModule (ExposedModule _ Nothing Nothing) = True + isExposedModule _ = False -- ----------------------------------------------------------------------------- diff --git a/compiler/main/Packages.lhs b/compiler/main/Packages.lhs index a308a990d1..519353e0bb 100644 --- a/compiler/main/Packages.lhs +++ b/compiler/main/Packages.lhs @@ -35,7 +35,6 @@ module Packages ( collectIncludeDirs, collectLibraryPaths, collectLinkOpts, packageHsLibs, - ModuleExport(..), -- * Utils packageKeyPackageIdString, @@ -211,17 +210,6 @@ originEmpty :: ModuleOrigin -> Bool originEmpty (ModOrigin Nothing [] [] False) = True originEmpty _ = False --- | When we do a plain lookup (e.g. for an import), initially, all we want --- to know is if we can find it or not (and if we do and it's a reexport, --- what the real name is). If the find fails, we'll want to investigate more --- to give a good error message. -data SimpleModuleConf = - SModConf Module PackageConfig ModuleOrigin - | SModConfAmbiguous - --- | 'UniqFM' map from 'ModuleName' -type ModuleNameMap = UniqFM - -- | 'UniqFM' map from 'PackageKey' type PackageKeyMap = UniqFM @@ -253,10 +241,6 @@ data PackageState = PackageState { -- is always mentioned before the packages it depends on. preloadPackages :: [PackageKey], - -- | This is a simplified map from 'ModuleName' to original 'Module' and - -- package configuration providing it. - moduleToPkgConf :: ModuleNameMap SimpleModuleConf, - -- | This is a full map from 'ModuleName' to all modules which may possibly -- be providing it. These providers may be hidden (but we'll still want -- to report them in error messages), or it may be an ambiguous import. @@ -997,7 +981,6 @@ mkPackageState dflags pkgs0 preload0 this_package = do let pstate = PackageState{ preloadPackages = dep_preload, pkgIdMap = pkg_db, - moduleToPkgConf = mkModuleToPkgConf dflags pkg_db ipid_map vis_map, moduleToPkgConfAll = mkModuleToPkgConfAll dflags pkg_db ipid_map vis_map, installedPackageIdMap = ipid_map } @@ -1047,16 +1030,17 @@ mkModuleToPkgConfGeneric emptyMap sing setOrigins addListTo ppr orig <+> text "in package" <+> ppr pk))) es :: Bool -> [(ModuleName, e)] - es e = - [(m, sing pk m pkg (fromExposedModules e)) | m <- exposed_mods] ++ - [(m, sing pk' m' pkg' (fromReexportedModules e pkg)) - | ModuleExport { - exportModuleName = m, - exportOriginalPackageId = ipid', - exportOriginalModuleName = m' - } <- reexported_mods - , let pk' = expectJust "mkModuleToPkgConf" (Map.lookup ipid' ipid_map) - pkg' = pkg_lookup pk' ] + es e = do + -- TODO: signature support + ExposedModule m exposedReexport _exposedSignature <- exposed_mods + let (pk', m', pkg', origin') = + case exposedReexport of + Nothing -> (pk, m, pkg, fromExposedModules e) + Just (OriginalModule ipid' m') -> + let pk' = expectJust "mkModuleToPkgConf" (Map.lookup ipid' ipid_map) + pkg' = pkg_lookup pk' + in (pk', m', pkg', fromReexportedModules e pkg') + return (m, sing pk' m' pkg' origin') esmap :: UniqFM e esmap = listToUFM (es False) -- parameter here doesn't matter, orig will @@ -1068,32 +1052,8 @@ mkModuleToPkgConfGeneric emptyMap sing setOrigins addListTo pkg_lookup = expectJust "mkModuleToPkgConf" . lookupPackage' pkg_db exposed_mods = exposedModules pkg - reexported_mods = reexportedModules pkg hidden_mods = hiddenModules pkg --- | This is a quick and efficient module map, which only contains an entry --- if it is specified unambiguously. -mkModuleToPkgConf - :: DynFlags - -> PackageConfigMap - -> InstalledPackageIdMap - -> VisibilityMap - -> ModuleNameMap SimpleModuleConf -mkModuleToPkgConf = - mkModuleToPkgConfGeneric emptyMap sing setOrigins addListTo - where emptyMap = emptyUFM - sing pk m pkg = SModConf (mkModule pk m) pkg - -- NB: don't put hidden entries in the map, they're not valid! - addListTo m xs = addListToUFM_C merge m (filter isVisible xs) - isVisible (_, SModConf _ _ o) = originVisible o - isVisible (_, SModConfAmbiguous) = False - merge (SModConf m pkg o) (SModConf m' _ o') - | m == m' = SModConf m pkg (o `mappend` o') - | otherwise = SModConfAmbiguous - merge _ _ = SModConfAmbiguous - setOrigins (SModConf m pkg _) os = SModConf m pkg os - setOrigins SModConfAmbiguous _ = SModConfAmbiguous - -- | This is a slow and complete map, which includes information about -- everything, including hidden modules mkModuleToPkgConfAll @@ -1241,17 +1201,11 @@ lookupModuleWithSuggestions :: DynFlags -> Maybe FastString -> LookupResult lookupModuleWithSuggestions dflags m mb_pn - = case lookupUFM (moduleToPkgConf pkg_state) m of - Just (SModConf m pkg o) | matches mb_pn pkg o -> - ASSERT( originVisible o ) LookupFound m pkg - _ -> case Map.lookup m (moduleToPkgConfAll pkg_state) of + = case Map.lookup m (moduleToPkgConfAll pkg_state) of Nothing -> LookupNotFound suggestions Just xs -> case foldl' classify ([],[],[]) (Map.toList xs) of ([], [], []) -> LookupNotFound suggestions - -- NB: Yes, we have to check this case too, since package qualified - -- imports could cause the main lookup to fail due to ambiguity, - -- but the second lookup to succeed. (_, _, [(m, _)]) -> LookupFound m (mod_pkg m) (_, _, exposed@(_:_)) -> LookupMultiple exposed (hidden_pkg, hidden_mod, []) -> LookupHidden hidden_pkg hidden_mod @@ -1269,9 +1223,6 @@ lookupModuleWithSuggestions dflags m mb_pn pkg_state = pkgState dflags mod_pkg = pkg_lookup . modulePackageKey - matches Nothing _ _ = True -- shortcut for efficiency - matches mb_pn pkg o = originVisible (filterOrigin mb_pn pkg o) - -- Filters out origins which are not associated with the given package -- qualifier. No-op if there is no package qualifier. Test if this -- excluded all origins with 'originEmpty'. diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs index a975fdd5ac..b7a867d718 100644 --- a/compiler/main/TidyPgm.lhs +++ b/compiler/main/TidyPgm.lhs @@ -421,7 +421,7 @@ lookup_aux_id :: TypeEnv -> Var -> Id lookup_aux_id type_env id = case lookupTypeEnv type_env (idName id) of Just (AnId id') -> id' - _other -> pprPanic "lookup_axu_id" (ppr id) + _other -> pprPanic "lookup_aux_id" (ppr id) \end{code} diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs index abd87ed087..a4115a0b6d 100644 --- a/compiler/nativeGen/X86/CodeGen.hs +++ b/compiler/nativeGen/X86/CodeGen.hs @@ -391,6 +391,21 @@ iselExpr64 (CmmMachOp (MO_Add _) [e1,e2]) = do ADC II32 (OpReg r2hi) (OpReg rhi) ] return (ChildCode64 code rlo) +iselExpr64 (CmmMachOp (MO_Sub _) [e1,e2]) = do + ChildCode64 code1 r1lo <- iselExpr64 e1 + ChildCode64 code2 r2lo <- iselExpr64 e2 + (rlo,rhi) <- getNewRegPairNat II32 + let + r1hi = getHiVRegFromLo r1lo + r2hi = getHiVRegFromLo r2lo + code = code1 `appOL` + code2 `appOL` + toOL [ MOV II32 (OpReg r1lo) (OpReg rlo), + SUB II32 (OpReg r2lo) (OpReg rlo), + MOV II32 (OpReg r1hi) (OpReg rhi), + SBB II32 (OpReg r2hi) (OpReg rhi) ] + return (ChildCode64 code rlo) + iselExpr64 (CmmMachOp (MO_UU_Conv _ W64) [expr]) = do fn <- getAnyReg expr r_dst_lo <- getNewRegNat II32 @@ -1272,24 +1287,23 @@ getCondCode (CmmMachOp mop [x, y]) MO_F_Lt W64 -> condFltCode LTT x y MO_F_Le W64 -> condFltCode LE x y - MO_Eq _ -> condIntCode EQQ x y - MO_Ne _ -> condIntCode NE x y - - MO_S_Gt _ -> condIntCode GTT x y - MO_S_Ge _ -> condIntCode GE x y - MO_S_Lt _ -> condIntCode LTT x y - MO_S_Le _ -> condIntCode LE x y - - MO_U_Gt _ -> condIntCode GU x y - MO_U_Ge _ -> condIntCode GEU x y - MO_U_Lt _ -> condIntCode LU x y - MO_U_Le _ -> condIntCode LEU x y - - _other -> pprPanic "getCondCode(x86,x86_64)" (ppr (CmmMachOp mop [x,y])) + _ -> condIntCode (machOpToCond mop) x y getCondCode other = pprPanic "getCondCode(2)(x86,x86_64)" (ppr other) - +machOpToCond :: MachOp -> Cond +machOpToCond mo = case mo of + MO_Eq _ -> EQQ + MO_Ne _ -> NE + MO_S_Gt _ -> GTT + MO_S_Ge _ -> GE + MO_S_Lt _ -> LTT + MO_S_Le _ -> LE + MO_U_Gt _ -> GU + MO_U_Ge _ -> GEU + MO_U_Lt _ -> LU + MO_U_Le _ -> LEU + _other -> pprPanic "machOpToCond" (pprMachOp mo) -- @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be @@ -1538,7 +1552,31 @@ genCondJump -> CmmExpr -- the condition on which to branch -> NatM InstrBlock -genCondJump id bool = do +genCondJump id expr = do + is32Bit <- is32BitPlatform + genCondJump' is32Bit id expr + +genCondJump' :: Bool -> BlockId -> CmmExpr -> NatM InstrBlock + +-- 64-bit integer comparisons on 32-bit +genCondJump' is32Bit true (CmmMachOp mop [e1,e2]) + | is32Bit, Just W64 <- maybeIntComparison mop = do + ChildCode64 code1 r1_lo <- iselExpr64 e1 + ChildCode64 code2 r2_lo <- iselExpr64 e2 + let r1_hi = getHiVRegFromLo r1_lo + r2_hi = getHiVRegFromLo r2_lo + cond = machOpToCond mop + Just cond' = maybeFlipCond cond + false <- getBlockIdNat + return $ code1 `appOL` code2 `appOL` toOL [ + CMP II32 (OpReg r2_hi) (OpReg r1_hi), + JXX cond true, + JXX cond' false, + CMP II32 (OpReg r2_lo) (OpReg r1_lo), + JXX cond true, + NEWBLOCK false ] + +genCondJump' _ id bool = do CondCode is_float cond cond_code <- getCondCode bool use_sse2 <- sse2Enabled if not is_float || not use_sse2 @@ -1569,7 +1607,6 @@ genCondJump id bool = do ] return (cond_code `appOL` code) - -- ----------------------------------------------------------------------------- -- Generating C calls diff --git a/compiler/nativeGen/X86/Instr.hs b/compiler/nativeGen/X86/Instr.hs index 2f6196227b..0d85376868 100644 --- a/compiler/nativeGen/X86/Instr.hs +++ b/compiler/nativeGen/X86/Instr.hs @@ -196,6 +196,7 @@ data Instr | ADD Size Operand Operand | ADC Size Operand Operand | SUB Size Operand Operand + | SBB Size Operand Operand | MUL Size Operand Operand | MUL2 Size Operand -- %edx:%eax = operand * %rax @@ -365,6 +366,7 @@ x86_regUsageOfInstr platform instr ADD _ src dst -> usageRM src dst ADC _ src dst -> usageRM src dst SUB _ src dst -> usageRM src dst + SBB _ src dst -> usageRM src dst IMUL _ src dst -> usageRM src dst IMUL2 _ src -> mkRU (eax:use_R src []) [eax,edx] MUL _ src dst -> usageRM src dst @@ -543,6 +545,7 @@ x86_patchRegsOfInstr instr env ADD sz src dst -> patch2 (ADD sz) src dst ADC sz src dst -> patch2 (ADC sz) src dst SUB sz src dst -> patch2 (SUB sz) src dst + SBB sz src dst -> patch2 (SBB sz) src dst IMUL sz src dst -> patch2 (IMUL sz) src dst IMUL2 sz src -> patch1 (IMUL2 sz) src MUL sz src dst -> patch2 (MUL sz) src dst diff --git a/compiler/nativeGen/X86/Ppr.hs b/compiler/nativeGen/X86/Ppr.hs index cc39557f1d..2b3711751c 100644 --- a/compiler/nativeGen/X86/Ppr.hs +++ b/compiler/nativeGen/X86/Ppr.hs @@ -570,11 +570,10 @@ pprInstr (ADD size (OpImm (ImmInt (-1))) dst) = pprSizeOp (sLit "dec") size dst pprInstr (ADD size (OpImm (ImmInt 1)) dst) = pprSizeOp (sLit "inc") size dst -pprInstr (ADD size src dst) - = pprSizeOpOp (sLit "add") size src dst -pprInstr (ADC size src dst) - = pprSizeOpOp (sLit "adc") size src dst +pprInstr (ADD size src dst) = pprSizeOpOp (sLit "add") size src dst +pprInstr (ADC size src dst) = pprSizeOpOp (sLit "adc") size src dst pprInstr (SUB size src dst) = pprSizeOpOp (sLit "sub") size src dst +pprInstr (SBB size src dst) = pprSizeOpOp (sLit "sbb") size src dst pprInstr (IMUL size op1 op2) = pprSizeOpOp (sLit "imul") size op1 op2 pprInstr (ADD_CC size src dst) diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs index 2fed8dd869..7098504d85 100644 --- a/compiler/prelude/PrelNames.lhs +++ b/compiler/prelude/PrelNames.lhs @@ -357,6 +357,7 @@ basicKnownKeyNames , ghciIoClassName, ghciStepIoMName ] ++ case cIntegerLibraryType of IntegerGMP -> [integerSDataConName] + IntegerGMP2 -> [integerSDataConName] IntegerSimple -> [] genericTyConNames :: [Name] @@ -937,6 +938,7 @@ integerTyConName = tcQual gHC_INTEGER_TYPE (fsLit "Integer") int integerSDataConName = conName gHC_INTEGER_TYPE (fsLit n) integerSDataConKey where n = case cIntegerLibraryType of IntegerGMP -> "S#" + IntegerGMP2 -> "S#" IntegerSimple -> panic "integerSDataConName evaluated for integer-simple" mkIntegerName = varQual gHC_INTEGER_TYPE (fsLit "mkInteger") mkIntegerIdKey integerToWord64Name = varQual gHC_INTEGER_TYPE (fsLit "integerToWord64") integerToWord64IdKey diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs index e33ed15808..0a73585976 100644 --- a/compiler/rename/RnEnv.lhs +++ b/compiler/rename/RnEnv.lhs @@ -309,9 +309,21 @@ lookupTopBndrRn_maybe rdr_name ----------------------------------------------- +-- | Lookup an @Exact@ @RdrName@. See Note [Looking up Exact RdrNames]. +-- This adds an error if the name cannot be found. lookupExactOcc :: Name -> RnM Name --- See Note [Looking up Exact RdrNames] lookupExactOcc name + = do { result <- lookupExactOcc_either name + ; case result of + Left err -> do { addErr err + ; return name } + Right name' -> return name' } + +-- | Lookup an @Exact@ @RdrName@. See Note [Looking up Exact RdrNames]. +-- This never adds an error, but it may return one. +lookupExactOcc_either :: Name -> RnM (Either MsgDoc Name) +-- See Note [Looking up Exact RdrNames] +lookupExactOcc_either name | Just thing <- wiredInNameTyThing_maybe name , Just tycon <- case thing of ATyCon tc -> Just tc @@ -319,10 +331,10 @@ lookupExactOcc name _ -> Nothing , isTupleTyCon tycon = do { checkTupSize (tyConArity tycon) - ; return name } + ; return (Right name) } | isExternalName name - = return name + = return (Right name) | otherwise = do { env <- getGlobalRdrEnv @@ -337,23 +349,23 @@ lookupExactOcc name ; case gres of [] -> -- See Note [Splicing Exact names] do { lcl_env <- getLocalRdrEnv - ; unless (name `inLocalRdrEnvScope` lcl_env) $ + ; if name `inLocalRdrEnvScope` lcl_env + then return (Right name) + else #ifdef GHCI do { th_topnames_var <- fmap tcg_th_topnames getGblEnv ; th_topnames <- readTcRef th_topnames_var - ; unless (name `elemNameSet` th_topnames) - (addErr exact_nm_err) + ; if name `elemNameSet` th_topnames + then return (Right name) + else return (Left exact_nm_err) } #else /* !GHCI */ - addErr exact_nm_err + return (Left exact_nm_err) #endif /* !GHCI */ - ; return name } - [gre] -> return (gre_name gre) - (gre:_) -> do {addErr dup_nm_err - ; return (gre_name gre) - } + [gre] -> return (Right (gre_name gre)) + _ -> return (Left dup_nm_err) -- We can get more than one GRE here, if there are multiple -- bindings for the same name. Sometimes they are caught later -- by findLocalDupsRdrEnv, like in this example (Trac #8932): @@ -1034,10 +1046,11 @@ lookupBindGroupOcc :: HsSigCtxt -- See Note [Looking up signature names] lookupBindGroupOcc ctxt what rdr_name | Just n <- isExact_maybe rdr_name - = do { n' <- lookupExactOcc n - ; return (Right n') } -- Maybe we should check the side conditions - -- but it's a pain, and Exact things only show - -- up when you know what you are doing + = lookupExactOcc_either n -- allow for the possibility of missing Exacts; + -- see Note [dataTcOccs and Exact Names] + -- Maybe we should check the side conditions + -- but it's a pain, and Exact things only show + -- up when you know what you are doing | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name = do { n' <- lookupOrig rdr_mod rdr_occ @@ -1114,10 +1127,8 @@ lookupLocalTcNames ctxt what rdr_name dataTcOccs :: RdrName -> [RdrName] -- Return both the given name and the same name promoted to the TcClsName -- namespace. This is useful when we aren't sure which we are looking at. +-- See also Note [dataTcOccs and Exact Names] dataTcOccs rdr_name - | Just n <- isExact_maybe rdr_name - , not (isBuiltInSyntax n) -- See Note [dataTcOccs and Exact Names] - = [rdr_name] | isDataOcc occ || isVarOcc occ = [rdr_name, rdr_name_tc] | otherwise @@ -1130,8 +1141,12 @@ dataTcOccs rdr_name Note [dataTcOccs and Exact Names] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Exact RdrNames can occur in code generated by Template Haskell, and generally -those references are, well, exact, so it's wrong to return the TyClsName too. -But there is an awkward exception for built-in syntax. Example in GHCi +those references are, well, exact. However, the TH `Name` type isn't expressive +enough to always track the correct namespace information, so we sometimes get +the right Unique but wrong namespace. Thus, we still have to do the double-lookup +for Exact RdrNames. + +There is also an awkward situation for built-in syntax. Example in GHCi :info [] This parses as the Exact RdrName for nilDataCon, but we also want the list type constructor. diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs index 8aed1657be..c2af40703d 100644 --- a/compiler/typecheck/TcBinds.lhs +++ b/compiler/typecheck/TcBinds.lhs @@ -16,7 +16,7 @@ module TcBinds ( tcLocalBinds, tcTopBinds, tcRecSelBinds, import {-# SOURCE #-} TcMatches ( tcGRHSsPat, tcMatchesFun ) import {-# SOURCE #-} TcExpr ( tcMonoExpr ) -import {-# SOURCE #-} TcPatSyn ( tcPatSynDecl, tcPatSynWrapper ) +import {-# SOURCE #-} TcPatSyn ( tcPatSynDecl, tcPatSynWorker ) import DynFlags import HsSyn @@ -320,8 +320,8 @@ tcValBinds top_lvl binds sigs thing_inside { (binds', (extra_binds', thing)) <- tcBindGroups top_lvl sig_fn prag_fn binds $ do { thing <- thing_inside -- See Note [Pattern synonym wrappers don't yield dependencies] - ; patsyn_wrappers <- mapM tcPatSynWrapper patsyns - ; let extra_binds = [ (NonRecursive, wrapper) | wrapper <- patsyn_wrappers ] + ; patsyn_workers <- mapM tcPatSynWorker patsyns + ; let extra_binds = [ (NonRecursive, worker) | worker <- patsyn_workers ] ; return (extra_binds, thing) } ; return (binds' ++ extra_binds', thing) }} where @@ -424,7 +424,7 @@ tc_single _top_lvl _sig_fn _prag_fn (L _ (PatSynBind psb)) thing_inside ; let tything = AConLike (PatSynCon pat_syn) implicit_ids = (patSynMatcher pat_syn) : - (maybeToList (patSynWrapper pat_syn)) + (maybeToList (patSynWorker pat_syn)) ; thing <- tcExtendGlobalEnv [tything] $ tcExtendGlobalEnvImplicit (map AnId implicit_ids) $ diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs index bcd6bfdf82..0ef74a1f5a 100644 --- a/compiler/typecheck/TcEnv.lhs +++ b/compiler/typecheck/TcEnv.lhs @@ -224,7 +224,8 @@ tcLookupInstance cls tys where extractTyVar (TyVarTy tv) = tv extractTyVar _ = panic "TcEnv.tcLookupInstance: extractTyVar" - + + -- NB: duplicated to prevent circular dependence on Inst tcGetInstEnvs = do { eps <- getEps; env <- getGblEnv; ; return (eps_inst_env eps, tcg_inst_env env) } diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs index deda6137d0..a242ed77d2 100644 --- a/compiler/typecheck/TcExpr.lhs +++ b/compiler/typecheck/TcExpr.lhs @@ -124,16 +124,9 @@ tcInferRho expr = addErrCtxt (exprCtxt expr) (tcInferRhoNC expr) tcInferRhoNC (L loc expr) = setSrcSpan loc $ - do { (expr', rho) <- tcInfExpr expr + do { (expr', rho) <- tcInfer (tcExpr expr) ; return (L loc expr', rho) } -tcInfExpr :: HsExpr Name -> TcM (HsExpr TcId, TcRhoType) -tcInfExpr (HsVar f) = tcInferId f -tcInfExpr (HsPar e) = do { (e', ty) <- tcInferRhoNC e - ; return (HsPar e', ty) } -tcInfExpr (HsApp e1 e2) = tcInferApp e1 [e2] -tcInfExpr e = tcInfer (tcExpr e) - tcHole :: OccName -> TcRhoType -> TcM (HsExpr TcId) tcHole occ res_ty = do { ty <- newFlexiTyVarTy liftedTypeKind @@ -326,13 +319,15 @@ tcExpr (OpApp arg1 op fix arg2) res_ty -- Eg we do not want to allow (D# $ 4.0#) Trac #5570 -- (which gives a seg fault) -- We do this by unifying with a MetaTv; but of course - -- it must allow foralls in the type it unifies with (hence PolyTv)! + -- it must allow foralls in the type it unifies with (hence ReturnTv)! -- -- The result type can have any kind (Trac #8739), -- so we can just use res_ty -- ($) :: forall (a:*) (b:Open). (a->b) -> a -> b - ; a_ty <- newPolyFlexiTyVarTy + ; a_tv <- newReturnTyVar liftedTypeKind + ; let a_ty = mkTyVarTy a_tv + ; arg2' <- tcArg op (arg2, arg2_ty, 2) ; co_a <- unifyType arg2_ty a_ty -- arg2 ~ a @@ -937,23 +932,6 @@ mk_app_msg fun = sep [ ptext (sLit "The function") <+> quotes (ppr fun) , ptext (sLit "is applied to")] ---------------- -tcInferApp :: LHsExpr Name -> [LHsExpr Name] -- Function and args - -> TcM (HsExpr TcId, TcRhoType) -- Translated fun and args - -tcInferApp (L _ (HsPar e)) args = tcInferApp e args -tcInferApp (L _ (HsApp e1 e2)) args = tcInferApp e1 (e2:args) -tcInferApp fun args - = -- Very like the tcApp version, except that there is - -- no expected result type passed in - do { (fun1, fun_tau) <- tcInferFun fun - ; (co_fun, expected_arg_tys, actual_res_ty) - <- matchExpectedFunTys (mk_app_msg fun) (length args) fun_tau - ; args1 <- tcArgs fun args expected_arg_tys - ; let fun2 = mkLHsWrapCo co_fun fun1 - app = foldl mkHsApp fun2 args1 - ; return (unLoc app, actual_res_ty) } - ----------------- tcInferFun :: LHsExpr Name -> TcM (LHsExpr TcId, TcRhoType) -- Infer and instantiate the type of a function tcInferFun (L loc (HsVar name)) diff --git a/compiler/typecheck/TcFlatten.lhs b/compiler/typecheck/TcFlatten.lhs index 3ee4d593f6..2e9c6eb0a9 100644 --- a/compiler/typecheck/TcFlatten.lhs +++ b/compiler/typecheck/TcFlatten.lhs @@ -601,6 +601,9 @@ goals. But to be honest I'm not absolutely certain, so I am leaving FM_Avoid in the code base. What I'm removing is the unique place where it is *used*, namely in TcCanonical.canEqTyVar. +See also Note [Conservative unification check] in TcUnify, which gives +other examples where lazy flattening caused problems. + Bottom line: FM_Avoid is unused for now (Nov 14). Note: T5321Fun got faster when I disabled FM_Avoid T5837 did too, but it's pathalogical anyway diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index ddb2e6531a..b6c0da1e8b 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -1009,23 +1009,28 @@ superclass is bottom when it should not be. Consider the following (extreme) situation: class C a => D a where ... - instance D [a] => D [a] where ... + instance D [a] => D [a] where ... (dfunD) + instance C [a] => C [a] where ... (dfunC) Although this looks wrong (assume D [a] to prove D [a]), it is only a more extreme case of what happens with recursive dictionaries, and it can, just about, make sense because the methods do some work before recursing. -To implement the dfun we must generate code for the superclass C [a], +To implement the dfunD we must generate code for the superclass C [a], which we had better not get by superclass selection from the supplied argument: - dfun :: forall a. D [a] -> D [a] - dfun = \d::D [a] -> MkD (scsel d) .. + dfunD :: forall a. D [a] -> D [a] + dfunD = \d::D [a] -> MkD (scsel d) .. Otherwise if we later encounter a situation where we have a [Wanted] dw::D [a] we might solve it thus: - dw := dfun dw + dw := dfunD dw Which is all fine except that now ** the superclass C is bottom **! +The instance we want is: + dfunD :: forall a. D [a] -> D [a] + dfunD = \d::D [a] -> MkD (dfunC (scsel d)) ... + THE SOLUTION Our solution to this problem "silent superclass arguments". We pass diff --git a/compiler/typecheck/TcInteract.lhs b/compiler/typecheck/TcInteract.lhs index 811b16a616..2e5618ea78 100644 --- a/compiler/typecheck/TcInteract.lhs +++ b/compiler/typecheck/TcInteract.lhs @@ -1197,56 +1197,69 @@ Consider generating the superclasses of the instance declaration instance Foo a => Foo [a] So our problem is this - d0 :_g Foo t - d1 :_w Data Maybe [t] + [G] d0 : Foo t + [W] d1 : Data Maybe [t] -- Desired superclass We may add the given in the inert set, along with its superclasses [assuming we don't fail because there is a matching instance, see topReactionsStage, given case ] Inert: - d0 :_g Foo t + [G] d0 : Foo t + [G] d01 : Data Maybe t -- Superclass of d0 WorkList - d01 :_g Data Maybe t -- d2 := EvDictSuperClass d0 0 - d1 :_w Data Maybe [t] -Then d2 can readily enter the inert, and we also do solving of the wanted + [W] d1 : Data Maybe [t] + +Solve d1 using instance dfunData2; d1 := dfunData2 d2 d3 Inert: - d0 :_g Foo t - d1 :_s Data Maybe [t] d1 := dfunData2 d2 d3 + [G] d0 : Foo t + [G] d01 : Data Maybe t -- Superclass of d0 + Solved: + d1 : Data Maybe [t] WorkList - d2 :_w Sat (Maybe [t]) - d3 :_w Data Maybe t - d01 :_g Data Maybe t -Now, we may simplify d2 more: + [W] d2 : Sat (Maybe [t]) + [W] d3 : Data Maybe t + +Now, we may simplify d2 using dfunSat; d2 := dfunSat d4 Inert: - d0 :_g Foo t - d1 :_s Data Maybe [t] d1 := dfunData2 d2 d3 - d1 :_g Data Maybe [t] - d2 :_g Sat (Maybe [t]) d2 := dfunSat d4 + [G] d0 : Foo t + [G] d01 : Data Maybe t -- Superclass of d0 + Solved: + d1 : Data Maybe [t] + d2 : Sat (Maybe [t]) WorkList: - d3 :_w Data Maybe t - d4 :_w Foo [t] - d01 :_g Data Maybe t + [W] d3 : Data Maybe t + [W] d4 : Foo [t] -Now, we can just solve d3. +Now, we can just solve d3 from d01; d3 := d01 Inert - d0 :_g Foo t - d1 :_s Data Maybe [t] d1 := dfunData2 d2 d3 - d2 :_g Sat (Maybe [t]) d2 := dfunSat d4 + [G] d0 : Foo t + [G] d01 : Data Maybe t -- Superclass of d0 + Solved: + d1 : Data Maybe [t] + d2 : Sat (Maybe [t]) WorkList - d4 :_w Foo [t] - d01 :_g Data Maybe t -And now we can simplify d4 again, but since it has superclasses we *add* them to the worklist: + [W] d4 : Foo [t] + +Now, solve d4 using dfunFoo2; d4 := dfunFoo2 d5 Inert - d0 :_g Foo t - d1 :_s Data Maybe [t] d1 := dfunData2 d2 d3 - d2 :_g Sat (Maybe [t]) d2 := dfunSat d4 - d4 :_g Foo [t] d4 := dfunFoo2 d5 + [G] d0 : Foo t + [G] d01 : Data Maybe t -- Superclass of d0 + Solved: + d1 : Data Maybe [t] + d2 : Sat (Maybe [t]) + d4 : Foo [t] WorkList: - d5 :_w Foo t - d6 :_g Data Maybe [t] d6 := EvDictSuperClass d4 0 - d01 :_g Data Maybe t -Now, d5 can be solved! (and its superclass enter scope) - Inert + [W] d5 : Foo t + +Now, d5 can be solved! d5 := d0 + +Result + d1 := dfunData2 d2 d3 + d2 := dfunSat d4 + d3 := d01 + d4 := dfunFoo2 d5 + d5 := d0 + d0 :_g Foo t d1 :_s Data Maybe [t] d1 := dfunData2 d2 d3 d2 :_g Sat (Maybe [t]) d2 := dfunSat d4 diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs index d6f37c8f96..c78c125bf1 100644 --- a/compiler/typecheck/TcMType.lhs +++ b/compiler/typecheck/TcMType.lhs @@ -19,12 +19,12 @@ module TcMType ( newFlexiTyVar, newFlexiTyVarTy, -- Kind -> TcM TcType newFlexiTyVarTys, -- Int -> Kind -> TcM [TcType] - newPolyFlexiTyVarTy, + newReturnTyVar, newMetaKindVar, newMetaKindVars, mkTcTyVarName, cloneMetaTyVar, newMetaTyVar, readMetaTyVar, writeMetaTyVar, writeMetaTyVarRef, - newMetaDetails, isFilledMetaTyVar, isFlexiMetaTyVar, + newMetaDetails, isFilledMetaTyVar, isUnfilledMetaTyVar, -------------------------------- -- Creating new evidence variables @@ -311,7 +311,7 @@ newMetaTyVar meta_info kind = do { uniq <- newUnique ; let name = mkTcTyVarName uniq s s = case meta_info of - PolyTv -> fsLit "s" + ReturnTv -> fsLit "r" TauTv -> fsLit "t" FlatMetaTv -> fsLit "fmv" SigTv -> fsLit "a" @@ -363,9 +363,9 @@ isFilledMetaTyVar tv ; return (isIndirect details) } | otherwise = return False -isFlexiMetaTyVar :: TyVar -> TcM Bool +isUnfilledMetaTyVar :: TyVar -> TcM Bool -- True of a un-filled-in (Flexi) meta type variable -isFlexiMetaTyVar tv +isUnfilledMetaTyVar tv | not (isTcTyVar tv) = return False | MetaTv { mtv_ref = ref } <- tcTyVarDetails tv = do { details <- readMutVar ref @@ -448,9 +448,8 @@ newFlexiTyVarTy kind = do newFlexiTyVarTys :: Int -> Kind -> TcM [TcType] newFlexiTyVarTys n kind = mapM newFlexiTyVarTy (nOfThem n kind) -newPolyFlexiTyVarTy :: TcM TcType -newPolyFlexiTyVarTy = do { tv <- newMetaTyVar PolyTv liftedTypeKind - ; return (TyVarTy tv) } +newReturnTyVar :: Kind -> TcM TcTyVar +newReturnTyVar kind = newMetaTyVar ReturnTv kind tcInstTyVars :: [TKVar] -> TcM (TvSubst, [TcTyVar]) -- Instantiate with META type variables diff --git a/compiler/typecheck/TcPatSyn.lhs b/compiler/typecheck/TcPatSyn.lhs index ea2dbce9d7..d6f6817cce 100644 --- a/compiler/typecheck/TcPatSyn.lhs +++ b/compiler/typecheck/TcPatSyn.lhs @@ -7,13 +7,14 @@ \begin{code} {-# LANGUAGE CPP #-} -module TcPatSyn (tcPatSynDecl, tcPatSynWrapper) where +module TcPatSyn (tcPatSynDecl, mkPatSynWrapperId, tcPatSynWorker) where import HsSyn import TcPat import TcRnMonad import TcEnv import TcMType +import TcIface import TysPrim import Name import SrcLoc @@ -36,7 +37,7 @@ import Data.Monoid import Bag import TcEvidence import BuildTyCl -import TypeRep +import Data.Maybe #include "HsVersions.h" \end{code} @@ -48,7 +49,6 @@ tcPatSynDecl PSB{ psb_id = lname@(L _ name), psb_args = details, psb_def = lpat, psb_dir = dir } = do { traceTc "tcPatSynDecl {" $ ppr name $$ ppr lpat ; tcCheckPatSynPat lpat - ; ; let (arg_names, is_infix) = case details of PrefixPatSyn names -> (map unLoc names, False) @@ -78,6 +78,7 @@ tcPatSynDecl PSB{ psb_id = lname@(L _ name), psb_args = details, ; req_theta <- zonkTcThetaType req_theta ; pat_ty <- zonkTcType pat_ty ; args <- mapM zonkId args + ; let arg_tys = map varType args ; traceTc "tcPatSynDecl: ex" (ppr ex_tvs $$ ppr prov_theta $$ @@ -87,7 +88,8 @@ tcPatSynDecl PSB{ psb_id = lname@(L _ name), psb_args = details, ppr req_dicts $$ ppr ev_binds) - ; let theta = prov_theta ++ req_theta + ; let qtvs = univ_tvs ++ ex_tvs + ; let theta = req_theta ++ prov_theta ; traceTc "tcPatSynDecl: type" (ppr name $$ ppr univ_tvs $$ @@ -101,17 +103,19 @@ tcPatSynDecl PSB{ psb_id = lname@(L _ name), psb_args = details, prov_theta req_theta pat_ty - ; wrapper_id <- if isBidirectional dir - then fmap Just $ mkPatSynWrapperId lname args univ_tvs ex_tvs theta pat_ty - else return Nothing + ; wrapper_ids <- if isBidirectional dir + then fmap Just $ mkPatSynWrapperIds lname + qtvs theta + arg_tys pat_ty + else return Nothing ; traceTc "tcPatSynDecl }" $ ppr name ; let patSyn = mkPatSyn name is_infix (univ_tvs, req_theta) (ex_tvs, prov_theta) - (map varType args) + arg_tys pat_ty - matcher_id wrapper_id + matcher_id wrapper_ids ; return (patSyn, matcher_bind) } \end{code} @@ -134,7 +138,7 @@ tcPatSynMatcher (L loc name) lpat args univ_tvs ex_tvs ev_binds prov_dicts req_d ; let tv_name = mkInternalName uniq (mkTyVarOcc "r") loc ; return $ mkTcTyVar tv_name openTypeKind (SkolemTv False) } ; matcher_name <- newImplicitBinder name mkMatcherOcc - ; let res_ty = TyVarTy res_tv + ; let res_ty = mkTyVarTy res_tv cont_args = if null args then [voidPrimId] else args cont_ty = mkSigmaTy ex_tvs prov_theta $ mkFunTys (map varType cont_args) res_ty @@ -149,7 +153,8 @@ tcPatSynMatcher (L loc name) lpat args univ_tvs ex_tvs ev_binds prov_dicts req_d ; scrutinee <- mkId "scrut" pat_ty ; cont <- mkId "cont" cont_ty - ; let cont' = nlHsApps cont $ map nlHsVar (ex_tvs ++ prov_dicts ++ cont_args) + ; let cont' = nlHsTyApps cont (map mkTyVarTy ex_tvs) $ + map nlHsVar (prov_dicts ++ cont_args) ; fail <- mkId "fail" fail_ty ; let fail' = nlHsApps fail [nlHsVar voidPrimId] @@ -201,73 +206,69 @@ isBidirectional Unidirectional = False isBidirectional ImplicitBidirectional = True isBidirectional ExplicitBidirectional{} = True -tcPatSynWrapper :: PatSynBind Name Name +tcPatSynWorker :: PatSynBind Name Name -> TcM (LHsBinds Id) -- See Note [Matchers and wrappers for pattern synonyms] in PatSyn -tcPatSynWrapper PSB{ psb_id = L loc name, psb_def = lpat, psb_dir = dir, psb_args = details } +tcPatSynWorker PSB{ psb_id = lname, psb_def = lpat, psb_dir = dir, psb_args = details } = case dir of Unidirectional -> return emptyBag ImplicitBidirectional -> - do { wrapper_id <- tcLookupPatSynWrapper name - ; lexpr <- case tcPatToExpr (mkNameSet args) lpat of + do { lexpr <- case tcPatToExpr (mkNameSet args) lpat of Nothing -> cannotInvertPatSynErr lpat Just lexpr -> return lexpr ; let wrapper_args = map (noLoc . VarPat) args - wrapper_lname = L (getLoc lpat) (idName wrapper_id) wrapper_match = mkMatch wrapper_args lexpr EmptyLocalBinds - wrapper_bind = mkTopFunBind Generated wrapper_lname [wrapper_match] - ; mkPatSynWrapper wrapper_id wrapper_bind } - ExplicitBidirectional mg -> - do { wrapper_id <- tcLookupPatSynWrapper name - ; mkPatSynWrapper wrapper_id $ - FunBind{ fun_id = L loc (idName wrapper_id) - , fun_infix = False - , fun_matches = mg - , fun_co_fn = idHsWrapper - , bind_fvs = placeHolderNamesTc - , fun_tick = Nothing }} + ; mkPatSynWorker lname $ mkMatchGroupName Generated [wrapper_match] } + ExplicitBidirectional mg -> mkPatSynWorker lname mg where args = map unLoc $ case details of PrefixPatSyn args -> args InfixPatSyn arg1 arg2 -> [arg1, arg2] - tcLookupPatSynWrapper name - = do { patsyn <- tcLookupPatSyn name - ; case patSynWrapper patsyn of - Nothing -> panic "tcLookupPatSynWrapper" - Just wrapper_id -> return wrapper_id } - -mkPatSynWrapperId :: Located Name - -> [Var] -> [TyVar] -> [TyVar] -> ThetaType -> Type - -> TcM Id -mkPatSynWrapperId (L _ name) args univ_tvs ex_tvs theta pat_ty - = do { let qtvs = univ_tvs ++ ex_tvs - ; (subst, wrapper_tvs) <- tcInstSkolTyVars qtvs - ; let wrapper_theta = substTheta subst theta - pat_ty' = substTy subst pat_ty - args' = map (\arg -> setVarType arg $ substTy subst (varType arg)) args - wrapper_tau = mkFunTys (map varType args') pat_ty' - wrapper_sigma = mkSigmaTy wrapper_tvs wrapper_theta wrapper_tau - - ; wrapper_name <- newImplicitBinder name mkDataConWrapperOcc - ; return $ mkVanillaGlobal wrapper_name wrapper_sigma } - -mkPatSynWrapper :: Id - -> HsBind Name +mkPatSynWrapperIds :: Located Name + -> [TyVar] -> ThetaType -> [Type] -> Type + -> TcM (Id, Id) +mkPatSynWrapperIds lname qtvs theta arg_tys pat_ty + = do { worker_id <- mkPatSynWorkerId lname mkDataConWorkerOcc qtvs theta worker_arg_tys pat_ty + ; wrapper_id <- mkPatSynWrapperId lname qtvs theta arg_tys pat_ty worker_id + ; return (wrapper_id, worker_id) } + where + worker_arg_tys | need_dummy_arg = [voidPrimTy] + | otherwise = arg_tys + need_dummy_arg = null arg_tys && isUnLiftedType pat_ty + +mkPatSynWorker :: Located Name + -> MatchGroup Name (LHsExpr Name) -> TcM (LHsBinds Id) -mkPatSynWrapper wrapper_id bind - = do { (wrapper_binds, _, _) <- tcPolyCheck NonRecursive (const []) sig (noLoc bind) - ; traceTc "tcPatSynDecl wrapper" $ ppr wrapper_binds - ; traceTc "tcPatSynDecl wrapper type" $ ppr (varType wrapper_id) - ; return wrapper_binds } +mkPatSynWorker (L loc name) mg + = do { patsyn <- tcLookupPatSyn name + ; let worker_id = fromMaybe (panic "mkPatSynWrapper") $ + patSynWorker patsyn + need_dummy_arg = null (patSynArgs patsyn) && isUnLiftedType (patSynType patsyn) + + ; let match_dummy = mkMatch [nlWildPatName] (noLoc $ HsLam mg) emptyLocalBinds + mg' | need_dummy_arg = mkMatchGroupName Generated [match_dummy] + | otherwise = mg + + ; let (worker_tvs, worker_theta, worker_tau) = tcSplitSigmaTy (idType worker_id) + bind = FunBind { fun_id = L loc (idName worker_id) + , fun_infix = False + , fun_matches = mg' + , fun_co_fn = idHsWrapper + , bind_fvs = placeHolderNamesTc + , fun_tick = Nothing } + + sig = TcSigInfo{ sig_id = worker_id + , sig_tvs = map (\tv -> (Nothing, tv)) worker_tvs + , sig_theta = worker_theta + , sig_tau = worker_tau + , sig_loc = noSrcSpan + } + + ; (worker_binds, _, _) <- tcPolyCheck NonRecursive (const []) sig (noLoc bind) + ; traceTc "tcPatSynDecl worker" $ ppr worker_binds + ; return worker_binds } where - sig = TcSigInfo{ sig_id = wrapper_id - , sig_tvs = map (\tv -> (Nothing, tv)) wrapper_tvs - , sig_theta = wrapper_theta - , sig_tau = wrapper_tau - , sig_loc = noSrcSpan - } - (wrapper_tvs, wrapper_theta, wrapper_tau) = tcSplitSigmaTy (idType wrapper_id) \end{code} diff --git a/compiler/typecheck/TcPatSyn.lhs-boot b/compiler/typecheck/TcPatSyn.lhs-boot index 700137c16c..0e28caa6ca 100644 --- a/compiler/typecheck/TcPatSyn.lhs-boot +++ b/compiler/typecheck/TcPatSyn.lhs-boot @@ -10,6 +10,6 @@ import PatSyn ( PatSyn ) tcPatSynDecl :: PatSynBind Name Name -> TcM (PatSyn, LHsBinds Id) -tcPatSynWrapper :: PatSynBind Name Name - -> TcM (LHsBinds Id) +tcPatSynWorker :: PatSynBind Name Name + -> TcM (LHsBinds Id) \end{code} diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 02d0026bdd..a646ea445a 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -238,10 +238,7 @@ checkHsigIface' gr ; r <- tcLookupImported_maybe name ; case r of Failed err -> addErr err - Succeeded real_thing -> - when (not (checkBootDecl sig_thing real_thing)) - $ addErrAt (nameSrcSpan (getName sig_thing)) - (bootMisMatch False real_thing sig_thing) + Succeeded real_thing -> checkBootDeclM False sig_thing real_thing }} where name = availName sig_avail @@ -767,9 +764,7 @@ checkHiBootIface' -- then compare the definitions | Just real_thing <- lookupTypeEnv local_type_env name, Just boot_thing <- mb_boot_thing - = when (not (checkBootDecl boot_thing real_thing)) - $ addErrAt (nameSrcSpan (getName boot_thing)) - (bootMisMatch True real_thing boot_thing) + = checkBootDeclM True boot_thing real_thing | otherwise = addErrTc (missingBootThing True name "defined in") @@ -810,11 +805,25 @@ checkHiBootIface' -- -- See rnfail055 for a good test of this stuff. -checkBootDecl :: TyThing -> TyThing -> Bool +-- | Compares two things for equivalence between boot-file and normal code, +-- reporting an error if they don't match up. +checkBootDeclM :: Bool -- ^ True <=> an hs-boot file (could also be a sig) + -> TyThing -> TyThing -> TcM () +checkBootDeclM is_boot boot_thing real_thing + = whenIsJust (checkBootDecl boot_thing real_thing) $ \ err -> + addErrAt (nameSrcSpan (getName boot_thing)) + (bootMisMatch is_boot err real_thing boot_thing) + +-- | Compares the two things for equivalence between boot-file and normal +-- code. Returns @Nothing@ on success or @Just "some helpful info for user"@ +-- failure. If the difference will be apparent to the user, @Just empty@ is +-- perfectly suitable. +checkBootDecl :: TyThing -> TyThing -> Maybe SDoc checkBootDecl (AnId id1) (AnId id2) = ASSERT(id1 == id2) - (idType id1 `eqType` idType id2) + check (idType id1 `eqType` idType id2) + (text "The two types are different") checkBootDecl (ATyCon tc1) (ATyCon tc2) = checkBootTyCon tc1 tc2 @@ -822,13 +831,52 @@ checkBootDecl (ATyCon tc1) (ATyCon tc2) checkBootDecl (AConLike (RealDataCon dc1)) (AConLike (RealDataCon _)) = pprPanic "checkBootDecl" (ppr dc1) -checkBootDecl _ _ = False -- probably shouldn't happen +checkBootDecl _ _ = Just empty -- probably shouldn't happen + +-- | Combines two potential error messages +andThenCheck :: Maybe SDoc -> Maybe SDoc -> Maybe SDoc +Nothing `andThenCheck` msg = msg +msg `andThenCheck` Nothing = msg +Just d1 `andThenCheck` Just d2 = Just (d1 $$ d2) +infixr 0 `andThenCheck` + +-- | If the test in the first parameter is True, succeed with @Nothing@; +-- otherwise, return the provided check +checkUnless :: Bool -> Maybe SDoc -> Maybe SDoc +checkUnless True _ = Nothing +checkUnless False k = k + +-- | Run the check provided for every pair of elements in the lists. +-- The provided SDoc should name the element type, in the plural. +checkListBy :: (a -> a -> Maybe SDoc) -> [a] -> [a] -> SDoc + -> Maybe SDoc +checkListBy check_fun as bs whats = go [] as bs + where + herald = text "The" <+> whats <+> text "do not match" + + go [] [] [] = Nothing + go docs [] [] = Just (hang (herald <> colon) 2 (vcat $ reverse docs)) + go docs (x:xs) (y:ys) = case check_fun x y of + Just doc -> go (doc:docs) xs ys + Nothing -> go docs xs ys + go _ _ _ = Just (hang (herald <> colon) + 2 (text "There are different numbers of" <+> whats)) + +-- | If the test in the first parameter is True, succeed with @Nothing@; +-- otherwise, fail with the given SDoc. +check :: Bool -> SDoc -> Maybe SDoc +check True _ = Nothing +check False doc = Just doc + +-- | A more perspicuous name for @Nothing@, for @checkBootDecl@ and friends. +checkSuccess :: Maybe SDoc +checkSuccess = Nothing ---------------- -checkBootTyCon :: TyCon -> TyCon -> Bool +checkBootTyCon :: TyCon -> TyCon -> Maybe SDoc checkBootTyCon tc1 tc2 | not (eqKind (tyConKind tc1) (tyConKind tc2)) - = False -- First off, check the kind + = Just $ text "The types have different kinds" -- First off, check the kind | Just c1 <- tyConClass_maybe tc1 , Just c2 <- tyConClass_maybe tc2 @@ -839,18 +887,29 @@ checkBootTyCon tc1 tc2 , Just env <- eqTyVarBndrs emptyRnEnv2 clas_tvs1 clas_tvs2 = let eqSig (id1, def_meth1) (id2, def_meth2) - = idName id1 == idName id2 && - eqTypeX env op_ty1 op_ty2 && - def_meth1 == def_meth2 + = check (name1 == name2) + (text "The names" <+> pname1 <+> text "and" <+> pname2 <+> + text "are different") `andThenCheck` + check (eqTypeX env op_ty1 op_ty2) + (text "The types of" <+> pname1 <+> + text "are different") `andThenCheck` + check (def_meth1 == def_meth2) + (text "The default methods associated with" <+> pname1 <+> + text "are different") where + name1 = idName id1 + name2 = idName id2 + pname1 = quotes (ppr name1) + pname2 = quotes (ppr name2) (_, rho_ty1) = splitForAllTys (idType id1) op_ty1 = funResultTy rho_ty1 (_, rho_ty2) = splitForAllTys (idType id2) op_ty2 = funResultTy rho_ty2 eqAT (ATI tc1 def_ats1) (ATI tc2 def_ats2) - = checkBootTyCon tc1 tc2 && - eqATDef def_ats1 def_ats2 + = checkBootTyCon tc1 tc2 `andThenCheck` + check (eqATDef def_ats1 def_ats2) + (text "The associated type defaults differ") -- Ignore the location of the defaults eqATDef Nothing Nothing = True @@ -861,14 +920,16 @@ checkBootTyCon tc1 tc2 eqListBy (eqTypeX env) (mkTyVarTys as1) (mkTyVarTys as2) && eqListBy (eqTypeX env) (mkTyVarTys bs1) (mkTyVarTys bs2) in - roles1 == roles2 && - -- Checks kind of class - eqListBy eqFD clas_fds1 clas_fds2 && - (null sc_theta1 && null op_stuff1 && null ats1 - || -- Above tests for an "abstract" class - eqListBy (eqPredX env) sc_theta1 sc_theta2 && - eqListBy eqSig op_stuff1 op_stuff2 && - eqListBy eqAT ats1 ats2) + check (roles1 == roles2) roles_msg `andThenCheck` + -- Checks kind of class + check (eqListBy eqFD clas_fds1 clas_fds2) + (text "The functional dependencies do not match") `andThenCheck` + checkUnless (null sc_theta1 && null op_stuff1 && null ats1) $ + -- Above tests for an "abstract" class + check (eqListBy (eqPredX env) sc_theta1 sc_theta2) + (text "The class constraints do not match") `andThenCheck` + checkListBy eqSig op_stuff1 op_stuff2 (text "methods") `andThenCheck` + checkListBy eqAT ats1 ats2 (text "associated types") | Just syn_rhs1 <- synTyConRhs_maybe tc1 , Just syn_rhs2 <- synTyConRhs_maybe tc2 @@ -884,37 +945,61 @@ checkBootTyCon tc1 tc2 eqSynRhs (BuiltInSynFamTyCon _) (BuiltInSynFamTyCon _) = tc1 == tc2 eqSynRhs _ _ = False in - roles1 == roles2 && - eqSynRhs syn_rhs1 syn_rhs2 + check (roles1 == roles2) roles_msg `andThenCheck` + check (eqSynRhs syn_rhs1 syn_rhs2) empty -- nothing interesting to say | isAlgTyCon tc1 && isAlgTyCon tc2 , Just env <- eqTyVarBndrs emptyRnEnv2 (tyConTyVars tc1) (tyConTyVars tc2) = ASSERT(tc1 == tc2) - roles1 == roles2 && - eqListBy (eqPredX env) (tyConStupidTheta tc1) (tyConStupidTheta tc2) && - eqAlgRhs (algTyConRhs tc1) (algTyConRhs tc2) + check (roles1 == roles2) roles_msg `andThenCheck` + check (eqListBy (eqPredX env) + (tyConStupidTheta tc1) (tyConStupidTheta tc2)) + (text "The datatype contexts do not match") `andThenCheck` + eqAlgRhs tc1 (algTyConRhs tc1) (algTyConRhs tc2) - | otherwise = False + | otherwise = Just empty -- two very different types -- should be obvious where roles1 = tyConRoles tc1 roles2 = tyConRoles tc2 - - eqAlgRhs (AbstractTyCon dis1) rhs2 - | dis1 = isDistinctAlgRhs rhs2 --Check compatibility - | otherwise = True - eqAlgRhs DataFamilyTyCon{} DataFamilyTyCon{} = True - eqAlgRhs tc1@DataTyCon{} tc2@DataTyCon{} = - eqListBy eqCon (data_cons tc1) (data_cons tc2) - eqAlgRhs tc1@NewTyCon{} tc2@NewTyCon{} = + roles_msg = text "The roles do not match." <+> + (text "Roles default to" <+> + quotes (text "representational") <+> text "in boot files") + + eqAlgRhs tc (AbstractTyCon dis1) rhs2 + | dis1 = check (isDistinctAlgRhs rhs2) --Check compatibility + (text "The natures of the declarations for" <+> + quotes (ppr tc) <+> text "are different") + | otherwise = checkSuccess + eqAlgRhs _ DataFamilyTyCon{} DataFamilyTyCon{} = checkSuccess + eqAlgRhs _ tc1@DataTyCon{} tc2@DataTyCon{} = + checkListBy eqCon (data_cons tc1) (data_cons tc2) (text "constructors") + eqAlgRhs _ tc1@NewTyCon{} tc2@NewTyCon{} = eqCon (data_con tc1) (data_con tc2) - eqAlgRhs _ _ = False + eqAlgRhs _ _ _ = Just (text "Cannot match a" <+> quotes (text "data") <+> + text "definition with a" <+> quotes (text "newtype") <+> + text "definition") eqCon c1 c2 - = dataConName c1 == dataConName c2 - && dataConIsInfix c1 == dataConIsInfix c2 - && eqListBy eqHsBang (dataConStrictMarks c1) (dataConStrictMarks c2) - && dataConFieldLabels c1 == dataConFieldLabels c2 - && eqType (dataConUserType c1) (dataConUserType c2) + = check (name1 == name2) + (text "The names" <+> pname1 <+> text "and" <+> pname2 <+> + text "differ") `andThenCheck` + check (dataConIsInfix c1 == dataConIsInfix c2) + (text "The fixities of" <+> pname1 <+> + text "differ") `andThenCheck` + check (eqListBy eqHsBang + (dataConStrictMarks c1) (dataConStrictMarks c2)) + (text "The strictness annotations for" <+> pname1 <+> + text "differ") `andThenCheck` + check (dataConFieldLabels c1 == dataConFieldLabels c2) + (text "The record label lists for" <+> pname1 <+> + text "differ") `andThenCheck` + check (eqType (dataConUserType c1) (dataConUserType c2)) + (text "The types for" <+> pname1 <+> text "differ") + where + name1 = dataConName c1 + name2 = dataConName c2 + pname1 = quotes (ppr name1) + pname2 = quotes (ppr name2) eqClosedFamilyAx (CoAxiom { co_ax_branches = branches1 }) (CoAxiom { co_ax_branches = branches2 }) @@ -940,8 +1025,8 @@ missingBootThing is_boot name what <+> ptext (sLit "file, but not") <+> text what <+> ptext (sLit "the module") -bootMisMatch :: Bool -> TyThing -> TyThing -> SDoc -bootMisMatch is_boot real_thing boot_thing +bootMisMatch :: Bool -> SDoc -> TyThing -> TyThing -> SDoc +bootMisMatch is_boot extra_info real_thing boot_thing = vcat [ppr real_thing <+> ptext (sLit "has conflicting definitions in the module"), ptext (sLit "and its") <+> @@ -951,7 +1036,8 @@ bootMisMatch is_boot real_thing boot_thing (if is_boot then ptext (sLit "Boot file: ") else ptext (sLit "Hsig file: ")) - <+> PprTyThing.pprTyThing boot_thing] + <+> PprTyThing.pprTyThing boot_thing, + extra_info] instMisMatch :: Bool -> ClsInst -> SDoc instMisMatch is_boot inst diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index 19bd602e52..743dcbcd55 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -1251,6 +1251,9 @@ mkIfLclEnv mod loc = IfLclEnv { if_mod = mod, if_tv_env = emptyUFM, if_id_env = emptyUFM } +-- | Run an 'IfG' (top-level interface monad) computation inside an existing +-- 'TcRn' (typecheck-renaming monad) computation by initializing an 'IfGblEnv' +-- based on 'TcGblEnv'. initIfaceTcRn :: IfG a -> TcRn a initIfaceTcRn thing_inside = do { tcg_env <- getGblEnv diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs index cc76c03523..15be2a6212 100644 --- a/compiler/typecheck/TcRnTypes.lhs +++ b/compiler/typecheck/TcRnTypes.lhs @@ -148,7 +148,11 @@ import qualified Language.Haskell.TH as TH The monad itself has to be defined here, because it is mentioned by ErrCtxt \begin{code} +-- | Type alias for 'IORef'; the convention is we'll use this for mutable +-- bits of data in 'TcGblEnv' which are updated during typechecking and +-- returned at the end. type TcRef a = IORef a +-- ToDo: when should I refer to it as a 'TcId' instead of an 'Id'? type TcId = Id type TcIdSet = IdSet @@ -158,9 +162,19 @@ type IfM lcl = TcRnIf IfGblEnv lcl -- Iface stuff type IfG = IfM () -- Top level type IfL = IfM IfLclEnv -- Nested + +-- | Type-checking and renaming monad: the main monad that most type-checking +-- takes place in. The global environment is 'TcGblEnv', which tracks +-- all of the top-level type-checking information we've accumulated while +-- checking a module, while the local environment is 'TcLclEnv', which +-- tracks local information as we move inside expressions. type TcRn = TcRnIf TcGblEnv TcLclEnv -type RnM = TcRn -- Historical -type TcM = TcRn -- Historical + +-- | Historical "renaming monad" (now it's just 'TcRn'). +type RnM = TcRn + +-- | Historical "type-checking monad" (now it's just 'TcRn'). +type TcM = TcRn \end{code} Representation of type bindings to uninstantiated meta variables used during @@ -208,12 +222,11 @@ instance ContainsDynFlags (Env gbl lcl) where instance ContainsModule gbl => ContainsModule (Env gbl lcl) where extractModule env = extractModule (env_gbl env) --- TcGblEnv describes the top-level of the module at the +-- | 'TcGblEnv' describes the top-level of the module at the -- point at which the typechecker is finished work. -- It is this structure that is handed on to the desugarer -- For state that needs to be updated during the typechecking --- phase and returned at end, use a TcRef (= IORef). - +-- phase and returned at end, use a 'TcRef' (= 'IORef'). data TcGblEnv = TcGblEnv { tcg_mod :: Module, -- ^ Module being compiled @@ -502,8 +515,8 @@ data IfLclEnv %* * %************************************************************************ -The Global-Env/Local-Env story -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [The Global-Env/Local-Env story] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ During type checking, we keep in the tcg_type_env * All types and classes * All Ids derived from types and classes (constructors, selectors) diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs index ea467f0ad0..f2efb2ae58 100644 --- a/compiler/typecheck/TcSplice.lhs +++ b/compiler/typecheck/TcSplice.lhs @@ -1308,15 +1308,22 @@ reifyClass cls = do { cxt <- reifyCxt theta ; inst_envs <- tcGetInstEnvs ; insts <- reifyClassInstances cls (InstEnv.classInstances inst_envs cls) - ; ops <- mapM reify_op op_stuff + ; ops <- concatMapM reify_op op_stuff ; tvs' <- reifyTyVars tvs ; let dec = TH.ClassD cxt (reifyName cls) tvs' fds' ops ; return (TH.ClassI dec insts ) } where (tvs, fds, theta, _, _, op_stuff) = classExtraBigSig cls fds' = map reifyFunDep fds - reify_op (op, _) = do { ty <- reifyType (idType op) - ; return (TH.SigD (reifyName op) ty) } + reify_op (op, def_meth) + = do { ty <- reifyType (idType op) + ; let nm' = reifyName op + ; case def_meth of + GenDefMeth gdm_nm -> + do { gdm_id <- tcLookupId gdm_nm + ; gdm_ty <- reifyType (idType gdm_id) + ; return [TH.SigD nm' ty, TH.DefaultSigD nm' gdm_ty] } + _ -> return [TH.SigD nm' ty] } ------------------------------ -- | Annotate (with TH.SigT) a type if the first parameter is True diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs index a4a646c8e9..dba1be8964 100644 --- a/compiler/typecheck/TcType.lhs +++ b/compiler/typecheck/TcType.lhs @@ -269,6 +269,35 @@ Similarly consider When doing kind inference on {S,T} we don't want *skolems* for k1,k2, because they end up unifying; we want those SigTvs again. +Note [ReturnTv] +~~~~~~~~~~~~~~~ +We sometimes want to convert a checking algorithm into an inference +algorithm. An easy way to do this is to "check" that a term has a +metavariable as a type. But, we must be careful to allow that metavariable +to unify with *anything*. (Well, anything that doesn't fail an occurs-check.) +This is what ReturnTv means. + +For example, if we have + + (undefined :: (forall a. TF1 a ~ TF2 a => a)) x + +we'll call (tcInfer . tcExpr) on the function expression. tcInfer will +create a ReturnTv to represent the expression's type. We really need this +ReturnTv to become set to (forall a. TF1 a ~ TF2 a => a) despite the fact +that this type mentions type families and is a polytype. + +However, we must also be careful to make sure that the ReturnTvs really +always do get unified with something -- we don't want these floating +around in the solver. So, we check after running the checker to make +sure the ReturnTv is filled. If it's not, we set it to a TauTv. + +We can't ASSERT that no ReturnTvs hit the solver, because they +can if there's, say, a kind error that stops checkTauTvUpdate from +working. This happens in test case typecheck/should_fail/T5570, for +example. + +See also the commentary on #9404. + \begin{code} -- A TyVarDetails is inside a TyVar data TcTyVarDetails @@ -307,7 +336,9 @@ data MetaInfo -- A TauTv is always filled in with a tau-type, which -- never contains any ForAlls - | PolyTv -- Like TauTv, but can unify with a sigma-type + | ReturnTv -- Can unify with *anything*. Used to convert a + -- type "checking" algorithm into a type inference algorithm. + -- See Note [ReturnTv] | SigTv -- A variant of TauTv, except that it should not be -- unified with a type, only with a type variable @@ -481,7 +512,7 @@ pprTcTyVarDetails (MetaTv { mtv_info = info, mtv_untch = untch }) = pp_info <> colon <> ppr untch where pp_info = case info of - PolyTv -> ptext (sLit "poly") + ReturnTv -> ptext (sLit "return") TauTv -> ptext (sLit "tau") SigTv -> ptext (sLit "sig") FlatMetaTv -> ptext (sLit "fuv") @@ -1133,7 +1164,7 @@ occurCheckExpand :: DynFlags -> TcTyVar -> Type -> OccCheckResult Type -- Check whether -- a) the given variable occurs in the given type. -- b) there is a forall in the type (unless we have -XImpredicativeTypes --- or it's a PolyTv +-- or it's a ReturnTv -- c) if it's a SigTv, ty should be a tyvar -- -- We may have needed to do some type synonym unfolding in order to @@ -1152,13 +1183,13 @@ occurCheckExpand dflags tv ty impredicative = case details of - MetaTv { mtv_info = PolyTv } -> True - MetaTv { mtv_info = SigTv } -> False - MetaTv { mtv_info = TauTv } -> xopt Opt_ImpredicativeTypes dflags - || isOpenTypeKind (tyVarKind tv) + MetaTv { mtv_info = ReturnTv } -> True + MetaTv { mtv_info = SigTv } -> False + MetaTv { mtv_info = TauTv } -> xopt Opt_ImpredicativeTypes dflags + || isOpenTypeKind (tyVarKind tv) -- Note [OpenTypeKind accepts foralls] -- in TcUnify - _other -> True + _other -> True -- We can have non-meta tyvars in given constraints -- Check 'ty' is a tyvar, or can be expanded into one diff --git a/compiler/typecheck/TcUnify.lhs b/compiler/typecheck/TcUnify.lhs index f5033ee08a..421d076dbf 100644 --- a/compiler/typecheck/TcUnify.lhs +++ b/compiler/typecheck/TcUnify.lhs @@ -46,6 +46,7 @@ import TyCon import TysWiredIn import Var import VarEnv +import VarSet import ErrUtils import DynFlags import BasicTypes @@ -338,10 +339,19 @@ tcSubType origin ctxt ty_actual ty_expected PatSigOrigin -> TypeEqOrigin { uo_actual = ty2, uo_expected = ty1 } _other -> TypeEqOrigin { uo_actual = ty1, uo_expected = ty2 } +-- | Infer a type using a type "checking" function by passing in a ReturnTv, +-- which can unify with *anything*. See also Note [ReturnTv] in TcType tcInfer :: (TcType -> TcM a) -> TcM (a, TcType) -tcInfer tc_infer = do { ty <- newFlexiTyVarTy openTypeKind - ; res <- tc_infer ty - ; return (res, ty) } +tcInfer tc_check + = do { tv <- newReturnTyVar openTypeKind + ; let ty = mkTyVarTy tv + ; res <- tc_check ty + ; whenM (isUnfilledMetaTyVar tv) $ -- checking was uninformative + do { traceTc "Defaulting an un-filled ReturnTv to a TauTv" empty + ; tau_ty <- newFlexiTyVarTy openTypeKind + ; writeMetaTyVar tv tau_ty } + ; return (res, ty) } + where ----------------- tcWrapResult :: HsExpr TcId -> TcRhoType -> TcRhoType -> TcM (HsExpr TcId) @@ -844,7 +854,7 @@ nicer_to_update_tv1 tv1 _ _ = isSystemName (Var.varName tv1) ---------------- checkTauTvUpdate :: DynFlags -> TcTyVar -> TcType -> TcM (Maybe TcType) -- (checkTauTvUpdate tv ty) --- We are about to update the TauTv/PolyTv tv with ty. +-- We are about to update the TauTv/ReturnTv tv with ty. -- Check (a) that tv doesn't occur in ty (occurs check) -- (b) that kind(ty) is a sub-kind of kind(tv) -- @@ -873,6 +883,9 @@ checkTauTvUpdate dflags tv ty ; case sub_k of Nothing -> return Nothing Just LT -> return Nothing + _ | is_return_tv -> if tv `elemVarSet` tyVarsOfType ty + then return Nothing + else return (Just ty1) _ | defer_me ty1 -- Quick test -> -- Failed quick test so try harder case occurCheckExpand dflags tv ty1 of @@ -882,11 +895,12 @@ checkTauTvUpdate dflags tv ty | otherwise -> return (Just ty1) } where info = ASSERT2( isMetaTyVar tv, ppr tv ) metaTyVarInfo tv + -- See Note [ReturnTv] in TcType + is_return_tv = case info of { ReturnTv -> True; _ -> False } impredicative = xopt Opt_ImpredicativeTypes dflags || isOpenTypeKind (tyVarKind tv) -- Note [OpenTypeKind accepts foralls] - || case info of { PolyTv -> True; _ -> False } defer_me :: TcType -> Bool -- Checks for (a) occurrence of tv @@ -917,7 +931,6 @@ we can instantiate it with Int#. So we also allow such type variables to be instantiate with foralls. It's a bit of a hack, but seems straightforward. - Note [Conservative unification check] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When unifying (tv ~ rhs), w try to avoid creating deferred constraints diff --git a/compiler/utils/MonadUtils.hs b/compiler/utils/MonadUtils.hs index 60748ead29..b066b404a1 100644 --- a/compiler/utils/MonadUtils.hs +++ b/compiler/utils/MonadUtils.hs @@ -21,6 +21,7 @@ module MonadUtils , anyM, allM , foldlM, foldlM_, foldrM , maybeMapM + , whenM ) where ------------------------------------------------------------------------------- @@ -149,3 +150,8 @@ foldrM k z (x:xs) = do { r <- foldrM k z xs; k x r } maybeMapM :: Monad m => (a -> m b) -> (Maybe a -> m (Maybe b)) maybeMapM _ Nothing = return Nothing maybeMapM m (Just x) = liftM Just $ m x + +-- | Monadic version of @when@, taking the condition in the monad +whenM :: Monad m => m Bool -> m () -> m () +whenM mb thing = do { b <- mb + ; when b thing } diff --git a/docs/users_guide/7.10.1-notes.xml b/docs/users_guide/7.10.1-notes.xml index 7c1e65a250..2e509e1e2d 100644 --- a/docs/users_guide/7.10.1-notes.xml +++ b/docs/users_guide/7.10.1-notes.xml @@ -91,6 +91,36 @@ </para> </listitem> <listitem> + <para> + A new warning flag, <option>-fwarn-trustworthy-safe</option> + has been added and is turned on with + <option>-Wall</option>. It warns when a module that is + compiled with <option>-XTrustworthy</option> is actually + infered as an <option>-XSafe</option> module. This lets the + module author know that they can tighten their Safe Haskell + bounds if desired. + </para> + </listitem> + <listitem> + <para> + The <option>-fwarn-safe</option> and + <option>-fwarn-unsafe</option> that warn if a module was + infered as Safe or Unsafe have been improved to work with + all Safe Haskell module types. Previously, they only worked + for unmarked modules where the compiler was infering the + modules Safe Haskell type. They now work even for modules + marked as <option>-XTrustworthy</option> or + <option>-XUnsafe</option>. This is useful either to have + GHC check your assumptions, or to generate a list of + reasons easily why a module is regarded as Unsafe. + </para> + <para> + For many use cases, the new + <option>-fwarn-trustworthy-safe</option> flag is better + suited than either of these two. + </para> + </listitem> + <listitem> <para> <option>-ddump-simpl-phases</option> and <option>-ddump-core-pipeline</option> flags have been removed. diff --git a/docs/users_guide/flags.xml b/docs/users_guide/flags.xml index ac3cc041a1..33af295f1b 100644 --- a/docs/users_guide/flags.xml +++ b/docs/users_guide/flags.xml @@ -1565,7 +1565,10 @@ <entry><option>-fwarn-unsafe</option></entry> <entry>warn if the module being compiled is regarded to be unsafe. Should be used to check the safety status of modules when using safe - inference.</entry> + inference. Works on all module types, even those using explicit + <link linkend="safe-haskell">Safe Haskell</link> modes (such as + <option>-XTrustworthy</option>) and so can be used to have the + compiler check any assumptions made.</entry> <entry>dynamic</entry> <entry><option>-fno-warn-unsafe</option></entry> </row> @@ -1574,7 +1577,21 @@ <entry><option>-fwarn-safe</option></entry> <entry>warn if the module being compiled is regarded to be safe. Should be used to check the safety status of modules when using safe - inference.</entry> + inference. Works on all module types, even those using explicit + <link linkend="safe-haskell">Safe Haskell</link> modes (such as + <option>-XTrustworthy</option>) and so can be used to have the + compiler check any assumptions made.</entry> + <entry>dynamic</entry> + <entry><option>-fno-warn-safe</option></entry> + </row> + + <row> + <entry><option>-fwarn-trustworthy-safe</option></entry> + <entry>warn if the module being compiled is marked as + <option>-XTrustworthy</option> but it could instead be marked as + <option>-XSafe</option>, a more informative bound. Can be used to + detect once a Safe Haskell bound can be improved as dependencies + are updated.</entry> <entry>dynamic</entry> <entry><option>-fno-warn-safe</option></entry> </row> @@ -2522,6 +2539,13 @@ <entry>-</entry> </row> <row> + <entry><option>-ticky</option></entry> + <entry>For linking, this simply implies <option>-debug</option>; + see <xref linkend="ticky-ticky"/>.</entry> + <entry>dynamic</entry> + <entry>-</entry> + </row> + <row> <entry><option>-eventlog</option></entry> <entry>Enable runtime event tracing</entry> <entry>dynamic</entry> diff --git a/docs/users_guide/profiling.xml b/docs/users_guide/profiling.xml index 5bb396d377..4971a7d9f8 100644 --- a/docs/users_guide/profiling.xml +++ b/docs/users_guide/profiling.xml @@ -1771,7 +1771,7 @@ Options: <para>Because ticky-ticky profiling requires a certain familiarity with GHC internals, we have moved the documentation to the - wiki. Take a look at its <ulink + GHC developers wiki. Take a look at its <ulink url="http://ghc.haskell.org/trac/ghc/wiki/Commentary/Profiling">overview of the profiling options</ulink>, which includeds a link to the ticky-ticky profiling page.</para> diff --git a/docs/users_guide/runtime_control.xml b/docs/users_guide/runtime_control.xml index d26dd96e8c..cdd9fd4997 100644 --- a/docs/users_guide/runtime_control.xml +++ b/docs/users_guide/runtime_control.xml @@ -1442,8 +1442,7 @@ $ ./a.out +RTS --info <literal>-threaded</literal> option) and <literal>rts_p</literal> (profiling runtime, i.e. linked using the <literal>-prof</literal> option). Other variants include <literal>debug</literal> - (linked using <literal>-debug</literal>), - <literal>t</literal> (ticky-ticky profiling) and + (linked using <literal>-debug</literal>), and <literal>dyn</literal> (the RTS is linked in dynamically, i.e. a shared library, rather than statically linked into the executable itself). These can be combined, diff --git a/docs/users_guide/safe_haskell.xml b/docs/users_guide/safe_haskell.xml index 10d0a638f0..634482a42c 100644 --- a/docs/users_guide/safe_haskell.xml +++ b/docs/users_guide/safe_haskell.xml @@ -705,7 +705,7 @@ </varlistentry> </variablelist> - And two warning flags: + And three warning flags: <variablelist> <varlistentry> @@ -724,6 +724,15 @@ when using safe inference. </listitem> </varlistentry> + <varlistentry> + <term>-fwarn-trustworthy-safe</term> + <indexterm><primary>-fwarn-trustworthy-safe</primary></indexterm> + <listitem>Issue a warning if the module being compiled is marked as + <option>-XTrustworthy</option> but it could instead be marked as + <option>-XSafe</option>, a more informative bound. Can be used to + detect once a Safe Haskell bound can be improved as dependencies are + updated.</listitem> + </varlistentry> </variablelist> </sect2> @@ -590,7 +590,9 @@ libraries/ghc-prim_dist-install_EXTRA_HADDOCK_SRCS = libraries/ghc-prim/dist-ins ifneq "$(CLEANING)" "YES" ifeq "$(INTEGER_LIBRARY)" "integer-gmp" -libraries/base_dist-install_CONFIGURE_OPTS += --flags=-integer-simple +libraries/base_dist-install_CONFIGURE_OPTS += --flags=integer-gmp +else ifeq "$(INTEGER_LIBRARY)" "integer-gmp2" +libraries/base_dist-install_CONFIGURE_OPTS += --flags=integer-gmp2 else ifeq "$(INTEGER_LIBRARY)" "integer-simple" libraries/base_dist-install_CONFIGURE_OPTS += --flags=integer-simple else @@ -657,6 +659,12 @@ BUILD_DIRS += libraries/integer-gmp/gmp BUILD_DIRS += libraries/integer-gmp/mkGmpDerivedConstants endif +ifeq "$(INTEGER_LIBRARY)" "integer-gmp2" +BUILD_DIRS += libraries/integer-gmp2/gmp +else ifneq "$(findstring clean,$(MAKECMDGOALS))" "" +BUILD_DIRS += libraries/integer-gmp2/gmp +endif + BUILD_DIRS += utils/haddock BUILD_DIRS += utils/haddock/doc BUILD_DIRS += compiler @@ -1212,6 +1220,7 @@ sdist_%: CLEAN_FILES += libraries/bootstrapping.conf CLEAN_FILES += libraries/integer-gmp/cbits/GmpDerivedConstants.h CLEAN_FILES += libraries/integer-gmp/include/HsIntegerGmp.h +CLEAN_FILES += libraries/integer-gmp2/include/HsIntegerGmp.h CLEAN_FILES += libraries/base/include/EventConfig.h CLEAN_FILES += mk/config.mk.old CLEAN_FILES += mk/project.mk.old diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs index e6d1529686..1d4504815c 100644 --- a/ghc/InteractiveUI.hs +++ b/ghc/InteractiveUI.hs @@ -275,8 +275,8 @@ defFullHelpText = " :list show the source code around current breakpoint\n" ++ " :list <identifier> show the source code for <identifier>\n" ++ " :list [<module>] <line> show the source code around line number <line>\n" ++ - " :print [<name> ...] prints a value without forcing its computation\n" ++ - " :sprint [<name> ...] simplifed version of :print\n" ++ + " :print [<name> ...] show a value without forcing its computation\n" ++ + " :sprint [<name> ...] simplified version of :print\n" ++ " :step single-step after stopping at a breakpoint\n"++ " :step <expr> single-step into <expr>\n"++ " :steplocal single-step within the current top-level binding\n"++ diff --git a/includes/Stg.h b/includes/Stg.h index 4c26e3ef80..f09fc00966 100644 --- a/includes/Stg.h +++ b/includes/Stg.h @@ -47,6 +47,10 @@ // We need _BSD_SOURCE so that math.h defines things like gamma // on Linux # define _BSD_SOURCE + +// '_BSD_SOURCE' is deprecated since glibc-2.20 +// in favour of '_DEFAULT_SOURCE' +# define _DEFAULT_SOURCE #endif #if IN_STG_CODE == 0 || defined(llvm_CC_FLAVOR) diff --git a/includes/rts/Constants.h b/includes/rts/Constants.h index 6fd0dc0dfc..02cb63210d 100644 --- a/includes/rts/Constants.h +++ b/includes/rts/Constants.h @@ -277,6 +277,12 @@ #define TSO_SQUEEZED 128 /* + * Enables the AllocationLimitExceeded exception when the thread's + * allocation limit goes negative. + */ +#define TSO_ALLOC_LIMIT 256 + +/* * The number of times we spin in a spin lock before yielding (see * #3758). To tune this value, use the benchmark in #3758: run the * server with -N2 and the client both on a dual-core. Also make sure diff --git a/includes/rts/Flags.h b/includes/rts/Flags.h index bf6a7f3c5c..ec542701df 100644 --- a/includes/rts/Flags.h +++ b/includes/rts/Flags.h @@ -56,6 +56,14 @@ struct GC_FLAGS { rtsBool doIdleGC; StgWord heapBase; /* address to ask the OS for memory */ + + StgWord allocLimitGrace; /* units: *blocks* + * After an AllocationLimitExceeded + * exception has been raised, how much + * extra space is given to the thread + * to handle the exception before we + * raise it again. + */ }; struct DEBUG_FLAGS { diff --git a/includes/rts/Threads.h b/includes/rts/Threads.h index 941f6daf65..fc8ae6e089 100644 --- a/includes/rts/Threads.h +++ b/includes/rts/Threads.h @@ -42,8 +42,12 @@ StgRegTable * resumeThread (void *); // // Thread operations from Threads.c // -int cmp_thread (StgPtr tso1, StgPtr tso2); -int rts_getThreadId (StgPtr tso); +int cmp_thread (StgPtr tso1, StgPtr tso2); +int rts_getThreadId (StgPtr tso); +HsInt64 rts_getThreadAllocationCounter (StgPtr tso); +void rts_setThreadAllocationCounter (StgPtr tso, HsInt64 i); +void rts_enableThreadAllocationLimit (StgPtr tso); +void rts_disableThreadAllocationLimit (StgPtr tso); #if !defined(mingw32_HOST_OS) pid_t forkProcess (HsStablePtr *entry); diff --git a/includes/rts/storage/TSO.h b/includes/rts/storage/TSO.h index 6dbcec2595..06056fe716 100644 --- a/includes/rts/storage/TSO.h +++ b/includes/rts/storage/TSO.h @@ -145,15 +145,18 @@ typedef struct StgTSO_ { */ struct StgBlockingQueue_ *bq; -#ifdef TICKY_TICKY - /* TICKY-specific stuff would go here. */ -#endif -#ifdef PROFILING - StgTSOProfInfo prof; -#endif -#ifdef mingw32_HOST_OS - StgWord32 saved_winerror; -#endif + /* + * The allocation limit for this thread, which is updated as the + * thread allocates. If the value drops below zero, and + * TSO_ALLOC_LIMIT is set in flags, we raise an exception in the + * thread, and give the thread a little more space to handle the + * exception before we raise the exception again. + * + * This is an integer, because we might update it in a place where + * it isn't convenient to raise the exception, so we want it to + * stay negative until we get around to checking it. + */ + StgInt64 alloc_limit; /* in bytes */ /* * sum of the sizes of all stack chunks (in words), used to decide @@ -168,6 +171,16 @@ typedef struct StgTSO_ { */ StgWord32 tot_stack_size; +#ifdef TICKY_TICKY + /* TICKY-specific stuff would go here. */ +#endif +#ifdef PROFILING + StgTSOProfInfo prof; +#endif +#ifdef mingw32_HOST_OS + StgWord32 saved_winerror; +#endif + } *StgTSOPtr; typedef struct StgStack_ { diff --git a/libraries/Cabal b/libraries/Cabal -Subproject bb7e8f8b0170deb9c0486b10f4a9898503427d9 +Subproject f54e7f95412c2ee9ee76ce9517b7d8aa769bdcf diff --git a/libraries/base/Control/Exception.hs b/libraries/base/Control/Exception.hs index fa505750f2..0bcbdca942 100644 --- a/libraries/base/Control/Exception.hs +++ b/libraries/base/Control/Exception.hs @@ -48,6 +48,7 @@ module Control.Exception ( NestedAtomically(..), BlockedIndefinitelyOnMVar(..), BlockedIndefinitelyOnSTM(..), + AllocationLimitExceeded(..), Deadlock(..), NoMethodError(..), PatternMatchFail(..), diff --git a/libraries/base/Control/Exception/Base.hs b/libraries/base/Control/Exception/Base.hs index c581d1a5c4..f7779d6f9c 100644 --- a/libraries/base/Control/Exception/Base.hs +++ b/libraries/base/Control/Exception/Base.hs @@ -31,6 +31,7 @@ module Control.Exception.Base ( NestedAtomically(..), BlockedIndefinitelyOnMVar(..), BlockedIndefinitelyOnSTM(..), + AllocationLimitExceeded(..), Deadlock(..), NoMethodError(..), PatternMatchFail(..), diff --git a/libraries/base/Data/Foldable.hs b/libraries/base/Data/Foldable.hs index 4167b92597..8ad8c2fe26 100644 --- a/libraries/base/Data/Foldable.hs +++ b/libraries/base/Data/Foldable.hs @@ -1,4 +1,5 @@ {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE Trustworthy #-} ----------------------------------------------------------------------------- @@ -55,7 +56,10 @@ import Data.Monoid import Data.Ord import Data.Proxy -import GHC.Arr ( Array(..), Ix(..), elems ) +import GHC.Arr ( Array(..), Ix(..), elems, numElements, + foldlElems, foldrElems, + foldlElems', foldrElems', + foldl1Elems, foldr1Elems) import GHC.Base hiding ( foldr ) import GHC.Num ( Num(..) ) @@ -82,6 +86,29 @@ infix 4 `elem`, `notElem` -- > foldr f z (Leaf x) = f x z -- > foldr f z (Node l k r) = foldr f (f k (foldr f z r)) l -- +-- @Foldable@ instances are expected to satisfy the following laws: +-- +-- > foldr f z t = appEndo (foldMap (Endo . f) t ) z +-- +-- > foldl f z t = appEndo (getDual (foldMap (Dual . Endo . flip f) t)) z +-- +-- > fold = foldMap id +-- +-- @sum@, @product@, @maximum@, and @minimum@ should all be essentially +-- equivalent to @foldMap@ forms, such as +-- +-- > sum = getSum . foldMap Sum +-- +-- but may be less defined. +-- +-- If the type is also a 'Functor' instance, it should satisfy +-- +-- > foldMap f = fold . fmap f +-- +-- which implies that +-- +-- > foldMap f . fmap g = foldMap (f . g) + class Foldable t where {-# MINIMAL foldMap | foldr #-} @@ -98,7 +125,7 @@ class Foldable t where -- -- @'foldr' f z = 'Prelude.foldr' f z . 'toList'@ foldr :: (a -> b -> b) -> b -> t a -> b - foldr f z t = appEndo (foldMap (Endo . f) t) z + foldr f z t = appEndo (foldMap (Endo #. f) t) z -- | Right-associative fold of a structure, -- but with strict application of the operator. @@ -111,6 +138,8 @@ class Foldable t where -- @'foldl' f z = 'Prelude.foldl' f z . 'toList'@ foldl :: (b -> a -> b) -> b -> t a -> b foldl f z t = appEndo (getDual (foldMap (Dual . Endo . flip f) t)) z + -- There's no point mucking around with coercions here, + -- because flip forces us to build a new function anyway. -- | Left-associative fold of a structure. -- but with strict application of the operator. @@ -144,16 +173,20 @@ class Foldable t where Nothing -> y Just x -> f x y) - -- | List of elements of a structure. + -- | List of elements of a structure, from left to right. toList :: t a -> [a] {-# INLINE toList #-} toList t = build (\ c n -> foldr c n t) - -- | Test whether the structure is empty. + -- | Test whether the structure is empty. The default implementation is + -- optimized for structures that are similar to cons-lists, because there + -- is no general way to do better. null :: t a -> Bool null = foldr (\_ _ -> False) True - -- | Returns the size/length of a finite structure as an 'Int'. + -- | Returns the size/length of a finite structure as an 'Int'. The + -- default implementation is optimized for structures that are similar to + -- cons-lists, because there is no general way to do better. length :: t a -> Int length = foldl' (\c _ -> c+1) 0 @@ -162,21 +195,23 @@ class Foldable t where elem = any . (==) -- | The largest element of a non-empty structure. - maximum :: Ord a => t a -> a - maximum = foldr1 max + maximum :: forall a . Ord a => t a -> a + maximum = fromMaybe (error "maximum: empty structure") . + getMax . foldMap (Max #. (Just :: a -> Maybe a)) -- | The least element of a non-empty structure. - minimum :: Ord a => t a -> a - minimum = foldr1 min + minimum :: forall a . Ord a => t a -> a + minimum = fromMaybe (error "minimum: empty structure") . + getMin . foldMap (Min #. (Just :: a -> Maybe a)) -- | The 'sum' function computes the sum of the numbers of a structure. sum :: Num a => t a -> a - sum = getSum . foldMap Sum + sum = getSum #. foldMap Sum -- | The 'product' function computes the product of the numbers of a -- structure. product :: Num a => t a -> a - product = getProduct . foldMap Product + product = getProduct #. foldMap Product -- instances for Prelude types @@ -209,16 +244,26 @@ instance Foldable (Either a) where foldr _ z (Left _) = z foldr f z (Right y) = f y z + length (Left _) = 0 + length (Right _) = 1 + + null = isLeft + instance Foldable ((,) a) where foldMap f (_, y) = f y foldr f z (_, y) = f y z instance Ix i => Foldable (Array i) where - foldr f z = List.foldr f z . elems - foldl f z = List.foldl f z . elems - foldr1 f = List.foldr1 f . elems - foldl1 f = List.foldl1 f . elems + foldr = foldrElems + foldl = foldlElems + foldl' = foldlElems' + foldr' = foldrElems' + foldl1 = foldl1Elems + foldr1 = foldr1Elems + toList = elems + length = numElements + null a = numElements a == 0 instance Foldable Proxy where foldMap _ _ = mempty @@ -230,9 +275,41 @@ instance Foldable Proxy where foldl _ z _ = z {-# INLINE foldl #-} foldl1 _ _ = error "foldl1: Proxy" - {-# INLINE foldl1 #-} foldr1 _ _ = error "foldr1: Proxy" - {-# INLINE foldr1 #-} + length _ = 0 + null _ = True + elem _ _ = False + sum _ = 0 + product _ = 1 + +-- We don't export Max and Min because, as Edward Kmett pointed out to me, +-- there are two reasonable ways to define them. One way is to use Maybe, as we +-- do here; the other way is to impose a Bounded constraint on the Monoid +-- instance. We may eventually want to add both versions, but we don't want to +-- trample on anyone's toes by imposing Max = MaxMaybe. + +newtype Max a = Max {getMax :: Maybe a} +newtype Min a = Min {getMin :: Maybe a} + +instance Ord a => Monoid (Max a) where + mempty = Max Nothing + + {-# INLINE mappend #-} + m `mappend` Max Nothing = m + Max Nothing `mappend` n = n + (Max m@(Just x)) `mappend` (Max n@(Just y)) + | x >= y = Max m + | otherwise = Max n + +instance Ord a => Monoid (Min a) where + mempty = Min Nothing + + {-# INLINE mappend #-} + m `mappend` Min Nothing = m + Min Nothing `mappend` n = n + (Min m@(Just x)) `mappend` (Min n@(Just y)) + | x <= y = Min m + | otherwise = Min n -- | Monadic fold over the elements of a structure, -- associating to the right, i.e. from right to left. @@ -257,11 +334,13 @@ for_ :: (Foldable t, Applicative f) => t a -> (a -> f b) -> f () for_ = flip traverse_ -- | Map each element of a structure to a monadic action, evaluate --- these actions from left to right, and ignore the results. +-- these actions from left to right, and ignore the results. As of +-- base 4.8.0.0, 'mapM_' is just 'traverse_', specialized to 'Monad'. mapM_ :: (Foldable t, Monad m) => (a -> m b) -> t a -> m () -mapM_ f = foldr ((>>) . f) (return ()) +mapM_ f= foldr ((>>) . f) (return ()) --- | 'forM_' is 'mapM_' with its arguments flipped. +-- | 'forM_' is 'mapM_' with its arguments flipped. As of base +-- 4.8.0.0, 'forM_' is just 'for_', specialized to 'Monad'. forM_ :: (Foldable t, Monad m) => t a -> (a -> m b) -> m () {-# INLINE forM_ #-} forM_ = flip mapM_ @@ -272,7 +351,8 @@ sequenceA_ :: (Foldable t, Applicative f) => t (f a) -> f () sequenceA_ = foldr (*>) (pure ()) -- | Evaluate each monadic action in the structure from left to right, --- and ignore the results. +-- and ignore the results. As of base 4.8.0.0, 'sequence_' is just +-- 'sequenceA_', specialized to 'Monad'. sequence_ :: (Foldable t, Monad m) => t (m a) -> m () sequence_ = foldr (>>) (return ()) @@ -282,40 +362,43 @@ asum :: (Foldable t, Alternative f) => t (f a) -> f a asum = foldr (<|>) empty -- | The sum of a collection of actions, generalizing 'concat'. +-- As of base 4.8.0.0, 'msum' is just 'asum', specialized to 'MonadPlus'. msum :: (Foldable t, MonadPlus m) => t (m a) -> m a {-# INLINE msum #-} -msum = foldr mplus mzero - --- These use foldr rather than foldMap to avoid repeated concatenation. +msum = asum -- | The concatenation of all the elements of a container of lists. concat :: Foldable t => t [a] -> [a] -concat = fold +concat xs = build (\c n -> foldr (\x y -> foldr c y x) n xs) +{-# INLINE concat #-} -- | Map a function over all the elements of a container and concatenate -- the resulting lists. concatMap :: Foldable t => (a -> [b]) -> t a -> [b] -concatMap = foldMap +concatMap f xs = build (\c n -> foldr (\x b -> foldr c b (f x)) n xs) +{-# INLINE concatMap #-} + +-- These use foldr rather than foldMap to avoid repeated concatenation. -- | 'and' returns the conjunction of a container of Bools. For the -- result to be 'True', the container must be finite; 'False', however, -- results from a 'False' value finitely far from the left end. and :: Foldable t => t Bool -> Bool -and = getAll . foldMap All +and = getAll #. foldMap All -- | 'or' returns the disjunction of a container of Bools. For the -- result to be 'False', the container must be finite; 'True', however, -- results from a 'True' value finitely far from the left end. or :: Foldable t => t Bool -> Bool -or = getAny . foldMap Any +or = getAny #. foldMap Any -- | Determines whether any element of the structure satisfies the predicate. any :: Foldable t => (a -> Bool) -> t a -> Bool -any p = getAny . foldMap (Any . p) +any p = getAny #. foldMap (Any #. p) -- | Determines whether all elements of the structure satisfy the predicate. all :: Foldable t => (a -> Bool) -> t a -> Bool -all p = getAll . foldMap (All . p) +all p = getAll #. foldMap (All #. p) -- | The largest element of a non-empty structure with respect to the -- given comparison function. @@ -341,5 +424,36 @@ notElem x = not . elem x -- the leftmost element of the structure matching the predicate, or -- 'Nothing' if there is no such element. find :: Foldable t => (a -> Bool) -> t a -> Maybe a -find p = listToMaybe . concatMap (\ x -> if p x then [x] else []) +find p = getFirst . foldMap (\ x -> First (if p x then Just x else Nothing)) + +-- See Note [Function coercion] +(#.) :: Coercible b c => (b -> c) -> (a -> b) -> (a -> c) +(#.) _f = coerce +{-# INLINE (#.) #-} + +{- +Note [Function coercion] +~~~~~~~~~~~~~~~~~~~~~~~~ + +Several functions here use (#.) instead of (.) to avoid potential efficiency +problems relating to #7542. The problem, in a nutshell: + +If N is a newtype constructor, then N x will always have the same +representation as x (something similar applies for a newtype deconstructor). +However, if f is a function, + +N . f = \x -> N (f x) + +This looks almost the same as f, but the eta expansion lifts it--the lhs could +be _|_, but the rhs never is. This can lead to very inefficient code. Thus we +steal a technique from Shachaf and Edward Kmett and adapt it to the current +(rather clean) setting. Instead of using N . f, we use N .## f, which is +just + +coerce f `asTypeOf` (N . f) +That is, we just *pretend* that f has the right type, and thanks to the safety +of coerce, the type checker guarantees that nothing really goes wrong. We still +have to be a bit careful, though: remember that #. completely ignores the +*value* of its left operand. +-} diff --git a/libraries/base/Data/Functor/Identity.hs b/libraries/base/Data/Functor/Identity.hs new file mode 100644 index 0000000000..4058df8824 --- /dev/null +++ b/libraries/base/Data/Functor/Identity.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE AutoDeriveTypeable #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Functor.Identity +-- Copyright : (c) Andy Gill 2001, +-- (c) Oregon Graduate Institute of Science and Technology 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : ross@soi.city.ac.uk +-- Stability : experimental +-- Portability : portable +-- +-- The identity functor and monad. +-- +-- This trivial type constructor serves two purposes: +-- +-- * It can be used with functions parameterized by functor or monad classes. +-- +-- * It can be used as a base monad to which a series of monad +-- transformers may be applied to construct a composite monad. +-- Most monad transformer modules include the special case of +-- applying the transformer to 'Identity'. For example, @State s@ +-- is an abbreviation for @StateT s 'Identity'@. +-- +-- /Since: 4.8.0.0/ +----------------------------------------------------------------------------- + +module Data.Functor.Identity ( + Identity(..), + ) where + +import Control.Monad.Fix +import Data.Functor + +-- | Identity functor and monad. (a non-strict monad) +-- +-- /Since: 4.8.0.0/ +newtype Identity a = Identity { runIdentity :: a } + deriving (Eq, Ord) + +-- | This instance would be equivalent to the derived instances of the +-- 'Identity' newtype if the 'runIdentity' field were removed +instance (Read a) => Read (Identity a) where + readsPrec d = readParen (d > 10) $ \ r -> + [(Identity x,t) | ("Identity",s) <- lex r, (x,t) <- readsPrec 11 s] + +-- | This instance would be equivalent to the derived instances of the +-- 'Identity' newtype if the 'runIdentity' field were removed +instance (Show a) => Show (Identity a) where + showsPrec d (Identity x) = showParen (d > 10) $ + showString "Identity " . showsPrec 11 x + +-- --------------------------------------------------------------------------- +-- Identity instances for Functor and Monad + +instance Functor Identity where + fmap f m = Identity (f (runIdentity m)) + +instance Foldable Identity where + foldMap f (Identity x) = f x + +instance Traversable Identity where + traverse f (Identity x) = Identity <$> f x + +instance Applicative Identity where + pure a = Identity a + Identity f <*> Identity x = Identity (f x) + +instance Monad Identity where + return a = Identity a + m >>= k = k (runIdentity m) + +instance MonadFix Identity where + mfix f = Identity (fix (runIdentity . f)) diff --git a/libraries/base/Data/OldList.hs b/libraries/base/Data/OldList.hs index caad044513..551b8be124 100644 --- a/libraries/base/Data/OldList.hs +++ b/libraries/base/Data/OldList.hs @@ -754,6 +754,7 @@ groupBy eq (x:xs) = (x:ys) : groupBy eq zs inits :: [a] -> [[a]] inits = map toListSB . scanl' snocSB emptySB {-# NOINLINE inits #-} + -- We do not allow inits to inline, because it plays havoc with Call Arity -- if it fuses with a consumer, and it would generally lead to serious -- loss of sharing if allowed to fuse with a producer. @@ -1066,12 +1067,26 @@ unlines (l:ls) = l ++ '\n' : unlines ls -- | 'words' breaks a string up into a list of words, which were delimited -- by white space. words :: String -> [String] +{-# NOINLINE [1] words #-} words s = case dropWhile {-partain:Char.-}isSpace s of "" -> [] s' -> w : words s'' where (w, s'') = break {-partain:Char.-}isSpace s' +{-# RULES +"words" [~1] forall s . words s = build (\c n -> wordsFB c n s) +"wordsList" [1] wordsFB (:) [] = words + #-} +wordsFB :: ([Char] -> b -> b) -> b -> String -> b +{-# NOINLINE [0] wordsFB #-} +wordsFB c n = go + where + go s = case dropWhile isSpace s of + "" -> n + s' -> w `c` go s'' + where (w, s'') = break isSpace s' + -- | 'unwords' is an inverse operation to 'words'. -- It joins words with separating spaces. unwords :: [String] -> String @@ -1079,11 +1094,35 @@ unwords :: [String] -> String unwords [] = "" unwords ws = foldr1 (\w s -> w ++ ' ':s) ws #else --- HBC version (stolen) --- here's a more efficient version +-- Here's a lazier version that can get the last element of a +-- _|_-terminated list. +{-# NOINLINE [1] unwords #-} unwords [] = "" -unwords [w] = w -unwords (w:ws) = w ++ ' ' : unwords ws +unwords (w:ws) = w ++ go ws + where + go [] = "" + go (v:vs) = ' ' : (v ++ go vs) + +-- In general, the foldr-based version is probably slightly worse +-- than the HBC version, because it adds an extra space and then takes +-- it back off again. But when it fuses, it reduces allocation. How much +-- depends entirely on the average word length--it's most effective when +-- the words are on the short side. +{-# RULES +"unwords" [~1] forall ws . + unwords ws = tailUnwords (foldr unwordsFB "" ws) +"unwordsList" [1] forall ws . + tailUnwords (foldr unwordsFB "" ws) = unwords ws + #-} + +{-# INLINE [0] tailUnwords #-} +tailUnwords :: String -> String +tailUnwords [] = [] +tailUnwords (_:xs) = xs + +{-# INLINE [0] unwordsFB #-} +unwordsFB :: String -> String -> String +unwordsFB w r = ' ' : w ++ r #endif {- A "SnocBuilder" is a version of Chris Okasaki's banker's queue that supports diff --git a/libraries/base/GHC/Arr.hs b/libraries/base/GHC/Arr.hs index 0d5099366b..e68c70f6bc 100644 --- a/libraries/base/GHC/Arr.hs +++ b/libraries/base/GHC/Arr.hs @@ -1,6 +1,5 @@ {-# LANGUAGE Unsafe #-} {-# LANGUAGE NoImplicitPrelude, MagicHash, UnboxedTuples #-} -{-# OPTIONS_GHC -funbox-strict-fields #-} {-# OPTIONS_HADDOCK hide #-} ----------------------------------------------------------------------------- @@ -30,6 +29,8 @@ module GHC.Arr ( newSTArray, boundsSTArray, readSTArray, writeSTArray, freezeSTArray, thawSTArray, + foldlElems, foldlElems', foldl1Elems, + foldrElems, foldrElems', foldr1Elems, -- * Unsafe operations fill, done, @@ -467,12 +468,6 @@ done l u n@(I# _) marr# = \s1# -> case unsafeFreezeArray# marr# s1# of (# s2#, arr# #) -> (# s2#, Array l u n arr# #) --- This is inefficient and I'm not sure why: --- listArray (l,u) es = unsafeArray (l,u) (zip [0 .. rangeSize (l,u) - 1] es) --- The code below is better. It still doesn't enable foldr/build --- transformation on the list of elements; I guess it's impossible --- using mechanisms currently available. - -- | Construct an array from a pair of bounds and a list of values in -- index order. {-# INLINE listArray #-} @@ -480,13 +475,17 @@ listArray :: Ix i => (i,i) -> [e] -> Array i e listArray (l,u) es = runST (ST $ \s1# -> case safeRangeSize (l,u) of { n@(I# n#) -> case newArray# n# arrEleBottom s1# of { (# s2#, marr# #) -> - let fillFromList i# xs s3# | isTrue# (i# ==# n#) = s3# - | otherwise = case xs of - [] -> s3# - y:ys -> case writeArray# marr# i# y s3# of { s4# -> - fillFromList (i# +# 1#) ys s4# } in - case fillFromList 0# es s2# of { s3# -> - done l u n marr# s3# }}}) + let + go y r = \ i# s3# -> + case writeArray# marr# i# y s3# of + s4# -> if (isTrue# (i# ==# n# -# 1#)) + then s4# + else r (i# +# 1#) s4# + in + done l u n marr# ( + if n == 0 + then s2# + else foldr go (\_ s# -> s#) es 0# s2#)}}) -- | The value at the given index in an array. {-# INLINE (!) #-} @@ -557,6 +556,62 @@ elems :: Ix i => Array i e -> [e] elems arr@(Array _ _ n _) = [unsafeAt arr i | i <- [0 .. n - 1]] +-- | A right fold over the elements +{-# INLINABLE foldrElems #-} +foldrElems :: Ix i => (a -> b -> b) -> b -> Array i a -> b +foldrElems f b0 = \ arr@(Array _ _ n _) -> + let + go i | i == n = b0 + | otherwise = f (unsafeAt arr i) (go (i+1)) + in go 0 + +-- | A left fold over the elements +{-# INLINABLE foldlElems #-} +foldlElems :: Ix i => (b -> a -> b) -> b -> Array i a -> b +foldlElems f b0 = \ arr@(Array _ _ n _) -> + let + go i | i == (-1) = b0 + | otherwise = f (go (i-1)) (unsafeAt arr i) + in go (n-1) + +-- | A strict right fold over the elements +{-# INLINABLE foldrElems' #-} +foldrElems' :: Ix i => (a -> b -> b) -> b -> Array i a -> b +foldrElems' f b0 = \ arr@(Array _ _ n _) -> + let + go i a | i == (-1) = a + | otherwise = go (i-1) (f (unsafeAt arr i) $! a) + in go (n-1) b0 + +-- | A strict left fold over the elements +{-# INLINABLE foldlElems' #-} +foldlElems' :: Ix i => (b -> a -> b) -> b -> Array i a -> b +foldlElems' f b0 = \ arr@(Array _ _ n _) -> + let + go i a | i == n = a + | otherwise = go (i+1) (a `seq` f a (unsafeAt arr i)) + in go 0 b0 + +-- | A left fold over the elements with no starting value +{-# INLINABLE foldl1Elems #-} +foldl1Elems :: Ix i => (a -> a -> a) -> Array i a -> a +foldl1Elems f = \ arr@(Array _ _ n _) -> + let + go i | i == 0 = unsafeAt arr 0 + | otherwise = f (go (i-1)) (unsafeAt arr i) + in + if n == 0 then error "foldl1: empty Array" else go (n-1) + +-- | A right fold over the elements with no starting value +{-# INLINABLE foldr1Elems #-} +foldr1Elems :: Ix i => (a -> a -> a) -> Array i a -> a +foldr1Elems f = \ arr@(Array _ _ n _) -> + let + go i | i == n-1 = unsafeAt arr i + | otherwise = f (unsafeAt arr i) (go (i + 1)) + in + if n == 0 then error "foldr1: empty Array" else go 0 + -- | The list of associations of an array in index order. {-# INLINE assocs #-} assocs :: Ix i => Array i e -> [(i, e)] @@ -647,10 +702,44 @@ unsafeAccum f arr ies = runST (do STArray l u n marr# <- thawSTArray arr ST (foldr (adjust f marr#) (done l u n marr#) ies)) -{-# INLINE amap #-} +{-# INLINE [1] amap #-} amap :: Ix i => (a -> b) -> Array i a -> Array i b -amap f arr@(Array l u n _) = - unsafeArray' (l,u) n [(i, f (unsafeAt arr i)) | i <- [0 .. n - 1]] +amap f arr@(Array l u n@(I# n#) _) = runST (ST $ \s1# -> + case newArray# n# arrEleBottom s1# of + (# s2#, marr# #) -> + let go i s# + | i == n = done l u n marr# s# + | otherwise = fill marr# (i, f (unsafeAt arr i)) (go (i+1)) s# + in go 0 s2# ) + +{- +amap was originally defined like this: + + amap f arr@(Array l u n _) = + unsafeArray' (l,u) n [(i, f (unsafeAt arr i)) | i <- [0 .. n - 1]] + +There are two problems: + +1. The enumFromTo implementation produces (spurious) code for the impossible +case of n<0 that ends up duplicating the array freezing code. + +2. This implementation relies on list fusion for efficiency. In order to +implement the amap/coerce rule, we need to delay inlining amap until simplifier +phase 1, which is when the eftIntList rule kicks in and makes that impossible. +-} + + +-- See Breitner, Eisenberg, Peyton Jones, and Weirich, "Safe Zero-cost +-- Coercions for Haskell", section 6.5: +-- http://research.microsoft.com/en-us/um/people/simonpj/papers/ext-f/coercible.pdf +{-# RULES +"amap/coerce" amap coerce = coerce + #-} + +-- Second functor law: +{-# RULES +"amap/amap" forall f g a . amap f (amap g a) = amap (f . g) a + #-} -- | 'ixmap' allows for transformations on array indices. -- It may be thought of as providing function composition on the right diff --git a/libraries/base/GHC/Base.hs b/libraries/base/GHC/Base.hs index 501a6d5693..25596e0d6c 100644 --- a/libraries/base/GHC/Base.hs +++ b/libraries/base/GHC/Base.hs @@ -225,8 +225,32 @@ class Monoid a where mconcat = foldr mappend mempty instance Monoid [a] where + {-# INLINE mempty #-} mempty = [] + {-# INLINE mappend #-} mappend = (++) + {-# INLINE mconcat #-} + mconcat xss = [x | xs <- xss, x <- xs] +-- See Note: [List comprehensions and inlining] + +{- +Note: [List comprehensions and inlining] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The list monad operations are traditionally described in terms of concatMap: + +xs >>= f = concatMap f xs + +Similarly, mconcat for lists is just concat. Here in Base, however, we don't +have concatMap, and we'll refrain from adding it here so it won't have to be +hidden in imports. Instead, we use GHC's list comprehension desugaring +mechanism to define mconcat and the Applicative and Monad instances for lists. +We mark them INLINE because the inliner is not generally too keen to inline +build forms such as the ones these desugar to without our insistence. Defining +these using list comprehensions instead of foldr has an additional potential +benefit, as described in compiler/deSugar/DsListComp.lhs: if optimizations +needed to make foldr/build forms efficient are turned off, we'll get reasonably +efficient translations anyway. +-} instance Monoid b => Monoid (a -> b) where mempty _ = mempty @@ -494,14 +518,32 @@ when p s = if p then s else pure () -- and collect the results. sequence :: Monad m => [m a] -> m [a] {-# INLINE sequence #-} -sequence ms = foldr k (return []) ms - where - k m m' = do { x <- m; xs <- m'; return (x:xs) } +sequence = mapM id +-- Note: [sequence and mapM] -- | @'mapM' f@ is equivalent to @'sequence' . 'map' f@. mapM :: Monad m => (a -> m b) -> [a] -> m [b] {-# INLINE mapM #-} -mapM f as = sequence (map f as) +mapM f as = foldr k (return []) as + where + k a r = do { x <- f a; xs <- r; return (x:xs) } + +{- +Note: [sequence and mapM] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Originally, we defined + +mapM f = sequence . map f + +This relied on list fusion to produce efficient code for mapM, and led to +excessive allocation in cryptarithm2. Defining + +sequence = mapM id + +relies only on inlining a tiny function (id) and beta reduction, which tends to +be a more reliable aspect of simplification. Indeed, this does not lead to +similar problems in nofib. +-} -- | Promote a function to a monad. liftM :: (Monad m) => (a1 -> r) -> m a1 -> m r @@ -667,16 +709,27 @@ instance MonadPlus Maybe -- The list type instance Functor [] where + {-# INLINE fmap #-} fmap = map +-- See Note: [List comprehensions and inlining] instance Applicative [] where - pure = return - (<*>) = ap - -instance Monad [] where - m >>= k = foldr ((++) . k) [] m - m >> k = foldr ((++) . (\ _ -> k)) [] m + {-# INLINE pure #-} + pure x = [x] + {-# INLINE (<*>) #-} + fs <*> xs = [f x | f <- fs, x <- xs] + {-# INLINE (*>) #-} + xs *> ys = [y | _ <- xs, y <- ys] + +-- See Note: [List comprehensions and inlining] +instance Monad [] where + {-# INLINE (>>=) #-} + xs >>= f = [y | x <- xs, y <- f x] + {-# INLINE (>>) #-} + (>>) = (*>) + {-# INLINE return #-} return x = [x] + {-# INLINE fail #-} fail _ = [] instance Alternative [] where @@ -827,9 +880,8 @@ mapFB c f = \x ys -> c (f x) ys "mapFB" forall c f g. mapFB (mapFB c f) g = mapFB c (f.g) #-} --- There's also a rule for Map and Data.Coerce. See "Safe Coercions", --- section 6.4: --- +-- See Breitner, Eisenberg, Peyton Jones, and Weirich, "Safe Zero-cost +-- Coercions for Haskell", section 6.5: -- http://research.microsoft.com/en-us/um/people/simonpj/papers/ext-f/coercible.pdf {-# RULES "map/coerce" [1] map coerce = coerce #-} @@ -977,7 +1029,10 @@ flip f x y = f y x ($) :: (a -> b) -> a -> b f $ x = f x --- | Strict (call-by-value) application, defined in terms of 'seq'. +-- | Strict (call-by-value) application operator. It takes a function and an +-- argument, evaluates the argument to weak head normal form (WHNF), then calls +-- the function with that value. + ($!) :: (a -> b) -> a -> b f $! x = let !vx = x in f vx -- see #2273 diff --git a/libraries/base/GHC/Conc.hs b/libraries/base/GHC/Conc.hs index f1708b33d4..68182a11e4 100644 --- a/libraries/base/GHC/Conc.hs +++ b/libraries/base/GHC/Conc.hs @@ -59,6 +59,12 @@ module GHC.Conc , threadWaitWriteSTM , closeFdWith + -- * Allocation counter and limit + , setAllocationCounter + , getAllocationCounter + , enableAllocationLimit + , disableAllocationLimit + -- * TVars , STM(..) , atomically diff --git a/libraries/base/GHC/Conc/Sync.hs b/libraries/base/GHC/Conc/Sync.hs index 6d2e772b5a..777fb71e20 100644 --- a/libraries/base/GHC/Conc/Sync.hs +++ b/libraries/base/GHC/Conc/Sync.hs @@ -60,6 +60,12 @@ module GHC.Conc.Sync , threadStatus , threadCapability + -- * Allocation counter and quota + , setAllocationCounter + , getAllocationCounter + , enableAllocationLimit + , disableAllocationLimit + -- * TVars , STM(..) , atomically @@ -171,16 +177,92 @@ instance Eq ThreadId where instance Ord ThreadId where compare = cmpThread +-- | Every thread has an allocation counter that tracks how much +-- memory has been allocated by the thread. The counter is +-- initialized to zero, and 'setAllocationCounter' sets the current +-- value. The allocation counter counts *down*, so in the absence of +-- a call to 'setAllocationCounter' its value is the negation of the +-- number of bytes of memory allocated by the thread. +-- +-- There are two things that you can do with this counter: +-- +-- * Use it as a simple profiling mechanism, with +-- 'getAllocationCounter'. +-- +-- * Use it as a resource limit. See 'enableAllocationLimit'. +-- +-- Allocation accounting is accurate only to about 4Kbytes. +-- +setAllocationCounter :: Int64 -> IO () +setAllocationCounter i = do + ThreadId t <- myThreadId + rts_setThreadAllocationCounter t i + +-- | Return the current value of the allocation counter for the +-- current thread. +getAllocationCounter :: IO Int64 +getAllocationCounter = do + ThreadId t <- myThreadId + rts_getThreadAllocationCounter t + +-- | Enables the allocation counter to be treated as a limit for the +-- current thread. When the allocation limit is enabled, if the +-- allocation counter counts down below zero, the thread will be sent +-- the 'AllocationLimitExceeded' asynchronous exception. When this +-- happens, the counter is reinitialised (by default +-- to 100K, but tunable with the @+RTS -xq@ option) so that it can handle +-- the exception and perform any necessary clean up. If it exhausts +-- this additional allowance, another 'AllocationLimitExceeded' exception +-- is sent, and so forth. +-- +-- Note that memory allocation is unrelated to /live memory/, also +-- known as /heap residency/. A thread can allocate a large amount of +-- memory and retain anything between none and all of it. It is +-- better to think of the allocation limit as a limit on +-- /CPU time/, rather than a limit on memory. +-- +-- Compared to using timeouts, allocation limits don't count time +-- spent blocked or in foreign calls. +-- +enableAllocationLimit :: IO () +enableAllocationLimit = do + ThreadId t <- myThreadId + rts_enableThreadAllocationLimit t + +-- | Disable allocation limit processing for the current thread. +disableAllocationLimit :: IO () +disableAllocationLimit = do + ThreadId t <- myThreadId + rts_disableThreadAllocationLimit t + +-- We cannot do these operations safely on another thread, because on +-- a 32-bit machine we cannot do atomic operations on a 64-bit value. +-- Therefore, we only expose APIs that allow getting and setting the +-- limit of the current thread. +foreign import ccall unsafe "rts_setThreadAllocationCounter" + rts_setThreadAllocationCounter :: ThreadId# -> Int64 -> IO () + +foreign import ccall unsafe "rts_getThreadAllocationCounter" + rts_getThreadAllocationCounter :: ThreadId# -> IO Int64 + +foreign import ccall unsafe "rts_enableThreadAllocationLimit" + rts_enableThreadAllocationLimit :: ThreadId# -> IO () + +foreign import ccall unsafe "rts_disableThreadAllocationLimit" + rts_disableThreadAllocationLimit :: ThreadId# -> IO () + {- | -Sparks off a new thread to run the 'IO' computation passed as the +Creates a new thread to run the 'IO' computation passed as the first argument, and returns the 'ThreadId' of the newly created thread. -The new thread will be a lightweight thread; if you want to use a foreign -library that uses thread-local storage, use 'Control.Concurrent.forkOS' instead. +The new thread will be a lightweight, /unbound/ thread. Foreign calls +made by this thread are not guaranteed to be made by any particular OS +thread; if you need foreign calls to be made by a particular OS +thread, then use 'Control.Concurrent.forkOS' instead. -GHC note: the new thread inherits the /masked/ state of the parent -(see 'Control.Exception.mask'). +The new thread inherits the /masked/ state of the parent (see +'Control.Exception.mask'). The newly created thread has an exception handler that discards the exceptions 'BlockedIndefinitelyOnMVar', 'BlockedIndefinitelyOnSTM', and diff --git a/libraries/base/GHC/Event/TimerManager.hs b/libraries/base/GHC/Event/TimerManager.hs index bf6339a4d8..c1ab64c7a9 100644 --- a/libraries/base/GHC/Event/TimerManager.hs +++ b/libraries/base/GHC/Event/TimerManager.hs @@ -81,32 +81,6 @@ data State = Created -- | A priority search queue, with timeouts as priorities. type TimeoutQueue = Q.PSQ TimeoutCallback -{- -Instead of directly modifying the 'TimeoutQueue' in -e.g. 'registerTimeout' we keep a list of edits to perform, in the form -of a chain of function closures, and have the I/O manager thread -perform the edits later. This exist to address the following GC -problem: - -Since e.g. 'registerTimeout' doesn't force the evaluation of the -thunks inside the 'emTimeouts' IORef a number of thunks build up -inside the IORef. If the I/O manager thread doesn't evaluate these -thunks soon enough they'll get promoted to the old generation and -become roots for all subsequent minor GCs. - -When the thunks eventually get evaluated they will each create a new -intermediate 'TimeoutQueue' that immediately becomes garbage. Since -the thunks serve as roots until the next major GC these intermediate -'TimeoutQueue's will get copied unnecessarily in the next minor GC, -increasing GC time. This problem is known as "floating garbage". - -Keeping a list of edits doesn't stop this from happening but makes the -amount of data that gets copied smaller. - -TODO: Evaluate the content of the IORef to WHNF on each insert once -this bug is resolved: http://ghc.haskell.org/trac/ghc/ticket/3838 --} - -- | An edit to apply to a 'TimeoutQueue'. type TimeoutEdit = TimeoutQueue -> TimeoutQueue diff --git a/libraries/base/GHC/IO/Exception.hs b/libraries/base/GHC/IO/Exception.hs index 0f351f0382..d0a21b2744 100644 --- a/libraries/base/GHC/IO/Exception.hs +++ b/libraries/base/GHC/IO/Exception.hs @@ -22,6 +22,7 @@ module GHC.IO.Exception ( BlockedIndefinitelyOnMVar(..), blockedIndefinitelyOnMVar, BlockedIndefinitelyOnSTM(..), blockedIndefinitelyOnSTM, Deadlock(..), + AllocationLimitExceeded(..), allocationLimitExceeded, AssertionFailed(..), SomeAsyncException(..), @@ -98,6 +99,23 @@ instance Show Deadlock where ----- +-- |This thread has exceeded its allocation limit. See +-- 'GHC.Conc.setAllocationCounter' and +-- 'GHC.Conc.enableAllocationLimit'. +data AllocationLimitExceeded = AllocationLimitExceeded + deriving Typeable + +instance Exception AllocationLimitExceeded + +instance Show AllocationLimitExceeded where + showsPrec _ AllocationLimitExceeded = + showString "allocation limit exceeded" + +allocationLimitExceeded :: SomeException -- for the RTS +allocationLimitExceeded = toException AllocationLimitExceeded + +----- + -- |'assert' was applied to 'False'. data AssertionFailed = AssertionFailed String deriving Typeable @@ -174,7 +192,8 @@ data ArrayException instance Exception ArrayException -stackOverflow, heapOverflow :: SomeException -- for the RTS +-- for the RTS +stackOverflow, heapOverflow :: SomeException stackOverflow = toException StackOverflow heapOverflow = toException HeapOverflow diff --git a/libraries/base/GHC/Real.hs b/libraries/base/GHC/Real.hs index dd806bc561..2b5f6cc78d 100644 --- a/libraries/base/GHC/Real.hs +++ b/libraries/base/GHC/Real.hs @@ -27,7 +27,11 @@ import GHC.Show import {-# SOURCE #-} GHC.Exception( divZeroException, overflowException, ratioZeroDenomException ) #ifdef OPTIMISE_INTEGER_GCD_LCM +# if defined(MIN_VERSION_integer_gmp) || defined(MIN_VERSION_integer_gmp2) import GHC.Integer.GMP.Internals +# else +# error unsupported OPTIMISE_INTEGER_GCD_LCM configuration +# endif #endif infixr 8 ^, ^^ diff --git a/libraries/base/base.cabal b/libraries/base/base.cabal index 6277d89e79..c3f4d28a1e 100644 --- a/libraries/base/base.cabal +++ b/libraries/base/base.cabal @@ -44,6 +44,18 @@ source-repository head Flag integer-simple Description: Use integer-simple + Manual: True + Default: False + +Flag integer-gmp + Description: Use integer-gmp + Manual: True + Default: False + +Flag integer-gmp2 + Description: Use integer-gmp2 + Manual: True + Default: False Library default-language: Haskell2010 @@ -90,10 +102,15 @@ Library build-depends: rts == 1.0.*, ghc-prim >= 0.3.1 && < 0.4 if flag(integer-simple) build-depends: integer-simple >= 0.1.1 && < 0.2 - else + + if flag(integer-gmp) build-depends: integer-gmp >= 0.5.1 && < 0.6 cpp-options: -DOPTIMISE_INTEGER_GCD_LCM + if flag(integer-gmp2) + build-depends: integer-gmp >= 1.0 && < 1.1 + cpp-options: -DOPTIMISE_INTEGER_GCD_LCM + exposed-modules: Control.Applicative Control.Arrow @@ -130,6 +147,7 @@ Library Data.Foldable Data.Function Data.Functor + Data.Functor.Identity Data.IORef Data.Int Data.Ix diff --git a/libraries/base/changelog.md b/libraries/base/changelog.md index 2fa25ae06e..c5047ce986 100644 --- a/libraries/base/changelog.md +++ b/libraries/base/changelog.md @@ -97,6 +97,9 @@ are swapped, such that `Data.List.nubBy (<) [1,2]` now returns `[1]` instead of `[1,2]` (#2528, #3280, #7913) + * New module `Data.Functor.Identity` (previously provided by `transformers` + package). (#9664) + ## 4.7.0.1 *Jul 2014* * Bundled with GHC 7.8.3 diff --git a/libraries/base/tests/all.T b/libraries/base/tests/all.T index d4005b7d1e..fa8ecd3d47 100644 --- a/libraries/base/tests/all.T +++ b/libraries/base/tests/all.T @@ -83,6 +83,7 @@ test('enum03', when(fast(), skip), compile_and_run, ['-cpp']) test('enum04', normal, compile_and_run, ['']) test('exceptionsrun001', normal, compile_and_run, ['']) test('exceptionsrun002', normal, compile_and_run, ['']) +test('foldableArray', normal, compile_and_run, ['']) test('list001' , when(fast(), skip), compile_and_run, ['']) test('list002', when(fast(), skip), compile_and_run, ['']) test('list003', when(fast(), skip), compile_and_run, ['']) diff --git a/libraries/base/tests/foldableArray.hs b/libraries/base/tests/foldableArray.hs new file mode 100644 index 0000000000..5a5041f102 --- /dev/null +++ b/libraries/base/tests/foldableArray.hs @@ -0,0 +1,129 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} +module Main where +import Prelude hiding (foldr, foldl, foldl', foldr1, foldl1, length, null, sum, + product, all, any, and, or) +import Data.Foldable +import Control.Exception +import Data.Array +import Data.Foldable +import Data.Typeable +import Data.Either +import Control.Applicative +import Control.DeepSeq +#if __GLASGOW_HASKELL__ < 709 +import qualified Data.List as L +#else +import qualified Data.OldList as L +#endif + +data BadElementException = BadFirst | BadLast deriving (Show, Typeable, Eq) +instance Exception BadElementException + +newtype ForceDefault f a = ForceDefault (f a) +instance Foldable f => Foldable (ForceDefault f) where + foldMap f (ForceDefault c) = foldMap f c + +goodLists, badFronts, badBacks :: [[Integer]] +goodLists = [[0..n] | n <- [(-1)..5]] +badFronts = map (throw BadFirst :) goodLists +badBacks = map (++ [throw BadLast]) goodLists +doubleBads = map (\l -> throw BadFirst : l ++ [throw BadLast]) goodLists +lists = + goodLists + ++ badFronts + ++ badBacks + ++ doubleBads + +makeArray xs = array (1::Int, length xs) (zip [1..] xs) + +arrays = map makeArray lists +goodArrays = map makeArray goodLists + + +strictCons x y = x + 10*y +rightLazyCons x y = x +leftLazyCons x y = y + +conses :: [Integer -> Integer -> Integer] +conses = [(+), strictCons, rightLazyCons, leftLazyCons] + +runOneRight :: forall f . Foldable f => + (forall a b . (a -> b -> b) -> b -> f a -> b) -> + (Integer -> Integer -> Integer) -> f Integer -> + IO (Either BadElementException Integer) +runOneRight fol f container = try (evaluate (fol f 12 container)) + +runOne1 :: forall f . Foldable f => (forall a . (a -> a -> a) -> f a -> a) -> + (Integer -> Integer -> Integer) -> f Integer -> + IO (Either BadElementException Integer) +runOne1 fol f container = try (evaluate (fol f container)) + +runOneLeft :: forall f . Foldable f => + (forall a b . (b -> a -> b) -> b -> f a -> b) -> + (Integer -> Integer -> Integer) -> f Integer -> + IO (Either BadElementException Integer) +runOneLeft fol f container = try (evaluate (fol f 13 container)) + +runWithAllRight :: forall f . Foldable f => + (forall a b . (a -> b -> b) -> b -> f a -> b) -> + [f Integer] -> IO [Either BadElementException Integer] +runWithAllRight fol containers = + mapM (uncurry (runOneRight fol)) [(f,c) | f <- conses, c <- containers] + +runWithAll1 :: forall f . Foldable f => + (forall a . (a -> a -> a) -> f a -> a) -> + [f Integer] -> IO [Either BadElementException Integer] +runWithAll1 fol containers = + mapM (uncurry (runOne1 fol)) [(f,c) | f <- conses, c <- containers] + +runWithAllLeft :: forall f . Foldable f => + (forall a b . (b -> a -> b) -> b -> f a -> b) -> + [f Integer] -> IO [Either BadElementException Integer] +runWithAllLeft fol containers = mapM (uncurry (runOneLeft fol)) + [(f,c) | f <- map flip conses, c <- containers] + +testWithAllRight :: forall f . Foldable f => + (forall a b . (a -> b -> b) -> b -> f a -> b) -> + (forall a b . (a -> b -> b) -> b -> ForceDefault f a -> b) -> + [f Integer] -> IO Bool +testWithAllRight fol1 fol2 containers = (==) <$> + runWithAllRight fol1 containers <*> + runWithAllRight fol2 (map ForceDefault containers) + +testWithAllLeft :: forall f . Foldable f => + (forall a b . (b -> a -> b) -> b -> f a -> b) -> + (forall a b . (b -> a -> b) -> b -> ForceDefault f a -> b) -> + [f Integer] -> IO Bool +testWithAllLeft fol1 fol2 containers = (==) <$> + runWithAllLeft fol1 containers <*> + runWithAllLeft fol2 (map ForceDefault containers) + + +testWithAll1 :: forall f . Foldable f => + (forall a . (a -> a -> a) -> f a -> a) -> + (forall a . (a -> a -> a) -> ForceDefault f a -> a) -> + [f Integer] -> IO Bool +testWithAll1 fol1 fol2 containers = + (==) <$> runWithAll1 fol1 containers + <*> runWithAll1 fol2 (map ForceDefault containers) + +checkup f g cs = map f cs == map g (map ForceDefault cs) + +main = do + testWithAllRight foldr foldr arrays >>= print + testWithAllRight foldr' foldr' arrays >>= print + testWithAllLeft foldl foldl arrays >>= print + testWithAllLeft foldl' foldl' arrays >>= print + testWithAll1 foldl1 foldl1 (filter (not . null) arrays) >>= print + testWithAll1 foldr1 foldr1 (filter (not . null) arrays) >>= print + -- we won't bother with the fancy laziness tests for the rest + print $ checkup length length goodArrays + print $ checkup sum sum goodArrays + print $ checkup product product goodArrays + print $ checkup maximum maximum $ filter (not . null) goodArrays + print $ checkup minimum minimum $ filter (not . null) goodArrays + print $ checkup toList toList goodArrays + print $ checkup null null arrays diff --git a/libraries/base/tests/foldableArray.stdout b/libraries/base/tests/foldableArray.stdout new file mode 100644 index 0000000000..50aa4a9638 --- /dev/null +++ b/libraries/base/tests/foldableArray.stdout @@ -0,0 +1,13 @@ +True +True +True +True +True +True +True +True +True +True +True +True +True diff --git a/libraries/bin-package-db/GHC/PackageDb.hs b/libraries/bin-package-db/GHC/PackageDb.hs index 76fa697990..e1715e69e5 100644 --- a/libraries/bin-package-db/GHC/PackageDb.hs +++ b/libraries/bin-package-db/GHC/PackageDb.hs @@ -37,7 +37,8 @@ -- module GHC.PackageDb ( InstalledPackageInfo(..), - ModuleExport(..), + ExposedModule(..), + OriginalModule(..), BinaryStringRep(..), emptyInstalledPackageInfo, readPackageDbForGhc, @@ -86,26 +87,58 @@ data InstalledPackageInfo instpkgid srcpkgid srcpkgname pkgkey modulename includeDirs :: [FilePath], haddockInterfaces :: [FilePath], haddockHTMLs :: [FilePath], - exposedModules :: [modulename], + exposedModules :: [ExposedModule instpkgid modulename], hiddenModules :: [modulename], - reexportedModules :: [ModuleExport instpkgid modulename], exposed :: Bool, trusted :: Bool } deriving (Eq, Show) -class BinaryStringRep a where - fromStringRep :: BS.ByteString -> a - toStringRep :: a -> BS.ByteString +-- | An original module is a fully-qualified module name (installed package ID +-- plus module name) representing where a module was *originally* defined +-- (i.e., the 'exposedReexport' field of the original ExposedModule entry should +-- be 'Nothing'). Invariant: an OriginalModule never points to a reexport. +data OriginalModule instpkgid modulename + = OriginalModule { + originalPackageId :: instpkgid, + originalModuleName :: modulename + } + deriving (Eq, Show) -data ModuleExport instpkgid modulename - = ModuleExport { - exportModuleName :: modulename, - exportOriginalPackageId :: instpkgid, - exportOriginalModuleName :: modulename +-- | Represents a module name which is exported by a package, stored in the +-- 'exposedModules' field. A module export may be a reexport (in which +-- case 'exposedReexport' is filled in with the original source of the module), +-- and may be a signature (in which case 'exposedSignature is filled in with +-- what the signature was compiled against). Thus: +-- +-- * @ExposedModule n Nothing Nothing@ represents an exposed module @n@ which +-- was defined in this package. +-- +-- * @ExposedModule n (Just o) Nothing@ represents a reexported module @n@ +-- which was originally defined in @o@. +-- +-- * @ExposedModule n Nothing (Just s)@ represents an exposed signature @n@ +-- which was compiled against the implementation @s@. +-- +-- * @ExposedModule n (Just o) (Just s)@ represents a reexported signature +-- which was originally defined in @o@ and was compiled against the +-- implementation @s@. +-- +-- We use two 'Maybe' data types instead of an ADT with four branches or +-- four fields because this representation allows us to treat +-- reexports/signatures uniformly. +data ExposedModule instpkgid modulename + = ExposedModule { + exposedName :: modulename, + exposedReexport :: Maybe (OriginalModule instpkgid modulename), + exposedSignature :: Maybe (OriginalModule instpkgid modulename) } deriving (Eq, Show) +class BinaryStringRep a where + fromStringRep :: BS.ByteString -> a + toStringRep :: a -> BS.ByteString + emptyInstalledPackageInfo :: (BinaryStringRep a, BinaryStringRep b, BinaryStringRep c, BinaryStringRep d) => InstalledPackageInfo a b c d e @@ -132,7 +165,6 @@ emptyInstalledPackageInfo = haddockHTMLs = [], exposedModules = [], hiddenModules = [], - reexportedModules = [], exposed = False, trusted = False } @@ -288,7 +320,7 @@ instance (BinaryStringRep a, BinaryStringRep b, BinaryStringRep c, ldOptions ccOptions includes includeDirs haddockInterfaces haddockHTMLs - exposedModules hiddenModules reexportedModules + exposedModules hiddenModules exposed trusted) = do put (toStringRep installedPackageId) put (toStringRep sourcePackageId) @@ -309,9 +341,8 @@ instance (BinaryStringRep a, BinaryStringRep b, BinaryStringRep c, put includeDirs put haddockInterfaces put haddockHTMLs - put (map toStringRep exposedModules) + put exposedModules put (map toStringRep hiddenModules) - put reexportedModules put exposed put trusted @@ -337,7 +368,6 @@ instance (BinaryStringRep a, BinaryStringRep b, BinaryStringRep c, haddockHTMLs <- get exposedModules <- get hiddenModules <- get - reexportedModules <- get exposed <- get trusted <- get return (InstalledPackageInfo @@ -352,9 +382,8 @@ instance (BinaryStringRep a, BinaryStringRep b, BinaryStringRep c, ldOptions ccOptions includes includeDirs haddockInterfaces haddockHTMLs - (map fromStringRep exposedModules) + exposedModules (map fromStringRep hiddenModules) - reexportedModules exposed trusted) instance Binary Version where @@ -367,15 +396,26 @@ instance Binary Version where return (Version a b) instance (BinaryStringRep a, BinaryStringRep b) => - Binary (ModuleExport a b) where - put (ModuleExport a b c) = do - put (toStringRep a) - put (toStringRep b) - put (toStringRep c) + Binary (OriginalModule a b) where + put (OriginalModule originalPackageId originalModuleName) = do + put (toStringRep originalPackageId) + put (toStringRep originalModuleName) get = do - a <- get - b <- get - c <- get - return (ModuleExport (fromStringRep a) - (fromStringRep b) - (fromStringRep c)) + originalPackageId <- get + originalModuleName <- get + return (OriginalModule (fromStringRep originalPackageId) + (fromStringRep originalModuleName)) + +instance (BinaryStringRep a, BinaryStringRep b) => + Binary (ExposedModule a b) where + put (ExposedModule exposedName exposedReexport exposedSignature) = do + put (toStringRep exposedName) + put exposedReexport + put exposedSignature + get = do + exposedName <- get + exposedReexport <- get + exposedSignature <- get + return (ExposedModule (fromStringRep exposedName) + exposedReexport + exposedSignature) diff --git a/libraries/bytestring b/libraries/bytestring -Subproject 6ad8c0d27bcff28c80684a29b57d7a8dbf00cac +Subproject 7a7602a142a1deae2e4f73782d88a91f39a0fa9 diff --git a/libraries/containers b/libraries/containers -Subproject 530fc76bdd17089fcaaa655d66156abbc2092c2 +Subproject c802c36dbed4b800d8c2131181f5af3db837ade diff --git a/libraries/deepseq b/libraries/deepseq -Subproject 3815fe819ba465159cc618b3521adcba97e3c0d +Subproject 75ce5767488774065025df34cbc80de6f03c4fd diff --git a/libraries/haskell2010 b/libraries/haskell2010 -Subproject 425df1d9ea7adcf823bbb5426528bd80eb2b820 +Subproject a21abff3e385a85e1353aa720516e148865710a diff --git a/libraries/haskell98 b/libraries/haskell98 -Subproject 401283a98a818f66f856939f939562de5c4a2b4 +Subproject cf064d954c511a2edddb5a55a1984d57ce36c40 diff --git a/libraries/hoopl b/libraries/hoopl -Subproject 7f06b16ba3a49c2c927fb06fe7dc89089dd7e29 +Subproject a90a3af92be400af8912555bce21b041a1c48ad diff --git a/libraries/hpc b/libraries/hpc -Subproject d430be4664aac337cd0e49dd6b69e818f21cde6 +Subproject 60e7bbfeea8ba54688b8f432f0f337b275f06c5 diff --git a/libraries/integer-gmp2/.gitignore b/libraries/integer-gmp2/.gitignore new file mode 100644 index 0000000000..98b7b18898 --- /dev/null +++ b/libraries/integer-gmp2/.gitignore @@ -0,0 +1,13 @@ +/GNUmakefile +/autom4te.cache/ +/config.log +/config.status +/configure +/dist-install/ +/ghc.mk +/gmp/config.mk +/include/HsIntegerGmp.h +/integer-gmp.buildinfo + +/gmp/gmp.h +/gmp/gmpbuild diff --git a/libraries/integer-gmp2/LICENSE b/libraries/integer-gmp2/LICENSE new file mode 100644 index 0000000000..0ce51e0bd0 --- /dev/null +++ b/libraries/integer-gmp2/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2014, Herbert Valerio Riedel + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * 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. + + * Neither the name of Herbert Valerio Riedel nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"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 +OWNER OR CONTRIBUTORS 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. diff --git a/libraries/integer-gmp2/Setup.hs b/libraries/integer-gmp2/Setup.hs new file mode 100644 index 0000000000..54f57d6f11 --- /dev/null +++ b/libraries/integer-gmp2/Setup.hs @@ -0,0 +1,6 @@ +module Main (main) where + +import Distribution.Simple + +main :: IO () +main = defaultMainWithHooks autoconfUserHooks diff --git a/libraries/integer-gmp2/aclocal.m4 b/libraries/integer-gmp2/aclocal.m4 new file mode 100644 index 0000000000..be248615f5 --- /dev/null +++ b/libraries/integer-gmp2/aclocal.m4 @@ -0,0 +1,44 @@ + +dnl-------------------------------------------------------------------- +dnl * Check whether this machine has gmp/gmp3 installed +dnl-------------------------------------------------------------------- + +AC_DEFUN([LOOK_FOR_GMP_LIB],[ + if test "$HaveFrameworkGMP" = "NO" + then + AC_CHECK_LIB([gmp], [__gmpz_powm], + [HaveLibGmp=YES; GMP_LIBS=gmp]) + if test "$HaveLibGmp" = "NO" + then + AC_CHECK_LIB([gmp3], [__gmpz_powm], + [HaveLibGmp=YES; GMP_LIBS=gmp3]) + fi + if test "$HaveLibGmp" = "YES" + then + AC_CHECK_LIB([$GMP_LIBS], [__gmpz_powm_sec], + [HaveSecurePowm=1]) + fi + fi +]) + +dnl-------------------------------------------------------------------- +dnl * Mac OS X only: check for GMP.framework +dnl-------------------------------------------------------------------- + +AC_DEFUN([LOOK_FOR_GMP_FRAMEWORK],[ + if test "$HaveLibGmp" = "NO" + then + case $target_os in + darwin*) + AC_MSG_CHECKING([for GMP.framework]) + save_libs="$LIBS" + LIBS="-framework GMP" + AC_TRY_LINK_FUNC(__gmpz_powm_sec, + [HaveFrameworkGMP=YES; GMP_FRAMEWORK=GMP]) + LIBS="$save_libs" + AC_MSG_RESULT([$HaveFrameworkGMP]) + ;; + esac + fi +]) + diff --git a/libraries/integer-gmp2/cbits/wrappers.c b/libraries/integer-gmp2/cbits/wrappers.c new file mode 100644 index 0000000000..930f5b8508 --- /dev/null +++ b/libraries/integer-gmp2/cbits/wrappers.c @@ -0,0 +1,290 @@ +#define _ISOC99_SOURCE + +#include <assert.h> +#include <stdbool.h> +#include <stdlib.h> +#include <stdint.h> +#include <string.h> +#include <math.h> +#include <float.h> +#include <stdio.h> + +#include <gmp.h> + +#include "HsFFI.h" +#include "MachDeps.h" + +// GMP 4.x compatibility +#if !defined(__GNU_MP_VERSION) +# error __GNU_MP_VERSION not defined +#elif __GNU_MP_VERSION < 4 +# error need GMP 4.0 or later +#elif __GNU_MP_VERSION < 5 +typedef unsigned long int mp_bitcnt_t; +#endif + +#if (GMP_NUMB_BITS) != (GMP_LIMB_BITS) +# error GMP_NUMB_BITS != GMP_LIMB_BITS not supported +#endif + +#if (WORD_SIZE_IN_BITS) != (GMP_LIMB_BITS) +# error WORD_SIZE_IN_BITS != GMP_LIMB_BITS not supported +#endif + +// sanity check +#if (SIZEOF_HSWORD*8) != WORD_SIZE_IN_BITS +# error (SIZEOF_HSWORD*8) != WORD_SIZE_IN_BITS +#endif + +/* Perform arithmetic right shift on MPNs (multi-precision naturals) + * + * pre-conditions: + * - 0 < count < sn*GMP_NUMB_BITS + * - rn = sn - floor(count / GMP_NUMB_BITS) + * - sn > 0 + * + * write {sp,sn} right-shifted by count bits into {rp,rn} + * + * return value: most-significant limb stored in {rp,rn} result + */ +mp_limb_t +integer_gmp_mpn_rshift (mp_limb_t rp[], const mp_limb_t sp[], mp_size_t sn, + mp_bitcnt_t count) +{ + const mp_size_t limb_shift = count / GMP_NUMB_BITS; + const unsigned int bit_shift = count % GMP_NUMB_BITS; + const mp_size_t rn = sn - limb_shift; + + if (bit_shift) + mpn_rshift(rp, &sp[limb_shift], rn, bit_shift); + else + memcpy(rp, &sp[limb_shift], rn*sizeof(mp_limb_t)); + + return rp[rn-1]; +} + +/* Twos-complement version of 'integer_gmp_mpn_rshift' for performing + * arithmetic right shifts on "negative" MPNs. + * + * Same pre-conditions as 'integer_gmp_mpn_rshift' + * + * This variant is needed to operate on MPNs interpreted as negative + * numbers, which require "rounding" towards minus infinity iff a + * non-zero bit is shifted out. + */ +mp_limb_t +integer_gmp_mpn_rshift_2c (mp_limb_t rp[], const mp_limb_t sp[], + const mp_size_t sn, const mp_bitcnt_t count) +{ + const mp_size_t limb_shift = count / GMP_NUMB_BITS; + const unsigned int bit_shift = count % GMP_NUMB_BITS; + const mp_size_t rn = sn - limb_shift; + + // whether non-zero bits were shifted out + bool nz_shift_out = false; + + if (bit_shift) { + if (mpn_rshift(rp, &sp[limb_shift], rn, bit_shift)) + nz_shift_out = true; + } else + memcpy(rp, &sp[limb_shift], rn*sizeof(mp_limb_t)); + + if (!nz_shift_out) + for (unsigned i = 0; i < limb_shift; i++) + if (sp[i]) { + nz_shift_out = true; + break; + } + + // round if non-zero bits were shifted out + if (nz_shift_out) + if (mpn_add_1(rp, rp, rn, 1)) + abort(); /* should never happen */ + + return rp[rn-1]; +} + +/* Perform left-shift operation on MPN + * + * pre-conditions: + * - 0 < count + * - rn = sn + ceil(count / GMP_NUMB_BITS) + * - sn > 0 + * + * return value: most-significant limb stored in {rp,rn} result + */ +mp_limb_t +integer_gmp_mpn_lshift (mp_limb_t rp[], const mp_limb_t sp[], + const mp_size_t sn, const mp_bitcnt_t count) +{ + const mp_size_t limb_shift = count / GMP_NUMB_BITS; + const unsigned int bit_shift = count % GMP_NUMB_BITS; + const mp_size_t rn0 = sn + limb_shift; + + memset(rp, 0, limb_shift*sizeof(mp_limb_t)); + if (bit_shift) { + const mp_limb_t msl = mpn_lshift(&rp[limb_shift], sp, sn, bit_shift); + rp[rn0] = msl; + return msl; + } else { + memcpy(&rp[limb_shift], sp, sn*sizeof(mp_limb_t)); + return rp[rn0-1]; + } +} + +/* + * + * sign of mp_size_t argument controls sign of converted double + */ +HsDouble +integer_gmp_mpn_get_d (const mp_limb_t sp[], const mp_size_t sn, + const HsInt exponent) +{ + if (sn == 0) + return 0.0; // should not happen + + if (sn == 1 && sp[0] == 0) + return 0.0; + + __mpz_struct const mpz = { + ._mp_alloc = abs(sn), + ._mp_size = sn, + ._mp_d = (mp_limb_t*)sp + }; + + if (!exponent) + return mpz_get_d(&mpz); + + long e = 0; + double d = mpz_get_d_2exp (&e, &mpz); + + // TODO: over/underflow handling? + return ldexp(d, e+exponent); +} + +mp_limb_t +integer_gmp_gcd_word(const mp_limb_t x, const mp_limb_t y) +{ + if (!x) return y; + if (!y) return x; + + return mpn_gcd_1(&x, 1, y); +} + +mp_limb_t +integer_gmp_mpn_gcd_1(const mp_limb_t x[], const mp_size_t xn, + const mp_limb_t y) +{ + assert (xn > 0); + assert (xn == 1 || y != 0); + + if (xn == 1) + return integer_gmp_gcd_word(x[0], y); + + return mpn_gcd_1(x, xn, y); +} + + +mp_size_t +integer_gmp_mpn_gcd(mp_limb_t r[], + const mp_limb_t x0[], const mp_size_t xn, + const mp_limb_t y0[], const mp_size_t yn) +{ + assert (xn >= yn); + assert (yn > 0); + assert (xn == yn || yn > 1 || y0[0] != 0); + /* post-condition: rn <= xn */ + + if (yn == 1) { + if (y0[0]) { + r[0] = integer_gmp_mpn_gcd_1(x0, xn, y0[0]); + return 1; + } else { /* {y0,yn} == 0 */ + assert (xn==yn); /* NB: redundant assertion */ + memcpy(r, x0, xn*sizeof(mp_limb_t)); + return xn; + } + } else { + // mpn_gcd() seems to require non-trivial normalization of its + // input arguments (which does not seem to be documented anywhere, + // see source of mpz_gcd() for more details), so we resort to just + // use mpz_gcd() which does the tiresome normalization for us at + // the cost of a few additional temporary buffer allocations in + // C-land. + + const mpz_t op1 = {{ + ._mp_alloc = xn, + ._mp_size = xn, + ._mp_d = (mp_limb_t*)x0 + }}; + + const mpz_t op2 = {{ + ._mp_alloc = yn, + ._mp_size = yn, + ._mp_d = (mp_limb_t*)y0 + }}; + + mpz_t rop; + mpz_init (rop); + + mpz_gcd(rop, op1, op2); + + const mp_size_t rn = rop[0]._mp_size; + assert(rn > 0); + assert(rn <= xn); + + /* the allocation/memcpy of the result can be neglectable since + mpz_gcd() already has to allocate other temporary buffers + anyway */ + memcpy(r, rop[0]._mp_d, rn*sizeof(mp_limb_t)); + + mpz_clear(rop); + + return rn; + } +} + +/* Truncating (i.e. rounded towards zero) integer division-quotient of MPN */ +void +integer_gmp_mpn_tdiv_q (mp_limb_t q[], + const mp_limb_t n[], const mp_size_t nn, + const mp_limb_t d[], const mp_size_t dn) +{ + /* qn = 1+nn-dn; rn = dn */ + assert(nn>=dn); + + if (dn > 128) { + // Use temporary heap allocated throw-away buffer for MPNs larger + // than 1KiB for 64bit-sized limbs (larger than 512bytes for + // 32bit-sized limbs) + mp_limb_t *const r = malloc(dn*sizeof(mp_limb_t)); + mpn_tdiv_qr(q, r, 0, n, nn, d, dn); + free (r); + } else { // allocate smaller arrays on the stack + mp_limb_t r[dn]; + mpn_tdiv_qr(q, r, 0, n, nn, d, dn); + } +} + +/* Truncating (i.e. rounded towards zero) integer division-remainder of MPNs */ +void +integer_gmp_mpn_tdiv_r (mp_limb_t r[], + const mp_limb_t n[], const mp_size_t nn, + const mp_limb_t d[], const mp_size_t dn) +{ + /* qn = 1+nn-dn; rn = dn */ + assert(nn>=dn); + const mp_size_t qn = 1+nn-dn; + + if (qn > 128) { + // Use temporary heap allocated throw-away buffer for MPNs larger + // than 1KiB for 64bit-sized limbs (larger than 512bytes for + // 32bit-sized limbs) + mp_limb_t *const q = malloc(qn*sizeof(mp_limb_t)); + mpn_tdiv_qr(q, r, 0, n, nn, d, dn); + free (q); + } else { // allocate smaller arrays on the stack + mp_limb_t q[qn]; + mpn_tdiv_qr(q, r, 0, n, nn, d, dn); + } +} diff --git a/libraries/integer-gmp2/changelog.md b/libraries/integer-gmp2/changelog.md new file mode 100644 index 0000000000..af3ac83e2b --- /dev/null +++ b/libraries/integer-gmp2/changelog.md @@ -0,0 +1,51 @@ +# Changelog for [`integer-gmp` package](http://hackage.haskell.org/package/integer-gmp) + +## 1.0.0.0 **TBA** + + * Bundled with GHC 7.10.1 + + * Complete rewrite of `integer-gmp`. For more details, see + https://ghc.haskell.org/trac/ghc/wiki/Design/IntegerGmp2 + +## 0.5.1.0 *Feb 2014* + + * Bundled with GHC 7.8.1 + + * Improved Haddock documentation + + * New [PrimBool](https://ghc.haskell.org/trac/ghc/wiki/PrimBool) + versions of comparison predicates in `GHC.Integer`: + + eqInteger# :: Integer -> Integer -> Int# + geInteger# :: Integer -> Integer -> Int# + gtInteger# :: Integer -> Integer -> Int# + leInteger# :: Integer -> Integer -> Int# + ltInteger# :: Integer -> Integer -> Int# + neqInteger# :: Integer -> Integer -> Int# + + * New `GHC.Integer.testBitInteger` primitive for use with `Data.Bits` + + * Reduce short-lived heap allocation and try to demote `J#` back + to `S#` more aggressively. See also + [#8647](https://ghc.haskell.org/trac/ghc/ticket/8647) + for more details. + + * New GMP-specific binary (de)serialization primitives added to + `GHC.Integer.GMP.Internals`: + + importIntegerFromByteArray + importIntegerFromAddr + exportIntegerToAddr + exportIntegerToMutableByteArray + sizeInBaseInteger + + * New GMP-implemented number-theoretic operations added to + `GHC.Integer.GMP.Internals`: + + gcdExtInteger + nextPrimeInteger + testPrimeInteger + powInteger + powModInteger + powModSecInteger + recipModInteger diff --git a/libraries/integer-gmp2/config.guess b/libraries/integer-gmp2/config.guess new file mode 100755 index 0000000000..1f5c50c0d1 --- /dev/null +++ b/libraries/integer-gmp2/config.guess @@ -0,0 +1,1420 @@ +#! /bin/sh +# Attempt to guess a canonical system name. +# Copyright 1992-2014 Free Software Foundation, Inc. + +timestamp='2014-03-23' + +# This file is free software; you can redistribute it and/or modify it +# under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 3 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, but +# WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +# General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, see <http://www.gnu.org/licenses/>. +# +# As a special exception to the GNU General Public License, if you +# distribute this file as part of a program that contains a +# configuration script generated by Autoconf, you may include it under +# the same distribution terms that you use for the rest of that +# program. This Exception is an additional permission under section 7 +# of the GNU General Public License, version 3 ("GPLv3"). +# +# Originally written by Per Bothner. +# +# You can get the latest version of this script from: +# http://git.savannah.gnu.org/gitweb/?p=config.git;a=blob_plain;f=config.guess;hb=HEAD +# +# Please send patches with a ChangeLog entry to config-patches@gnu.org. + + +me=`echo "$0" | sed -e 's,.*/,,'` + +usage="\ +Usage: $0 [OPTION] + +Output the configuration name of the system \`$me' is run on. + +Operation modes: + -h, --help print this help, then exit + -t, --time-stamp print date of last modification, then exit + -v, --version print version number, then exit + +Report bugs and patches to <config-patches@gnu.org>." + +version="\ +GNU config.guess ($timestamp) + +Originally written by Per Bothner. +Copyright 1992-2014 Free Software Foundation, Inc. + +This is free software; see the source for copying conditions. There is NO +warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE." + +help=" +Try \`$me --help' for more information." + +# Parse command line +while test $# -gt 0 ; do + case $1 in + --time-stamp | --time* | -t ) + echo "$timestamp" ; exit ;; + --version | -v ) + echo "$version" ; exit ;; + --help | --h* | -h ) + echo "$usage"; exit ;; + -- ) # Stop option processing + shift; break ;; + - ) # Use stdin as input. + break ;; + -* ) + echo "$me: invalid option $1$help" >&2 + exit 1 ;; + * ) + break ;; + esac +done + +if test $# != 0; then + echo "$me: too many arguments$help" >&2 + exit 1 +fi + +trap 'exit 1' 1 2 15 + +# CC_FOR_BUILD -- compiler used by this script. Note that the use of a +# compiler to aid in system detection is discouraged as it requires +# temporary files to be created and, as you can see below, it is a +# headache to deal with in a portable fashion. + +# Historically, `CC_FOR_BUILD' used to be named `HOST_CC'. We still +# use `HOST_CC' if defined, but it is deprecated. + +# Portable tmp directory creation inspired by the Autoconf team. + +set_cc_for_build=' +trap "exitcode=\$?; (rm -f \$tmpfiles 2>/dev/null; rmdir \$tmp 2>/dev/null) && exit \$exitcode" 0 ; +trap "rm -f \$tmpfiles 2>/dev/null; rmdir \$tmp 2>/dev/null; exit 1" 1 2 13 15 ; +: ${TMPDIR=/tmp} ; + { tmp=`(umask 077 && mktemp -d "$TMPDIR/cgXXXXXX") 2>/dev/null` && test -n "$tmp" && test -d "$tmp" ; } || + { test -n "$RANDOM" && tmp=$TMPDIR/cg$$-$RANDOM && (umask 077 && mkdir $tmp) ; } || + { tmp=$TMPDIR/cg-$$ && (umask 077 && mkdir $tmp) && echo "Warning: creating insecure temp directory" >&2 ; } || + { echo "$me: cannot create a temporary directory in $TMPDIR" >&2 ; exit 1 ; } ; +dummy=$tmp/dummy ; +tmpfiles="$dummy.c $dummy.o $dummy.rel $dummy" ; +case $CC_FOR_BUILD,$HOST_CC,$CC in + ,,) echo "int x;" > $dummy.c ; + for c in cc gcc c89 c99 ; do + if ($c -c -o $dummy.o $dummy.c) >/dev/null 2>&1 ; then + CC_FOR_BUILD="$c"; break ; + fi ; + done ; + if test x"$CC_FOR_BUILD" = x ; then + CC_FOR_BUILD=no_compiler_found ; + fi + ;; + ,,*) CC_FOR_BUILD=$CC ;; + ,*,*) CC_FOR_BUILD=$HOST_CC ;; +esac ; set_cc_for_build= ;' + +# This is needed to find uname on a Pyramid OSx when run in the BSD universe. +# (ghazi@noc.rutgers.edu 1994-08-24) +if (test -f /.attbin/uname) >/dev/null 2>&1 ; then + PATH=$PATH:/.attbin ; export PATH +fi + +UNAME_MACHINE=`(uname -m) 2>/dev/null` || UNAME_MACHINE=unknown +UNAME_RELEASE=`(uname -r) 2>/dev/null` || UNAME_RELEASE=unknown +UNAME_SYSTEM=`(uname -s) 2>/dev/null` || UNAME_SYSTEM=unknown +UNAME_VERSION=`(uname -v) 2>/dev/null` || UNAME_VERSION=unknown + +case "${UNAME_SYSTEM}" in +Linux|GNU|GNU/*) + # If the system lacks a compiler, then just pick glibc. + # We could probably try harder. + LIBC=gnu + + eval $set_cc_for_build + cat <<-EOF > $dummy.c + #include <features.h> + #if defined(__UCLIBC__) + LIBC=uclibc + #elif defined(__dietlibc__) + LIBC=dietlibc + #else + LIBC=gnu + #endif + EOF + eval `$CC_FOR_BUILD -E $dummy.c 2>/dev/null | grep '^LIBC' | sed 's, ,,g'` + ;; +esac + +# Note: order is significant - the case branches are not exclusive. + +case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in + *:NetBSD:*:*) + # NetBSD (nbsd) targets should (where applicable) match one or + # more of the tuples: *-*-netbsdelf*, *-*-netbsdaout*, + # *-*-netbsdecoff* and *-*-netbsd*. For targets that recently + # switched to ELF, *-*-netbsd* would select the old + # object file format. This provides both forward + # compatibility and a consistent mechanism for selecting the + # object file format. + # + # Note: NetBSD doesn't particularly care about the vendor + # portion of the name. We always set it to "unknown". + sysctl="sysctl -n hw.machine_arch" + UNAME_MACHINE_ARCH=`(/sbin/$sysctl 2>/dev/null || \ + /usr/sbin/$sysctl 2>/dev/null || echo unknown)` + case "${UNAME_MACHINE_ARCH}" in + armeb) machine=armeb-unknown ;; + arm*) machine=arm-unknown ;; + sh3el) machine=shl-unknown ;; + sh3eb) machine=sh-unknown ;; + sh5el) machine=sh5le-unknown ;; + *) machine=${UNAME_MACHINE_ARCH}-unknown ;; + esac + # The Operating System including object format, if it has switched + # to ELF recently, or will in the future. + case "${UNAME_MACHINE_ARCH}" in + arm*|i386|m68k|ns32k|sh3*|sparc|vax) + eval $set_cc_for_build + if echo __ELF__ | $CC_FOR_BUILD -E - 2>/dev/null \ + | grep -q __ELF__ + then + # Once all utilities can be ECOFF (netbsdecoff) or a.out (netbsdaout). + # Return netbsd for either. FIX? + os=netbsd + else + os=netbsdelf + fi + ;; + *) + os=netbsd + ;; + esac + # The OS release + # Debian GNU/NetBSD machines have a different userland, and + # thus, need a distinct triplet. However, they do not need + # kernel version information, so it can be replaced with a + # suitable tag, in the style of linux-gnu. + case "${UNAME_VERSION}" in + Debian*) + release='-gnu' + ;; + *) + release=`echo ${UNAME_RELEASE}|sed -e 's/[-_].*/\./'` + ;; + esac + # Since CPU_TYPE-MANUFACTURER-KERNEL-OPERATING_SYSTEM: + # contains redundant information, the shorter form: + # CPU_TYPE-MANUFACTURER-OPERATING_SYSTEM is used. + echo "${machine}-${os}${release}" + exit ;; + *:Bitrig:*:*) + UNAME_MACHINE_ARCH=`arch | sed 's/Bitrig.//'` + echo ${UNAME_MACHINE_ARCH}-unknown-bitrig${UNAME_RELEASE} + exit ;; + *:OpenBSD:*:*) + UNAME_MACHINE_ARCH=`arch | sed 's/OpenBSD.//'` + echo ${UNAME_MACHINE_ARCH}-unknown-openbsd${UNAME_RELEASE} + exit ;; + *:ekkoBSD:*:*) + echo ${UNAME_MACHINE}-unknown-ekkobsd${UNAME_RELEASE} + exit ;; + *:SolidBSD:*:*) + echo ${UNAME_MACHINE}-unknown-solidbsd${UNAME_RELEASE} + exit ;; + macppc:MirBSD:*:*) + echo powerpc-unknown-mirbsd${UNAME_RELEASE} + exit ;; + *:MirBSD:*:*) + echo ${UNAME_MACHINE}-unknown-mirbsd${UNAME_RELEASE} + exit ;; + alpha:OSF1:*:*) + case $UNAME_RELEASE in + *4.0) + UNAME_RELEASE=`/usr/sbin/sizer -v | awk '{print $3}'` + ;; + *5.*) + UNAME_RELEASE=`/usr/sbin/sizer -v | awk '{print $4}'` + ;; + esac + # According to Compaq, /usr/sbin/psrinfo has been available on + # OSF/1 and Tru64 systems produced since 1995. I hope that + # covers most systems running today. This code pipes the CPU + # types through head -n 1, so we only detect the type of CPU 0. + ALPHA_CPU_TYPE=`/usr/sbin/psrinfo -v | sed -n -e 's/^ The alpha \(.*\) processor.*$/\1/p' | head -n 1` + case "$ALPHA_CPU_TYPE" in + "EV4 (21064)") + UNAME_MACHINE="alpha" ;; + "EV4.5 (21064)") + UNAME_MACHINE="alpha" ;; + "LCA4 (21066/21068)") + UNAME_MACHINE="alpha" ;; + "EV5 (21164)") + UNAME_MACHINE="alphaev5" ;; + "EV5.6 (21164A)") + UNAME_MACHINE="alphaev56" ;; + "EV5.6 (21164PC)") + UNAME_MACHINE="alphapca56" ;; + "EV5.7 (21164PC)") + UNAME_MACHINE="alphapca57" ;; + "EV6 (21264)") + UNAME_MACHINE="alphaev6" ;; + "EV6.7 (21264A)") + UNAME_MACHINE="alphaev67" ;; + "EV6.8CB (21264C)") + UNAME_MACHINE="alphaev68" ;; + "EV6.8AL (21264B)") + UNAME_MACHINE="alphaev68" ;; + "EV6.8CX (21264D)") + UNAME_MACHINE="alphaev68" ;; + "EV6.9A (21264/EV69A)") + UNAME_MACHINE="alphaev69" ;; + "EV7 (21364)") + UNAME_MACHINE="alphaev7" ;; + "EV7.9 (21364A)") + UNAME_MACHINE="alphaev79" ;; + esac + # A Pn.n version is a patched version. + # A Vn.n version is a released version. + # A Tn.n version is a released field test version. + # A Xn.n version is an unreleased experimental baselevel. + # 1.2 uses "1.2" for uname -r. + echo ${UNAME_MACHINE}-dec-osf`echo ${UNAME_RELEASE} | sed -e 's/^[PVTX]//' | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz'` + # Reset EXIT trap before exiting to avoid spurious non-zero exit code. + exitcode=$? + trap '' 0 + exit $exitcode ;; + Alpha\ *:Windows_NT*:*) + # How do we know it's Interix rather than the generic POSIX subsystem? + # Should we change UNAME_MACHINE based on the output of uname instead + # of the specific Alpha model? + echo alpha-pc-interix + exit ;; + 21064:Windows_NT:50:3) + echo alpha-dec-winnt3.5 + exit ;; + Amiga*:UNIX_System_V:4.0:*) + echo m68k-unknown-sysv4 + exit ;; + *:[Aa]miga[Oo][Ss]:*:*) + echo ${UNAME_MACHINE}-unknown-amigaos + exit ;; + *:[Mm]orph[Oo][Ss]:*:*) + echo ${UNAME_MACHINE}-unknown-morphos + exit ;; + *:OS/390:*:*) + echo i370-ibm-openedition + exit ;; + *:z/VM:*:*) + echo s390-ibm-zvmoe + exit ;; + *:OS400:*:*) + echo powerpc-ibm-os400 + exit ;; + arm:RISC*:1.[012]*:*|arm:riscix:1.[012]*:*) + echo arm-acorn-riscix${UNAME_RELEASE} + exit ;; + arm*:riscos:*:*|arm*:RISCOS:*:*) + echo arm-unknown-riscos + exit ;; + SR2?01:HI-UX/MPP:*:* | SR8000:HI-UX/MPP:*:*) + echo hppa1.1-hitachi-hiuxmpp + exit ;; + Pyramid*:OSx*:*:* | MIS*:OSx*:*:* | MIS*:SMP_DC-OSx*:*:*) + # akee@wpdis03.wpafb.af.mil (Earle F. Ake) contributed MIS and NILE. + if test "`(/bin/universe) 2>/dev/null`" = att ; then + echo pyramid-pyramid-sysv3 + else + echo pyramid-pyramid-bsd + fi + exit ;; + NILE*:*:*:dcosx) + echo pyramid-pyramid-svr4 + exit ;; + DRS?6000:unix:4.0:6*) + echo sparc-icl-nx6 + exit ;; + DRS?6000:UNIX_SV:4.2*:7* | DRS?6000:isis:4.2*:7*) + case `/usr/bin/uname -p` in + sparc) echo sparc-icl-nx7; exit ;; + esac ;; + s390x:SunOS:*:*) + echo ${UNAME_MACHINE}-ibm-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` + exit ;; + sun4H:SunOS:5.*:*) + echo sparc-hal-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` + exit ;; + sun4*:SunOS:5.*:* | tadpole*:SunOS:5.*:*) + echo sparc-sun-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` + exit ;; + i86pc:AuroraUX:5.*:* | i86xen:AuroraUX:5.*:*) + echo i386-pc-auroraux${UNAME_RELEASE} + exit ;; + i86pc:SunOS:5.*:* | i86xen:SunOS:5.*:*) + eval $set_cc_for_build + SUN_ARCH="i386" + # If there is a compiler, see if it is configured for 64-bit objects. + # Note that the Sun cc does not turn __LP64__ into 1 like gcc does. + # This test works for both compilers. + if [ "$CC_FOR_BUILD" != 'no_compiler_found' ]; then + if (echo '#ifdef __amd64'; echo IS_64BIT_ARCH; echo '#endif') | \ + (CCOPTS= $CC_FOR_BUILD -E - 2>/dev/null) | \ + grep IS_64BIT_ARCH >/dev/null + then + SUN_ARCH="x86_64" + fi + fi + echo ${SUN_ARCH}-pc-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` + exit ;; + sun4*:SunOS:6*:*) + # According to config.sub, this is the proper way to canonicalize + # SunOS6. Hard to guess exactly what SunOS6 will be like, but + # it's likely to be more like Solaris than SunOS4. + echo sparc-sun-solaris3`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` + exit ;; + sun4*:SunOS:*:*) + case "`/usr/bin/arch -k`" in + Series*|S4*) + UNAME_RELEASE=`uname -v` + ;; + esac + # Japanese Language versions have a version number like `4.1.3-JL'. + echo sparc-sun-sunos`echo ${UNAME_RELEASE}|sed -e 's/-/_/'` + exit ;; + sun3*:SunOS:*:*) + echo m68k-sun-sunos${UNAME_RELEASE} + exit ;; + sun*:*:4.2BSD:*) + UNAME_RELEASE=`(sed 1q /etc/motd | awk '{print substr($5,1,3)}') 2>/dev/null` + test "x${UNAME_RELEASE}" = "x" && UNAME_RELEASE=3 + case "`/bin/arch`" in + sun3) + echo m68k-sun-sunos${UNAME_RELEASE} + ;; + sun4) + echo sparc-sun-sunos${UNAME_RELEASE} + ;; + esac + exit ;; + aushp:SunOS:*:*) + echo sparc-auspex-sunos${UNAME_RELEASE} + exit ;; + # The situation for MiNT is a little confusing. The machine name + # can be virtually everything (everything which is not + # "atarist" or "atariste" at least should have a processor + # > m68000). The system name ranges from "MiNT" over "FreeMiNT" + # to the lowercase version "mint" (or "freemint"). Finally + # the system name "TOS" denotes a system which is actually not + # MiNT. But MiNT is downward compatible to TOS, so this should + # be no problem. + atarist[e]:*MiNT:*:* | atarist[e]:*mint:*:* | atarist[e]:*TOS:*:*) + echo m68k-atari-mint${UNAME_RELEASE} + exit ;; + atari*:*MiNT:*:* | atari*:*mint:*:* | atarist[e]:*TOS:*:*) + echo m68k-atari-mint${UNAME_RELEASE} + exit ;; + *falcon*:*MiNT:*:* | *falcon*:*mint:*:* | *falcon*:*TOS:*:*) + echo m68k-atari-mint${UNAME_RELEASE} + exit ;; + milan*:*MiNT:*:* | milan*:*mint:*:* | *milan*:*TOS:*:*) + echo m68k-milan-mint${UNAME_RELEASE} + exit ;; + hades*:*MiNT:*:* | hades*:*mint:*:* | *hades*:*TOS:*:*) + echo m68k-hades-mint${UNAME_RELEASE} + exit ;; + *:*MiNT:*:* | *:*mint:*:* | *:*TOS:*:*) + echo m68k-unknown-mint${UNAME_RELEASE} + exit ;; + m68k:machten:*:*) + echo m68k-apple-machten${UNAME_RELEASE} + exit ;; + powerpc:machten:*:*) + echo powerpc-apple-machten${UNAME_RELEASE} + exit ;; + RISC*:Mach:*:*) + echo mips-dec-mach_bsd4.3 + exit ;; + RISC*:ULTRIX:*:*) + echo mips-dec-ultrix${UNAME_RELEASE} + exit ;; + VAX*:ULTRIX*:*:*) + echo vax-dec-ultrix${UNAME_RELEASE} + exit ;; + 2020:CLIX:*:* | 2430:CLIX:*:*) + echo clipper-intergraph-clix${UNAME_RELEASE} + exit ;; + mips:*:*:UMIPS | mips:*:*:RISCos) + eval $set_cc_for_build + sed 's/^ //' << EOF >$dummy.c +#ifdef __cplusplus +#include <stdio.h> /* for printf() prototype */ + int main (int argc, char *argv[]) { +#else + int main (argc, argv) int argc; char *argv[]; { +#endif + #if defined (host_mips) && defined (MIPSEB) + #if defined (SYSTYPE_SYSV) + printf ("mips-mips-riscos%ssysv\n", argv[1]); exit (0); + #endif + #if defined (SYSTYPE_SVR4) + printf ("mips-mips-riscos%ssvr4\n", argv[1]); exit (0); + #endif + #if defined (SYSTYPE_BSD43) || defined(SYSTYPE_BSD) + printf ("mips-mips-riscos%sbsd\n", argv[1]); exit (0); + #endif + #endif + exit (-1); + } +EOF + $CC_FOR_BUILD -o $dummy $dummy.c && + dummyarg=`echo "${UNAME_RELEASE}" | sed -n 's/\([0-9]*\).*/\1/p'` && + SYSTEM_NAME=`$dummy $dummyarg` && + { echo "$SYSTEM_NAME"; exit; } + echo mips-mips-riscos${UNAME_RELEASE} + exit ;; + Motorola:PowerMAX_OS:*:*) + echo powerpc-motorola-powermax + exit ;; + Motorola:*:4.3:PL8-*) + echo powerpc-harris-powermax + exit ;; + Night_Hawk:*:*:PowerMAX_OS | Synergy:PowerMAX_OS:*:*) + echo powerpc-harris-powermax + exit ;; + Night_Hawk:Power_UNIX:*:*) + echo powerpc-harris-powerunix + exit ;; + m88k:CX/UX:7*:*) + echo m88k-harris-cxux7 + exit ;; + m88k:*:4*:R4*) + echo m88k-motorola-sysv4 + exit ;; + m88k:*:3*:R3*) + echo m88k-motorola-sysv3 + exit ;; + AViiON:dgux:*:*) + # DG/UX returns AViiON for all architectures + UNAME_PROCESSOR=`/usr/bin/uname -p` + if [ $UNAME_PROCESSOR = mc88100 ] || [ $UNAME_PROCESSOR = mc88110 ] + then + if [ ${TARGET_BINARY_INTERFACE}x = m88kdguxelfx ] || \ + [ ${TARGET_BINARY_INTERFACE}x = x ] + then + echo m88k-dg-dgux${UNAME_RELEASE} + else + echo m88k-dg-dguxbcs${UNAME_RELEASE} + fi + else + echo i586-dg-dgux${UNAME_RELEASE} + fi + exit ;; + M88*:DolphinOS:*:*) # DolphinOS (SVR3) + echo m88k-dolphin-sysv3 + exit ;; + M88*:*:R3*:*) + # Delta 88k system running SVR3 + echo m88k-motorola-sysv3 + exit ;; + XD88*:*:*:*) # Tektronix XD88 system running UTekV (SVR3) + echo m88k-tektronix-sysv3 + exit ;; + Tek43[0-9][0-9]:UTek:*:*) # Tektronix 4300 system running UTek (BSD) + echo m68k-tektronix-bsd + exit ;; + *:IRIX*:*:*) + echo mips-sgi-irix`echo ${UNAME_RELEASE}|sed -e 's/-/_/g'` + exit ;; + ????????:AIX?:[12].1:2) # AIX 2.2.1 or AIX 2.1.1 is RT/PC AIX. + echo romp-ibm-aix # uname -m gives an 8 hex-code CPU id + exit ;; # Note that: echo "'`uname -s`'" gives 'AIX ' + i*86:AIX:*:*) + echo i386-ibm-aix + exit ;; + ia64:AIX:*:*) + if [ -x /usr/bin/oslevel ] ; then + IBM_REV=`/usr/bin/oslevel` + else + IBM_REV=${UNAME_VERSION}.${UNAME_RELEASE} + fi + echo ${UNAME_MACHINE}-ibm-aix${IBM_REV} + exit ;; + *:AIX:2:3) + if grep bos325 /usr/include/stdio.h >/dev/null 2>&1; then + eval $set_cc_for_build + sed 's/^ //' << EOF >$dummy.c + #include <sys/systemcfg.h> + + main() + { + if (!__power_pc()) + exit(1); + puts("powerpc-ibm-aix3.2.5"); + exit(0); + } +EOF + if $CC_FOR_BUILD -o $dummy $dummy.c && SYSTEM_NAME=`$dummy` + then + echo "$SYSTEM_NAME" + else + echo rs6000-ibm-aix3.2.5 + fi + elif grep bos324 /usr/include/stdio.h >/dev/null 2>&1; then + echo rs6000-ibm-aix3.2.4 + else + echo rs6000-ibm-aix3.2 + fi + exit ;; + *:AIX:*:[4567]) + IBM_CPU_ID=`/usr/sbin/lsdev -C -c processor -S available | sed 1q | awk '{ print $1 }'` + if /usr/sbin/lsattr -El ${IBM_CPU_ID} | grep ' POWER' >/dev/null 2>&1; then + IBM_ARCH=rs6000 + else + IBM_ARCH=powerpc + fi + if [ -x /usr/bin/oslevel ] ; then + IBM_REV=`/usr/bin/oslevel` + else + IBM_REV=${UNAME_VERSION}.${UNAME_RELEASE} + fi + echo ${IBM_ARCH}-ibm-aix${IBM_REV} + exit ;; + *:AIX:*:*) + echo rs6000-ibm-aix + exit ;; + ibmrt:4.4BSD:*|romp-ibm:BSD:*) + echo romp-ibm-bsd4.4 + exit ;; + ibmrt:*BSD:*|romp-ibm:BSD:*) # covers RT/PC BSD and + echo romp-ibm-bsd${UNAME_RELEASE} # 4.3 with uname added to + exit ;; # report: romp-ibm BSD 4.3 + *:BOSX:*:*) + echo rs6000-bull-bosx + exit ;; + DPX/2?00:B.O.S.:*:*) + echo m68k-bull-sysv3 + exit ;; + 9000/[34]??:4.3bsd:1.*:*) + echo m68k-hp-bsd + exit ;; + hp300:4.4BSD:*:* | 9000/[34]??:4.3bsd:2.*:*) + echo m68k-hp-bsd4.4 + exit ;; + 9000/[34678]??:HP-UX:*:*) + HPUX_REV=`echo ${UNAME_RELEASE}|sed -e 's/[^.]*.[0B]*//'` + case "${UNAME_MACHINE}" in + 9000/31? ) HP_ARCH=m68000 ;; + 9000/[34]?? ) HP_ARCH=m68k ;; + 9000/[678][0-9][0-9]) + if [ -x /usr/bin/getconf ]; then + sc_cpu_version=`/usr/bin/getconf SC_CPU_VERSION 2>/dev/null` + sc_kernel_bits=`/usr/bin/getconf SC_KERNEL_BITS 2>/dev/null` + case "${sc_cpu_version}" in + 523) HP_ARCH="hppa1.0" ;; # CPU_PA_RISC1_0 + 528) HP_ARCH="hppa1.1" ;; # CPU_PA_RISC1_1 + 532) # CPU_PA_RISC2_0 + case "${sc_kernel_bits}" in + 32) HP_ARCH="hppa2.0n" ;; + 64) HP_ARCH="hppa2.0w" ;; + '') HP_ARCH="hppa2.0" ;; # HP-UX 10.20 + esac ;; + esac + fi + if [ "${HP_ARCH}" = "" ]; then + eval $set_cc_for_build + sed 's/^ //' << EOF >$dummy.c + + #define _HPUX_SOURCE + #include <stdlib.h> + #include <unistd.h> + + int main () + { + #if defined(_SC_KERNEL_BITS) + long bits = sysconf(_SC_KERNEL_BITS); + #endif + long cpu = sysconf (_SC_CPU_VERSION); + + switch (cpu) + { + case CPU_PA_RISC1_0: puts ("hppa1.0"); break; + case CPU_PA_RISC1_1: puts ("hppa1.1"); break; + case CPU_PA_RISC2_0: + #if defined(_SC_KERNEL_BITS) + switch (bits) + { + case 64: puts ("hppa2.0w"); break; + case 32: puts ("hppa2.0n"); break; + default: puts ("hppa2.0"); break; + } break; + #else /* !defined(_SC_KERNEL_BITS) */ + puts ("hppa2.0"); break; + #endif + default: puts ("hppa1.0"); break; + } + exit (0); + } +EOF + (CCOPTS= $CC_FOR_BUILD -o $dummy $dummy.c 2>/dev/null) && HP_ARCH=`$dummy` + test -z "$HP_ARCH" && HP_ARCH=hppa + fi ;; + esac + if [ ${HP_ARCH} = "hppa2.0w" ] + then + eval $set_cc_for_build + + # hppa2.0w-hp-hpux* has a 64-bit kernel and a compiler generating + # 32-bit code. hppa64-hp-hpux* has the same kernel and a compiler + # generating 64-bit code. GNU and HP use different nomenclature: + # + # $ CC_FOR_BUILD=cc ./config.guess + # => hppa2.0w-hp-hpux11.23 + # $ CC_FOR_BUILD="cc +DA2.0w" ./config.guess + # => hppa64-hp-hpux11.23 + + if echo __LP64__ | (CCOPTS= $CC_FOR_BUILD -E - 2>/dev/null) | + grep -q __LP64__ + then + HP_ARCH="hppa2.0w" + else + HP_ARCH="hppa64" + fi + fi + echo ${HP_ARCH}-hp-hpux${HPUX_REV} + exit ;; + ia64:HP-UX:*:*) + HPUX_REV=`echo ${UNAME_RELEASE}|sed -e 's/[^.]*.[0B]*//'` + echo ia64-hp-hpux${HPUX_REV} + exit ;; + 3050*:HI-UX:*:*) + eval $set_cc_for_build + sed 's/^ //' << EOF >$dummy.c + #include <unistd.h> + int + main () + { + long cpu = sysconf (_SC_CPU_VERSION); + /* The order matters, because CPU_IS_HP_MC68K erroneously returns + true for CPU_PA_RISC1_0. CPU_IS_PA_RISC returns correct + results, however. */ + if (CPU_IS_PA_RISC (cpu)) + { + switch (cpu) + { + case CPU_PA_RISC1_0: puts ("hppa1.0-hitachi-hiuxwe2"); break; + case CPU_PA_RISC1_1: puts ("hppa1.1-hitachi-hiuxwe2"); break; + case CPU_PA_RISC2_0: puts ("hppa2.0-hitachi-hiuxwe2"); break; + default: puts ("hppa-hitachi-hiuxwe2"); break; + } + } + else if (CPU_IS_HP_MC68K (cpu)) + puts ("m68k-hitachi-hiuxwe2"); + else puts ("unknown-hitachi-hiuxwe2"); + exit (0); + } +EOF + $CC_FOR_BUILD -o $dummy $dummy.c && SYSTEM_NAME=`$dummy` && + { echo "$SYSTEM_NAME"; exit; } + echo unknown-hitachi-hiuxwe2 + exit ;; + 9000/7??:4.3bsd:*:* | 9000/8?[79]:4.3bsd:*:* ) + echo hppa1.1-hp-bsd + exit ;; + 9000/8??:4.3bsd:*:*) + echo hppa1.0-hp-bsd + exit ;; + *9??*:MPE/iX:*:* | *3000*:MPE/iX:*:*) + echo hppa1.0-hp-mpeix + exit ;; + hp7??:OSF1:*:* | hp8?[79]:OSF1:*:* ) + echo hppa1.1-hp-osf + exit ;; + hp8??:OSF1:*:*) + echo hppa1.0-hp-osf + exit ;; + i*86:OSF1:*:*) + if [ -x /usr/sbin/sysversion ] ; then + echo ${UNAME_MACHINE}-unknown-osf1mk + else + echo ${UNAME_MACHINE}-unknown-osf1 + fi + exit ;; + parisc*:Lites*:*:*) + echo hppa1.1-hp-lites + exit ;; + C1*:ConvexOS:*:* | convex:ConvexOS:C1*:*) + echo c1-convex-bsd + exit ;; + C2*:ConvexOS:*:* | convex:ConvexOS:C2*:*) + if getsysinfo -f scalar_acc + then echo c32-convex-bsd + else echo c2-convex-bsd + fi + exit ;; + C34*:ConvexOS:*:* | convex:ConvexOS:C34*:*) + echo c34-convex-bsd + exit ;; + C38*:ConvexOS:*:* | convex:ConvexOS:C38*:*) + echo c38-convex-bsd + exit ;; + C4*:ConvexOS:*:* | convex:ConvexOS:C4*:*) + echo c4-convex-bsd + exit ;; + CRAY*Y-MP:*:*:*) + echo ymp-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' + exit ;; + CRAY*[A-Z]90:*:*:*) + echo ${UNAME_MACHINE}-cray-unicos${UNAME_RELEASE} \ + | sed -e 's/CRAY.*\([A-Z]90\)/\1/' \ + -e y/ABCDEFGHIJKLMNOPQRSTUVWXYZ/abcdefghijklmnopqrstuvwxyz/ \ + -e 's/\.[^.]*$/.X/' + exit ;; + CRAY*TS:*:*:*) + echo t90-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' + exit ;; + CRAY*T3E:*:*:*) + echo alphaev5-cray-unicosmk${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' + exit ;; + CRAY*SV1:*:*:*) + echo sv1-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' + exit ;; + *:UNICOS/mp:*:*) + echo craynv-cray-unicosmp${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' + exit ;; + F30[01]:UNIX_System_V:*:* | F700:UNIX_System_V:*:*) + FUJITSU_PROC=`uname -m | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz'` + FUJITSU_SYS=`uname -p | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/\///'` + FUJITSU_REL=`echo ${UNAME_RELEASE} | sed -e 's/ /_/'` + echo "${FUJITSU_PROC}-fujitsu-${FUJITSU_SYS}${FUJITSU_REL}" + exit ;; + 5000:UNIX_System_V:4.*:*) + FUJITSU_SYS=`uname -p | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/\///'` + FUJITSU_REL=`echo ${UNAME_RELEASE} | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/ /_/'` + echo "sparc-fujitsu-${FUJITSU_SYS}${FUJITSU_REL}" + exit ;; + i*86:BSD/386:*:* | i*86:BSD/OS:*:* | *:Ascend\ Embedded/OS:*:*) + echo ${UNAME_MACHINE}-pc-bsdi${UNAME_RELEASE} + exit ;; + sparc*:BSD/OS:*:*) + echo sparc-unknown-bsdi${UNAME_RELEASE} + exit ;; + *:BSD/OS:*:*) + echo ${UNAME_MACHINE}-unknown-bsdi${UNAME_RELEASE} + exit ;; + *:FreeBSD:*:*) + UNAME_PROCESSOR=`/usr/bin/uname -p` + case ${UNAME_PROCESSOR} in + amd64) + echo x86_64-unknown-freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` ;; + *) + echo ${UNAME_PROCESSOR}-unknown-freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` ;; + esac + exit ;; + i*:CYGWIN*:*) + echo ${UNAME_MACHINE}-pc-cygwin + exit ;; + *:MINGW64*:*) + echo ${UNAME_MACHINE}-pc-mingw64 + exit ;; + *:MINGW*:*) + echo ${UNAME_MACHINE}-pc-mingw32 + exit ;; + *:MSYS*:*) + echo ${UNAME_MACHINE}-pc-msys + exit ;; + i*:windows32*:*) + # uname -m includes "-pc" on this system. + echo ${UNAME_MACHINE}-mingw32 + exit ;; + i*:PW*:*) + echo ${UNAME_MACHINE}-pc-pw32 + exit ;; + *:Interix*:*) + case ${UNAME_MACHINE} in + x86) + echo i586-pc-interix${UNAME_RELEASE} + exit ;; + authenticamd | genuineintel | EM64T) + echo x86_64-unknown-interix${UNAME_RELEASE} + exit ;; + IA64) + echo ia64-unknown-interix${UNAME_RELEASE} + exit ;; + esac ;; + [345]86:Windows_95:* | [345]86:Windows_98:* | [345]86:Windows_NT:*) + echo i${UNAME_MACHINE}-pc-mks + exit ;; + 8664:Windows_NT:*) + echo x86_64-pc-mks + exit ;; + i*:Windows_NT*:* | Pentium*:Windows_NT*:*) + # How do we know it's Interix rather than the generic POSIX subsystem? + # It also conflicts with pre-2.0 versions of AT&T UWIN. Should we + # UNAME_MACHINE based on the output of uname instead of i386? + echo i586-pc-interix + exit ;; + i*:UWIN*:*) + echo ${UNAME_MACHINE}-pc-uwin + exit ;; + amd64:CYGWIN*:*:* | x86_64:CYGWIN*:*:*) + echo x86_64-unknown-cygwin + exit ;; + p*:CYGWIN*:*) + echo powerpcle-unknown-cygwin + exit ;; + prep*:SunOS:5.*:*) + echo powerpcle-unknown-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` + exit ;; + *:GNU:*:*) + # the GNU system + echo `echo ${UNAME_MACHINE}|sed -e 's,[-/].*$,,'`-unknown-${LIBC}`echo ${UNAME_RELEASE}|sed -e 's,/.*$,,'` + exit ;; + *:GNU/*:*:*) + # other systems with GNU libc and userland + echo ${UNAME_MACHINE}-unknown-`echo ${UNAME_SYSTEM} | sed 's,^[^/]*/,,' | tr '[A-Z]' '[a-z]'``echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'`-${LIBC} + exit ;; + i*86:Minix:*:*) + echo ${UNAME_MACHINE}-pc-minix + exit ;; + aarch64:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-${LIBC} + exit ;; + aarch64_be:Linux:*:*) + UNAME_MACHINE=aarch64_be + echo ${UNAME_MACHINE}-unknown-linux-${LIBC} + exit ;; + alpha:Linux:*:*) + case `sed -n '/^cpu model/s/^.*: \(.*\)/\1/p' < /proc/cpuinfo` in + EV5) UNAME_MACHINE=alphaev5 ;; + EV56) UNAME_MACHINE=alphaev56 ;; + PCA56) UNAME_MACHINE=alphapca56 ;; + PCA57) UNAME_MACHINE=alphapca56 ;; + EV6) UNAME_MACHINE=alphaev6 ;; + EV67) UNAME_MACHINE=alphaev67 ;; + EV68*) UNAME_MACHINE=alphaev68 ;; + esac + objdump --private-headers /bin/sh | grep -q ld.so.1 + if test "$?" = 0 ; then LIBC="gnulibc1" ; fi + echo ${UNAME_MACHINE}-unknown-linux-${LIBC} + exit ;; + arc:Linux:*:* | arceb:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-${LIBC} + exit ;; + arm*:Linux:*:*) + eval $set_cc_for_build + if echo __ARM_EABI__ | $CC_FOR_BUILD -E - 2>/dev/null \ + | grep -q __ARM_EABI__ + then + echo ${UNAME_MACHINE}-unknown-linux-${LIBC} + else + if echo __ARM_PCS_VFP | $CC_FOR_BUILD -E - 2>/dev/null \ + | grep -q __ARM_PCS_VFP + then + echo ${UNAME_MACHINE}-unknown-linux-${LIBC}eabi + else + echo ${UNAME_MACHINE}-unknown-linux-${LIBC}eabihf + fi + fi + exit ;; + avr32*:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-${LIBC} + exit ;; + cris:Linux:*:*) + echo ${UNAME_MACHINE}-axis-linux-${LIBC} + exit ;; + crisv32:Linux:*:*) + echo ${UNAME_MACHINE}-axis-linux-${LIBC} + exit ;; + frv:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-${LIBC} + exit ;; + hexagon:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-${LIBC} + exit ;; + i*86:Linux:*:*) + echo ${UNAME_MACHINE}-pc-linux-${LIBC} + exit ;; + ia64:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-${LIBC} + exit ;; + m32r*:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-${LIBC} + exit ;; + m68*:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-${LIBC} + exit ;; + mips:Linux:*:* | mips64:Linux:*:*) + eval $set_cc_for_build + sed 's/^ //' << EOF >$dummy.c + #undef CPU + #undef ${UNAME_MACHINE} + #undef ${UNAME_MACHINE}el + #if defined(__MIPSEL__) || defined(__MIPSEL) || defined(_MIPSEL) || defined(MIPSEL) + CPU=${UNAME_MACHINE}el + #else + #if defined(__MIPSEB__) || defined(__MIPSEB) || defined(_MIPSEB) || defined(MIPSEB) + CPU=${UNAME_MACHINE} + #else + CPU= + #endif + #endif +EOF + eval `$CC_FOR_BUILD -E $dummy.c 2>/dev/null | grep '^CPU'` + test x"${CPU}" != x && { echo "${CPU}-unknown-linux-${LIBC}"; exit; } + ;; + openrisc*:Linux:*:*) + echo or1k-unknown-linux-${LIBC} + exit ;; + or32:Linux:*:* | or1k*:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-${LIBC} + exit ;; + padre:Linux:*:*) + echo sparc-unknown-linux-${LIBC} + exit ;; + parisc64:Linux:*:* | hppa64:Linux:*:*) + echo hppa64-unknown-linux-${LIBC} + exit ;; + parisc:Linux:*:* | hppa:Linux:*:*) + # Look for CPU level + case `grep '^cpu[^a-z]*:' /proc/cpuinfo 2>/dev/null | cut -d' ' -f2` in + PA7*) echo hppa1.1-unknown-linux-${LIBC} ;; + PA8*) echo hppa2.0-unknown-linux-${LIBC} ;; + *) echo hppa-unknown-linux-${LIBC} ;; + esac + exit ;; + ppc64:Linux:*:*) + echo powerpc64-unknown-linux-${LIBC} + exit ;; + ppc:Linux:*:*) + echo powerpc-unknown-linux-${LIBC} + exit ;; + ppc64le:Linux:*:*) + echo powerpc64le-unknown-linux-${LIBC} + exit ;; + ppcle:Linux:*:*) + echo powerpcle-unknown-linux-${LIBC} + exit ;; + s390:Linux:*:* | s390x:Linux:*:*) + echo ${UNAME_MACHINE}-ibm-linux-${LIBC} + exit ;; + sh64*:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-${LIBC} + exit ;; + sh*:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-${LIBC} + exit ;; + sparc:Linux:*:* | sparc64:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-${LIBC} + exit ;; + tile*:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-${LIBC} + exit ;; + vax:Linux:*:*) + echo ${UNAME_MACHINE}-dec-linux-${LIBC} + exit ;; + x86_64:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-${LIBC} + exit ;; + xtensa*:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-${LIBC} + exit ;; + i*86:DYNIX/ptx:4*:*) + # ptx 4.0 does uname -s correctly, with DYNIX/ptx in there. + # earlier versions are messed up and put the nodename in both + # sysname and nodename. + echo i386-sequent-sysv4 + exit ;; + i*86:UNIX_SV:4.2MP:2.*) + # Unixware is an offshoot of SVR4, but it has its own version + # number series starting with 2... + # I am not positive that other SVR4 systems won't match this, + # I just have to hope. -- rms. + # Use sysv4.2uw... so that sysv4* matches it. + echo ${UNAME_MACHINE}-pc-sysv4.2uw${UNAME_VERSION} + exit ;; + i*86:OS/2:*:*) + # If we were able to find `uname', then EMX Unix compatibility + # is probably installed. + echo ${UNAME_MACHINE}-pc-os2-emx + exit ;; + i*86:XTS-300:*:STOP) + echo ${UNAME_MACHINE}-unknown-stop + exit ;; + i*86:atheos:*:*) + echo ${UNAME_MACHINE}-unknown-atheos + exit ;; + i*86:syllable:*:*) + echo ${UNAME_MACHINE}-pc-syllable + exit ;; + i*86:LynxOS:2.*:* | i*86:LynxOS:3.[01]*:* | i*86:LynxOS:4.[02]*:*) + echo i386-unknown-lynxos${UNAME_RELEASE} + exit ;; + i*86:*DOS:*:*) + echo ${UNAME_MACHINE}-pc-msdosdjgpp + exit ;; + i*86:*:4.*:* | i*86:SYSTEM_V:4.*:*) + UNAME_REL=`echo ${UNAME_RELEASE} | sed 's/\/MP$//'` + if grep Novell /usr/include/link.h >/dev/null 2>/dev/null; then + echo ${UNAME_MACHINE}-univel-sysv${UNAME_REL} + else + echo ${UNAME_MACHINE}-pc-sysv${UNAME_REL} + fi + exit ;; + i*86:*:5:[678]*) + # UnixWare 7.x, OpenUNIX and OpenServer 6. + case `/bin/uname -X | grep "^Machine"` in + *486*) UNAME_MACHINE=i486 ;; + *Pentium) UNAME_MACHINE=i586 ;; + *Pent*|*Celeron) UNAME_MACHINE=i686 ;; + esac + echo ${UNAME_MACHINE}-unknown-sysv${UNAME_RELEASE}${UNAME_SYSTEM}${UNAME_VERSION} + exit ;; + i*86:*:3.2:*) + if test -f /usr/options/cb.name; then + UNAME_REL=`sed -n 's/.*Version //p' </usr/options/cb.name` + echo ${UNAME_MACHINE}-pc-isc$UNAME_REL + elif /bin/uname -X 2>/dev/null >/dev/null ; then + UNAME_REL=`(/bin/uname -X|grep Release|sed -e 's/.*= //')` + (/bin/uname -X|grep i80486 >/dev/null) && UNAME_MACHINE=i486 + (/bin/uname -X|grep '^Machine.*Pentium' >/dev/null) \ + && UNAME_MACHINE=i586 + (/bin/uname -X|grep '^Machine.*Pent *II' >/dev/null) \ + && UNAME_MACHINE=i686 + (/bin/uname -X|grep '^Machine.*Pentium Pro' >/dev/null) \ + && UNAME_MACHINE=i686 + echo ${UNAME_MACHINE}-pc-sco$UNAME_REL + else + echo ${UNAME_MACHINE}-pc-sysv32 + fi + exit ;; + pc:*:*:*) + # Left here for compatibility: + # uname -m prints for DJGPP always 'pc', but it prints nothing about + # the processor, so we play safe by assuming i586. + # Note: whatever this is, it MUST be the same as what config.sub + # prints for the "djgpp" host, or else GDB configury will decide that + # this is a cross-build. + echo i586-pc-msdosdjgpp + exit ;; + Intel:Mach:3*:*) + echo i386-pc-mach3 + exit ;; + paragon:*:*:*) + echo i860-intel-osf1 + exit ;; + i860:*:4.*:*) # i860-SVR4 + if grep Stardent /usr/include/sys/uadmin.h >/dev/null 2>&1 ; then + echo i860-stardent-sysv${UNAME_RELEASE} # Stardent Vistra i860-SVR4 + else # Add other i860-SVR4 vendors below as they are discovered. + echo i860-unknown-sysv${UNAME_RELEASE} # Unknown i860-SVR4 + fi + exit ;; + mini*:CTIX:SYS*5:*) + # "miniframe" + echo m68010-convergent-sysv + exit ;; + mc68k:UNIX:SYSTEM5:3.51m) + echo m68k-convergent-sysv + exit ;; + M680?0:D-NIX:5.3:*) + echo m68k-diab-dnix + exit ;; + M68*:*:R3V[5678]*:*) + test -r /sysV68 && { echo 'm68k-motorola-sysv'; exit; } ;; + 3[345]??:*:4.0:3.0 | 3[34]??A:*:4.0:3.0 | 3[34]??,*:*:4.0:3.0 | 3[34]??/*:*:4.0:3.0 | 4400:*:4.0:3.0 | 4850:*:4.0:3.0 | SKA40:*:4.0:3.0 | SDS2:*:4.0:3.0 | SHG2:*:4.0:3.0 | S7501*:*:4.0:3.0) + OS_REL='' + test -r /etc/.relid \ + && OS_REL=.`sed -n 's/[^ ]* [^ ]* \([0-9][0-9]\).*/\1/p' < /etc/.relid` + /bin/uname -p 2>/dev/null | grep 86 >/dev/null \ + && { echo i486-ncr-sysv4.3${OS_REL}; exit; } + /bin/uname -p 2>/dev/null | /bin/grep entium >/dev/null \ + && { echo i586-ncr-sysv4.3${OS_REL}; exit; } ;; + 3[34]??:*:4.0:* | 3[34]??,*:*:4.0:*) + /bin/uname -p 2>/dev/null | grep 86 >/dev/null \ + && { echo i486-ncr-sysv4; exit; } ;; + NCR*:*:4.2:* | MPRAS*:*:4.2:*) + OS_REL='.3' + test -r /etc/.relid \ + && OS_REL=.`sed -n 's/[^ ]* [^ ]* \([0-9][0-9]\).*/\1/p' < /etc/.relid` + /bin/uname -p 2>/dev/null | grep 86 >/dev/null \ + && { echo i486-ncr-sysv4.3${OS_REL}; exit; } + /bin/uname -p 2>/dev/null | /bin/grep entium >/dev/null \ + && { echo i586-ncr-sysv4.3${OS_REL}; exit; } + /bin/uname -p 2>/dev/null | /bin/grep pteron >/dev/null \ + && { echo i586-ncr-sysv4.3${OS_REL}; exit; } ;; + m68*:LynxOS:2.*:* | m68*:LynxOS:3.0*:*) + echo m68k-unknown-lynxos${UNAME_RELEASE} + exit ;; + mc68030:UNIX_System_V:4.*:*) + echo m68k-atari-sysv4 + exit ;; + TSUNAMI:LynxOS:2.*:*) + echo sparc-unknown-lynxos${UNAME_RELEASE} + exit ;; + rs6000:LynxOS:2.*:*) + echo rs6000-unknown-lynxos${UNAME_RELEASE} + exit ;; + PowerPC:LynxOS:2.*:* | PowerPC:LynxOS:3.[01]*:* | PowerPC:LynxOS:4.[02]*:*) + echo powerpc-unknown-lynxos${UNAME_RELEASE} + exit ;; + SM[BE]S:UNIX_SV:*:*) + echo mips-dde-sysv${UNAME_RELEASE} + exit ;; + RM*:ReliantUNIX-*:*:*) + echo mips-sni-sysv4 + exit ;; + RM*:SINIX-*:*:*) + echo mips-sni-sysv4 + exit ;; + *:SINIX-*:*:*) + if uname -p 2>/dev/null >/dev/null ; then + UNAME_MACHINE=`(uname -p) 2>/dev/null` + echo ${UNAME_MACHINE}-sni-sysv4 + else + echo ns32k-sni-sysv + fi + exit ;; + PENTIUM:*:4.0*:*) # Unisys `ClearPath HMP IX 4000' SVR4/MP effort + # says <Richard.M.Bartel@ccMail.Census.GOV> + echo i586-unisys-sysv4 + exit ;; + *:UNIX_System_V:4*:FTX*) + # From Gerald Hewes <hewes@openmarket.com>. + # How about differentiating between stratus architectures? -djm + echo hppa1.1-stratus-sysv4 + exit ;; + *:*:*:FTX*) + # From seanf@swdc.stratus.com. + echo i860-stratus-sysv4 + exit ;; + i*86:VOS:*:*) + # From Paul.Green@stratus.com. + echo ${UNAME_MACHINE}-stratus-vos + exit ;; + *:VOS:*:*) + # From Paul.Green@stratus.com. + echo hppa1.1-stratus-vos + exit ;; + mc68*:A/UX:*:*) + echo m68k-apple-aux${UNAME_RELEASE} + exit ;; + news*:NEWS-OS:6*:*) + echo mips-sony-newsos6 + exit ;; + R[34]000:*System_V*:*:* | R4000:UNIX_SYSV:*:* | R*000:UNIX_SV:*:*) + if [ -d /usr/nec ]; then + echo mips-nec-sysv${UNAME_RELEASE} + else + echo mips-unknown-sysv${UNAME_RELEASE} + fi + exit ;; + BeBox:BeOS:*:*) # BeOS running on hardware made by Be, PPC only. + echo powerpc-be-beos + exit ;; + BeMac:BeOS:*:*) # BeOS running on Mac or Mac clone, PPC only. + echo powerpc-apple-beos + exit ;; + BePC:BeOS:*:*) # BeOS running on Intel PC compatible. + echo i586-pc-beos + exit ;; + BePC:Haiku:*:*) # Haiku running on Intel PC compatible. + echo i586-pc-haiku + exit ;; + x86_64:Haiku:*:*) + echo x86_64-unknown-haiku + exit ;; + SX-4:SUPER-UX:*:*) + echo sx4-nec-superux${UNAME_RELEASE} + exit ;; + SX-5:SUPER-UX:*:*) + echo sx5-nec-superux${UNAME_RELEASE} + exit ;; + SX-6:SUPER-UX:*:*) + echo sx6-nec-superux${UNAME_RELEASE} + exit ;; + SX-7:SUPER-UX:*:*) + echo sx7-nec-superux${UNAME_RELEASE} + exit ;; + SX-8:SUPER-UX:*:*) + echo sx8-nec-superux${UNAME_RELEASE} + exit ;; + SX-8R:SUPER-UX:*:*) + echo sx8r-nec-superux${UNAME_RELEASE} + exit ;; + Power*:Rhapsody:*:*) + echo powerpc-apple-rhapsody${UNAME_RELEASE} + exit ;; + *:Rhapsody:*:*) + echo ${UNAME_MACHINE}-apple-rhapsody${UNAME_RELEASE} + exit ;; + *:Darwin:*:*) + UNAME_PROCESSOR=`uname -p` || UNAME_PROCESSOR=unknown + eval $set_cc_for_build + if test "$UNAME_PROCESSOR" = unknown ; then + UNAME_PROCESSOR=powerpc + fi + if test `echo "$UNAME_RELEASE" | sed -e 's/\..*//'` -le 10 ; then + if [ "$CC_FOR_BUILD" != 'no_compiler_found' ]; then + if (echo '#ifdef __LP64__'; echo IS_64BIT_ARCH; echo '#endif') | \ + (CCOPTS= $CC_FOR_BUILD -E - 2>/dev/null) | \ + grep IS_64BIT_ARCH >/dev/null + then + case $UNAME_PROCESSOR in + i386) UNAME_PROCESSOR=x86_64 ;; + powerpc) UNAME_PROCESSOR=powerpc64 ;; + esac + fi + fi + elif test "$UNAME_PROCESSOR" = i386 ; then + # Avoid executing cc on OS X 10.9, as it ships with a stub + # that puts up a graphical alert prompting to install + # developer tools. Any system running Mac OS X 10.7 or + # later (Darwin 11 and later) is required to have a 64-bit + # processor. This is not true of the ARM version of Darwin + # that Apple uses in portable devices. + UNAME_PROCESSOR=x86_64 + fi + echo ${UNAME_PROCESSOR}-apple-darwin${UNAME_RELEASE} + exit ;; + *:procnto*:*:* | *:QNX:[0123456789]*:*) + UNAME_PROCESSOR=`uname -p` + if test "$UNAME_PROCESSOR" = "x86"; then + UNAME_PROCESSOR=i386 + UNAME_MACHINE=pc + fi + echo ${UNAME_PROCESSOR}-${UNAME_MACHINE}-nto-qnx${UNAME_RELEASE} + exit ;; + *:QNX:*:4*) + echo i386-pc-qnx + exit ;; + NEO-?:NONSTOP_KERNEL:*:*) + echo neo-tandem-nsk${UNAME_RELEASE} + exit ;; + NSE-*:NONSTOP_KERNEL:*:*) + echo nse-tandem-nsk${UNAME_RELEASE} + exit ;; + NSR-?:NONSTOP_KERNEL:*:*) + echo nsr-tandem-nsk${UNAME_RELEASE} + exit ;; + *:NonStop-UX:*:*) + echo mips-compaq-nonstopux + exit ;; + BS2000:POSIX*:*:*) + echo bs2000-siemens-sysv + exit ;; + DS/*:UNIX_System_V:*:*) + echo ${UNAME_MACHINE}-${UNAME_SYSTEM}-${UNAME_RELEASE} + exit ;; + *:Plan9:*:*) + # "uname -m" is not consistent, so use $cputype instead. 386 + # is converted to i386 for consistency with other x86 + # operating systems. + if test "$cputype" = "386"; then + UNAME_MACHINE=i386 + else + UNAME_MACHINE="$cputype" + fi + echo ${UNAME_MACHINE}-unknown-plan9 + exit ;; + *:TOPS-10:*:*) + echo pdp10-unknown-tops10 + exit ;; + *:TENEX:*:*) + echo pdp10-unknown-tenex + exit ;; + KS10:TOPS-20:*:* | KL10:TOPS-20:*:* | TYPE4:TOPS-20:*:*) + echo pdp10-dec-tops20 + exit ;; + XKL-1:TOPS-20:*:* | TYPE5:TOPS-20:*:*) + echo pdp10-xkl-tops20 + exit ;; + *:TOPS-20:*:*) + echo pdp10-unknown-tops20 + exit ;; + *:ITS:*:*) + echo pdp10-unknown-its + exit ;; + SEI:*:*:SEIUX) + echo mips-sei-seiux${UNAME_RELEASE} + exit ;; + *:DragonFly:*:*) + echo ${UNAME_MACHINE}-unknown-dragonfly`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` + exit ;; + *:*VMS:*:*) + UNAME_MACHINE=`(uname -p) 2>/dev/null` + case "${UNAME_MACHINE}" in + A*) echo alpha-dec-vms ; exit ;; + I*) echo ia64-dec-vms ; exit ;; + V*) echo vax-dec-vms ; exit ;; + esac ;; + *:XENIX:*:SysV) + echo i386-pc-xenix + exit ;; + i*86:skyos:*:*) + echo ${UNAME_MACHINE}-pc-skyos`echo ${UNAME_RELEASE}` | sed -e 's/ .*$//' + exit ;; + i*86:rdos:*:*) + echo ${UNAME_MACHINE}-pc-rdos + exit ;; + i*86:AROS:*:*) + echo ${UNAME_MACHINE}-pc-aros + exit ;; + x86_64:VMkernel:*:*) + echo ${UNAME_MACHINE}-unknown-esx + exit ;; +esac + +cat >&2 <<EOF +$0: unable to guess system type + +This script, last modified $timestamp, has failed to recognize +the operating system you are using. It is advised that you +download the most up to date version of the config scripts from + + http://git.savannah.gnu.org/gitweb/?p=config.git;a=blob_plain;f=config.guess;hb=HEAD +and + http://git.savannah.gnu.org/gitweb/?p=config.git;a=blob_plain;f=config.sub;hb=HEAD + +If the version you run ($0) is already up to date, please +send the following data and any information you think might be +pertinent to <config-patches@gnu.org> in order to provide the needed +information to handle your system. + +config.guess timestamp = $timestamp + +uname -m = `(uname -m) 2>/dev/null || echo unknown` +uname -r = `(uname -r) 2>/dev/null || echo unknown` +uname -s = `(uname -s) 2>/dev/null || echo unknown` +uname -v = `(uname -v) 2>/dev/null || echo unknown` + +/usr/bin/uname -p = `(/usr/bin/uname -p) 2>/dev/null` +/bin/uname -X = `(/bin/uname -X) 2>/dev/null` + +hostinfo = `(hostinfo) 2>/dev/null` +/bin/universe = `(/bin/universe) 2>/dev/null` +/usr/bin/arch -k = `(/usr/bin/arch -k) 2>/dev/null` +/bin/arch = `(/bin/arch) 2>/dev/null` +/usr/bin/oslevel = `(/usr/bin/oslevel) 2>/dev/null` +/usr/convex/getsysinfo = `(/usr/convex/getsysinfo) 2>/dev/null` + +UNAME_MACHINE = ${UNAME_MACHINE} +UNAME_RELEASE = ${UNAME_RELEASE} +UNAME_SYSTEM = ${UNAME_SYSTEM} +UNAME_VERSION = ${UNAME_VERSION} +EOF + +exit 1 + +# Local variables: +# eval: (add-hook 'write-file-hooks 'time-stamp) +# time-stamp-start: "timestamp='" +# time-stamp-format: "%:y-%02m-%02d" +# time-stamp-end: "'" +# End: diff --git a/libraries/integer-gmp2/config.sub b/libraries/integer-gmp2/config.sub new file mode 100755 index 0000000000..d654d03cdc --- /dev/null +++ b/libraries/integer-gmp2/config.sub @@ -0,0 +1,1794 @@ +#! /bin/sh +# Configuration validation subroutine script. +# Copyright 1992-2014 Free Software Foundation, Inc. + +timestamp='2014-05-01' + +# This file is free software; you can redistribute it and/or modify it +# under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 3 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, but +# WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +# General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, see <http://www.gnu.org/licenses/>. +# +# As a special exception to the GNU General Public License, if you +# distribute this file as part of a program that contains a +# configuration script generated by Autoconf, you may include it under +# the same distribution terms that you use for the rest of that +# program. This Exception is an additional permission under section 7 +# of the GNU General Public License, version 3 ("GPLv3"). + + +# Please send patches with a ChangeLog entry to config-patches@gnu.org. +# +# Configuration subroutine to validate and canonicalize a configuration type. +# Supply the specified configuration type as an argument. +# If it is invalid, we print an error message on stderr and exit with code 1. +# Otherwise, we print the canonical config type on stdout and succeed. + +# You can get the latest version of this script from: +# http://git.savannah.gnu.org/gitweb/?p=config.git;a=blob_plain;f=config.sub;hb=HEAD + +# This file is supposed to be the same for all GNU packages +# and recognize all the CPU types, system types and aliases +# that are meaningful with *any* GNU software. +# Each package is responsible for reporting which valid configurations +# it does not support. The user should be able to distinguish +# a failure to support a valid configuration from a meaningless +# configuration. + +# The goal of this file is to map all the various variations of a given +# machine specification into a single specification in the form: +# CPU_TYPE-MANUFACTURER-OPERATING_SYSTEM +# or in some cases, the newer four-part form: +# CPU_TYPE-MANUFACTURER-KERNEL-OPERATING_SYSTEM +# It is wrong to echo any other type of specification. + +me=`echo "$0" | sed -e 's,.*/,,'` + +usage="\ +Usage: $0 [OPTION] CPU-MFR-OPSYS + $0 [OPTION] ALIAS + +Canonicalize a configuration name. + +Operation modes: + -h, --help print this help, then exit + -t, --time-stamp print date of last modification, then exit + -v, --version print version number, then exit + +Report bugs and patches to <config-patches@gnu.org>." + +version="\ +GNU config.sub ($timestamp) + +Copyright 1992-2014 Free Software Foundation, Inc. + +This is free software; see the source for copying conditions. There is NO +warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE." + +help=" +Try \`$me --help' for more information." + +# Parse command line +while test $# -gt 0 ; do + case $1 in + --time-stamp | --time* | -t ) + echo "$timestamp" ; exit ;; + --version | -v ) + echo "$version" ; exit ;; + --help | --h* | -h ) + echo "$usage"; exit ;; + -- ) # Stop option processing + shift; break ;; + - ) # Use stdin as input. + break ;; + -* ) + echo "$me: invalid option $1$help" + exit 1 ;; + + *local*) + # First pass through any local machine types. + echo $1 + exit ;; + + * ) + break ;; + esac +done + +case $# in + 0) echo "$me: missing argument$help" >&2 + exit 1;; + 1) ;; + *) echo "$me: too many arguments$help" >&2 + exit 1;; +esac + +# Separate what the user gave into CPU-COMPANY and OS or KERNEL-OS (if any). +# Here we must recognize all the valid KERNEL-OS combinations. +maybe_os=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\2/'` +case $maybe_os in + nto-qnx* | linux-gnu* | linux-android* | linux-dietlibc | linux-newlib* | \ + linux-musl* | linux-uclibc* | uclinux-uclibc* | uclinux-gnu* | kfreebsd*-gnu* | \ + knetbsd*-gnu* | netbsd*-gnu* | \ + kopensolaris*-gnu* | \ + storm-chaos* | os2-emx* | rtmk-nova*) + os=-$maybe_os + basic_machine=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\1/'` + ;; + android-linux) + os=-linux-android + basic_machine=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\1/'`-unknown + ;; + *) + basic_machine=`echo $1 | sed 's/-[^-]*$//'` + if [ $basic_machine != $1 ] + then os=`echo $1 | sed 's/.*-/-/'` + else os=; fi + ;; +esac + +### Let's recognize common machines as not being operating systems so +### that things like config.sub decstation-3100 work. We also +### recognize some manufacturers as not being operating systems, so we +### can provide default operating systems below. +case $os in + -sun*os*) + # Prevent following clause from handling this invalid input. + ;; + -dec* | -mips* | -sequent* | -encore* | -pc532* | -sgi* | -sony* | \ + -att* | -7300* | -3300* | -delta* | -motorola* | -sun[234]* | \ + -unicom* | -ibm* | -next | -hp | -isi* | -apollo | -altos* | \ + -convergent* | -ncr* | -news | -32* | -3600* | -3100* | -hitachi* |\ + -c[123]* | -convex* | -sun | -crds | -omron* | -dg | -ultra | -tti* | \ + -harris | -dolphin | -highlevel | -gould | -cbm | -ns | -masscomp | \ + -apple | -axis | -knuth | -cray | -microblaze*) + os= + basic_machine=$1 + ;; + -bluegene*) + os=-cnk + ;; + -sim | -cisco | -oki | -wec | -winbond) + os= + basic_machine=$1 + ;; + -scout) + ;; + -wrs) + os=-vxworks + basic_machine=$1 + ;; + -chorusos*) + os=-chorusos + basic_machine=$1 + ;; + -chorusrdb) + os=-chorusrdb + basic_machine=$1 + ;; + -hiux*) + os=-hiuxwe2 + ;; + -sco6) + os=-sco5v6 + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; + -sco5) + os=-sco3.2v5 + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; + -sco4) + os=-sco3.2v4 + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; + -sco3.2.[4-9]*) + os=`echo $os | sed -e 's/sco3.2./sco3.2v/'` + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; + -sco3.2v[4-9]*) + # Don't forget version if it is 3.2v4 or newer. + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; + -sco5v6*) + # Don't forget version if it is 3.2v4 or newer. + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; + -sco*) + os=-sco3.2v2 + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; + -udk*) + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; + -isc) + os=-isc2.2 + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; + -clix*) + basic_machine=clipper-intergraph + ;; + -isc*) + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; + -lynx*178) + os=-lynxos178 + ;; + -lynx*5) + os=-lynxos5 + ;; + -lynx*) + os=-lynxos + ;; + -ptx*) + basic_machine=`echo $1 | sed -e 's/86-.*/86-sequent/'` + ;; + -windowsnt*) + os=`echo $os | sed -e 's/windowsnt/winnt/'` + ;; + -psos*) + os=-psos + ;; + -mint | -mint[0-9]*) + basic_machine=m68k-atari + os=-mint + ;; +esac + +# Decode aliases for certain CPU-COMPANY combinations. +case $basic_machine in + # Recognize the basic CPU types without company name. + # Some are omitted here because they have special meanings below. + 1750a | 580 \ + | a29k \ + | aarch64 | aarch64_be \ + | alpha | alphaev[4-8] | alphaev56 | alphaev6[78] | alphapca5[67] \ + | alpha64 | alpha64ev[4-8] | alpha64ev56 | alpha64ev6[78] | alpha64pca5[67] \ + | am33_2.0 \ + | arc | arceb \ + | arm | arm[bl]e | arme[lb] | armv[2-8] | armv[3-8][lb] | armv7[arm] \ + | avr | avr32 \ + | be32 | be64 \ + | bfin \ + | c4x | c8051 | clipper \ + | d10v | d30v | dlx | dsp16xx \ + | epiphany \ + | fido | fr30 | frv \ + | h8300 | h8500 | hppa | hppa1.[01] | hppa2.0 | hppa2.0[nw] | hppa64 \ + | hexagon \ + | i370 | i860 | i960 | ia64 \ + | ip2k | iq2000 \ + | k1om \ + | le32 | le64 \ + | lm32 \ + | m32c | m32r | m32rle | m68000 | m68k | m88k \ + | maxq | mb | microblaze | microblazeel | mcore | mep | metag \ + | mips | mipsbe | mipseb | mipsel | mipsle \ + | mips16 \ + | mips64 | mips64el \ + | mips64octeon | mips64octeonel \ + | mips64orion | mips64orionel \ + | mips64r5900 | mips64r5900el \ + | mips64vr | mips64vrel \ + | mips64vr4100 | mips64vr4100el \ + | mips64vr4300 | mips64vr4300el \ + | mips64vr5000 | mips64vr5000el \ + | mips64vr5900 | mips64vr5900el \ + | mipsisa32 | mipsisa32el \ + | mipsisa32r2 | mipsisa32r2el \ + | mipsisa32r6 | mipsisa32r6el \ + | mipsisa64 | mipsisa64el \ + | mipsisa64r2 | mipsisa64r2el \ + | mipsisa64r6 | mipsisa64r6el \ + | mipsisa64sb1 | mipsisa64sb1el \ + | mipsisa64sr71k | mipsisa64sr71kel \ + | mipsr5900 | mipsr5900el \ + | mipstx39 | mipstx39el \ + | mn10200 | mn10300 \ + | moxie \ + | mt \ + | msp430 \ + | nds32 | nds32le | nds32be \ + | nios | nios2 | nios2eb | nios2el \ + | ns16k | ns32k \ + | open8 | or1k | or1knd | or32 \ + | pdp10 | pdp11 | pj | pjl \ + | powerpc | powerpc64 | powerpc64le | powerpcle \ + | pyramid \ + | rl78 | rx \ + | score \ + | sh | sh[1234] | sh[24]a | sh[24]aeb | sh[23]e | sh[34]eb | sheb | shbe | shle | sh[1234]le | sh3ele \ + | sh64 | sh64le \ + | sparc | sparc64 | sparc64b | sparc64v | sparc86x | sparclet | sparclite \ + | sparcv8 | sparcv9 | sparcv9b | sparcv9v \ + | spu \ + | tahoe | tic4x | tic54x | tic55x | tic6x | tic80 | tron \ + | ubicom32 \ + | v850 | v850e | v850e1 | v850e2 | v850es | v850e2v3 \ + | we32k \ + | x86 | xc16x | xstormy16 | xtensa \ + | z8k | z80) + basic_machine=$basic_machine-unknown + ;; + c54x) + basic_machine=tic54x-unknown + ;; + c55x) + basic_machine=tic55x-unknown + ;; + c6x) + basic_machine=tic6x-unknown + ;; + m6811 | m68hc11 | m6812 | m68hc12 | m68hcs12x | nvptx | picochip) + basic_machine=$basic_machine-unknown + os=-none + ;; + m88110 | m680[12346]0 | m683?2 | m68360 | m5200 | v70 | w65 | z8k) + ;; + ms1) + basic_machine=mt-unknown + ;; + + strongarm | thumb | xscale) + basic_machine=arm-unknown + ;; + xgate) + basic_machine=$basic_machine-unknown + os=-none + ;; + xscaleeb) + basic_machine=armeb-unknown + ;; + + xscaleel) + basic_machine=armel-unknown + ;; + + # We use `pc' rather than `unknown' + # because (1) that's what they normally are, and + # (2) the word "unknown" tends to confuse beginning users. + i*86 | x86_64) + basic_machine=$basic_machine-pc + ;; + # Object if more than one company name word. + *-*-*) + echo Invalid configuration \`$1\': machine \`$basic_machine\' not recognized 1>&2 + exit 1 + ;; + # Recognize the basic CPU types with company name. + 580-* \ + | a29k-* \ + | aarch64-* | aarch64_be-* \ + | alpha-* | alphaev[4-8]-* | alphaev56-* | alphaev6[78]-* \ + | alpha64-* | alpha64ev[4-8]-* | alpha64ev56-* | alpha64ev6[78]-* \ + | alphapca5[67]-* | alpha64pca5[67]-* | arc-* | arceb-* \ + | arm-* | armbe-* | armle-* | armeb-* | armv*-* \ + | avr-* | avr32-* \ + | be32-* | be64-* \ + | bfin-* | bs2000-* \ + | c[123]* | c30-* | [cjt]90-* | c4x-* \ + | c8051-* | clipper-* | craynv-* | cydra-* \ + | d10v-* | d30v-* | dlx-* \ + | elxsi-* \ + | f30[01]-* | f700-* | fido-* | fr30-* | frv-* | fx80-* \ + | h8300-* | h8500-* \ + | hppa-* | hppa1.[01]-* | hppa2.0-* | hppa2.0[nw]-* | hppa64-* \ + | hexagon-* \ + | i*86-* | i860-* | i960-* | ia64-* \ + | ip2k-* | iq2000-* \ + | k1om-* \ + | le32-* | le64-* \ + | lm32-* \ + | m32c-* | m32r-* | m32rle-* \ + | m68000-* | m680[012346]0-* | m68360-* | m683?2-* | m68k-* \ + | m88110-* | m88k-* | maxq-* | mcore-* | metag-* \ + | microblaze-* | microblazeel-* \ + | mips-* | mipsbe-* | mipseb-* | mipsel-* | mipsle-* \ + | mips16-* \ + | mips64-* | mips64el-* \ + | mips64octeon-* | mips64octeonel-* \ + | mips64orion-* | mips64orionel-* \ + | mips64r5900-* | mips64r5900el-* \ + | mips64vr-* | mips64vrel-* \ + | mips64vr4100-* | mips64vr4100el-* \ + | mips64vr4300-* | mips64vr4300el-* \ + | mips64vr5000-* | mips64vr5000el-* \ + | mips64vr5900-* | mips64vr5900el-* \ + | mipsisa32-* | mipsisa32el-* \ + | mipsisa32r2-* | mipsisa32r2el-* \ + | mipsisa32r6-* | mipsisa32r6el-* \ + | mipsisa64-* | mipsisa64el-* \ + | mipsisa64r2-* | mipsisa64r2el-* \ + | mipsisa64r6-* | mipsisa64r6el-* \ + | mipsisa64sb1-* | mipsisa64sb1el-* \ + | mipsisa64sr71k-* | mipsisa64sr71kel-* \ + | mipsr5900-* | mipsr5900el-* \ + | mipstx39-* | mipstx39el-* \ + | mmix-* \ + | mt-* \ + | msp430-* \ + | nds32-* | nds32le-* | nds32be-* \ + | nios-* | nios2-* | nios2eb-* | nios2el-* \ + | none-* | np1-* | ns16k-* | ns32k-* \ + | open8-* \ + | or1k*-* \ + | orion-* \ + | pdp10-* | pdp11-* | pj-* | pjl-* | pn-* | power-* \ + | powerpc-* | powerpc64-* | powerpc64le-* | powerpcle-* \ + | pyramid-* \ + | rl78-* | romp-* | rs6000-* | rx-* \ + | sh-* | sh[1234]-* | sh[24]a-* | sh[24]aeb-* | sh[23]e-* | sh[34]eb-* | sheb-* | shbe-* \ + | shle-* | sh[1234]le-* | sh3ele-* | sh64-* | sh64le-* \ + | sparc-* | sparc64-* | sparc64b-* | sparc64v-* | sparc86x-* | sparclet-* \ + | sparclite-* \ + | sparcv8-* | sparcv9-* | sparcv9b-* | sparcv9v-* | sv1-* | sx?-* \ + | tahoe-* \ + | tic30-* | tic4x-* | tic54x-* | tic55x-* | tic6x-* | tic80-* \ + | tile*-* \ + | tron-* \ + | ubicom32-* \ + | v850-* | v850e-* | v850e1-* | v850es-* | v850e2-* | v850e2v3-* \ + | vax-* \ + | we32k-* \ + | x86-* | x86_64-* | xc16x-* | xps100-* \ + | xstormy16-* | xtensa*-* \ + | ymp-* \ + | z8k-* | z80-*) + ;; + # Recognize the basic CPU types without company name, with glob match. + xtensa*) + basic_machine=$basic_machine-unknown + ;; + # Recognize the various machine names and aliases which stand + # for a CPU type and a company and sometimes even an OS. + 386bsd) + basic_machine=i386-unknown + os=-bsd + ;; + 3b1 | 7300 | 7300-att | att-7300 | pc7300 | safari | unixpc) + basic_machine=m68000-att + ;; + 3b*) + basic_machine=we32k-att + ;; + a29khif) + basic_machine=a29k-amd + os=-udi + ;; + abacus) + basic_machine=abacus-unknown + ;; + adobe68k) + basic_machine=m68010-adobe + os=-scout + ;; + alliant | fx80) + basic_machine=fx80-alliant + ;; + altos | altos3068) + basic_machine=m68k-altos + ;; + am29k) + basic_machine=a29k-none + os=-bsd + ;; + amd64) + basic_machine=x86_64-pc + ;; + amd64-*) + basic_machine=x86_64-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + amdahl) + basic_machine=580-amdahl + os=-sysv + ;; + amiga | amiga-*) + basic_machine=m68k-unknown + ;; + amigaos | amigados) + basic_machine=m68k-unknown + os=-amigaos + ;; + amigaunix | amix) + basic_machine=m68k-unknown + os=-sysv4 + ;; + apollo68) + basic_machine=m68k-apollo + os=-sysv + ;; + apollo68bsd) + basic_machine=m68k-apollo + os=-bsd + ;; + aros) + basic_machine=i386-pc + os=-aros + ;; + aux) + basic_machine=m68k-apple + os=-aux + ;; + balance) + basic_machine=ns32k-sequent + os=-dynix + ;; + blackfin) + basic_machine=bfin-unknown + os=-linux + ;; + blackfin-*) + basic_machine=bfin-`echo $basic_machine | sed 's/^[^-]*-//'` + os=-linux + ;; + bluegene*) + basic_machine=powerpc-ibm + os=-cnk + ;; + c54x-*) + basic_machine=tic54x-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + c55x-*) + basic_machine=tic55x-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + c6x-*) + basic_machine=tic6x-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + c90) + basic_machine=c90-cray + os=-unicos + ;; + cegcc) + basic_machine=arm-unknown + os=-cegcc + ;; + convex-c1) + basic_machine=c1-convex + os=-bsd + ;; + convex-c2) + basic_machine=c2-convex + os=-bsd + ;; + convex-c32) + basic_machine=c32-convex + os=-bsd + ;; + convex-c34) + basic_machine=c34-convex + os=-bsd + ;; + convex-c38) + basic_machine=c38-convex + os=-bsd + ;; + cray | j90) + basic_machine=j90-cray + os=-unicos + ;; + craynv) + basic_machine=craynv-cray + os=-unicosmp + ;; + cr16 | cr16-*) + basic_machine=cr16-unknown + os=-elf + ;; + crds | unos) + basic_machine=m68k-crds + ;; + crisv32 | crisv32-* | etraxfs*) + basic_machine=crisv32-axis + ;; + cris | cris-* | etrax*) + basic_machine=cris-axis + ;; + crx) + basic_machine=crx-unknown + os=-elf + ;; + da30 | da30-*) + basic_machine=m68k-da30 + ;; + decstation | decstation-3100 | pmax | pmax-* | pmin | dec3100 | decstatn) + basic_machine=mips-dec + ;; + decsystem10* | dec10*) + basic_machine=pdp10-dec + os=-tops10 + ;; + decsystem20* | dec20*) + basic_machine=pdp10-dec + os=-tops20 + ;; + delta | 3300 | motorola-3300 | motorola-delta \ + | 3300-motorola | delta-motorola) + basic_machine=m68k-motorola + ;; + delta88) + basic_machine=m88k-motorola + os=-sysv3 + ;; + dicos) + basic_machine=i686-pc + os=-dicos + ;; + djgpp) + basic_machine=i586-pc + os=-msdosdjgpp + ;; + dpx20 | dpx20-*) + basic_machine=rs6000-bull + os=-bosx + ;; + dpx2* | dpx2*-bull) + basic_machine=m68k-bull + os=-sysv3 + ;; + ebmon29k) + basic_machine=a29k-amd + os=-ebmon + ;; + elxsi) + basic_machine=elxsi-elxsi + os=-bsd + ;; + encore | umax | mmax) + basic_machine=ns32k-encore + ;; + es1800 | OSE68k | ose68k | ose | OSE) + basic_machine=m68k-ericsson + os=-ose + ;; + fx2800) + basic_machine=i860-alliant + ;; + genix) + basic_machine=ns32k-ns + ;; + gmicro) + basic_machine=tron-gmicro + os=-sysv + ;; + go32) + basic_machine=i386-pc + os=-go32 + ;; + h3050r* | hiux*) + basic_machine=hppa1.1-hitachi + os=-hiuxwe2 + ;; + h8300hms) + basic_machine=h8300-hitachi + os=-hms + ;; + h8300xray) + basic_machine=h8300-hitachi + os=-xray + ;; + h8500hms) + basic_machine=h8500-hitachi + os=-hms + ;; + harris) + basic_machine=m88k-harris + os=-sysv3 + ;; + hp300-*) + basic_machine=m68k-hp + ;; + hp300bsd) + basic_machine=m68k-hp + os=-bsd + ;; + hp300hpux) + basic_machine=m68k-hp + os=-hpux + ;; + hp3k9[0-9][0-9] | hp9[0-9][0-9]) + basic_machine=hppa1.0-hp + ;; + hp9k2[0-9][0-9] | hp9k31[0-9]) + basic_machine=m68000-hp + ;; + hp9k3[2-9][0-9]) + basic_machine=m68k-hp + ;; + hp9k6[0-9][0-9] | hp6[0-9][0-9]) + basic_machine=hppa1.0-hp + ;; + hp9k7[0-79][0-9] | hp7[0-79][0-9]) + basic_machine=hppa1.1-hp + ;; + hp9k78[0-9] | hp78[0-9]) + # FIXME: really hppa2.0-hp + basic_machine=hppa1.1-hp + ;; + hp9k8[67]1 | hp8[67]1 | hp9k80[24] | hp80[24] | hp9k8[78]9 | hp8[78]9 | hp9k893 | hp893) + # FIXME: really hppa2.0-hp + basic_machine=hppa1.1-hp + ;; + hp9k8[0-9][13679] | hp8[0-9][13679]) + basic_machine=hppa1.1-hp + ;; + hp9k8[0-9][0-9] | hp8[0-9][0-9]) + basic_machine=hppa1.0-hp + ;; + hppa-next) + os=-nextstep3 + ;; + hppaosf) + basic_machine=hppa1.1-hp + os=-osf + ;; + hppro) + basic_machine=hppa1.1-hp + os=-proelf + ;; + i370-ibm* | ibm*) + basic_machine=i370-ibm + ;; + i*86v32) + basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` + os=-sysv32 + ;; + i*86v4*) + basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` + os=-sysv4 + ;; + i*86v) + basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` + os=-sysv + ;; + i*86sol2) + basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` + os=-solaris2 + ;; + i386mach) + basic_machine=i386-mach + os=-mach + ;; + i386-vsta | vsta) + basic_machine=i386-unknown + os=-vsta + ;; + iris | iris4d) + basic_machine=mips-sgi + case $os in + -irix*) + ;; + *) + os=-irix4 + ;; + esac + ;; + isi68 | isi) + basic_machine=m68k-isi + os=-sysv + ;; + m68knommu) + basic_machine=m68k-unknown + os=-linux + ;; + m68knommu-*) + basic_machine=m68k-`echo $basic_machine | sed 's/^[^-]*-//'` + os=-linux + ;; + m88k-omron*) + basic_machine=m88k-omron + ;; + magnum | m3230) + basic_machine=mips-mips + os=-sysv + ;; + merlin) + basic_machine=ns32k-utek + os=-sysv + ;; + microblaze*) + basic_machine=microblaze-xilinx + ;; + mingw64) + basic_machine=x86_64-pc + os=-mingw64 + ;; + mingw32) + basic_machine=i686-pc + os=-mingw32 + ;; + mingw32ce) + basic_machine=arm-unknown + os=-mingw32ce + ;; + miniframe) + basic_machine=m68000-convergent + ;; + *mint | -mint[0-9]* | *MiNT | *MiNT[0-9]*) + basic_machine=m68k-atari + os=-mint + ;; + mips3*-*) + basic_machine=`echo $basic_machine | sed -e 's/mips3/mips64/'` + ;; + mips3*) + basic_machine=`echo $basic_machine | sed -e 's/mips3/mips64/'`-unknown + ;; + monitor) + basic_machine=m68k-rom68k + os=-coff + ;; + morphos) + basic_machine=powerpc-unknown + os=-morphos + ;; + msdos) + basic_machine=i386-pc + os=-msdos + ;; + ms1-*) + basic_machine=`echo $basic_machine | sed -e 's/ms1-/mt-/'` + ;; + msys) + basic_machine=i686-pc + os=-msys + ;; + mvs) + basic_machine=i370-ibm + os=-mvs + ;; + nacl) + basic_machine=le32-unknown + os=-nacl + ;; + ncr3000) + basic_machine=i486-ncr + os=-sysv4 + ;; + netbsd386) + basic_machine=i386-unknown + os=-netbsd + ;; + netwinder) + basic_machine=armv4l-rebel + os=-linux + ;; + news | news700 | news800 | news900) + basic_machine=m68k-sony + os=-newsos + ;; + news1000) + basic_machine=m68030-sony + os=-newsos + ;; + news-3600 | risc-news) + basic_machine=mips-sony + os=-newsos + ;; + necv70) + basic_machine=v70-nec + os=-sysv + ;; + next | m*-next ) + basic_machine=m68k-next + case $os in + -nextstep* ) + ;; + -ns2*) + os=-nextstep2 + ;; + *) + os=-nextstep3 + ;; + esac + ;; + nh3000) + basic_machine=m68k-harris + os=-cxux + ;; + nh[45]000) + basic_machine=m88k-harris + os=-cxux + ;; + nindy960) + basic_machine=i960-intel + os=-nindy + ;; + mon960) + basic_machine=i960-intel + os=-mon960 + ;; + nonstopux) + basic_machine=mips-compaq + os=-nonstopux + ;; + np1) + basic_machine=np1-gould + ;; + neo-tandem) + basic_machine=neo-tandem + ;; + nse-tandem) + basic_machine=nse-tandem + ;; + nsr-tandem) + basic_machine=nsr-tandem + ;; + op50n-* | op60c-*) + basic_machine=hppa1.1-oki + os=-proelf + ;; + openrisc | openrisc-*) + basic_machine=or32-unknown + ;; + os400) + basic_machine=powerpc-ibm + os=-os400 + ;; + OSE68000 | ose68000) + basic_machine=m68000-ericsson + os=-ose + ;; + os68k) + basic_machine=m68k-none + os=-os68k + ;; + pa-hitachi) + basic_machine=hppa1.1-hitachi + os=-hiuxwe2 + ;; + paragon) + basic_machine=i860-intel + os=-osf + ;; + parisc) + basic_machine=hppa-unknown + os=-linux + ;; + parisc-*) + basic_machine=hppa-`echo $basic_machine | sed 's/^[^-]*-//'` + os=-linux + ;; + pbd) + basic_machine=sparc-tti + ;; + pbb) + basic_machine=m68k-tti + ;; + pc532 | pc532-*) + basic_machine=ns32k-pc532 + ;; + pc98) + basic_machine=i386-pc + ;; + pc98-*) + basic_machine=i386-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + pentium | p5 | k5 | k6 | nexgen | viac3) + basic_machine=i586-pc + ;; + pentiumpro | p6 | 6x86 | athlon | athlon_*) + basic_machine=i686-pc + ;; + pentiumii | pentium2 | pentiumiii | pentium3) + basic_machine=i686-pc + ;; + pentium4) + basic_machine=i786-pc + ;; + pentium-* | p5-* | k5-* | k6-* | nexgen-* | viac3-*) + basic_machine=i586-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + pentiumpro-* | p6-* | 6x86-* | athlon-*) + basic_machine=i686-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + pentiumii-* | pentium2-* | pentiumiii-* | pentium3-*) + basic_machine=i686-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + pentium4-*) + basic_machine=i786-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + pn) + basic_machine=pn-gould + ;; + power) basic_machine=power-ibm + ;; + ppc | ppcbe) basic_machine=powerpc-unknown + ;; + ppc-* | ppcbe-*) + basic_machine=powerpc-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + ppcle | powerpclittle | ppc-le | powerpc-little) + basic_machine=powerpcle-unknown + ;; + ppcle-* | powerpclittle-*) + basic_machine=powerpcle-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + ppc64) basic_machine=powerpc64-unknown + ;; + ppc64-*) basic_machine=powerpc64-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + ppc64le | powerpc64little | ppc64-le | powerpc64-little) + basic_machine=powerpc64le-unknown + ;; + ppc64le-* | powerpc64little-*) + basic_machine=powerpc64le-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + ps2) + basic_machine=i386-ibm + ;; + pw32) + basic_machine=i586-unknown + os=-pw32 + ;; + rdos | rdos64) + basic_machine=x86_64-pc + os=-rdos + ;; + rdos32) + basic_machine=i386-pc + os=-rdos + ;; + rom68k) + basic_machine=m68k-rom68k + os=-coff + ;; + rm[46]00) + basic_machine=mips-siemens + ;; + rtpc | rtpc-*) + basic_machine=romp-ibm + ;; + s390 | s390-*) + basic_machine=s390-ibm + ;; + s390x | s390x-*) + basic_machine=s390x-ibm + ;; + sa29200) + basic_machine=a29k-amd + os=-udi + ;; + sb1) + basic_machine=mipsisa64sb1-unknown + ;; + sb1el) + basic_machine=mipsisa64sb1el-unknown + ;; + sde) + basic_machine=mipsisa32-sde + os=-elf + ;; + sei) + basic_machine=mips-sei + os=-seiux + ;; + sequent) + basic_machine=i386-sequent + ;; + sh) + basic_machine=sh-hitachi + os=-hms + ;; + sh5el) + basic_machine=sh5le-unknown + ;; + sh64) + basic_machine=sh64-unknown + ;; + sparclite-wrs | simso-wrs) + basic_machine=sparclite-wrs + os=-vxworks + ;; + sps7) + basic_machine=m68k-bull + os=-sysv2 + ;; + spur) + basic_machine=spur-unknown + ;; + st2000) + basic_machine=m68k-tandem + ;; + stratus) + basic_machine=i860-stratus + os=-sysv4 + ;; + strongarm-* | thumb-*) + basic_machine=arm-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + sun2) + basic_machine=m68000-sun + ;; + sun2os3) + basic_machine=m68000-sun + os=-sunos3 + ;; + sun2os4) + basic_machine=m68000-sun + os=-sunos4 + ;; + sun3os3) + basic_machine=m68k-sun + os=-sunos3 + ;; + sun3os4) + basic_machine=m68k-sun + os=-sunos4 + ;; + sun4os3) + basic_machine=sparc-sun + os=-sunos3 + ;; + sun4os4) + basic_machine=sparc-sun + os=-sunos4 + ;; + sun4sol2) + basic_machine=sparc-sun + os=-solaris2 + ;; + sun3 | sun3-*) + basic_machine=m68k-sun + ;; + sun4) + basic_machine=sparc-sun + ;; + sun386 | sun386i | roadrunner) + basic_machine=i386-sun + ;; + sv1) + basic_machine=sv1-cray + os=-unicos + ;; + symmetry) + basic_machine=i386-sequent + os=-dynix + ;; + t3e) + basic_machine=alphaev5-cray + os=-unicos + ;; + t90) + basic_machine=t90-cray + os=-unicos + ;; + tile*) + basic_machine=$basic_machine-unknown + os=-linux-gnu + ;; + tx39) + basic_machine=mipstx39-unknown + ;; + tx39el) + basic_machine=mipstx39el-unknown + ;; + toad1) + basic_machine=pdp10-xkl + os=-tops20 + ;; + tower | tower-32) + basic_machine=m68k-ncr + ;; + tpf) + basic_machine=s390x-ibm + os=-tpf + ;; + udi29k) + basic_machine=a29k-amd + os=-udi + ;; + ultra3) + basic_machine=a29k-nyu + os=-sym1 + ;; + v810 | necv810) + basic_machine=v810-nec + os=-none + ;; + vaxv) + basic_machine=vax-dec + os=-sysv + ;; + vms) + basic_machine=vax-dec + os=-vms + ;; + vpp*|vx|vx-*) + basic_machine=f301-fujitsu + ;; + vxworks960) + basic_machine=i960-wrs + os=-vxworks + ;; + vxworks68) + basic_machine=m68k-wrs + os=-vxworks + ;; + vxworks29k) + basic_machine=a29k-wrs + os=-vxworks + ;; + w65*) + basic_machine=w65-wdc + os=-none + ;; + w89k-*) + basic_machine=hppa1.1-winbond + os=-proelf + ;; + xbox) + basic_machine=i686-pc + os=-mingw32 + ;; + xps | xps100) + basic_machine=xps100-honeywell + ;; + xscale-* | xscalee[bl]-*) + basic_machine=`echo $basic_machine | sed 's/^xscale/arm/'` + ;; + ymp) + basic_machine=ymp-cray + os=-unicos + ;; + z8k-*-coff) + basic_machine=z8k-unknown + os=-sim + ;; + z80-*-coff) + basic_machine=z80-unknown + os=-sim + ;; + none) + basic_machine=none-none + os=-none + ;; + +# Here we handle the default manufacturer of certain CPU types. It is in +# some cases the only manufacturer, in others, it is the most popular. + w89k) + basic_machine=hppa1.1-winbond + ;; + op50n) + basic_machine=hppa1.1-oki + ;; + op60c) + basic_machine=hppa1.1-oki + ;; + romp) + basic_machine=romp-ibm + ;; + mmix) + basic_machine=mmix-knuth + ;; + rs6000) + basic_machine=rs6000-ibm + ;; + vax) + basic_machine=vax-dec + ;; + pdp10) + # there are many clones, so DEC is not a safe bet + basic_machine=pdp10-unknown + ;; + pdp11) + basic_machine=pdp11-dec + ;; + we32k) + basic_machine=we32k-att + ;; + sh[1234] | sh[24]a | sh[24]aeb | sh[34]eb | sh[1234]le | sh[23]ele) + basic_machine=sh-unknown + ;; + sparc | sparcv8 | sparcv9 | sparcv9b | sparcv9v) + basic_machine=sparc-sun + ;; + cydra) + basic_machine=cydra-cydrome + ;; + orion) + basic_machine=orion-highlevel + ;; + orion105) + basic_machine=clipper-highlevel + ;; + mac | mpw | mac-mpw) + basic_machine=m68k-apple + ;; + pmac | pmac-mpw) + basic_machine=powerpc-apple + ;; + *-unknown) + # Make sure to match an already-canonicalized machine name. + ;; + *) + echo Invalid configuration \`$1\': machine \`$basic_machine\' not recognized 1>&2 + exit 1 + ;; +esac + +# Here we canonicalize certain aliases for manufacturers. +case $basic_machine in + *-digital*) + basic_machine=`echo $basic_machine | sed 's/digital.*/dec/'` + ;; + *-commodore*) + basic_machine=`echo $basic_machine | sed 's/commodore.*/cbm/'` + ;; + *) + ;; +esac + +# Decode manufacturer-specific aliases for certain operating systems. + +if [ x"$os" != x"" ] +then +case $os in + # First match some system type aliases + # that might get confused with valid system types. + # -solaris* is a basic system type, with this one exception. + -auroraux) + os=-auroraux + ;; + -solaris1 | -solaris1.*) + os=`echo $os | sed -e 's|solaris1|sunos4|'` + ;; + -solaris) + os=-solaris2 + ;; + -svr4*) + os=-sysv4 + ;; + -unixware*) + os=-sysv4.2uw + ;; + -gnu/linux*) + os=`echo $os | sed -e 's|gnu/linux|linux-gnu|'` + ;; + # First accept the basic system types. + # The portable systems comes first. + # Each alternative MUST END IN A *, to match a version number. + # -sysv* is not here because it comes later, after sysvr4. + -gnu* | -bsd* | -mach* | -minix* | -genix* | -ultrix* | -irix* \ + | -*vms* | -sco* | -esix* | -isc* | -aix* | -cnk* | -sunos | -sunos[34]*\ + | -hpux* | -unos* | -osf* | -luna* | -dgux* | -auroraux* | -solaris* \ + | -sym* | -kopensolaris* | -plan9* \ + | -amigaos* | -amigados* | -msdos* | -newsos* | -unicos* | -aof* \ + | -aos* | -aros* \ + | -nindy* | -vxsim* | -vxworks* | -ebmon* | -hms* | -mvs* \ + | -clix* | -riscos* | -uniplus* | -iris* | -rtu* | -xenix* \ + | -hiux* | -386bsd* | -knetbsd* | -mirbsd* | -netbsd* \ + | -bitrig* | -openbsd* | -solidbsd* \ + | -ekkobsd* | -kfreebsd* | -freebsd* | -riscix* | -lynxos* \ + | -bosx* | -nextstep* | -cxux* | -aout* | -elf* | -oabi* \ + | -ptx* | -coff* | -ecoff* | -winnt* | -domain* | -vsta* \ + | -udi* | -eabi* | -lites* | -ieee* | -go32* | -aux* \ + | -chorusos* | -chorusrdb* | -cegcc* \ + | -cygwin* | -msys* | -pe* | -psos* | -moss* | -proelf* | -rtems* \ + | -mingw32* | -mingw64* | -linux-gnu* | -linux-android* \ + | -linux-newlib* | -linux-musl* | -linux-uclibc* \ + | -uxpv* | -beos* | -mpeix* | -udk* \ + | -interix* | -uwin* | -mks* | -rhapsody* | -darwin* | -opened* \ + | -openstep* | -oskit* | -conix* | -pw32* | -nonstopux* \ + | -storm-chaos* | -tops10* | -tenex* | -tops20* | -its* \ + | -os2* | -vos* | -palmos* | -uclinux* | -nucleus* \ + | -morphos* | -superux* | -rtmk* | -rtmk-nova* | -windiss* \ + | -powermax* | -dnix* | -nx6 | -nx7 | -sei* | -dragonfly* \ + | -skyos* | -haiku* | -rdos* | -toppers* | -drops* | -es* | -tirtos*) + # Remember, each alternative MUST END IN *, to match a version number. + ;; + -qnx*) + case $basic_machine in + x86-* | i*86-*) + ;; + *) + os=-nto$os + ;; + esac + ;; + -nto-qnx*) + ;; + -nto*) + os=`echo $os | sed -e 's|nto|nto-qnx|'` + ;; + -sim | -es1800* | -hms* | -xray | -os68k* | -none* | -v88r* \ + | -windows* | -osx | -abug | -netware* | -os9* | -beos* | -haiku* \ + | -macos* | -mpw* | -magic* | -mmixware* | -mon960* | -lnews*) + ;; + -mac*) + os=`echo $os | sed -e 's|mac|macos|'` + ;; + -linux-dietlibc) + os=-linux-dietlibc + ;; + -linux*) + os=`echo $os | sed -e 's|linux|linux-gnu|'` + ;; + -sunos5*) + os=`echo $os | sed -e 's|sunos5|solaris2|'` + ;; + -sunos6*) + os=`echo $os | sed -e 's|sunos6|solaris3|'` + ;; + -opened*) + os=-openedition + ;; + -os400*) + os=-os400 + ;; + -wince*) + os=-wince + ;; + -osfrose*) + os=-osfrose + ;; + -osf*) + os=-osf + ;; + -utek*) + os=-bsd + ;; + -dynix*) + os=-bsd + ;; + -acis*) + os=-aos + ;; + -atheos*) + os=-atheos + ;; + -syllable*) + os=-syllable + ;; + -386bsd) + os=-bsd + ;; + -ctix* | -uts*) + os=-sysv + ;; + -nova*) + os=-rtmk-nova + ;; + -ns2 ) + os=-nextstep2 + ;; + -nsk*) + os=-nsk + ;; + # Preserve the version number of sinix5. + -sinix5.*) + os=`echo $os | sed -e 's|sinix|sysv|'` + ;; + -sinix*) + os=-sysv4 + ;; + -tpf*) + os=-tpf + ;; + -triton*) + os=-sysv3 + ;; + -oss*) + os=-sysv3 + ;; + -svr4) + os=-sysv4 + ;; + -svr3) + os=-sysv3 + ;; + -sysvr4) + os=-sysv4 + ;; + # This must come after -sysvr4. + -sysv*) + ;; + -ose*) + os=-ose + ;; + -es1800*) + os=-ose + ;; + -xenix) + os=-xenix + ;; + -*mint | -mint[0-9]* | -*MiNT | -MiNT[0-9]*) + os=-mint + ;; + -aros*) + os=-aros + ;; + -zvmoe) + os=-zvmoe + ;; + -dicos*) + os=-dicos + ;; + -nacl*) + ;; + -none) + ;; + *) + # Get rid of the `-' at the beginning of $os. + os=`echo $os | sed 's/[^-]*-//'` + echo Invalid configuration \`$1\': system \`$os\' not recognized 1>&2 + exit 1 + ;; +esac +else + +# Here we handle the default operating systems that come with various machines. +# The value should be what the vendor currently ships out the door with their +# machine or put another way, the most popular os provided with the machine. + +# Note that if you're going to try to match "-MANUFACTURER" here (say, +# "-sun"), then you have to tell the case statement up towards the top +# that MANUFACTURER isn't an operating system. Otherwise, code above +# will signal an error saying that MANUFACTURER isn't an operating +# system, and we'll never get to this point. + +case $basic_machine in + score-*) + os=-elf + ;; + spu-*) + os=-elf + ;; + *-acorn) + os=-riscix1.2 + ;; + arm*-rebel) + os=-linux + ;; + arm*-semi) + os=-aout + ;; + c4x-* | tic4x-*) + os=-coff + ;; + c8051-*) + os=-elf + ;; + hexagon-*) + os=-elf + ;; + tic54x-*) + os=-coff + ;; + tic55x-*) + os=-coff + ;; + tic6x-*) + os=-coff + ;; + # This must come before the *-dec entry. + pdp10-*) + os=-tops20 + ;; + pdp11-*) + os=-none + ;; + *-dec | vax-*) + os=-ultrix4.2 + ;; + m68*-apollo) + os=-domain + ;; + i386-sun) + os=-sunos4.0.2 + ;; + m68000-sun) + os=-sunos3 + ;; + m68*-cisco) + os=-aout + ;; + mep-*) + os=-elf + ;; + mips*-cisco) + os=-elf + ;; + mips*-*) + os=-elf + ;; + or32-*) + os=-coff + ;; + *-tti) # must be before sparc entry or we get the wrong os. + os=-sysv3 + ;; + sparc-* | *-sun) + os=-sunos4.1.1 + ;; + *-be) + os=-beos + ;; + *-haiku) + os=-haiku + ;; + *-ibm) + os=-aix + ;; + *-knuth) + os=-mmixware + ;; + *-wec) + os=-proelf + ;; + *-winbond) + os=-proelf + ;; + *-oki) + os=-proelf + ;; + *-hp) + os=-hpux + ;; + *-hitachi) + os=-hiux + ;; + i860-* | *-att | *-ncr | *-altos | *-motorola | *-convergent) + os=-sysv + ;; + *-cbm) + os=-amigaos + ;; + *-dg) + os=-dgux + ;; + *-dolphin) + os=-sysv3 + ;; + m68k-ccur) + os=-rtu + ;; + m88k-omron*) + os=-luna + ;; + *-next ) + os=-nextstep + ;; + *-sequent) + os=-ptx + ;; + *-crds) + os=-unos + ;; + *-ns) + os=-genix + ;; + i370-*) + os=-mvs + ;; + *-next) + os=-nextstep3 + ;; + *-gould) + os=-sysv + ;; + *-highlevel) + os=-bsd + ;; + *-encore) + os=-bsd + ;; + *-sgi) + os=-irix + ;; + *-siemens) + os=-sysv4 + ;; + *-masscomp) + os=-rtu + ;; + f30[01]-fujitsu | f700-fujitsu) + os=-uxpv + ;; + *-rom68k) + os=-coff + ;; + *-*bug) + os=-coff + ;; + *-apple) + os=-macos + ;; + *-atari*) + os=-mint + ;; + *) + os=-none + ;; +esac +fi + +# Here we handle the case where we know the os, and the CPU type, but not the +# manufacturer. We pick the logical manufacturer. +vendor=unknown +case $basic_machine in + *-unknown) + case $os in + -riscix*) + vendor=acorn + ;; + -sunos*) + vendor=sun + ;; + -cnk*|-aix*) + vendor=ibm + ;; + -beos*) + vendor=be + ;; + -hpux*) + vendor=hp + ;; + -mpeix*) + vendor=hp + ;; + -hiux*) + vendor=hitachi + ;; + -unos*) + vendor=crds + ;; + -dgux*) + vendor=dg + ;; + -luna*) + vendor=omron + ;; + -genix*) + vendor=ns + ;; + -mvs* | -opened*) + vendor=ibm + ;; + -os400*) + vendor=ibm + ;; + -ptx*) + vendor=sequent + ;; + -tpf*) + vendor=ibm + ;; + -vxsim* | -vxworks* | -windiss*) + vendor=wrs + ;; + -aux*) + vendor=apple + ;; + -hms*) + vendor=hitachi + ;; + -mpw* | -macos*) + vendor=apple + ;; + -*mint | -mint[0-9]* | -*MiNT | -MiNT[0-9]*) + vendor=atari + ;; + -vos*) + vendor=stratus + ;; + esac + basic_machine=`echo $basic_machine | sed "s/unknown/$vendor/"` + ;; +esac + +echo $basic_machine$os +exit + +# Local variables: +# eval: (add-hook 'write-file-hooks 'time-stamp) +# time-stamp-start: "timestamp='" +# time-stamp-format: "%:y-%02m-%02d" +# time-stamp-end: "'" +# End: diff --git a/libraries/integer-gmp2/configure.ac b/libraries/integer-gmp2/configure.ac new file mode 100644 index 0000000000..0794d9630c --- /dev/null +++ b/libraries/integer-gmp2/configure.ac @@ -0,0 +1,86 @@ +AC_INIT([Haskell integer (GMP)], [0.1], [libraries@haskell.org], [integer]) + +# Safety check: Ensure that we are in the correct source directory. +AC_CONFIG_SRCDIR([cbits/wrappers.c]) + +AC_CANONICAL_TARGET + +AC_ARG_WITH([cc], + [C compiler], + [CC=$withval]) +AC_PROG_CC() + + +dnl-------------------------------------------------------------------- +dnl * Deal with arguments telling us gmp is somewhere odd +dnl-------------------------------------------------------------------- + +AC_ARG_WITH([gmp-includes], + [AC_HELP_STRING([--with-gmp-includes], + [directory containing gmp.h])], + [GMP_INCLUDE_DIRS=$withval; CPPFLAGS="-I$withval"], + [GMP_INCLUDE_DIRS=]) + +AC_ARG_WITH([gmp-libraries], + [AC_HELP_STRING([--with-gmp-libraries], + [directory containing gmp library])], + [GMP_LIB_DIRS=$withval; LDFLAGS="-L$withval"], + [GMP_LIB_DIRS=]) + +AC_ARG_WITH([gmp-framework-preferred], + [AC_HELP_STRING([--with-gmp-framework-preferred], + [on OSX, prefer the GMP framework to the gmp lib])], + [GMP_PREFER_FRAMEWORK=YES], + [GMP_PREFER_FRAMEWORK=NO]) + +AC_ARG_WITH([intree-gmp], + [AC_HELP_STRING([--with-intree-gmp], + [force using the in-tree GMP])], + [GMP_FORCE_INTREE=YES], + [GMP_FORCE_INTREE=NO]) + +dnl-------------------------------------------------------------------- +dnl * Detect gmp +dnl-------------------------------------------------------------------- + +HaveLibGmp=NO +GMP_LIBS= +HaveFrameworkGMP=NO +GMP_FRAMEWORK= +HaveSecurePowm=0 + +if test "$GMP_FORCE_INTREE" != "YES" +then + if test "$GMP_PREFER_FRAMEWORK" = "YES" + then + LOOK_FOR_GMP_FRAMEWORK + LOOK_FOR_GMP_LIB + else + LOOK_FOR_GMP_LIB + LOOK_FOR_GMP_FRAMEWORK + fi +fi +if test "$HaveFrameworkGMP" = "YES" || test "$HaveLibGmp" = "YES" +then + AC_CHECK_HEADER([gmp.h], , [AC_MSG_ERROR([Cannot find gmp.h])]) +fi + +dnl-------------------------------------------------------------------- +dnl * Make sure we got some form of gmp +dnl-------------------------------------------------------------------- + +AC_SUBST(GMP_INCLUDE_DIRS) +AC_SUBST(GMP_LIBS) +AC_SUBST(GMP_LIB_DIRS) +AC_SUBST(GMP_FRAMEWORK) +AC_SUBST(HaveLibGmp) +AC_SUBST(HaveFrameworkGMP) +AC_SUBST(HaveSecurePowm) + +AC_CONFIG_FILES([integer-gmp.buildinfo gmp/config.mk include/HsIntegerGmp.h]) + +dnl-------------------------------------------------------------------- +dnl * Generate the header cbits/GmpDerivedConstants.h +dnl-------------------------------------------------------------------- + +AC_OUTPUT diff --git a/libraries/integer-gmp2/gmp/config.mk.in b/libraries/integer-gmp2/gmp/config.mk.in new file mode 100644 index 0000000000..93a4f5369b --- /dev/null +++ b/libraries/integer-gmp2/gmp/config.mk.in @@ -0,0 +1,11 @@ +ifeq "$(HaveLibGmp)" "" + HaveLibGmp = @HaveLibGmp@ +endif + +ifeq "$(HaveFrameworkGMP)" "" + HaveFrameworkGMP = @HaveFrameworkGMP@ +endif + +GMP_INCLUDE_DIRS = @GMP_INCLUDE_DIRS@ +GMP_LIB_DIRS = @GMP_LIB_DIRS@ + diff --git a/libraries/integer-gmp2/gmp/ghc.mk b/libraries/integer-gmp2/gmp/ghc.mk new file mode 100644 index 0000000000..298005ff1f --- /dev/null +++ b/libraries/integer-gmp2/gmp/ghc.mk @@ -0,0 +1,124 @@ +# ----------------------------------------------------------------------------- +# +# (c) 2009 The University of Glasgow +# +# This file is part of the GHC build system. +# +# To understand how the build system works and how to modify it, see +# http://ghc.haskell.org/trac/ghc/wiki/Building/Architecture +# http://ghc.haskell.org/trac/ghc/wiki/Building/Modifying +# +# ----------------------------------------------------------------------------- + +# We use a tarball like gmp-4.2.4-nodoc.tar.bz2, which is +# gmp-4.2.4.tar.bz2 repacked without the doc/ directory contents. +# That's because the doc/ directory contents are under the GFDL, +# which causes problems for Debian. + +GMP_TARBALL := $(wildcard libraries/integer-gmp/gmp/tarball/gmp*.tar.bz2) +GMP_DIR := $(patsubst libraries/integer-gmp/gmp/tarball/%-nodoc-patched.tar.bz2,%,$(GMP_TARBALL)) + +ifneq "$(NO_CLEAN_GMP)" "YES" +$(eval $(call clean-target,gmp,,\ + libraries/integer-gmp2/gmp/config.mk \ + libraries/integer-gmp2/gmp/libgmp.a \ + libraries/integer-gmp2/gmp/gmp.h \ + libraries/integer-gmp2/gmp/gmpbuild \ + libraries/integer-gmp2/gmp/$(GMP_DIR))) + +clean : clean_gmp +.PHONY: clean_gmp +clean_gmp: + $(call removeTrees,libraries/integer-gmp2/gmp/objs) + $(call removeTrees,libraries/integer-gmp2/gmp/gmpbuild) +endif + +ifeq "$(Windows_Host)" "YES" +# Apparently building on Windows fails when there is a system gmp +# available, so we never try to use the system gmp on Windows +libraries/integer-gmp2_CONFIGURE_OPTS += --configure-option=--with-intree-gmp +endif + +ifeq "$(GMP_PREFER_FRAMEWORK)" "YES" +libraries/integer-gmp2_CONFIGURE_OPTS += --with-gmp-framework-preferred +endif + +ifeq "$(phase)" "final" + +ifeq "$(findstring clean,$(MAKECMDGOALS))" "" +include libraries/integer-gmp2/gmp/config.mk +endif + +gmp_CC_OPTS += $(addprefix -I,$(GMP_INCLUDE_DIRS)) +gmp_CC_OPTS += $(addprefix -L,$(GMP_LIB_DIRS)) + +# Compile GMP only if we don't have it already +# +# We use GMP's own configuration stuff, because it's all rather hairy +# and not worth re-implementing in our Makefile framework. + +ifeq "$(findstring dyn, $(GhcRTSWays))" "dyn" +BUILD_SHARED=yes +else +BUILD_SHARED=no +endif + +# In a bindist, we don't want to know whether /this/ machine has gmp, +# but whether the machine the bindist was built on had gmp. +ifeq "$(BINDIST)" "YES" +ifeq "$(wildcard libraries/integer-gmp2/gmp/libgmp.a)" "" +HaveLibGmp = YES +HaveFrameworkGMP = YES +else +HaveLibGmp = NO +HaveFrameworkGMP = NO +endif +endif + +ifneq "$(HaveLibGmp)" "YES" +ifneq "$(HaveFrameworkGMP)" "YES" +$(libraries/integer-gmp2_dist-install_depfile_c_asm): libraries/integer-gmp2/gmp/gmp.h + +gmp_CC_OPTS += -Ilibraries/integer-gmp2/gmp + +libraries/integer-gmp2_dist-install_EXTRA_OBJS += libraries/integer-gmp2/gmp/objs/*.o +endif +endif + +libraries/integer-gmp2_dist-install_EXTRA_CC_OPTS += $(gmp_CC_OPTS) + +CLANG = $(findstring clang, $(shell $(CC_STAGE1) --version)) + +ifeq "$(CLANG)" "clang" +CCX = $(CLANG) +else +CCX = $(CC_STAGE1) +endif + +libraries/integer-gmp2/gmp/libgmp.a libraries/integer-gmp2/gmp/gmp.h: + $(RM) -rf libraries/integer-gmp2/gmp/$(GMP_DIR) libraries/integer-gmp2/gmp/gmpbuild libraries/integer-gmp2/gmp/objs + cat $(GMP_TARBALL) | $(BZIP2_CMD) -d | { cd libraries/integer-gmp2/gmp && $(TAR_CMD) -xf - ; } + mv libraries/integer-gmp2/gmp/$(GMP_DIR) libraries/integer-gmp2/gmp/gmpbuild + cd libraries/integer-gmp2/gmp && patch -p0 < gmpsrc.patch + chmod +x libraries/integer-gmp2/gmp/ln + + # Their cmd invocation only works on msys. On cygwin it starts + # a cmd interactive shell. The replacement works in both environments. + mv libraries/integer-gmp2/gmp/gmpbuild/ltmain.sh libraries/integer-gmp2/gmp/gmpbuild/ltmain.sh.orig + sed 's#cmd //c echo "\$$1"#cmd /c "echo $$1"#' < libraries/integer-gmp2/gmp/gmpbuild/ltmain.sh.orig > libraries/integer-gmp2/gmp/gmpbuild/ltmain.sh + + cd libraries/integer-gmp2/gmp; (set -o igncr 2>/dev/null) && set -o igncr; export SHELLOPTS; \ + PATH=`pwd`:$$PATH; \ + export PATH; \ + cd gmpbuild && \ + CC=$(CCX) NM=$(NM) AR=$(AR_STAGE1) ./configure \ + --enable-shared=no \ + --host=$(HOSTPLATFORM) --build=$(BUILDPLATFORM) + $(MAKE) -C libraries/integer-gmp2/gmp/gmpbuild MAKEFLAGS= + $(CP) libraries/integer-gmp2/gmp/gmpbuild/gmp.h libraries/integer-gmp2/gmp/ + $(CP) libraries/integer-gmp2/gmp/gmpbuild/.libs/libgmp.a libraries/integer-gmp2/gmp/ + $(MKDIRHIER) libraries/integer-gmp2/gmp/objs + cd libraries/integer-gmp2/gmp/objs && $(AR_STAGE1) x ../libgmp.a + $(RANLIB_CMD) libraries/integer-gmp2/gmp/libgmp.a + +endif diff --git a/libraries/integer-gmp2/gmp/gmpsrc.patch b/libraries/integer-gmp2/gmp/gmpsrc.patch new file mode 100644 index 0000000000..e3906329ee --- /dev/null +++ b/libraries/integer-gmp2/gmp/gmpsrc.patch @@ -0,0 +1,37 @@ +--- gmp-5.0.3/configure 2012-02-03 16:52:49.000000000 +0100 ++++ gmpbuild/configure 2014-11-07 23:46:33.629758238 +0100 +@@ -3937,8 +3937,8 @@ + # + cclist="gcc cc" + +-gcc_cflags="-O2 -pedantic" +-gcc_64_cflags="-O2 -pedantic" ++gcc_cflags="-O2 -pedantic -fPIC" ++gcc_64_cflags="-O2 -pedantic -fPIC" + cc_cflags="-O" + cc_64_cflags="-O" + +--- gmp-5.0.3/memory.c 2012-02-03 16:52:49.000000000 +0100 ++++ gmpbuild/memory.c 2014-11-07 23:54:20.734523242 +0100 +@@ -24,21 +24,10 @@ + #include "gmp-impl.h" + + +-/* Patched for GHC: */ +-void * stgAllocForGMP (size_t size_in_bytes); +-void * stgReallocForGMP (void *ptr, size_t old_size, size_t new_size); +-void stgDeallocForGMP (void *ptr, size_t size); +- +-void * (*__gmp_allocate_func) __GMP_PROTO ((size_t)) = stgAllocForGMP; +-void * (*__gmp_reallocate_func) __GMP_PROTO ((void *, size_t, size_t)) +- = stgReallocForGMP; +-void (*__gmp_free_func) __GMP_PROTO ((void *, size_t)) = stgDeallocForGMP; +-/* + void * (*__gmp_allocate_func) __GMP_PROTO ((size_t)) = __gmp_default_allocate; + void * (*__gmp_reallocate_func) __GMP_PROTO ((void *, size_t, size_t)) + = __gmp_default_reallocate; + void (*__gmp_free_func) __GMP_PROTO ((void *, size_t)) = __gmp_default_free; +-*/ + + + /* Default allocation functions. In case of failure to allocate/reallocate diff --git a/libraries/integer-gmp2/gmp/ln b/libraries/integer-gmp2/gmp/ln new file mode 100755 index 0000000000..a3a297ccdb --- /dev/null +++ b/libraries/integer-gmp2/gmp/ln @@ -0,0 +1,3 @@ +#!/bin/sh +exit 1 + diff --git a/libraries/integer-gmp2/include/HsIntegerGmp.h.in b/libraries/integer-gmp2/include/HsIntegerGmp.h.in new file mode 100644 index 0000000000..11c64677e8 --- /dev/null +++ b/libraries/integer-gmp2/include/HsIntegerGmp.h.in @@ -0,0 +1,6 @@ +#ifndef _HS_INTEGER_GMP_H_ +#define _HS_INTEGER_GMP_H_ + +#define HAVE_SECURE_POWM @HaveSecurePowm@ + +#endif /* _HS_INTEGER_GMP_H_ */ diff --git a/libraries/integer-gmp2/integer-gmp.buildinfo.in b/libraries/integer-gmp2/integer-gmp.buildinfo.in new file mode 100644 index 0000000000..91b4313226 --- /dev/null +++ b/libraries/integer-gmp2/integer-gmp.buildinfo.in @@ -0,0 +1,5 @@ +include-dirs: @GMP_INCLUDE_DIRS@ +extra-lib-dirs: @GMP_LIB_DIRS@ +extra-libraries: @GMP_LIBS@ +frameworks: @GMP_FRAMEWORK@ +install-includes: HsIntegerGmp.h diff --git a/libraries/integer-gmp2/integer-gmp.cabal b/libraries/integer-gmp2/integer-gmp.cabal new file mode 100644 index 0000000000..a76e62214a --- /dev/null +++ b/libraries/integer-gmp2/integer-gmp.cabal @@ -0,0 +1,65 @@ +name: integer-gmp +version: 1.0.0.0 +synopsis: Integer library based on GMP +license: BSD3 +license-file: LICENSE +author: Herbert Valerio Riedel +maintainer: hvr@gnu.org +category: Numeric, Algebra +build-type: Configure +cabal-version: >=1.10 + +extra-source-files: + aclocal.m4 + cbits/wrappers.c + changelog.md + config.guess + config.sub + configure + configure.ac + gmp/config.mk.in + include/HsIntegerGmp.h.in + integer-gmp.buildinfo.in + +extra-tmp-files: + autom4te.cache + config.log + config.status + gmp/config.mk + integer-gmp.buildinfo + include/HsIntegerGmp.h + +library + default-language: Haskell2010 + other-extensions: + BangPatterns + CApiFFI + CPP + DeriveDataTypeable + ExplicitForAll + GHCForeignImportPrim + MagicHash + NegativeLiterals + NoImplicitPrelude + RebindableSyntax + StandaloneDeriving + UnboxedTuples + UnliftedFFITypes + build-depends: ghc-prim + hs-source-dirs: src/ + ghc-options: -this-package-key integer-gmp -Wall + cc-options: -std=c99 -Wall + + include-dirs: include + c-sources: + cbits/wrappers.c + + exposed-modules: + GHC.Integer + GHC.Integer.Logarithms + GHC.Integer.Logarithms.Internals + + GHC.Integer.GMP.Internals + + other-modules: + GHC.Integer.Type diff --git a/libraries/integer-gmp2/src/GHC/Integer.hs b/libraries/integer-gmp2/src/GHC/Integer.hs new file mode 100644 index 0000000000..ffd708bb93 --- /dev/null +++ b/libraries/integer-gmp2/src/GHC/Integer.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE NoImplicitPrelude #-} + +#include "MachDeps.h" + +-- | +-- Module : GHC.Integer.Type +-- Copyright : (c) Herbert Valerio Riedel 2014 +-- License : BSD3 +-- +-- Maintainer : ghc-devs@haskell.org +-- Stability : provisional +-- Portability : non-portable (GHC Extensions) +-- +-- The 'Integer' type. +-- +-- This module exposes the /portable/ 'Integer' API. See +-- "GHC.Integer.GMP.Internals" for the @integer-gmp@-specific internal +-- representation of 'Integer' as well as optimized GMP-specific +-- operations. + +module GHC.Integer ( + Integer, + + -- * Construct 'Integer's + mkInteger, smallInteger, wordToInteger, +#if WORD_SIZE_IN_BITS < 64 + word64ToInteger, int64ToInteger, +#endif + -- * Conversion to other integral types + integerToWord, integerToInt, +#if WORD_SIZE_IN_BITS < 64 + integerToWord64, integerToInt64, +#endif + + -- * Helpers for 'RealFloat' type-class operations + encodeFloatInteger, floatFromInteger, + encodeDoubleInteger, decodeDoubleInteger, doubleFromInteger, + + -- * Arithmetic operations + plusInteger, minusInteger, timesInteger, negateInteger, + absInteger, signumInteger, + + divModInteger, divInteger, modInteger, + quotRemInteger, quotInteger, remInteger, + + -- * Comparison predicates + eqInteger, neqInteger, leInteger, gtInteger, ltInteger, geInteger, + compareInteger, + + -- ** 'Int#'-boolean valued versions of comparision predicates + -- + -- | These operations return @0#@ and @1#@ instead of 'False' and + -- 'True' respectively. See + -- <https://ghc.haskell.org/trac/ghc/wiki/PrimBool PrimBool wiki-page> + -- for more details + eqInteger#, neqInteger#, leInteger#, gtInteger#, ltInteger#, geInteger#, + + + -- * Bit-operations + andInteger, orInteger, xorInteger, + + complementInteger, + shiftLInteger, shiftRInteger, testBitInteger, + + -- * Hashing + hashInteger, + ) where + +import GHC.Integer.Type + +default () diff --git a/libraries/integer-gmp2/src/GHC/Integer/GMP/Internals.hs b/libraries/integer-gmp2/src/GHC/Integer/GMP/Internals.hs new file mode 100644 index 0000000000..d119adb9f8 --- /dev/null +++ b/libraries/integer-gmp2/src/GHC/Integer/GMP/Internals.hs @@ -0,0 +1,126 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CApiFFI #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UnliftedFFITypes #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GHCForeignImportPrim #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE NoImplicitPrelude #-} + +#include "MachDeps.h" + +-- | +-- Module : GHC.Integer.GMP.Internals +-- Copyright : (c) Herbert Valerio Riedel 2014 +-- License : BSD3 +-- +-- Maintainer : ghc-devs@haskell.org +-- Stability : provisional +-- Portability : non-portable (GHC Extensions) +-- +-- This modules provides access to the 'Integer' constructors and +-- exposes some highly optimized GMP-operations. +-- +-- Note that since @integer-gmp@ does not depend on `base`, error +-- reporting via exceptions, 'error', or 'undefined' is not +-- available. Instead, the low-level functions will crash the runtime +-- if called with invalid arguments. +-- +-- See also +-- <https://ghc.haskell.org/trac/ghc/wiki/Commentary/Libraries/Integer GHC Commentary: Libraries/Integer>. + +module GHC.Integer.GMP.Internals + ( -- * The 'Integer' type + Integer(..) + , isValidInteger# + + -- ** Basic 'Integer' operations + + , module GHC.Integer + + -- ** Additional 'Integer' operations + , bitInteger + , popCountInteger + , gcdInteger + , lcmInteger + , sqrInteger + + -- ** Additional conversion operations to 'Integer' + , wordToNegInteger + , bigNatToInteger + , bigNatToNegInteger + + -- * The 'BigNat' type + , BigNat(..) + + , GmpLimb, GmpLimb# + , GmpSize, GmpSize# + + -- ** + + , isValidBigNat# + , sizeofBigNat# + , zeroBigNat + , oneBigNat + , nullBigNat + + -- ** Conversions to/from 'BigNat' + + , byteArrayToBigNat# + , wordToBigNat + , wordToBigNat2 + , bigNatToWord + , indexBigNat# + + -- ** 'BigNat' arithmetic operations + , plusBigNat + , plusBigNatWord + , minusBigNat + , minusBigNatWord + , timesBigNat + , timesBigNatWord + , sqrBigNat + + , quotRemBigNat + , quotRemBigNatWord + , quotBigNatWord + , quotBigNat + , remBigNat + , remBigNatWord + + , gcdBigNat + , gcdBigNatWord + + -- ** 'BigNat' logic operations + , shiftRBigNat + , shiftLBigNat + , testBitBigNat + , andBigNat + , xorBigNat + , popCountBigNat + , orBigNat + , bitBigNat + + -- ** 'BigNat' comparision predicates + , isZeroBigNat + , isNullBigNat# + + , compareBigNatWord + , compareBigNat + , eqBigNatWord + , eqBigNatWord# + , eqBigNat + , eqBigNat# + , gtBigNatWord# + + -- * Miscellaneous GMP-provided operations + , gcdInt + + ) where + +import GHC.Integer.Type +import GHC.Integer + +default () diff --git a/libraries/integer-gmp2/src/GHC/Integer/Logarithms.hs b/libraries/integer-gmp2/src/GHC/Integer/Logarithms.hs new file mode 100644 index 0000000000..cbcc860002 --- /dev/null +++ b/libraries/integer-gmp2/src/GHC/Integer/Logarithms.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UnliftedFFITypes #-} +{-# LANGUAGE CPP #-} + +module GHC.Integer.Logarithms + ( wordLog2# + , integerLog2# + , integerLogBase# + ) where + +#include "MachDeps.h" + +#if WORD_SIZE_IN_BITS == 32 +# define LD_WORD_SIZE_IN_BITS 5 +#elif WORD_SIZE_IN_BITS == 64 +# define LD_WORD_SIZE_IN_BITS 6 +#else +# error unsupported WORD_SIZE_IN_BITS +#endif + +import GHC.Integer.Type + +import GHC.Prim + +default () + +-- | Calculate the integer logarithm for an arbitrary base. +-- +-- The base must be greater than @1@, the second argument, the number +-- whose logarithm is sought, shall be positive, otherwise the +-- result is meaningless. +-- +-- The following property holds +-- +-- @base ^ 'integerLogBase#' base m <= m < base ^('integerLogBase#' base m + 1)@ +-- +-- for @base > 1@ and @m > 0@. +-- +-- Note: Internally uses 'integerLog2#' for base 2 +integerLogBase# :: Integer -> Integer -> Int# +integerLogBase# (S# 2#) m = integerLog2# m +integerLogBase# b m = e' + where + (# _, e' #) = go b + + go pw | m `ltInteger` pw = (# m, 0# #) + go pw = case go (sqrInteger pw) of + (# q, e #) | q `ltInteger` pw -> (# q, 2# *# e #) + (# q, e #) -> (# q `quotInteger` pw, 2# *# e +# 1# #) + + +-- | Calculate the integer base 2 logarithm of an 'Integer'. The +-- calculation is more efficient than for the general case, on +-- platforms with 32- or 64-bit words much more efficient. +-- +-- The argument must be strictly positive, that condition is /not/ checked. +integerLog2# :: Integer -> Int# +integerLog2# (S# i#) = wordLog2# (int2Word# i#) +integerLog2# (Jn# _) = -1# +integerLog2# (Jp# bn) = go (s -# 1#) + where + s = sizeofBigNat# bn + go i = case indexBigNat# bn i of + 0## -> go (i -# 1#) + w -> wordLog2# w +# (uncheckedIShiftL# i LD_WORD_SIZE_IN_BITS#) + +-- | Compute base-2 log of 'Word#' +-- +-- This is internally implemented as count-leading-zeros machine instruction. +wordLog2# :: Word# -> Int# +wordLog2# w# = (WORD_SIZE_IN_BITS# -# 1#) -# (word2Int# (clz# w#)) diff --git a/libraries/integer-gmp2/src/GHC/Integer/Logarithms/Internals.hs b/libraries/integer-gmp2/src/GHC/Integer/Logarithms/Internals.hs new file mode 100644 index 0000000000..7ac3645c74 --- /dev/null +++ b/libraries/integer-gmp2/src/GHC/Integer/Logarithms/Internals.hs @@ -0,0 +1,118 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE CPP #-} + +{-# OPTIONS_HADDOCK hide #-} + +#include "MachDeps.h" + +#if WORD_SIZE_IN_BITS == 32 +# define WSHIFT 5 +# define MMASK 31 +#elif WORD_SIZE_IN_BITS == 64 +# define WSHIFT 6 +# define MMASK 63 +#else +# error unsupported WORD_SIZE_IN_BITS +#endif + +-- | Fast 'Integer' logarithms to base 2. 'integerLog2#' and +-- 'wordLog2#' are of general usefulness, the others are only needed +-- for a fast implementation of 'fromRational'. Since they are needed +-- in "GHC.Float", we must expose this module, but it should not show +-- up in the docs. +-- +-- See https://ghc.haskell.org/trac/ghc/ticket/5122 +-- for the origin of the code in this module +module GHC.Integer.Logarithms.Internals + ( wordLog2# + , integerLog2IsPowerOf2# + , integerLog2# + , roundingMode# + ) where + +import GHC.Integer.Type +import GHC.Integer.Logarithms + +import GHC.Types +import GHC.Prim + +default () + +-- | Extended version of 'integerLog2#' +-- +-- Assumption: Integer is strictly positive +-- +-- First component of result is @log2 n@, second is @0#@ iff /n/ is a +-- power of two. +integerLog2IsPowerOf2# :: Integer -> (# Int#, Int# #) +-- The power of 2 test is n&(n-1) == 0, thus powers of 2 +-- are indicated bythe second component being zero. +integerLog2IsPowerOf2# (S# i#) = case int2Word# i# of + w -> (# wordLog2# w, word2Int# (w `and#` (w `minusWord#` 1##)) #) +integerLog2IsPowerOf2# (Jn# _) = (# -1#, -1# #) +-- Find the log2 as above, test whether that word is a power +-- of 2, if so, check whether only zero bits follow. +integerLog2IsPowerOf2# (Jp# bn) = check (s -# 1#) + where + s = sizeofBigNat# bn + check :: Int# -> (# Int#, Int# #) + check i = case indexBigNat# bn i of + 0## -> check (i -# 1#) + w -> (# wordLog2# w +# (uncheckedIShiftL# i WSHIFT#) + , case w `and#` (w `minusWord#` 1##) of + 0## -> test (i -# 1#) + _ -> 1# #) + test :: Int# -> Int# + test i = if isTrue# (i <# 0#) + then 0# + else case indexBigNat# bn i of + 0## -> test (i -# 1#) + _ -> 1# + + +-- Assumption: Integer and Int# are strictly positive, Int# is less +-- than logBase 2 of Integer, otherwise havoc ensues. +-- Used only for the numerator in fromRational when the denominator +-- is a power of 2. +-- The Int# argument is log2 n minus the number of bits in the mantissa +-- of the target type, i.e. the index of the first non-integral bit in +-- the quotient. +-- +-- 0# means round down (towards zero) +-- 1# means we have a half-integer, round to even +-- 2# means round up (away from zero) +roundingMode# :: Integer -> Int# -> Int# +roundingMode# (S# i#) t = + case int2Word# i# `and#` ((uncheckedShiftL# 2## t) `minusWord#` 1##) of + k -> case uncheckedShiftL# 1## t of + c -> if isTrue# (c `gtWord#` k) + then 0# + else if isTrue# (c `ltWord#` k) + then 2# + else 1# + +roundingMode# (Jn# bn) t = roundingMode# (Jp# bn) t -- dummy +roundingMode# (Jp# bn) t = + case word2Int# (int2Word# t `and#` MMASK##) of + j -> -- index of relevant bit in word + case uncheckedIShiftRA# t WSHIFT# of + k -> -- index of relevant word + case indexBigNat# bn k `and#` + ((uncheckedShiftL# 2## j) `minusWord#` 1##) of + r -> + case uncheckedShiftL# 1## j of + c -> if isTrue# (c `gtWord#` r) + then 0# + else if isTrue# (c `ltWord#` r) + + + then 2# + else test (k -# 1#) + where + test i = if isTrue# (i <# 0#) + then 1# + else case indexBigNat# bn i of + 0## -> test (i -# 1#) + _ -> 2# diff --git a/libraries/integer-gmp2/src/GHC/Integer/Type.hs b/libraries/integer-gmp2/src/GHC/Integer/Type.hs new file mode 100644 index 0000000000..a143160b6b --- /dev/null +++ b/libraries/integer-gmp2/src/GHC/Integer/Type.hs @@ -0,0 +1,1663 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GHCForeignImportPrim #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UnliftedFFITypes #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NegativeLiterals #-} +{-# LANGUAGE ExplicitForAll #-} + +-- | +-- Module : GHC.Integer.Type +-- Copyright : (c) Herbert Valerio Riedel 2014 +-- License : BSD3 +-- +-- Maintainer : ghc-devs@haskell.org +-- Stability : provisional +-- Portability : non-portable (GHC Extensions) +-- +-- GHC needs this module to be named "GHC.Integer.Type" and provide +-- all the low-level 'Integer' operations. + +module GHC.Integer.Type where + +#include "MachDeps.h" + +-- Sanity check as CPP defines are implicitly 0-valued when undefined +#if !(defined(SIZEOF_LONG) && defined(SIZEOF_HSWORD) \ + && defined(WORD_SIZE_IN_BITS)) +# error missing defines +#endif + +import GHC.Classes +import GHC.Magic +import GHC.Prim +import GHC.Types +#if WORD_SIZE_IN_BITS < 64 +import GHC.IntWord64 +#endif + +default () + +-- Most high-level operations need to be marked `NOINLINE` as +-- otherwise GHC doesn't recognize them and fails to apply constant +-- folding to `Integer`-typed expression. +-- +-- To this end, the CPP hack below allows to write the pseudo-pragma +-- +-- {-# CONSTANT_FOLDED plusInteger #-} +-- +-- which is simply expaned into a +-- +-- {-# NOINLINE plusInteger #-} +-- +#define CONSTANT_FOLDED NOINLINE + +---------------------------------------------------------------------------- +-- type definitions + +-- NB: all code assumes GMP_LIMB_BITS == WORD_SIZE_IN_BITS +-- The C99 code in cbits/wrappers.c will fail to compile if this doesn't hold + +-- | Type representing a GMP Limb +type GmpLimb = Word -- actually, 'CULong' +type GmpLimb# = Word# + +-- | Count of 'GmpLimb's, must be positive (unless specified otherwise). +type GmpSize = Int -- actually, a 'CLong' +type GmpSize# = Int# + +narrowGmpSize# :: Int# -> Int# +#if SIZEOF_LONG == SIZEOF_HSWORD +narrowGmpSize# x = x +#elif (SIZEOF_LONG == 4) && (SIZEOF_HSWORD == 8) +-- On IL32P64 (i.e. Win64), we have to be careful with CLong not being +-- 64bit. This is mostly an issue on values returned from C functions +-- due to sign-extension. +narrowGmpSize# = narrow32Int# +#endif + + +type GmpBitCnt = Word -- actually, 'CULong' +type GmpBitCnt# = Word# -- actually, 'CULong' + +-- Pseudo FFI CType +type CInt = Int +type CInt# = Int# + +narrowCInt# :: Int# -> Int# +narrowCInt# = narrow32Int# + +-- | Bits in a 'GmpLimb'. Same as @WORD_SIZE_IN_BITS@. +gmpLimbBits :: Word -- 8 `shiftL` gmpLimbShift +gmpLimbBits = W# WORD_SIZE_IN_BITS## + +#if WORD_SIZE_IN_BITS == 64 +# define GMP_LIMB_SHIFT 3 +# define GMP_LIMB_BYTES 8 +# define GMP_LIMB_BITS 64 +# define INT_MINBOUND -0x8000000000000000 +# define INT_MAXBOUND 0x7fffffffffffffff +# define ABS_INT_MINBOUND 0x8000000000000000 +# define SQRT_INT_MAXBOUND 0xb504f333 +#elif WORD_SIZE_IN_BITS == 32 +# define GMP_LIMB_SHIFT 2 +# define GMP_LIMB_BYTES 4 +# define GMP_LIMB_BITS 32 +# define INT_MINBOUND -0x80000000 +# define INT_MAXBOUND 0x7fffffff +# define ABS_INT_MINBOUND 0x80000000 +# define SQRT_INT_MAXBOUND 0xb504 +#else +# error unsupported WORD_SIZE_IN_BITS config +#endif + +-- | Type representing /raw/ arbitrary-precision Naturals +-- +-- This is common type used by 'Natural' and 'Integer'. As this type +-- consists of a single constructor wrapping a 'ByteArray#' it can be +-- unpacked. +-- +-- Essential invariants: +-- +-- - 'ByteArray#' size is an exact multiple of 'Word#' size +-- - limbs are stored in least-significant-limb-first order, +-- - the most-significant limb must be non-zero, except for +-- - @0@ which is represented as a 1-limb. +data BigNat = BN# ByteArray# + +instance Eq BigNat where + (==) = eqBigNat + +instance Ord BigNat where + compare = compareBigNat + +-- | Invariant: 'Jn#' and 'Jp#' are used iff value doesn't fit in 'S#' +-- +-- Useful properties resulting from the invariants: +-- +-- - @abs ('S#' _) <= abs ('Jp#' _)@ +-- - @abs ('S#' _) < abs ('Jn#' _)@ +-- +data Integer = S# !Int# + -- ^ iff value in @[minBound::'Int', maxBound::'Int']@ range + | Jp# {-# UNPACK #-} !BigNat + -- ^ iff value in @]maxBound::'Int', +inf[@ range + | Jn# {-# UNPACK #-} !BigNat + -- ^ iff value in @]-inf, minBound::'Int'[@ range + +-- TODO: experiment with different constructor-ordering + +instance Eq Integer where + (==) = eqInteger + (/=) = neqInteger + +instance Ord Integer where + compare = compareInteger + (>) = gtInteger + (>=) = geInteger + (<) = ltInteger + (<=) = leInteger + +---------------------------------------------------------------------------- + +-- | Construct 'Integer' value from list of 'Int's. +-- +-- This function is used by GHC for constructing 'Integer' literals. +mkInteger :: Bool -- ^ sign of integer ('True' if non-negative) + -> [Int] -- ^ absolute value expressed in 31 bit chunks, least + -- significant first (ideally these would be machine-word + -- 'Word's rather than 31-bit truncated 'Int's) + -> Integer +mkInteger nonNegative is + | nonNegative = f is + | True = negateInteger (f is) + where + f [] = S# 0# + f (I# i : is') = smallInteger (i `andI#` 0x7fffffff#) `orInteger` + shiftLInteger (f is') 31# +{-# CONSTANT_FOLDED mkInteger #-} + +-- | Test whether all internal invariants are satisfied by 'Integer' value +-- +-- Returns @1#@ if valid, @0#@ otherwise. +-- +-- This operation is mostly useful for test-suites and/or code which +-- constructs 'Integer' values directly. +isValidInteger# :: Integer -> Int# +isValidInteger# (S# _) = 1# +isValidInteger# (Jp# bn) + = isValidBigNat# bn `andI#` (bn `gtBigNatWord#` INT_MAXBOUND##) +isValidInteger# (Jn# bn) + = isValidBigNat# bn `andI#` (bn `gtBigNatWord#` ABS_INT_MINBOUND##) + +-- | Should rather be called @intToInteger@ +smallInteger :: Int# -> Integer +smallInteger i# = S# i# +{-# CONSTANT_FOLDED smallInteger #-} + +---------------------------------------------------------------------------- +-- Int64/Word64 specific primitives + +#if WORD_SIZE_IN_BITS < 64 +int64ToInteger :: Int64# -> Integer +int64ToInteger i + | isTrue# (i `leInt64#` intToInt64# 0x7FFFFFFF#) + , isTrue# (i `geInt64#` intToInt64# -0x80000000#) + = S# (int64ToInt# i) + | isTrue# (i `geInt64#` intToInt64# 0#) + = Jp# (word64ToBigNat (int64ToWord64# i)) + | True + = Jn# (word64ToBigNat (int64ToWord64# (negateInt64# i))) +{-# CONSTANT_FOLDED int64ToInteger #-} + +word64ToInteger :: Word64# -> Integer +word64ToInteger w + | isTrue# (w `leWord64#` wordToWord64# 0x7FFFFFFF##) + = S# (int64ToInt# (word64ToInt64# w)) + | True + = Jp# (word64ToBigNat w) +{-# CONSTANT_FOLDED word64ToInteger #-} + +integerToInt64 :: Integer -> Int64# +integerToInt64 (S# i#) = intToInt64# i# +integerToInt64 (Jp# bn) = word64ToInt64# (bigNatToWord64 bn) +integerToInt64 (Jn# bn) = negateInt64# (word64ToInt64# (bigNatToWord64 bn)) +{-# CONSTANT_FOLDED integerToInt64 #-} + +integerToWord64 :: Integer -> Word64# +integerToWord64 (S# i#) = int64ToWord64# (intToInt64# i#) +integerToWord64 (Jp# bn) = bigNatToWord64 bn +integerToWord64 (Jn# bn) + = int64ToWord64# (negateInt64# (word64ToInt64# (bigNatToWord64 bn))) +{-# CONSTANT_FOLDED integerToWord64 #-} + +#if GMP_LIMB_BITS == 32 +word64ToBigNat :: Word64# -> BigNat +word64ToBigNat w64 = wordToBigNat2 wh# wl# + where + wh# = word64ToWord# (uncheckedShiftRL64# w64 32#) + wl# = word64ToWord# w64 + +bigNatToWord64 :: BigNat -> Word64# +bigNatToWord64 bn + | isTrue# (sizeofBigNat# bn ># 1#) + = let wh# = wordToWord64# (indexBigNat# bn 1#) + in uncheckedShiftL64# wh# 32# `or64#` wl# + | True = wl# + where + wl# = wordToWord64# (bigNatToWord bn) +#endif +#endif + +-- End of Int64/Word64 specific primitives +---------------------------------------------------------------------------- + +-- | Truncates 'Integer' to least-significant 'Int#' +integerToInt :: Integer -> Int# +integerToInt (S# i#) = i# +integerToInt (Jp# bn) = bigNatToInt bn +integerToInt (Jn# bn) = negateInt# (bigNatToInt bn) +{-# CONSTANT_FOLDED integerToInt #-} + +hashInteger :: Integer -> Int# +hashInteger = integerToInt -- emulating what integer-{simple,gmp} already do + +integerToWord :: Integer -> Word# +integerToWord (S# i#) = int2Word# i# +integerToWord (Jp# bn) = bigNatToWord bn +integerToWord (Jn# bn) = int2Word# (negateInt# (bigNatToInt bn)) +{-# CONSTANT_FOLDED integerToWord #-} + +wordToInteger :: Word# -> Integer +wordToInteger w# + | isTrue# (i# >=# 0#) = S# i# + | True = Jp# (wordToBigNat w#) + where + i# = word2Int# w# +{-# CONSTANT_FOLDED wordToInteger #-} + +wordToNegInteger :: Word# -> Integer +wordToNegInteger w# + | isTrue# (i# <=# 0#) = S# i# + | True = Jn# (wordToBigNat w#) + where + i# = negateInt# (word2Int# w#) + +-- we could almost auto-derive Ord if it wasn't for the Jn#-Jn# case +compareInteger :: Integer -> Integer -> Ordering +compareInteger (Jn# x) (Jn# y) = compareBigNat y x +compareInteger (S# x) (S# y) = compareInt# x y +compareInteger (Jp# x) (Jp# y) = compareBigNat x y +compareInteger (Jn# _) _ = LT +compareInteger (S# _) (Jp# _) = LT +compareInteger (S# _) (Jn# _) = GT +compareInteger (Jp# _) _ = GT +{-# CONSTANT_FOLDED compareInteger #-} + +isNegInteger# :: Integer -> Int# +isNegInteger# (S# i#) = i# <# 0# +isNegInteger# (Jp# _) = 0# +isNegInteger# (Jn# _) = 1# + +-- | Not-equal predicate. +neqInteger :: Integer -> Integer -> Bool +neqInteger x y = isTrue# (neqInteger# x y) + +eqInteger, leInteger, ltInteger, gtInteger, geInteger + :: Integer -> Integer -> Bool +eqInteger x y = isTrue# (eqInteger# x y) +leInteger x y = isTrue# (leInteger# x y) +ltInteger x y = isTrue# (ltInteger# x y) +gtInteger x y = isTrue# (gtInteger# x y) +geInteger x y = isTrue# (geInteger# x y) + +eqInteger#, neqInteger#, leInteger#, ltInteger#, gtInteger#, geInteger# + :: Integer -> Integer -> Int# +eqInteger# (S# x#) (S# y#) = x# ==# y# +eqInteger# (Jn# x) (Jn# y) = eqBigNat# x y +eqInteger# (Jp# x) (Jp# y) = eqBigNat# x y +eqInteger# _ _ = 0# +{-# CONSTANT_FOLDED eqInteger# #-} + +neqInteger# (S# x#) (S# y#) = x# /=# y# +neqInteger# (Jn# x) (Jn# y) = neqBigNat# x y +neqInteger# (Jp# x) (Jp# y) = neqBigNat# x y +neqInteger# _ _ = 1# +{-# CONSTANT_FOLDED neqInteger# #-} + + +gtInteger# (S# x#) (S# y#) = x# ># y# +gtInteger# x y | inline compareInteger x y == GT = 1# +gtInteger# _ _ = 0# +{-# CONSTANT_FOLDED gtInteger# #-} + +leInteger# (S# x#) (S# y#) = x# <=# y# +leInteger# x y | inline compareInteger x y /= GT = 1# +leInteger# _ _ = 0# +{-# CONSTANT_FOLDED leInteger# #-} + +ltInteger# (S# x#) (S# y#) = x# <# y# +ltInteger# x y | inline compareInteger x y == LT = 1# +ltInteger# _ _ = 0# +{-# CONSTANT_FOLDED ltInteger# #-} + +geInteger# (S# x#) (S# y#) = x# >=# y# +geInteger# x y | inline compareInteger x y /= LT = 1# +geInteger# _ _ = 0# +{-# CONSTANT_FOLDED geInteger# #-} + +-- | Compute absolute value of an 'Integer' +absInteger :: Integer -> Integer +absInteger (Jn# n) = Jp# n +absInteger (S# INT_MINBOUND#) = Jp# (wordToBigNat ABS_INT_MINBOUND##) +absInteger (S# i#) | isTrue# (i# <# 0#) = S# (negateInt# i#) +absInteger i@(S# _) = i +absInteger i@(Jp# _) = i +{-# CONSTANT_FOLDED absInteger #-} + +-- | Return @-1@, @0@, and @1@ depending on whether argument is +-- negative, zero, or positive, respectively +signumInteger :: Integer -> Integer +signumInteger j = S# (signumInteger# j) +{-# CONSTANT_FOLDED signumInteger #-} + +-- | Return @-1#@, @0#@, and @1#@ depending on whether argument is +-- negative, zero, or positive, respectively +signumInteger# :: Integer -> Int# +signumInteger# (Jn# _) = -1# +signumInteger# (S# i#) = sgnI# i# +signumInteger# (Jp# _ ) = 1# + +-- | Negate 'Integer' +negateInteger :: Integer -> Integer +negateInteger (Jn# n) = Jp# n +negateInteger (S# INT_MINBOUND#) = Jp# (wordToBigNat ABS_INT_MINBOUND##) +negateInteger (S# i#) = S# (negateInt# i#) +negateInteger (Jp# bn) + | isTrue# (eqBigNatWord# bn ABS_INT_MINBOUND##) = S# INT_MINBOUND# + | True = Jn# bn +{-# CONSTANT_FOLDED negateInteger #-} + +-- one edge-case issue to take into account is that Int's range is not +-- symmetric around 0. I.e. @minBound+maxBound = -1@ +-- +-- Jp# is used iff n > maxBound::Int +-- Jn# is used iff n < minBound::Int + +-- | Add two 'Integer's +plusInteger :: Integer -> Integer -> Integer +plusInteger x (S# 0#) = x +plusInteger (S# 0#) y = y +plusInteger (S# x#) (S# y#) + = case addIntC# x# y# of + (# z#, 0# #) -> S# z# + (# 0#, _ #) -> Jn# (wordToBigNat2 1## 0##) -- 2*minBound::Int + (# z#, _ #) + | isTrue# (z# ># 0#) -> Jn# (wordToBigNat ( (int2Word# (negateInt# z#)))) + | True -> Jp# (wordToBigNat ( (int2Word# z#))) +plusInteger y@(S# _) x = plusInteger x y +-- no S# as first arg from here on +plusInteger (Jp# x) (Jp# y) = Jp# (plusBigNat x y) +plusInteger (Jn# x) (Jn# y) = Jn# (plusBigNat x y) +plusInteger (Jp# x) (S# y#) -- edge-case: @(maxBound+1) + minBound == 0@ + | isTrue# (y# >=# 0#) = Jp# (plusBigNatWord x (int2Word# y#)) + | True = bigNatToInteger (minusBigNatWord x (int2Word# + (negateInt# y#))) +plusInteger (Jn# x) (S# y#) -- edge-case: @(minBound-1) + maxBound == -2@ + | isTrue# (y# >=# 0#) = bigNatToNegInteger (minusBigNatWord x (int2Word# y#)) + | True = Jn# (plusBigNatWord x (int2Word# (negateInt# y#))) +plusInteger y@(Jn# _) x@(Jp# _) = plusInteger x y +plusInteger (Jp# x) (Jn# y) + = case compareBigNat x y of + LT -> bigNatToNegInteger (minusBigNat y x) + EQ -> S# 0# + GT -> bigNatToInteger (minusBigNat x y) +{-# CONSTANT_FOLDED plusInteger #-} + +-- TODO +-- | Subtract two 'Integer's from each other. +minusInteger :: Integer -> Integer -> Integer +minusInteger x y = inline plusInteger x (inline negateInteger y) +{-# CONSTANT_FOLDED minusInteger #-} + +-- | Multiply two 'Integer's +timesInteger :: Integer -> Integer -> Integer +timesInteger _ (S# 0#) = S# 0# +timesInteger (S# 0#) _ = S# 0# +timesInteger x (S# 1#) = x +timesInteger (S# 1#) y = y +timesInteger x (S# -1#) = negateInteger x +timesInteger (S# -1#) y = negateInteger y +timesInteger (S# x#) (S# y#) + = case mulIntMayOflo# x# y# of + 0# -> S# (x# *# y#) + _ -> timesInt2Integer x# y# +timesInteger x@(S# _) y = timesInteger y x +-- no S# as first arg from here on +timesInteger (Jp# x) (Jp# y) = Jp# (timesBigNat x y) +timesInteger (Jp# x) (Jn# y) = Jn# (timesBigNat x y) +timesInteger (Jp# x) (S# y#) + | isTrue# (y# >=# 0#) = Jp# (timesBigNatWord x (int2Word# y#)) + | True = Jn# (timesBigNatWord x (int2Word# (negateInt# y#))) +timesInteger (Jn# x) (Jn# y) = Jp# (timesBigNat x y) +timesInteger (Jn# x) (Jp# y) = Jn# (timesBigNat x y) +timesInteger (Jn# x) (S# y#) + | isTrue# (y# >=# 0#) = Jn# (timesBigNatWord x (int2Word# y#)) + | True = Jp# (timesBigNatWord x (int2Word# (negateInt# y#))) +{-# CONSTANT_FOLDED timesInteger #-} + +-- | Square 'Integer' +sqrInteger :: Integer -> Integer +sqrInteger (S# INT_MINBOUND#) = timesInt2Integer INT_MINBOUND# INT_MINBOUND# +sqrInteger (S# j#) | isTrue# (absI# j# <=# SQRT_INT_MAXBOUND#) = S# (j# *# j#) +sqrInteger (S# j#) = timesInt2Integer j# j# +sqrInteger (Jp# bn) = Jp# (sqrBigNat bn) +sqrInteger (Jn# bn) = Jp# (sqrBigNat bn) + +-- | Construct 'Integer' from the product of two 'Int#'s +timesInt2Integer :: Int# -> Int# -> Integer +timesInt2Integer x# y# = case (# x# >=# 0#, y# >=# 0# #) of + (# 0#, 0# #) -> case timesWord2# (int2Word# (negateInt# x#)) + (int2Word# (negateInt# y#)) of + (# 0##,l #) -> inline wordToInteger l + (# h ,l #) -> Jp# (wordToBigNat2 h l) + + (# _, 0# #) -> case timesWord2# (int2Word# x#) + (int2Word# (negateInt# y#)) of + (# 0##,l #) -> wordToNegInteger l + (# h ,l #) -> Jn# (wordToBigNat2 h l) + + (# 0#, _ #) -> case timesWord2# (int2Word# (negateInt# x#)) + (int2Word# y#) of + (# 0##,l #) -> wordToNegInteger l + (# h ,l #) -> Jn# (wordToBigNat2 h l) + + (# _, _ #) -> case timesWord2# (int2Word# x#) + (int2Word# y#) of + (# 0##,l #) -> inline wordToInteger l + (# h ,l #) -> Jp# (wordToBigNat2 h l) + +bigNatToInteger :: BigNat -> Integer +bigNatToInteger bn + | isTrue# ((sizeofBigNat# bn ==# 1#) `andI#` (i# >=# 0#)) = S# i# + | True = Jp# bn + where + i# = word2Int# (bigNatToWord bn) + +bigNatToNegInteger :: BigNat -> Integer +bigNatToNegInteger bn + | isTrue# ((sizeofBigNat# bn ==# 1#) `andI#` (i# <=# 0#)) = S# i# + | True = Jn# bn + where + i# = negateInt# (word2Int# (bigNatToWord bn)) + +-- | Count number of set bits. For negative arguments returns negative +-- population count of negated argument. +popCountInteger :: Integer -> Int# +popCountInteger (S# i#) + | isTrue# (i# >=# 0#) = popCntI# i# + | True = negateInt# (popCntI# (negateInt# i#)) +popCountInteger (Jp# bn) = popCountBigNat bn +popCountInteger (Jn# bn) = negateInt# (popCountBigNat bn) +{-# CONSTANT_FOLDED popCountInteger #-} + +-- | 'Integer' for which only /n/-th bit is set. Undefined behaviour +-- for negative /n/ values. +bitInteger :: Int# -> Integer +bitInteger i# + | isTrue# (i# <# (GMP_LIMB_BITS# -# 1#)) = S# (uncheckedIShiftL# 1# i#) + | True = Jp# (bitBigNat i#) +{-# CONSTANT_FOLDED bitInteger #-} + +-- | Test if /n/-th bit is set. +testBitInteger :: Integer -> Int# -> Bool +testBitInteger _ n# | isTrue# (n# <# 0#) = False +testBitInteger (S# i#) n# + | isTrue# (n# <# GMP_LIMB_BITS#) = isTrue# (((uncheckedIShiftL# 1# n#) + `andI#` i#) /=# 0#) + | True = isTrue# (i# <# 0#) +testBitInteger (Jp# bn) n = testBitBigNat bn n +testBitInteger (Jn# bn) n = testBitNegBigNat bn n +{-# CONSTANT_FOLDED testBitInteger #-} + +-- | Bitwise @NOT@ operation +complementInteger :: Integer -> Integer +complementInteger (S# i#) = S# (notI# i#) +complementInteger (Jp# bn) = Jn# (plusBigNatWord bn 1##) +complementInteger (Jn# bn) = Jp# (minusBigNatWord bn 1##) +{-# CONSTANT_FOLDED complementInteger #-} + +-- | Arithmetic shift-right operation +-- +-- Even though the shift-amount is expressed as `Int#`, the result is +-- undefined for negative shift-amounts. +shiftRInteger :: Integer -> Int# -> Integer +shiftRInteger x 0# = x +shiftRInteger (S# i#) n# = S# (iShiftRA# i# n#) + where + iShiftRA# a b + | isTrue# (b >=# WORD_SIZE_IN_BITS#) = (a <# 0#) *# (-1#) + | True = a `uncheckedIShiftRA#` b +shiftRInteger (Jp# bn) n# = bigNatToInteger (shiftRBigNat bn n#) +shiftRInteger (Jn# bn) n# + = case bigNatToNegInteger (shiftRNegBigNat bn n#) of + S# 0# -> S# -1# + r -> r +{-# CONSTANT_FOLDED shiftRInteger #-} + +-- | Shift-left operation +-- +-- Even though the shift-amount is expressed as `Int#`, the result is +-- undefined for negative shift-amounts. +shiftLInteger :: Integer -> Int# -> Integer +shiftLInteger x 0# = x +shiftLInteger (S# 0#) _ = S# 0# +shiftLInteger (S# 1#) n# = bitInteger n# +shiftLInteger (S# i#) n# + | isTrue# (i# >=# 0#) = bigNatToInteger (shiftLBigNat + (wordToBigNat (int2Word# i#)) n#) + | True = bigNatToNegInteger (shiftLBigNat + (wordToBigNat (int2Word# + (negateInt# i#))) n#) +shiftLInteger (Jp# bn) n# = Jp# (shiftLBigNat bn n#) +shiftLInteger (Jn# bn) n# = Jn# (shiftLBigNat bn n#) +{-# CONSTANT_FOLDED shiftLInteger #-} + +-- | Bitwise OR operation +orInteger :: Integer -> Integer -> Integer +-- short-cuts +orInteger (S# 0#) y = y +orInteger x (S# 0#) = x +orInteger (S# -1#) _ = S# -1# +orInteger _ (S# -1#) = S# -1# +-- base-cases +orInteger (S# x#) (S# y#) = S# (orI# x# y#) +orInteger (Jp# x) (Jp# y) = Jp# (orBigNat x y) +orInteger (Jn# x) (Jn# y) + = bigNatToNegInteger (plusBigNatWord (andBigNat + (minusBigNatWord x 1##) + (minusBigNatWord y 1##)) 1##) +orInteger x@(Jn# _) y@(Jp# _) = orInteger y x -- retry with swapped args +orInteger (Jp# x) (Jn# y) + = bigNatToNegInteger (plusBigNatWord (andnBigNat (minusBigNatWord y 1##) x) + 1##) +-- TODO/FIXpromotion-hack +orInteger x@(S# _) y = orInteger (unsafePromote x) y +orInteger x y {- S# -}= orInteger x (unsafePromote y) +{-# CONSTANT_FOLDED orInteger #-} + +-- | Bitwise XOR operation +xorInteger :: Integer -> Integer -> Integer +-- short-cuts +xorInteger (S# 0#) y = y +xorInteger x (S# 0#) = x +-- TODO: (S# -1) cases +-- base-cases +xorInteger (S# x#) (S# y#) = S# (xorI# x# y#) +xorInteger (Jp# x) (Jp# y) = bigNatToInteger (xorBigNat x y) +xorInteger (Jn# x) (Jn# y) + = bigNatToInteger (xorBigNat (minusBigNatWord x 1##) + (minusBigNatWord y 1##)) +xorInteger x@(Jn# _) y@(Jp# _) = xorInteger y x -- retry with swapped args +xorInteger (Jp# x) (Jn# y) + = bigNatToNegInteger (plusBigNatWord (xorBigNat x (minusBigNatWord y 1##)) + 1##) +-- TODO/FIXME promotion-hack +xorInteger x@(S# _) y = xorInteger (unsafePromote x) y +xorInteger x y {- S# -} = xorInteger x (unsafePromote y) +{-# CONSTANT_FOLDED xorInteger #-} + +-- | Bitwise AND operation +andInteger :: Integer -> Integer -> Integer +-- short-cuts +andInteger (S# 0#) _ = S# 0# +andInteger _ (S# 0#) = S# 0# +andInteger (S# -1#) y = y +andInteger x (S# -1#) = x +-- base-cases +andInteger (S# x#) (S# y#) = S# (andI# x# y#) +andInteger (Jp# x) (Jp# y) = bigNatToInteger (andBigNat x y) +andInteger (Jn# x) (Jn# y) + = bigNatToNegInteger (plusBigNatWord (orBigNat (minusBigNatWord x 1##) + (minusBigNatWord y 1##)) 1##) +andInteger x@(Jn# _) y@(Jp# _) = andInteger y x +andInteger (Jp# x) (Jn# y) + = bigNatToInteger (andnBigNat x (minusBigNatWord y 1##)) +-- TODO/FIXME promotion-hack +andInteger x@(S# _) y = andInteger (unsafePromote x) y +andInteger x y {- S# -}= andInteger x (unsafePromote y) +{-# CONSTANT_FOLDED andInteger #-} + +-- HACK warning! breaks invariant on purpose +unsafePromote :: Integer -> Integer +unsafePromote (S# x#) + | isTrue# (x# >=# 0#) = Jp# (wordToBigNat (int2Word# x#)) + | True = Jn# (wordToBigNat (int2Word# (negateInt# x#))) +unsafePromote x = x + +-- | Simultaneous 'quotInteger' and 'remInteger'. +-- +-- Divisor must be non-zero otherwise the GHC runtime will terminate +-- with a division-by-zero fault. +quotRemInteger :: Integer -> Integer -> (# Integer, Integer #) +quotRemInteger n (S# 1#) = (# n, S# 0# #) +quotRemInteger n (S# -1#) = let !q = negateInteger n in (# q, (S# 0#) #) +quotRemInteger _ (S# 0#) = (# S# (quotInt# 0# 0#),S# (remInt# 0# 0#) #) +quotRemInteger (S# 0#) _ = (# S# 0#, S# 0# #) +quotRemInteger (S# n#) (S# d#) = case quotRemInt# n# d# of + (# q#, r# #) -> (# S# q#, S# r# #) +quotRemInteger (Jp# n) (Jp# d) = case quotRemBigNat n d of + (# q, r #) -> (# bigNatToInteger q, bigNatToInteger r #) +quotRemInteger (Jp# n) (Jn# d) = case quotRemBigNat n d of + (# q, r #) -> (# bigNatToNegInteger q, bigNatToInteger r #) +quotRemInteger (Jn# n) (Jn# d) = case quotRemBigNat n d of + (# q, r #) -> (# bigNatToInteger q, bigNatToNegInteger r #) +quotRemInteger (Jn# n) (Jp# d) = case quotRemBigNat n d of + (# q, r #) -> (# bigNatToNegInteger q, bigNatToNegInteger r #) +quotRemInteger (Jp# n) (S# d#) + | isTrue# (d# >=# 0#) = case quotRemBigNatWord n (int2Word# d#) of + (# q, r# #) -> (# bigNatToInteger q, inline wordToInteger r# #) + | True = case quotRemBigNatWord n (int2Word# (negateInt# d#)) of + (# q, r# #) -> (# bigNatToNegInteger q, inline wordToInteger r# #) +quotRemInteger (Jn# n) (S# d#) + | isTrue# (d# >=# 0#) = case quotRemBigNatWord n (int2Word# d#) of + (# q, r# #) -> (# bigNatToNegInteger q, wordToNegInteger r# #) + | True = case quotRemBigNatWord n (int2Word# (negateInt# d#)) of + (# q, r# #) -> (# bigNatToInteger q, wordToNegInteger r# #) +quotRemInteger n@(S# _) (Jn# _) = (# S# 0#, n #) -- since @n < d@ +quotRemInteger n@(S# n#) (Jp# d) -- need to account for (S# minBound) + | isTrue# (n# ># 0#) = (# S# 0#, n #) + | isTrue# (gtBigNatWord# d (int2Word# (negateInt# n#))) = (# S# 0#, n #) + | True {- abs(n) == d -} = (# S# -1#, S# 0# #) +{-# CONSTANT_FOLDED quotRemInteger #-} + + +quotInteger :: Integer -> Integer -> Integer +quotInteger n (S# 1#) = n +quotInteger n (S# -1#) = negateInteger n +quotInteger _ (S# 0#) = S# (quotInt# 0# 0#) +quotInteger (S# 0#) _ = S# 0# +quotInteger (S# n#) (S# d#) = S# (quotInt# n# d#) +quotInteger (Jp# n) (S# d#) + | isTrue# (d# >=# 0#) = bigNatToInteger (quotBigNatWord n (int2Word# d#)) + | True = bigNatToNegInteger (quotBigNatWord n + (int2Word# (negateInt# d#))) +quotInteger (Jn# n) (S# d#) + | isTrue# (d# >=# 0#) = bigNatToNegInteger (quotBigNatWord n (int2Word# d#)) + | True = bigNatToInteger (quotBigNatWord n + (int2Word# (negateInt# d#))) +quotInteger (Jp# n) (Jp# d) = bigNatToInteger (quotBigNat n d) +quotInteger (Jp# n) (Jn# d) = bigNatToNegInteger (quotBigNat n d) +quotInteger (Jn# n) (Jp# d) = bigNatToNegInteger (quotBigNat n d) +quotInteger (Jn# n) (Jn# d) = bigNatToInteger (quotBigNat n d) +-- handle remaining non-allocating cases +quotInteger n d = case inline quotRemInteger n d of (# q, _ #) -> q +{-# CONSTANT_FOLDED quotInteger #-} + +remInteger :: Integer -> Integer -> Integer +remInteger _ (S# 1#) = S# 0# +remInteger _ (S# -1#) = S# 0# +remInteger _ (S# 0#) = S# (remInt# 0# 0#) +remInteger (S# 0#) _ = S# 0# +remInteger (S# n#) (S# d#) = S# (remInt# n# d#) +remInteger (Jp# n) (S# d#) + = wordToInteger (remBigNatWord n (int2Word# (absI# d#))) +remInteger (Jn# n) (S# d#) + = wordToNegInteger (remBigNatWord n (int2Word# (absI# d#))) +remInteger (Jp# n) (Jp# d) = bigNatToInteger (remBigNat n d) +remInteger (Jp# n) (Jn# d) = bigNatToInteger (remBigNat n d) +remInteger (Jn# n) (Jp# d) = bigNatToNegInteger (remBigNat n d) +remInteger (Jn# n) (Jn# d) = bigNatToNegInteger (remBigNat n d) +-- handle remaining non-allocating cases +remInteger n d = case inline quotRemInteger n d of (# _, r #) -> r +{-# CONSTANT_FOLDED remInteger #-} + +-- | Simultaneous 'divInteger' and 'modInteger'. +-- +-- Divisor must be non-zero otherwise the GHC runtime will terminate +-- with a division-by-zero fault. +divModInteger :: Integer -> Integer -> (# Integer, Integer #) +divModInteger n d + | isTrue# (signumInteger# r ==# negateInt# (signumInteger# d)) + = let !q' = plusInteger q (S# -1#) -- TODO: optimize + !r' = plusInteger r d + in (# q', r' #) + | True = qr + where + qr@(# q, r #) = quotRemInteger n d +{-# CONSTANT_FOLDED divModInteger #-} + +divInteger :: Integer -> Integer -> Integer +-- same-sign ops can be handled by more efficient 'quotInteger' +divInteger n d | isTrue# (isNegInteger# n ==# isNegInteger# d) = quotInteger n d +divInteger n d = case inline divModInteger n d of (# q, _ #) -> q +{-# CONSTANT_FOLDED divInteger #-} + +modInteger :: Integer -> Integer -> Integer +-- same-sign ops can be handled by more efficient 'remInteger' +modInteger n d | isTrue# (isNegInteger# n ==# isNegInteger# d) = remInteger n d +modInteger n d = case inline divModInteger n d of (# _, r #) -> r +{-# CONSTANT_FOLDED modInteger #-} + +-- | Compute greatest common divisor. +gcdInteger :: Integer -> Integer -> Integer +gcdInteger (S# 0#) b = absInteger b +gcdInteger a (S# 0#) = absInteger a +gcdInteger (S# 1#) _ = S# 1# +gcdInteger (S# -1#) _ = S# 1# +gcdInteger _ (S# 1#) = S# 1# +gcdInteger _ (S# -1#) = S# 1# +gcdInteger (S# a#) (S# b#) + = wordToInteger (gcdWord# (int2Word# (absI# a#)) (int2Word# (absI# b#))) +gcdInteger a@(S# _) b = gcdInteger b a +gcdInteger (Jn# a) b = gcdInteger (Jp# a) b +gcdInteger (Jp# a) (Jp# b) = bigNatToInteger (gcdBigNat a b) +gcdInteger (Jp# a) (Jn# b) = bigNatToInteger (gcdBigNat a b) +gcdInteger (Jp# a) (S# b#) + = wordToInteger (gcdBigNatWord a (int2Word# (absI# b#))) +{-# CONSTANT_FOLDED gcdInteger #-} + +-- | Compute least common multiple. +lcmInteger :: Integer -> Integer -> Integer +lcmInteger (S# 0#) _ = S# 0# +lcmInteger (S# 1#) b = absInteger b +lcmInteger (S# -1#) b = absInteger b +lcmInteger _ (S# 0#) = S# 0# +lcmInteger a (S# 1#) = absInteger a +lcmInteger a (S# -1#) = absInteger a +lcmInteger a b = (aa `quotInteger` (aa `gcdInteger` ab)) `timesInteger` ab + where + aa = absInteger a + ab = absInteger b +{-# CONSTANT_FOLDED lcmInteger #-} + +-- | Compute greatest common divisor. +-- +-- Warning: result may become negative if (at least) one argument is 'minBound' +gcdInt :: Int# -> Int# -> Int# +gcdInt x# y# + = word2Int# (gcdWord# (int2Word# (absI# x#)) (int2Word# (absI# y#))) + +---------------------------------------------------------------------------- +-- BigNat operations + +compareBigNat :: BigNat -> BigNat -> Ordering +compareBigNat x@(BN# x#) y@(BN# y#) + | isTrue# (nx# ==# ny#) + = compareInt# (narrowCInt# (c_mpn_cmp x# y# nx#)) 0# + | isTrue# (nx# <# ny#) = LT + | True = GT + where + nx# = sizeofBigNat# x + ny# = sizeofBigNat# y + +compareBigNatWord :: BigNat -> GmpLimb# -> Ordering +compareBigNatWord bn w# + | isTrue# (sizeofBigNat# bn ==# 1#) = cmpW# (bigNatToWord bn) w# + | True = GT + +gtBigNatWord# :: BigNat -> GmpLimb# -> Int# +gtBigNatWord# bn w# + = (sizeofBigNat# bn ># 1#) `orI#` (bigNatToWord bn `gtWord#` w#) + +eqBigNat :: BigNat -> BigNat -> Bool +eqBigNat x y = isTrue# (eqBigNat# x y) + +eqBigNat# :: BigNat -> BigNat -> Int# +eqBigNat# x@(BN# x#) y@(BN# y#) + | isTrue# (nx# ==# ny#) = c_mpn_cmp x# y# nx# ==# 0# + | True = 0# + where + nx# = sizeofBigNat# x + ny# = sizeofBigNat# y + +neqBigNat# :: BigNat -> BigNat -> Int# +neqBigNat# x@(BN# x#) y@(BN# y#) + | isTrue# (nx# ==# ny#) = c_mpn_cmp x# y# nx# /=# 0# + | True = 1# + where + nx# = sizeofBigNat# x + ny# = sizeofBigNat# y + +eqBigNatWord :: BigNat -> GmpLimb# -> Bool +eqBigNatWord bn w# = isTrue# (eqBigNatWord# bn w#) + +eqBigNatWord# :: BigNat -> GmpLimb# -> Int# +eqBigNatWord# bn w# + = sizeofBigNat# bn ==# 1# `andI#` (bigNatToWord bn `eqWord#` w#) + + +-- | Same as @'indexBigNat#' bn 0\#@ +bigNatToWord :: BigNat -> Word# +bigNatToWord bn = indexBigNat# bn 0# + +bigNatToInt :: BigNat -> Int# +bigNatToInt (BN# ba#) = indexIntArray# ba# 0# + +-- | CAF representing the value @0 :: BigNat@ +zeroBigNat :: BigNat +zeroBigNat = runS $ do + mbn <- newBigNat# 1# + _ <- svoid (writeBigNat# mbn 0# 0##) + unsafeFreezeBigNat# mbn +{-# NOINLINE zeroBigNat #-} + +-- | Test if 'BigNat' value is equal to zero. +isZeroBigNat :: BigNat -> Bool +isZeroBigNat bn = eqBigNatWord bn 0## + +-- | CAF representing the value @1 :: BigNat@ +oneBigNat :: BigNat +oneBigNat = runS $ do + mbn <- newBigNat# 1# + _ <- svoid (writeBigNat# mbn 0# 1##) + unsafeFreezeBigNat# mbn +{-# NOINLINE oneBigNat #-} + +czeroBigNat :: BigNat +czeroBigNat = runS $ do + mbn <- newBigNat# 1# + _ <- svoid (writeBigNat# mbn 0# (not# 0##)) + unsafeFreezeBigNat# mbn +{-# NOINLINE czeroBigNat #-} + +-- | Special 0-sized bigNat returned in case of arithmetic underflow +-- +-- This is currently only returned by the following operations: +-- +-- - 'minusBigNat' +-- - 'minusBigNatWord' +-- +-- Other operations such as 'quotBigNat' may return 'nullBigNat' as +-- well as a dummy/place-holder value instead of 'undefined' since we +-- can't throw exceptions. But that behaviour should not be relied +-- upon. +-- +-- NB: @isValidBigNat# nullBigNat@ is false +nullBigNat :: BigNat +nullBigNat = runS (newBigNat# 0# >>= unsafeFreezeBigNat#) +{-# NOINLINE nullBigNat #-} + +-- | Test for special 0-sized 'BigNat' representing underflows. +isNullBigNat# :: BigNat -> Int# +isNullBigNat# (BN# ba#) = sizeofByteArray# ba# ==# 0# + +-- | Construct 1-limb 'BigNat' from 'Word#' +wordToBigNat :: Word# -> BigNat +wordToBigNat 0## = zeroBigNat +wordToBigNat 1## = oneBigNat +wordToBigNat w# + | isTrue# (not# w# `eqWord#` 0##) = czeroBigNat + | True = runS $ do + mbn <- newBigNat# 1# + _ <- svoid (writeBigNat# mbn 0# w#) + unsafeFreezeBigNat# mbn + +-- | Construct BigNat from 2 limbs. +-- The first argument is the most-significant limb. +wordToBigNat2 :: Word# -> Word# -> BigNat +wordToBigNat2 0## lw# = wordToBigNat lw# +wordToBigNat2 hw# lw# = runS $ do + mbn <- newBigNat# 2# + _ <- svoid (writeBigNat# mbn 0# lw#) + _ <- svoid (writeBigNat# mbn 1# hw#) + unsafeFreezeBigNat# mbn + +plusBigNat :: BigNat -> BigNat -> BigNat +plusBigNat x y + | isTrue# (eqBigNatWord# x 0##) = y + | isTrue# (eqBigNatWord# y 0##) = x + | isTrue# (nx# >=# ny#) = go x nx# y ny# + | True = go y ny# x nx# + where + go (BN# a#) na# (BN# b#) nb# = runS $ do + mbn@(MBN# mba#) <- newBigNat# na# + (W# c#) <- liftIO (c_mpn_add mba# a# na# b# nb#) + case c# of + 0## -> unsafeFreezeBigNat# mbn + _ -> unsafeSnocFreezeBigNat# mbn c# + + nx# = sizeofBigNat# x + ny# = sizeofBigNat# y + +plusBigNatWord :: BigNat -> GmpLimb# -> BigNat +plusBigNatWord x 0## = x +plusBigNatWord x@(BN# x#) y# = runS $ do + mbn@(MBN# mba#) <- newBigNat# nx# + (W# c#) <- liftIO (c_mpn_add_1 mba# x# nx# y#) + case c# of + 0## -> unsafeFreezeBigNat# mbn + _ -> unsafeSnocFreezeBigNat# mbn c# + where + nx# = sizeofBigNat# x + +-- | Returns 'nullBigNat' (see 'isNullBigNat#') in case of underflow +minusBigNat :: BigNat -> BigNat -> BigNat +minusBigNat x@(BN# x#) y@(BN# y#) + | isZeroBigNat y = x + | isTrue# (nx# >=# ny#) = runS $ do + mbn@(MBN# mba#) <- newBigNat# nx# + (W# b#) <- liftIO (c_mpn_sub mba# x# nx# y# ny#) + case b# of + 0## -> unsafeRenormFreezeBigNat# mbn + _ -> return nullBigNat + + | True = nullBigNat + where + nx# = sizeofBigNat# x + ny# = sizeofBigNat# y + +-- | Returns 'nullBigNat' (see 'isNullBigNat#') in case of underflow +minusBigNatWord :: BigNat -> GmpLimb# -> BigNat +minusBigNatWord x 0## = x +minusBigNatWord x@(BN# x#) y# = runS $ do + mbn@(MBN# mba#) <- newBigNat# nx# + (W# b#) <- liftIO $ c_mpn_sub_1 mba# x# nx# y# + case b# of + 0## -> unsafeRenormFreezeBigNat# mbn + _ -> return nullBigNat + where + nx# = sizeofBigNat# x + + +timesBigNat :: BigNat -> BigNat -> BigNat +timesBigNat x y + | isZeroBigNat x = zeroBigNat + | isZeroBigNat y = zeroBigNat + | isTrue# (nx# >=# ny#) = go x nx# y ny# + | True = go y ny# x nx# + where + go (BN# a#) na# (BN# b#) nb# = runS $ do + let n# = nx# +# ny# + mbn@(MBN# mba#) <- newBigNat# n# + (W# msl#) <- liftIO (c_mpn_mul mba# a# na# b# nb#) + case msl# of + 0## -> unsafeShrinkFreezeBigNat# mbn (n# -# 1#) + _ -> unsafeFreezeBigNat# mbn + + nx# = sizeofBigNat# x + ny# = sizeofBigNat# y + +-- | Square 'BigNat' +sqrBigNat :: BigNat -> BigNat +sqrBigNat x + | isZeroBigNat x = zeroBigNat + -- TODO: 1-limb BigNats below sqrt(maxBound::GmpLimb) +sqrBigNat x = timesBigNat x x -- TODO: mpn_sqr + +timesBigNatWord :: BigNat -> GmpLimb# -> BigNat +timesBigNatWord _ 0## = zeroBigNat +timesBigNatWord x 1## = x +timesBigNatWord x@(BN# x#) y# + | isTrue# (nx# ==# 1#) = + let (# !h#, !l# #) = timesWord2# (bigNatToWord x) y# + in wordToBigNat2 h# l# + | True = runS $ do + mbn@(MBN# mba#) <- newBigNat# nx# + (W# msl#) <- liftIO (c_mpn_mul_1 mba# x# nx# y#) + case msl# of + 0## -> unsafeFreezeBigNat# mbn + _ -> unsafeSnocFreezeBigNat# mbn msl# + + where + nx# = sizeofBigNat# x + +bitBigNat :: Int# -> BigNat +bitBigNat i# = shiftLBigNat (wordToBigNat 1##) i# -- FIXME + +testBitBigNat :: BigNat -> Int# -> Bool +testBitBigNat bn i# + | isTrue# (i# <# 0#) = False + | isTrue# (li# <# nx#) = isTrue# (testBitWord# (indexBigNat# bn li#) bi#) + | True = False + where + (# li#, bi# #) = quotRemInt# i# GMP_LIMB_BITS# + nx# = sizeofBigNat# bn + +testBitNegBigNat :: BigNat -> Int# -> Bool +testBitNegBigNat bn i# + | isTrue# (i# <# 0#) = False + | isTrue# (li# >=# nx#) = True + | allZ li# = isTrue# ((testBitWord# + (indexBigNat# bn li# `minusWord#` 1##) bi#) ==# 0#) + | True = isTrue# ((testBitWord# (indexBigNat# bn li#) bi#) ==# 0#) + where + (# li#, bi# #) = quotRemInt# i# GMP_LIMB_BITS# + nx# = sizeofBigNat# bn + + allZ 0# = True + allZ j | isTrue# (indexBigNat# bn (j -# 1#) `eqWord#` 0##) = allZ (j -# 1#) + | True = False + +popCountBigNat :: BigNat -> Int# +popCountBigNat bn@(BN# ba#) = word2Int# (c_mpn_popcount ba# (sizeofBigNat# bn)) + + +shiftLBigNat :: BigNat -> Int# -> BigNat +shiftLBigNat x 0# = x +shiftLBigNat x _ | isZeroBigNat x = zeroBigNat +shiftLBigNat x@(BN# xba#) n# = runS $ do + ymbn@(MBN# ymba#) <- newBigNat# yn# + W# ymsl <- liftIO (c_mpn_lshift ymba# xba# xn# (int2Word# n#)) + case ymsl of + 0## -> unsafeShrinkFreezeBigNat# ymbn (yn# -# 1#) + _ -> unsafeFreezeBigNat# ymbn + where + xn# = sizeofBigNat# x + yn# = xn# +# nlimbs# +# (nbits# /=# 0#) + (# nlimbs#, nbits# #) = quotRemInt# n# GMP_LIMB_BITS# + + + +shiftRBigNat :: BigNat -> Int# -> BigNat +shiftRBigNat x 0# = x +shiftRBigNat x _ | isZeroBigNat x = zeroBigNat +shiftRBigNat x@(BN# xba#) n# + | isTrue# (nlimbs# >=# xn#) = zeroBigNat + | True = runS $ do + ymbn@(MBN# ymba#) <- newBigNat# yn# + W# ymsl <- liftIO (c_mpn_rshift ymba# xba# xn# (int2Word# n#)) + case ymsl of + 0## -> unsafeRenormFreezeBigNat# ymbn -- may shrink more than one + _ -> unsafeFreezeBigNat# ymbn + where + xn# = sizeofBigNat# x + yn# = xn# -# nlimbs# + nlimbs# = quotInt# n# GMP_LIMB_BITS# + +shiftRNegBigNat :: BigNat -> Int# -> BigNat +shiftRNegBigNat x 0# = x +shiftRNegBigNat x _ | isZeroBigNat x = zeroBigNat +shiftRNegBigNat x@(BN# xba#) n# + | isTrue# (nlimbs# >=# xn#) = zeroBigNat + | True = runS $ do + ymbn@(MBN# ymba#) <- newBigNat# yn# + W# ymsl <- liftIO (c_mpn_rshift_2c ymba# xba# xn# (int2Word# n#)) + case ymsl of + 0## -> unsafeRenormFreezeBigNat# ymbn -- may shrink more than one + _ -> unsafeFreezeBigNat# ymbn + where + xn# = sizeofBigNat# x + yn# = xn# -# nlimbs# + nlimbs# = quotInt# n# GMP_LIMB_BITS# + + +orBigNat :: BigNat -> BigNat -> BigNat +orBigNat x@(BN# x#) y@(BN# y#) + | isZeroBigNat x = y + | isZeroBigNat y = x + | isTrue# (nx# >=# ny#) = runS (ior' x# nx# y# ny#) + | True = runS (ior' y# ny# x# nx#) + where + ior' a# na# b# nb# = do -- na >= nb + mbn@(MBN# mba#) <- newBigNat# na# + _ <- liftIO (c_mpn_ior_n mba# a# b# nb#) + _ <- case na# ==# nb# of + 0# -> svoid (copyWordArray# a# nb# mba# nb# (na# -# nb#)) + _ -> return () + unsafeFreezeBigNat# mbn + + nx# = sizeofBigNat# x + ny# = sizeofBigNat# y + + +xorBigNat :: BigNat -> BigNat -> BigNat +xorBigNat x@(BN# x#) y@(BN# y#) + | isZeroBigNat x = y + | isZeroBigNat y = x + | isTrue# (nx# >=# ny#) = runS (xor' x# nx# y# ny#) + | True = runS (xor' y# ny# x# nx#) + where + xor' a# na# b# nb# = do -- na >= nb + mbn@(MBN# mba#) <- newBigNat# na# + _ <- liftIO (c_mpn_xor_n mba# a# b# nb#) + case na# ==# nb# of + 0# -> do _ <- svoid (copyWordArray# a# nb# mba# nb# (na# -# nb#)) + unsafeFreezeBigNat# mbn + _ -> unsafeRenormFreezeBigNat# mbn + + nx# = sizeofBigNat# x + ny# = sizeofBigNat# y + +-- | aka @\x y -> x .&. (complement y)@ +andnBigNat :: BigNat -> BigNat -> BigNat +andnBigNat x@(BN# x#) y@(BN# y#) + | isZeroBigNat x = zeroBigNat + | isZeroBigNat y = x + | True = runS $ do + mbn@(MBN# mba#) <- newBigNat# nx# + _ <- liftIO (c_mpn_andn_n mba# x# y# n#) + _ <- case nx# ==# n# of + 0# -> svoid (copyWordArray# x# n# mba# n# (nx# -# n#)) + _ -> return () + unsafeRenormFreezeBigNat# mbn + where + n# | isTrue# (nx# <# ny#) = nx# + | True = ny# + nx# = sizeofBigNat# x + ny# = sizeofBigNat# y + + +andBigNat :: BigNat -> BigNat -> BigNat +andBigNat x@(BN# x#) y@(BN# y#) + | isZeroBigNat x = zeroBigNat + | isZeroBigNat y = zeroBigNat + | True = runS $ do + mbn@(MBN# mba#) <- newBigNat# n# + _ <- liftIO (c_mpn_and_n mba# x# y# n#) + unsafeRenormFreezeBigNat# mbn + where + n# | isTrue# (nx# <# ny#) = nx# + | True = ny# + nx# = sizeofBigNat# x + ny# = sizeofBigNat# y + +-- | If divisor is zero, @(\# 'nullBigNat', 'nullBigNat' \#)@ is returned +quotRemBigNat :: BigNat -> BigNat -> (# BigNat,BigNat #) +quotRemBigNat n@(BN# nba#) d@(BN# dba#) + | isZeroBigNat d = (# nullBigNat, nullBigNat #) + | eqBigNatWord d 1## = (# n, zeroBigNat #) + | n < d = (# zeroBigNat, n #) + | True = case runS go of (!q,!r) -> (# q, r #) + where + nn# = sizeofBigNat# n + dn# = sizeofBigNat# d + qn# = 1# +# nn# -# dn# + rn# = dn# + + go = do + qmbn@(MBN# qmba#) <- newBigNat# qn# + rmbn@(MBN# rmba#) <- newBigNat# rn# + + _ <- liftIO (c_mpn_tdiv_qr qmba# rmba# 0# nba# nn# dba# dn#) + + q <- unsafeRenormFreezeBigNat# qmbn + r <- unsafeRenormFreezeBigNat# rmbn + return (q, r) + +quotBigNat :: BigNat -> BigNat -> BigNat +quotBigNat n@(BN# nba#) d@(BN# dba#) + | isZeroBigNat d = nullBigNat + | eqBigNatWord d 1## = n + | n < d = zeroBigNat + | True = runS $ do + let nn# = sizeofBigNat# n + let dn# = sizeofBigNat# d + let qn# = 1# +# nn# -# dn# + qmbn@(MBN# qmba#) <- newBigNat# qn# + _ <- liftIO (c_mpn_tdiv_q qmba# nba# nn# dba# dn#) + unsafeRenormFreezeBigNat# qmbn + +remBigNat :: BigNat -> BigNat -> BigNat +remBigNat n@(BN# nba#) d@(BN# dba#) + | isZeroBigNat d = nullBigNat + | eqBigNatWord d 1## = zeroBigNat + | n < d = n + | True = runS $ do + let nn# = sizeofBigNat# n + let dn# = sizeofBigNat# d + rmbn@(MBN# rmba#) <- newBigNat# dn# + _ <- liftIO (c_mpn_tdiv_r rmba# nba# nn# dba# dn#) + unsafeRenormFreezeBigNat# rmbn + +-- | Note: Result of div/0 undefined +quotRemBigNatWord :: BigNat -> GmpLimb# -> (# BigNat, GmpLimb# #) +quotRemBigNatWord _ 0## = (# nullBigNat, 0## #) +quotRemBigNatWord n 1## = (# n, 0## #) +quotRemBigNatWord n@(BN# nba#) d# = case compareBigNatWord n d# of + LT -> (# zeroBigNat, bigNatToWord n #) + EQ -> (# oneBigNat, 0## #) + GT -> case runS go of (!q,!(W# r#)) -> (# q, r# #) -- TODO: handle word/word + where + go = do + let nn# = sizeofBigNat# n + qmbn@(MBN# qmba#) <- newBigNat# nn# + r <- liftIO (c_mpn_divrem_1 qmba# 0# nba# nn# d#) + q <- unsafeRenormFreezeBigNat# qmbn + return (q,r) + +quotBigNatWord :: BigNat -> GmpLimb# -> BigNat +quotBigNatWord n d# = case inline quotRemBigNatWord n d# of (# q, _ #) -> q + +-- | div/0 not checked +remBigNatWord :: BigNat -> GmpLimb# -> Word# +remBigNatWord n@(BN# nba#) d# = c_mpn_mod_1 nba# (sizeofBigNat# n) d# + +gcdBigNatWord :: BigNat -> Word# -> Word# +gcdBigNatWord bn@(BN# ba#) = c_mpn_gcd_1# ba# (sizeofBigNat# bn) + +gcdBigNat :: BigNat -> BigNat -> BigNat +gcdBigNat x@(BN# x#) y@(BN# y#) + | isZeroBigNat x = y + | isZeroBigNat y = x + | isTrue# (nx# >=# ny#) = runS (gcd' x# nx# y# ny#) + | True = runS (gcd' y# ny# x# nx#) + where + gcd' a# na# b# nb# = do -- na >= nb + mbn@(MBN# mba#) <- newBigNat# nb# + I# rn'# <- liftIO (c_mpn_gcd# mba# a# na# b# nb#) + let rn# = narrowGmpSize# rn'# + case rn# ==# nb# of + 0# -> unsafeShrinkFreezeBigNat# mbn rn# + _ -> unsafeFreezeBigNat# mbn + + nx# = sizeofBigNat# x + ny# = sizeofBigNat# y + + +---------------------------------------------------------------------------- +-- Conversions to/from floating point + +decodeDoubleInteger :: Double# -> (# Integer, Int# #) +-- decodeDoubleInteger 0.0## = (# S# 0#, 0# #) +#if WORD_SIZE_IN_BITS == 64 +decodeDoubleInteger x = case decodeDouble_Int64# x of + (# m#, e# #) -> (# S# m#, e# #) +#elif WORD_SIZE_IN_BITS == 32 +decodeDoubleInteger x = case decodeDouble_Int64# x of + (# m#, e# #) -> (# int64ToInteger m#, e# #) +#endif +{-# CONSTANT_FOLDED decodeDoubleInteger #-} + +-- provided by GHC's RTS +foreign import ccall unsafe "__int_encodeDouble" + int_encodeDouble# :: Int# -> Int# -> Double# + +encodeDoubleInteger :: Integer -> Int# -> Double# +encodeDoubleInteger (S# m#) 0# = int2Double# m# +encodeDoubleInteger (S# m#) e# = int_encodeDouble# m# e# +encodeDoubleInteger (Jp# bn@(BN# bn#)) e# + = c_mpn_get_d bn# (sizeofBigNat# bn) e# +encodeDoubleInteger (Jn# bn@(BN# bn#)) e# + = c_mpn_get_d bn# (negateInt# (sizeofBigNat# bn)) e# +{-# CONSTANT_FOLDED encodeDoubleInteger #-} + +-- double integer_gmp_mpn_get_d (const mp_limb_t sp[], const mp_size_t sn) +foreign import ccall unsafe "integer_gmp_mpn_get_d" + c_mpn_get_d :: ByteArray# -> GmpSize# -> Int# -> Double# + +doubleFromInteger :: Integer -> Double# +doubleFromInteger (S# m#) = int2Double# m# +doubleFromInteger (Jp# bn@(BN# bn#)) + = c_mpn_get_d bn# (sizeofBigNat# bn) 0# +doubleFromInteger (Jn# bn@(BN# bn#)) + = c_mpn_get_d bn# (negateInt# (sizeofBigNat# bn)) 0# +{-# CONSTANT_FOLDED doubleFromInteger #-} + +-- TODO: Not sure if it's worth to write 'Float' optimized versions here +floatFromInteger :: Integer -> Float# +floatFromInteger i = double2Float# (doubleFromInteger i) + +encodeFloatInteger :: Integer -> Int# -> Float# +encodeFloatInteger m e = double2Float# (encodeDoubleInteger m e) + +---------------------------------------------------------------------------- +-- FFI ccall imports + +foreign import ccall unsafe "integer_gmp_gcd_word" + gcdWord# :: GmpLimb# -> GmpLimb# -> GmpLimb# + +foreign import ccall unsafe "integer_gmp_mpn_gcd_1" + c_mpn_gcd_1# :: ByteArray# -> GmpSize# -> GmpLimb# -> GmpLimb# + +foreign import ccall unsafe "integer_gmp_mpn_gcd" + c_mpn_gcd# :: MutableByteArray# s -> ByteArray# -> GmpSize# + -> ByteArray# -> GmpSize# -> IO GmpSize + +-- mp_limb_t mpn_add_1 (mp_limb_t *rp, const mp_limb_t *s1p, mp_size_t n, +-- mp_limb_t s2limb) +foreign import ccall unsafe "gmp.h __gmpn_add_1" + c_mpn_add_1 :: MutableByteArray# s -> ByteArray# -> GmpSize# -> GmpLimb# + -> IO GmpLimb + +-- mp_limb_t mpn_sub_1 (mp_limb_t *rp, const mp_limb_t *s1p, mp_size_t n, +-- mp_limb_t s2limb) +foreign import ccall unsafe "gmp.h __gmpn_sub_1" + c_mpn_sub_1 :: MutableByteArray# s -> ByteArray# -> GmpSize# -> GmpLimb# + -> IO GmpLimb + +-- mp_limb_t mpn_mul_1 (mp_limb_t *rp, const mp_limb_t *s1p, mp_size_t n, +-- mp_limb_t s2limb) +foreign import ccall unsafe "gmp.h __gmpn_mul_1" + c_mpn_mul_1 :: MutableByteArray# s -> ByteArray# -> GmpSize# -> GmpLimb# + -> IO GmpLimb + +-- mp_limb_t mpn_add (mp_limb_t *rp, const mp_limb_t *s1p, mp_size_t s1n, +-- const mp_limb_t *s2p, mp_size_t s2n) +foreign import ccall unsafe "gmp.h __gmpn_add" + c_mpn_add :: MutableByteArray# s -> ByteArray# -> GmpSize# + -> ByteArray# -> GmpSize# -> IO GmpLimb + +-- mp_limb_t mpn_sub (mp_limb_t *rp, const mp_limb_t *s1p, mp_size_t s1n, +-- const mp_limb_t *s2p, mp_size_t s2n) +foreign import ccall unsafe "gmp.h __gmpn_sub" + c_mpn_sub :: MutableByteArray# s -> ByteArray# -> GmpSize# -> ByteArray# + -> GmpSize# -> IO GmpLimb + +-- mp_limb_t mpn_mul (mp_limb_t *rp, const mp_limb_t *s1p, mp_size_t s1n, +-- const mp_limb_t *s2p, mp_size_t s2n) +foreign import ccall unsafe "gmp.h __gmpn_mul" + c_mpn_mul :: MutableByteArray# s -> ByteArray# -> GmpSize# -> ByteArray# + -> GmpSize# -> IO GmpLimb + +-- int mpn_cmp (const mp_limb_t *s1p, const mp_limb_t *s2p, mp_size_t n) +foreign import ccall unsafe "gmp.h __gmpn_cmp" + c_mpn_cmp :: ByteArray# -> ByteArray# -> GmpSize# -> CInt# + +-- void mpn_tdiv_qr (mp_limb_t *qp, mp_limb_t *rp, mp_size_t qxn, +-- const mp_limb_t *np, mp_size_t nn, +-- const mp_limb_t *dp, mp_size_t dn) +foreign import ccall unsafe "gmp.h __gmpn_tdiv_qr" + c_mpn_tdiv_qr :: MutableByteArray# s -> MutableByteArray# s -> GmpSize# + -> ByteArray# -> GmpSize# -> ByteArray# -> GmpSize# -> IO () + +foreign import ccall unsafe "integer_gmp_mpn_tdiv_q" + c_mpn_tdiv_q :: MutableByteArray# s -> ByteArray# -> GmpSize# -> ByteArray# + -> GmpSize# -> IO () + +foreign import ccall unsafe "integer_gmp_mpn_tdiv_r" + c_mpn_tdiv_r :: MutableByteArray# s -> ByteArray# -> GmpSize# -> ByteArray# + -> GmpSize# -> IO () + +-- mp_limb_t mpn_divrem_1 (mp_limb_t *r1p, mp_size_t qxn, mp_limb_t *s2p, +-- mp_size_t s2n, mp_limb_t s3limb) +foreign import ccall unsafe "gmp.h __gmpn_divrem_1" + c_mpn_divrem_1 :: MutableByteArray# s -> GmpSize# -> ByteArray# -> GmpSize# + -> GmpLimb# -> IO GmpLimb + +-- mp_limb_t mpn_mod_1 (const mp_limb_t *s1p, mp_size_t s1n, mp_limb_t s2limb) +foreign import ccall unsafe "gmp.h __gmpn_mod_1" + c_mpn_mod_1 :: ByteArray# -> GmpSize# -> GmpLimb# -> GmpLimb# + +-- mp_limb_t integer_gmp_mpn_rshift (mp_limb_t rp[], const mp_limb_t sp[], +-- mp_size_t sn, mp_bitcnt_t count) +foreign import ccall unsafe "integer_gmp_mpn_rshift" + c_mpn_rshift :: MutableByteArray# s -> ByteArray# -> GmpSize# -> GmpBitCnt# + -> IO GmpLimb + +-- mp_limb_t integer_gmp_mpn_rshift (mp_limb_t rp[], const mp_limb_t sp[], +-- mp_size_t sn, mp_bitcnt_t count) +foreign import ccall unsafe "integer_gmp_mpn_rshift_2c" + c_mpn_rshift_2c :: MutableByteArray# s -> ByteArray# -> GmpSize# -> GmpBitCnt# + -> IO GmpLimb + +-- mp_limb_t integer_gmp_mpn_lshift (mp_limb_t rp[], const mp_limb_t sp[], +-- mp_size_t sn, mp_bitcnt_t count) +foreign import ccall unsafe "integer_gmp_mpn_lshift" + c_mpn_lshift :: MutableByteArray# s -> ByteArray# -> GmpSize# -> GmpBitCnt# + -> IO GmpLimb + +-- void mpn_and_n (mp_limb_t *rp, const mp_limb_t *s1p, const mp_limb_t *s2p, +-- mp_size_t n) +foreign import ccall unsafe "gmp.h __gmpn_and_n" + c_mpn_and_n :: MutableByteArray# s -> ByteArray# -> ByteArray# -> GmpSize# + -> IO () + +-- void mpn_andn_n (mp_limb_t *rp, const mp_limb_t *s1p, const mp_limb_t *s2p, +-- mp_size_t n) +foreign import ccall unsafe "gmp.h __gmpn_andn_n" + c_mpn_andn_n :: MutableByteArray# s -> ByteArray# -> ByteArray# -> GmpSize# + -> IO () + +-- void mpn_ior_n (mp_limb_t *rp, const mp_limb_t *s1p, const mp_limb_t *s2p, +-- mp_size_t n) +foreign import ccall unsafe "gmp.h __gmpn_ior_n" + c_mpn_ior_n :: MutableByteArray# s -> ByteArray# -> ByteArray# -> GmpSize# + -> IO () + +-- void mpn_xor_n (mp_limb_t *rp, const mp_limb_t *s1p, const mp_limb_t *s2p, +-- mp_size_t n) +foreign import ccall unsafe "gmp.h __gmpn_xor_n" + c_mpn_xor_n :: MutableByteArray# s -> ByteArray# -> ByteArray# -> GmpSize# + -> IO () + +-- mp_bitcnt_t mpn_popcount (const mp_limb_t *s1p, mp_size_t n) +foreign import ccall unsafe "gmp.h __gmpn_popcount" + c_mpn_popcount :: ByteArray# -> GmpSize# -> GmpBitCnt# + +---------------------------------------------------------------------------- +-- BigNat-wrapped ByteArray#-primops + +-- | Return number of limbs contained in 'BigNat'. +sizeofBigNat# :: BigNat -> GmpSize# +sizeofBigNat# (BN# x#) + = sizeofByteArray# x# `uncheckedIShiftRL#` GMP_LIMB_SHIFT# + +data MutBigNat s = MBN# !(MutableByteArray# s) + +sizeofMutBigNat# :: MutBigNat s -> GmpSize# +sizeofMutBigNat# (MBN# x#) + = sizeofMutableByteArray# x# `uncheckedIShiftRL#` GMP_LIMB_SHIFT# + +newBigNat# :: GmpSize# -> S s (MutBigNat s) +newBigNat# limbs# s = + case newByteArray# (limbs# `uncheckedIShiftL#` GMP_LIMB_SHIFT#) s of + (# s', mba# #) -> (# s', MBN# mba# #) + +writeBigNat# :: MutBigNat s -> GmpSize# -> GmpLimb# -> State# s -> State# s +writeBigNat# (MBN# mba#) = writeWordArray# mba# + +-- | Extract /n/-th (0-based) limb in 'BigNat'. +-- /n/ must be less than size as reported by 'sizeofBigNat#'. +indexBigNat# :: BigNat -> GmpSize# -> GmpLimb# +indexBigNat# (BN# ba#) = indexWordArray# ba# + +unsafeFreezeBigNat# :: MutBigNat s -> S s BigNat +unsafeFreezeBigNat# (MBN# mba#) s = case unsafeFreezeByteArray# mba# s of + (# s', ba# #) -> (# s', BN# ba# #) + +resizeMutBigNat# :: MutBigNat s -> GmpSize# -> S s (MutBigNat s) +resizeMutBigNat# (MBN# mba0#) nsz# s + | isTrue# (bsz# ==# sizeofMutableByteArray# mba0#) = (# s, MBN# mba0# #) + | True = case resizeMutableByteArray# mba0# bsz# s of + (# s', mba# #) -> (# s' , MBN# mba# #) + where + bsz# = nsz# `uncheckedIShiftL#` GMP_LIMB_SHIFT# + +shrinkMutBigNat# :: MutBigNat s -> GmpSize# -> State# s -> State# s +shrinkMutBigNat# (MBN# mba0#) nsz# + | isTrue# (bsz# ==# sizeofMutableByteArray# mba0#) = \s -> s -- no-op + | True = shrinkMutableByteArray# mba0# bsz# + where + bsz# = nsz# `uncheckedIShiftL#` GMP_LIMB_SHIFT# + +unsafeSnocFreezeBigNat# :: MutBigNat s -> GmpLimb# -> S s BigNat +unsafeSnocFreezeBigNat# mbn0@(MBN# mba0#) limb# = do + -- (MBN# mba#) <- newBigNat# (n# +# 1#) + -- _ <- svoid (copyMutableByteArray# mba0# 0# mba# 0# nb0#) + (MBN# mba#) <- resizeMutBigNat# mbn0 (n# +# 1#) + _ <- svoid (writeWordArray# mba# n# limb#) + unsafeFreezeBigNat# (MBN# mba#) + where + n# = nb0# `uncheckedIShiftRL#` GMP_LIMB_SHIFT# + nb0# = sizeofMutableByteArray# mba0# + +-- | May shrink underlyng 'ByteArray#' if needed to satisfy BigNat invariant +unsafeRenormFreezeBigNat# :: MutBigNat s -> S s BigNat +unsafeRenormFreezeBigNat# mbn s + | isTrue# (n0# ==# 0#) = (# s', nullBigNat #) + | isTrue# (n# ==# 0#) = (# s', zeroBigNat #) + | isTrue# (n# ==# n0#) = (unsafeFreezeBigNat# mbn) s' + | True = (unsafeShrinkFreezeBigNat# mbn n#) s' + where + (# s', n# #) = normSizeofMutBigNat'# mbn n0# s + n0# = sizeofMutBigNat# mbn + +-- | Shrink MBN +unsafeShrinkFreezeBigNat# :: MutBigNat s -> GmpSize# -> S s BigNat +unsafeShrinkFreezeBigNat# x@(MBN# xmba) 1# + = \s -> case readWordArray# xmba 0# s of + (# s', w# #) -> freezeOneLimb w# s' + where + freezeOneLimb 0## = return zeroBigNat + freezeOneLimb 1## = return oneBigNat + freezeOneLimb w# | isTrue# (not# w# `eqWord#` 0##) = return czeroBigNat + freezeOneLimb _ = do + _ <- svoid (shrinkMutBigNat# x 1#) + unsafeFreezeBigNat# x +unsafeShrinkFreezeBigNat# x y# = do + _ <- svoid (shrinkMutBigNat# x y#) + unsafeFreezeBigNat# x + + +copyWordArray# :: ByteArray# -> Int# -> MutableByteArray# s -> Int# -> Int# + -> State# s -> State# s +copyWordArray# src src_ofs dst dst_ofs len + = copyByteArray# src (src_ofs `uncheckedIShiftL#` GMP_LIMB_SHIFT#) + dst (dst_ofs `uncheckedIShiftL#` GMP_LIMB_SHIFT#) + (len `uncheckedIShiftL#` GMP_LIMB_SHIFT#) + +-- | Version of 'normSizeofMutBigNat'#' which scans all allocated 'MutBigNat#' +normSizeofMutBigNat# :: MutBigNat s -> State# s -> (# State# s, Int# #) +normSizeofMutBigNat# mbn@(MBN# mba) = normSizeofMutBigNat'# mbn sz# + where + sz# = sizeofMutableByteArray# mba `uncheckedIShiftRA#` GMP_LIMB_SHIFT# + +-- | Find most-significant non-zero limb and return its index-position +-- plus one. Start scanning downward from the initial limb-size +-- (i.e. start-index plus one) given as second argument. +-- +-- NB: The 'normSizeofMutBigNat' of 'zeroBigNat' would be @0#@ +normSizeofMutBigNat'# :: MutBigNat s -> GmpSize# + -> State# s -> (# State# s, GmpSize# #) +normSizeofMutBigNat'# (MBN# mba) = go + where + go 0# s = (# s, 0# #) + go i0# s = case readWordArray# mba (i0# -# 1#) s of + (# s', 0## #) -> go (i0# -# 1#) s' + (# s', _ #) -> (# s', i0# #) + +-- | Construct 'BigNat' from existing 'ByteArray#' containing /n/ +-- 'GmpLimb's in least-significant-first order. +-- +-- If possible 'ByteArray#', will be used directly (i.e. shared +-- /without/ cloning the 'ByteArray#' into a newly allocated one) +-- +-- Note: size parameter (times @sizeof(GmpLimb)@) must be less or +-- equal to its 'sizeofByteArray#'. +byteArrayToBigNat# :: ByteArray# -> GmpSize# -> BigNat +byteArrayToBigNat# ba# n0# + | isTrue# (n# ==# 0#) = zeroBigNat + | isTrue# (baszr# ==# 0#) -- i.e. ba# is multiple of limb-size + , isTrue# (baszq# ==# n#) = (BN# ba#) + | True = runS $ do + mbn@(MBN# mba#) <- newBigNat# n# + _ <- svoid (copyByteArray# ba# 0# mba# 0# (sizeofMutableByteArray# mba#)) + unsafeFreezeBigNat# mbn + where + (# baszq#, baszr# #) = quotRemInt# (sizeofByteArray# ba#) GMP_LIMB_BYTES# + + n# = fmssl (n0# -# 1#) + + -- find most signifcant set limb, return normalized size + fmssl i# + | isTrue# (i# <# 0#) = 0# + | isTrue# (neWord# (indexWordArray# ba# i#) 0##) = i# +# 1# + | True = fmssl (i# -# 1#) + +-- | Test whether all internal invariants are satisfied by 'BigNat' value +-- +-- Returns @1#@ if valid, @0#@ otherwise. +-- +-- This operation is mostly useful for test-suites and/or code which +-- constructs 'Integer' values directly. +isValidBigNat# :: BigNat -> Int# +isValidBigNat# (BN# ba#) + = (szq# ># 0#) `andI#` (szr# ==# 0#) `andI#` isNorm# + where + isNorm# = case szq# ># 1# of + 1# -> (indexWordArray# ba# (szq# -# 1#)) `neWord#` 0## + _ -> 1# + + sz# = sizeofByteArray# ba# + + (# szq#, szr# #) = quotRemInt# sz# GMP_LIMB_BYTES# + +---------------------------------------------------------------------------- +-- monadic combinators for low-level state threading + +type S s a = State# s -> (# State# s, a #) + +infixl 1 >>= +infixl 1 >> +infixr 0 $ + +{-# INLINE ($) #-} +($) :: (a -> b) -> a -> b +f $ x = f x + +{-# INLINE (>>=) #-} +(>>=) :: S s a -> (a -> S s b) -> S s b +(>>=) m k = \s -> case m s of (# s', a #) -> k a s' + +{-# INLINE (>>) #-} +(>>) :: S s a -> S s b -> S s b +(>>) m k = \s -> case m s of (# s', _ #) -> k s' + +{-# INLINE svoid #-} +svoid :: (State# s -> State# s) -> S s () +svoid m0 = \s -> case m0 s of s' -> (# s', () #) + +{-# INLINE return #-} +return :: a -> S s a +return a = \s -> (# s, a #) + +{-# INLINE liftIO #-} +liftIO :: IO a -> S RealWorld a +liftIO (IO m) = m + +-- NB: equivalent of GHC.IO.unsafeDupablePerformIO, see notes there +runS :: S RealWorld a -> a +runS m = lazy (case m realWorld# of (# _, r #) -> r) +{-# NOINLINE runS #-} + +-- stupid hack +fail :: [Char] -> S s a +fail s = return (raise# s) + +---------------------------------------------------------------------------- +-- misc helpers, some of these should rather be primitives exported by ghc-prim + +cmpW# :: Word# -> Word# -> Ordering +cmpW# x# y# + | isTrue# (x# `ltWord#` y#) = LT + | isTrue# (x# `eqWord#` y#) = EQ + | True = GT +{-# INLINE cmpW# #-} + +subWordC# :: Word# -> Word# -> (# Word#, Int# #) +subWordC# x# y# = (# d#, c# #) + where + d# = x# `minusWord#` y# + c# = d# `gtWord#` x# +{-# INLINE subWordC# #-} + +bitWord# :: Int# -> Word# +bitWord# = uncheckedShiftL# 1## +{-# INLINE bitWord# #-} + +testBitWord# :: Word# -> Int# -> Int# +testBitWord# w# i# = (bitWord# i# `and#` w#) `neWord#` 0## +{-# INLINE testBitWord# #-} + +popCntI# :: Int# -> Int# +popCntI# i# = word2Int# (popCnt# (int2Word# i#)) +{-# INLINE popCntI# #-} + +-- branchless version +absI# :: Int# -> Int# +absI# i# = (i# `xorI#` nsign) -# nsign + where + -- nsign = negateInt# (i# <# 0#) + nsign = uncheckedIShiftRA# i# (WORD_SIZE_IN_BITS# -# 1#) + +-- branchless version +sgnI# :: Int# -> Int# +sgnI# x# = (x# ># 0#) -# (x# <# 0#) + +cmpI# :: Int# -> Int# -> Int# +cmpI# x# y# = (x# ># y#) -# (x# <# y#) diff --git a/libraries/parallel b/libraries/parallel -Subproject 94e1aa6f621df464c237c9987bb7f65bd4cb5ff +Subproject 50a2b2a622898786d623a9f933183525305058d diff --git a/libraries/process b/libraries/process -Subproject 7b3ede7dbbb2de80b906c76f747d0b3196c4669 +Subproject bc5f2348b982d9e86bf2f15065187a0ba535a1a diff --git a/libraries/stm b/libraries/stm -Subproject 40fd6d88f75c31b66419ab93f436225c9403846 +Subproject 6b63e91b2b0b7d7b4bef654117da62c22cac34d diff --git a/libraries/template-haskell/Language/Haskell/TH.hs b/libraries/template-haskell/Language/Haskell/TH.hs index 76aae272bd..e038a3ba6b 100644 --- a/libraries/template-haskell/Language/Haskell/TH.hs +++ b/libraries/template-haskell/Language/Haskell/TH.hs @@ -41,15 +41,15 @@ module Language.Haskell.TH( TExp, unType, -- * Names - Name, NameSpace, -- Abstract + Name, NameSpace, -- Abstract -- ** Constructing names mkName, -- :: String -> Name newName, -- :: String -> Q Name -- ** Deconstructing names - nameBase, -- :: Name -> String - nameModule, -- :: Name -> Maybe String + nameBase, -- :: Name -> String + nameModule, -- :: Name -> Maybe String -- ** Built-in names - tupleTypeName, tupleDataName, -- Int -> Name + tupleTypeName, tupleDataName, -- Int -> Name unboxedTupleTypeName, unboxedTupleDataName, -- :: Int -> Name -- * The algebraic data types @@ -124,7 +124,7 @@ module Language.Haskell.TH( -- **** Data valD, funD, tySynD, dataD, newtypeD, -- **** Class - classD, instanceD, sigD, + classD, instanceD, sigD, standaloneDerivD, defaultSigD, -- **** Role annotations roleAnnotD, -- **** Type Family / Data Family diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib.hs b/libraries/template-haskell/Language/Haskell/TH/Lib.hs index 4d4f079719..efe597275b 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Lib.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Lib.hs @@ -171,7 +171,7 @@ patG ss = do { ss' <- sequence ss; return (PatG ss') } patGE :: [StmtQ] -> ExpQ -> Q (Guard, Exp) patGE ss e = do { ss' <- sequence ss; - e' <- e; + e' <- e; return (PatG ss', e') } ------------------------------------------------------------------------------- @@ -459,6 +459,19 @@ closedTypeFamilyKindD tc tvs kind eqns = roleAnnotD :: Name -> [Role] -> DecQ roleAnnotD name roles = return $ RoleAnnotD name roles +standaloneDerivD :: CxtQ -> TypeQ -> DecQ +standaloneDerivD ctxtq tyq = + do + ctxt <- ctxtq + ty <- tyq + return $ StandaloneDerivD ctxt ty + +defaultSigD :: Name -> TypeQ -> DecQ +defaultSigD n tyq = + do + ty <- tyq + return $ DefaultSigD n ty + tySynEqn :: [TypeQ] -> TypeQ -> TySynEqnQ tySynEqn lhs rhs = do diff --git a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs index 81bf3c1d66..5f3a0c6c9b 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs @@ -52,9 +52,9 @@ instance Ppr Info where ppr (FamilyI d is) = ppr d $$ vcat (map ppr is) ppr (PrimTyConI name arity is_unlifted) = text "Primitive" - <+> (if is_unlifted then text "unlifted" else empty) - <+> text "type constructor" <+> quotes (ppr name) - <+> parens (text "arity" <+> int arity) + <+> (if is_unlifted then text "unlifted" else empty) + <+> text "type constructor" <+> quotes (ppr name) + <+> parens (text "arity" <+> int arity) ppr (ClassOpI v ty cls fix) = text "Class op from" <+> ppr cls <> colon <+> vcat [ppr_sig v ty, pprFixity v fix] @@ -327,11 +327,17 @@ ppr_dec _ (ClosedTypeFamilyD tc tvs mkind eqns) ppr_dec _ (RoleAnnotD name roles) = hsep [ text "type role", ppr name ] <+> hsep (map ppr roles) +ppr_dec _ (StandaloneDerivD cxt ty) + = hsep [ text "deriving instance", pprCxt cxt, ppr ty ] + +ppr_dec _ (DefaultSigD n ty) + = hsep [ text "default", pprPrefixOcc n, text "::", ppr ty ] + ppr_data :: Doc -> Cxt -> Name -> Doc -> [Con] -> [Name] -> Doc ppr_data maybeInst ctxt t argsDoc cs decs = sep [text "data" <+> maybeInst - <+> pprCxt ctxt - <+> ppr t <+> argsDoc, + <+> pprCxt ctxt + <+> ppr t <+> argsDoc, nest nestDepth (sep (pref $ map ppr cs)), if null decs then empty @@ -346,14 +352,14 @@ ppr_data maybeInst ctxt t argsDoc cs decs ppr_newtype :: Doc -> Cxt -> Name -> Doc -> Con -> [Name] -> Doc ppr_newtype maybeInst ctxt t argsDoc c decs = sep [text "newtype" <+> maybeInst - <+> pprCxt ctxt - <+> ppr t <+> argsDoc, + <+> pprCxt ctxt + <+> ppr t <+> argsDoc, nest 2 (char '=' <+> ppr c), if null decs - then empty - else nest nestDepth - $ text "deriving" - <+> parens (hsep $ punctuate comma $ map ppr decs)] + then empty + else nest nestDepth + $ text "deriving" + <+> parens (hsep $ punctuate comma $ map ppr decs)] ppr_tySyn :: Doc -> Name -> Doc -> Type -> Doc ppr_tySyn maybeInst t argsDoc rhs @@ -507,7 +513,7 @@ pprTyApp (PromotedTupleT n, args) | length args == n = quoteParens (sep (punctuate comma (map ppr args))) pprTyApp (fun, args) = pprParendType fun <+> sep (map pprParendType args) -pprFunArgType :: Type -> Doc -- Should really use a precedence argument +pprFunArgType :: Type -> Doc -- Should really use a precedence argument -- Everything except forall and (->) binds more tightly than (->) pprFunArgType ty@(ForallT {}) = parens (ppr ty) pprFunArgType ty@((ArrowT `AppT` _) `AppT` _) = parens (ppr ty) diff --git a/libraries/template-haskell/Language/Haskell/TH/PprLib.hs b/libraries/template-haskell/Language/Haskell/TH/PprLib.hs index 22b336ae81..a6b923cc35 100644 --- a/libraries/template-haskell/Language/Haskell/TH/PprLib.hs +++ b/libraries/template-haskell/Language/Haskell/TH/PprLib.hs @@ -1,35 +1,35 @@ -{-# LANGUAGE FlexibleInstances, MagicHash #-} +{-# LANGUAGE FlexibleInstances #-} -- | Monadic front-end to Text.PrettyPrint module Language.Haskell.TH.PprLib ( - -- * The document type + -- * The document type Doc, -- Abstract, instance of Show PprM, - -- * Primitive Documents + -- * Primitive Documents empty, semi, comma, colon, space, equals, arrow, lparen, rparen, lbrack, rbrack, lbrace, rbrace, - -- * Converting values into documents + -- * Converting values into documents text, char, ptext, int, integer, float, double, rational, - -- * Wrapping documents in delimiters + -- * Wrapping documents in delimiters parens, brackets, braces, quotes, doubleQuotes, - -- * Combining documents + -- * Combining documents (<>), (<+>), hcat, hsep, ($$), ($+$), vcat, sep, cat, fsep, fcat, - nest, + nest, hang, punctuate, - -- * Predicates on documents - isEmpty, + -- * Predicates on documents + isEmpty, to_HPJ_Doc, pprName, pprName' ) where @@ -41,7 +41,6 @@ import qualified Text.PrettyPrint as HPJ import Control.Monad (liftM, liftM2, ap) import Language.Haskell.TH.Lib.Map ( Map ) import qualified Language.Haskell.TH.Lib.Map as Map ( lookup, insert, empty ) -import GHC.Base (Int(..)) infixl 6 <> infixl 6 <+> @@ -57,23 +56,23 @@ instance Show Doc where isEmpty :: Doc -> PprM Bool; -- ^ Returns 'True' if the document is empty -empty :: Doc; -- ^ An empty document -semi :: Doc; -- ^ A ';' character -comma :: Doc; -- ^ A ',' character -colon :: Doc; -- ^ A ':' character -space :: Doc; -- ^ A space character -equals :: Doc; -- ^ A '=' character -arrow :: Doc; -- ^ A "->" string -lparen :: Doc; -- ^ A '(' character -rparen :: Doc; -- ^ A ')' character -lbrack :: Doc; -- ^ A '[' character -rbrack :: Doc; -- ^ A ']' character -lbrace :: Doc; -- ^ A '{' character -rbrace :: Doc; -- ^ A '}' character - -text :: String -> Doc -ptext :: String -> Doc -char :: Char -> Doc +empty :: Doc; -- ^ An empty document +semi :: Doc; -- ^ A ';' character +comma :: Doc; -- ^ A ',' character +colon :: Doc; -- ^ A ':' character +space :: Doc; -- ^ A space character +equals :: Doc; -- ^ A '=' character +arrow :: Doc; -- ^ A "->" string +lparen :: Doc; -- ^ A '(' character +rparen :: Doc; -- ^ A ')' character +lbrack :: Doc; -- ^ A '[' character +rbrack :: Doc; -- ^ A ']' character +lbrace :: Doc; -- ^ A '{' character +rbrace :: Doc; -- ^ A '}' character + +text :: String -> Doc +ptext :: String -> Doc +char :: Char -> Doc int :: Int -> Doc integer :: Integer -> Doc float :: Float -> Doc @@ -81,11 +80,11 @@ double :: Double -> Doc rational :: Rational -> Doc -parens :: Doc -> Doc; -- ^ Wrap document in @(...)@ -brackets :: Doc -> Doc; -- ^ Wrap document in @[...]@ -braces :: Doc -> Doc; -- ^ Wrap document in @{...}@ -quotes :: Doc -> Doc; -- ^ Wrap document in @\'...\'@ -doubleQuotes :: Doc -> Doc; -- ^ Wrap document in @\"...\"@ +parens :: Doc -> Doc; -- ^ Wrap document in @(...)@ +brackets :: Doc -> Doc; -- ^ Wrap document in @[...]@ +braces :: Doc -> Doc; -- ^ Wrap document in @{...}@ +quotes :: Doc -> Doc; -- ^ Wrap document in @\'...\'@ +doubleQuotes :: Doc -> Doc; -- ^ Wrap document in @\"...\"@ -- Combining @Doc@ values @@ -96,7 +95,7 @@ hsep :: [Doc] -> Doc; -- ^List version of '<+>' ($$) :: Doc -> Doc -> Doc; -- ^Above; if there is no -- overlap it \"dovetails\" the two -($+$) :: Doc -> Doc -> Doc; -- ^Above, without dovetailing. +($+$) :: Doc -> Doc -> Doc; -- ^Above, without dovetailing. vcat :: [Doc] -> Doc; -- ^List version of '$$' cat :: [Doc] -> Doc; -- ^ Either hcat or vcat @@ -109,7 +108,7 @@ nest :: Int -> Doc -> Doc; -- ^ Nested -- GHC-specific ones. -hang :: Doc -> Int -> Doc -> Doc; -- ^ @hang d1 n d2 = sep [d1, nest n d2]@ +hang :: Doc -> Int -> Doc -> Doc; -- ^ @hang d1 n d2 = sep [d1, nest n d2]@ punctuate :: Doc -> [Doc] -> [Doc]; -- ^ @punctuate p [d1, ... dn] = [d1 \<> p, d2 \<> p, ... dn-1 \<> p, dn]@ @@ -124,10 +123,10 @@ pprName = pprName' Alone pprName' :: NameIs -> Name -> Doc pprName' ni n@(Name o (NameU _)) - = PprM $ \s@(fm, i@(I# i')) + = PprM $ \s@(fm, i) -> let (n', s') = case Map.lookup n fm of Just d -> (d, s) - Nothing -> let n'' = Name o (NameU i') + Nothing -> let n'' = Name o (NameU i) in (n'', (Map.insert n n'' fm, i + 1)) in (HPJ.text $ showName' ni n', s') pprName' ni n = text $ showName' ni n @@ -141,7 +140,7 @@ instance Show Name where data Name = Name OccName NameFlavour data NameFlavour - | NameU Int# -- A unique local name + | NameU Int# -- A unique local name -} to_HPJ_Doc :: Doc -> HPJ.Doc diff --git a/libraries/template-haskell/Language/Haskell/TH/Quote.hs b/libraries/template-haskell/Language/Haskell/TH/Quote.hs index b9c0d25d2b..618906d901 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Quote.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Quote.hs @@ -1,6 +1,6 @@ {-# LANGUAGE RankNTypes, ScopedTypeVariables #-} module Language.Haskell.TH.Quote( - QuasiQuoter(..), + QuasiQuoter(..), dataToQa, dataToExpQ, dataToPatQ, quoteFile ) where diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs index b5163cb44b..48199a4d8e 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE CPP, DeriveDataTypeable, MagicHash, PolymorphicComponents, RoleAnnotations, UnboxedTuples #-} +{-# LANGUAGE CPP, DeriveDataTypeable, PolymorphicComponents, + RoleAnnotations, DeriveGeneric #-} ----------------------------------------------------------------------------- -- | @@ -16,9 +17,7 @@ module Language.Haskell.TH.Syntax where -import GHC.Exts -import Data.Data (Data(..), Typeable, mkConstr, mkDataType, constrIndex) -import qualified Data.Data as Data +import Data.Data (Data(..), Typeable ) #if __GLASGOW_HASKELL__ < 709 import Control.Applicative( Applicative(..) ) #endif @@ -28,6 +27,7 @@ import Control.Monad (liftM) import System.IO ( hPutStrLn, stderr ) import Data.Char ( isAlpha, isAlphaNum, isUpper ) import Data.Word ( Word8 ) +import GHC.Generics ( Generic ) ----------------------------------------------------- -- @@ -377,9 +377,16 @@ runIO :: IO a -> Q a runIO m = Q (qRunIO m) -- | Record external files that runIO is using (dependent upon). --- The compiler can then recognize that it should re-compile the file using this TH when the external file changes. --- Note that ghc -M will still not know about these dependencies - it does not execute TH. +-- The compiler can then recognize that it should re-compile the Haskell file +-- when an external file changes. +-- -- Expects an absolute file path. +-- +-- Notes: +-- +-- * ghc -M does not know about these dependencies - it does not execute TH. +-- +-- * The dependency is based on file content, not a modification time addDependentFile :: FilePath -> Q () addDependentFile fp = Q (qAddDependentFile fp) @@ -525,17 +532,17 @@ rightName = mkNameG DataName "base" "Data.Either" "Right" ----------------------------------------------------- newtype ModName = ModName String -- Module name - deriving (Show,Eq,Ord,Typeable,Data) + deriving (Show,Eq,Ord,Typeable,Data,Generic) newtype PkgName = PkgName String -- package name - deriving (Show,Eq,Ord,Typeable,Data) + deriving (Show,Eq,Ord,Typeable,Data,Generic) -- | Obtained from 'reifyModule' and 'thisModule'. data Module = Module PkgName ModName -- package qualified module name - deriving (Show,Eq,Ord,Typeable,Data) + deriving (Show,Eq,Ord,Typeable,Data,Generic) newtype OccName = OccName String - deriving (Show,Eq,Ord,Typeable,Data) + deriving (Show,Eq,Ord,Typeable,Data,Generic) mkModName :: String -> ModName mkModName s = ModName s @@ -646,67 +653,29 @@ Names constructed using @newName@ and @mkName@ may be used in bindings (such as @let x = ...@ or @\x -> ...@), but names constructed using @lookupValueName@, @lookupTypeName@, @'f@, @''T@ may not. -} -data Name = Name OccName NameFlavour deriving (Typeable, Data) +data Name = Name OccName NameFlavour deriving (Typeable, Data, Eq, Generic) + +instance Ord Name where + -- check if unique is different before looking at strings + (Name o1 f1) `compare` (Name o2 f2) = (f1 `compare` f2) `thenCmp` + (o1 `compare` o2) data NameFlavour = NameS -- ^ An unqualified name; dynamically bound | NameQ ModName -- ^ A qualified name; dynamically bound - | NameU Int# -- ^ A unique local name - | NameL Int# -- ^ Local name bound outside of the TH AST + | NameU !Int -- ^ A unique local name + | NameL !Int -- ^ Local name bound outside of the TH AST | NameG NameSpace PkgName ModName -- ^ Global name bound outside of the TH AST: -- An original name (occurrences only, not binders) -- Need the namespace too to be sure which -- thing we are naming - deriving ( Typeable ) - --- | --- Although the NameFlavour type is abstract, the Data instance is not. The reason for this --- is that currently we use Data to serialize values in annotations, and in order for that to --- work for Template Haskell names introduced via the 'x syntax we need gunfold on NameFlavour --- to work. Bleh! --- --- The long term solution to this is to use the binary package for annotation serialization and --- then remove this instance. However, to do _that_ we need to wait on binary to become stable, since --- boot libraries cannot be upgraded separately from GHC itself. --- --- This instance cannot be derived automatically due to bug #2701 -instance Data NameFlavour where - gfoldl _ z NameS = z NameS - gfoldl k z (NameQ mn) = z NameQ `k` mn - gfoldl k z (NameU i) = z (\(I# i') -> NameU i') `k` (I# i) - gfoldl k z (NameL i) = z (\(I# i') -> NameL i') `k` (I# i) - gfoldl k z (NameG ns p m) = z NameG `k` ns `k` p `k` m - gunfold k z c = case constrIndex c of - 1 -> z NameS - 2 -> k $ z NameQ - 3 -> k $ z (\(I# i) -> NameU i) - 4 -> k $ z (\(I# i) -> NameL i) - 5 -> k $ k $ k $ z NameG - _ -> error "gunfold: NameFlavour" - toConstr NameS = con_NameS - toConstr (NameQ _) = con_NameQ - toConstr (NameU _) = con_NameU - toConstr (NameL _) = con_NameL - toConstr (NameG _ _ _) = con_NameG - dataTypeOf _ = ty_NameFlavour - -con_NameS, con_NameQ, con_NameU, con_NameL, con_NameG :: Data.Constr -con_NameS = mkConstr ty_NameFlavour "NameS" [] Data.Prefix -con_NameQ = mkConstr ty_NameFlavour "NameQ" [] Data.Prefix -con_NameU = mkConstr ty_NameFlavour "NameU" [] Data.Prefix -con_NameL = mkConstr ty_NameFlavour "NameL" [] Data.Prefix -con_NameG = mkConstr ty_NameFlavour "NameG" [] Data.Prefix - -ty_NameFlavour :: Data.DataType -ty_NameFlavour = mkDataType "Language.Haskell.TH.Syntax.NameFlavour" - [con_NameS, con_NameQ, con_NameU, - con_NameL, con_NameG] + deriving ( Typeable, Data, Eq, Ord, Generic ) data NameSpace = VarName -- ^ Variables | DataName -- ^ Data constructors | TcClsName -- ^ Type constructors and classes; Haskell has them -- in the same name space for now. - deriving( Eq, Ord, Data, Typeable ) + deriving( Eq, Ord, Data, Typeable, Generic ) type Uniq = Int @@ -789,11 +758,11 @@ mkName str -- | Only used internally mkNameU :: String -> Uniq -> Name -mkNameU s (I# u) = Name (mkOccName s) (NameU u) +mkNameU s u = Name (mkOccName s) (NameU u) -- | Only used internally mkNameL :: String -> Uniq -> Name -mkNameL s (I# u) = Name (mkOccName s) (NameL u) +mkNameL s u = Name (mkOccName s) (NameL u) -- | Used for 'x etc, but not available to the programmer mkNameG :: NameSpace -> String -> String -> String -> Name @@ -805,45 +774,6 @@ mkNameG_v = mkNameG VarName mkNameG_tc = mkNameG TcClsName mkNameG_d = mkNameG DataName -instance Eq Name where - v1 == v2 = cmpEq (v1 `compare` v2) - -instance Ord Name where - (Name o1 f1) `compare` (Name o2 f2) = (f1 `compare` f2) `thenCmp` - (o1 `compare` o2) - -instance Eq NameFlavour where - f1 == f2 = cmpEq (f1 `compare` f2) - -instance Ord NameFlavour where - -- NameS < NameQ < NameU < NameL < NameG - NameS `compare` NameS = EQ - NameS `compare` _ = LT - - (NameQ _) `compare` NameS = GT - (NameQ m1) `compare` (NameQ m2) = m1 `compare` m2 - (NameQ _) `compare` _ = LT - - (NameU _) `compare` NameS = GT - (NameU _) `compare` (NameQ _) = GT - (NameU u1) `compare` (NameU u2) | isTrue# (u1 <# u2) = LT - | isTrue# (u1 ==# u2) = EQ - | otherwise = GT - (NameU _) `compare` _ = LT - - (NameL _) `compare` NameS = GT - (NameL _) `compare` (NameQ _) = GT - (NameL _) `compare` (NameU _) = GT - (NameL u1) `compare` (NameL u2) | isTrue# (u1 <# u2) = LT - | isTrue# (u1 ==# u2) = EQ - | otherwise = GT - (NameL _) `compare` _ = LT - - (NameG ns1 p1 m1) `compare` (NameG ns2 p2 m2) = (ns1 `compare` ns2) `thenCmp` - (p1 `compare` p2) `thenCmp` - (m1 `compare` m2) - (NameG _ _ _) `compare` _ = GT - data NameIs = Alone | Applied | Infix showName :: Name -> String @@ -870,8 +800,8 @@ showName' ni nm Name occ NameS -> occString occ Name occ (NameQ m) -> modString m ++ "." ++ occString occ Name occ (NameG _ _ m) -> modString m ++ "." ++ occString occ - Name occ (NameU u) -> occString occ ++ "_" ++ show (I# u) - Name occ (NameL u) -> occString occ ++ "_" ++ show (I# u) + Name occ (NameU u) -> occString occ ++ "_" ++ show u + Name occ (NameL u) -> occString occ ++ "_" ++ show u pnam = classify nms @@ -1015,13 +945,13 @@ data Info | TyVarI -- Scoped type variable Name Type -- What it is bound to - deriving( Show, Data, Typeable ) + deriving( Show, Data, Typeable, Generic ) -- | Obtained from 'reifyModule' in the 'Q' Monad. data ModuleInfo = -- | Contains the import list of the module. ModuleInfo [Module] - deriving( Show, Data, Typeable ) + deriving( Show, Data, Typeable, Generic ) {- | In 'ClassOpI' and 'DataConI', name of the parent class or type @@ -1045,9 +975,9 @@ type Unlifted = Bool type InstanceDec = Dec data Fixity = Fixity Int FixityDirection - deriving( Eq, Show, Data, Typeable ) + deriving( Eq, Show, Data, Typeable, Generic ) data FixityDirection = InfixL | InfixR | InfixN - deriving( Eq, Show, Data, Typeable ) + deriving( Eq, Show, Data, Typeable, Generic ) -- | Highest allowed operator precedence for 'Fixity' constructor (answer: 9) maxPrecedence :: Int @@ -1139,7 +1069,7 @@ data Lit = CharL Char | FloatPrimL Rational | DoublePrimL Rational | StringPrimL [Word8] -- ^ A primitive C-style string, type Addr# - deriving( Show, Eq, Data, Typeable ) + deriving( Show, Eq, Data, Typeable, Generic ) -- We could add Int, Float, Double etc, as we do in HsLit, -- but that could complicate the @@ -1167,15 +1097,15 @@ data Pat | ListP [ Pat ] -- ^ @{ [1,2,3] }@ | SigP Pat Type -- ^ @{ p :: t }@ | ViewP Exp Pat -- ^ @{ e -> p }@ - deriving( Show, Eq, Data, Typeable ) + deriving( Show, Eq, Data, Typeable, Generic ) type FieldPat = (Name,Pat) data Match = Match Pat Body [Dec] -- ^ @case e of { pat -> body where decs }@ - deriving( Show, Eq, Data, Typeable ) + deriving( Show, Eq, Data, Typeable, Generic ) data Clause = Clause [Pat] Body [Dec] -- ^ @f { p1 p2 = body where decs }@ - deriving( Show, Eq, Data, Typeable ) + deriving( Show, Eq, Data, Typeable, Generic ) data Exp = VarE Name -- ^ @{ x }@ @@ -1222,7 +1152,7 @@ data Exp | SigE Exp Type -- ^ @{ e :: t }@ | RecConE Name [FieldExp] -- ^ @{ T { x = y, z = w } }@ | RecUpdE Exp [FieldExp] -- ^ @{ (f x) { z = w } }@ - deriving( Show, Eq, Data, Typeable ) + deriving( Show, Eq, Data, Typeable, Generic ) type FieldExp = (Name,Exp) @@ -1233,23 +1163,23 @@ data Body -- | e3 = e4 } -- where ds@ | NormalB Exp -- ^ @f p { = e } where ds@ - deriving( Show, Eq, Data, Typeable ) + deriving( Show, Eq, Data, Typeable, Generic ) data Guard = NormalG Exp -- ^ @f x { | odd x } = x@ | PatG [Stmt] -- ^ @f x { | Just y <- x, Just z <- y } = z@ - deriving( Show, Eq, Data, Typeable ) + deriving( Show, Eq, Data, Typeable, Generic ) data Stmt = BindS Pat Exp | LetS [ Dec ] | NoBindS Exp | ParS [[Stmt]] - deriving( Show, Eq, Data, Typeable ) + deriving( Show, Eq, Data, Typeable, Generic ) data Range = FromR Exp | FromThenR Exp Exp | FromToR Exp Exp | FromThenToR Exp Exp Exp - deriving( Show, Eq, Data, Typeable ) + deriving( Show, Eq, Data, Typeable, Generic ) data Dec = FunD Name [Clause] -- ^ @{ f p1 p2 = b where decs }@ @@ -1292,29 +1222,31 @@ data Dec [TySynEqn] -- ^ @{ type family F a b :: * where ... }@ | RoleAnnotD Name [Role] -- ^ @{ type role T nominal representational }@ - deriving( Show, Eq, Data, Typeable ) + | StandaloneDerivD Cxt Type -- ^ @{ deriving instance Ord a => Ord (Foo a) }@ + | DefaultSigD Name Type -- ^ @{ default size :: Data a => a -> Int }@ + deriving( Show, Eq, Data, Typeable, Generic ) -- | One equation of a type family instance or closed type family. The -- arguments are the left-hand-side type patterns and the right-hand-side -- result. data TySynEqn = TySynEqn [Type] Type - deriving( Show, Eq, Data, Typeable ) + deriving( Show, Eq, Data, Typeable, Generic ) data FunDep = FunDep [Name] [Name] - deriving( Show, Eq, Data, Typeable ) + deriving( Show, Eq, Data, Typeable, Generic ) data FamFlavour = TypeFam | DataFam - deriving( Show, Eq, Data, Typeable ) + deriving( Show, Eq, Data, Typeable, Generic ) data Foreign = ImportF Callconv Safety String Name Type | ExportF Callconv String Name Type - deriving( Show, Eq, Data, Typeable ) + deriving( Show, Eq, Data, Typeable, Generic ) data Callconv = CCall | StdCall - deriving( Show, Eq, Data, Typeable ) + deriving( Show, Eq, Data, Typeable, Generic ) data Safety = Unsafe | Safe | Interruptible - deriving( Show, Eq, Data, Typeable ) + deriving( Show, Eq, Data, Typeable, Generic ) data Pragma = InlineP Name Inline RuleMatch Phases | SpecialiseP Name Type (Maybe Inline) Phases @@ -1322,30 +1254,30 @@ data Pragma = InlineP Name Inline RuleMatch Phases | RuleP String [RuleBndr] Exp Exp Phases | AnnP AnnTarget Exp | LineP Int String - deriving( Show, Eq, Data, Typeable ) + deriving( Show, Eq, Data, Typeable, Generic ) data Inline = NoInline | Inline | Inlinable - deriving (Show, Eq, Data, Typeable) + deriving (Show, Eq, Data, Typeable, Generic) data RuleMatch = ConLike | FunLike - deriving (Show, Eq, Data, Typeable) + deriving (Show, Eq, Data, Typeable, Generic) data Phases = AllPhases | FromPhase Int | BeforePhase Int - deriving (Show, Eq, Data, Typeable) + deriving (Show, Eq, Data, Typeable, Generic) data RuleBndr = RuleVar Name | TypedRuleVar Name Type - deriving (Show, Eq, Data, Typeable) + deriving (Show, Eq, Data, Typeable, Generic) data AnnTarget = ModuleAnnotation | TypeAnnotation Name | ValueAnnotation Name - deriving (Show, Eq, Data, Typeable) + deriving (Show, Eq, Data, Typeable, Generic) type Cxt = [Pred] -- ^ @(Eq a, Ord b)@ @@ -1355,13 +1287,13 @@ type Cxt = [Pred] -- ^ @(Eq a, Ord b)@ type Pred = Type data Strict = IsStrict | NotStrict | Unpacked - deriving( Show, Eq, Data, Typeable ) + deriving( Show, Eq, Data, Typeable, Generic ) data Con = NormalC Name [StrictType] -- ^ @C Int a@ | RecC Name [VarStrictType] -- ^ @C { v :: Int, w :: a }@ | InfixC StrictType Name StrictType -- ^ @Int :+ a@ | ForallC [TyVarBndr] Cxt Con -- ^ @forall a. Eq a => C [a]@ - deriving( Show, Eq, Data, Typeable ) + deriving( Show, Eq, Data, Typeable, Generic ) type StrictType = (Strict, Type) type VarStrictType = (Name, Strict, Type) @@ -1385,27 +1317,27 @@ data Type = ForallT [TyVarBndr] Cxt Type -- ^ @forall \<vars\>. \<ctxt\> -> \<t | StarT -- ^ @*@ | ConstraintT -- ^ @Constraint@ | LitT TyLit -- ^ @0,1,2, etc.@ - deriving( Show, Eq, Data, Typeable ) + deriving( Show, Eq, Data, Typeable, Generic ) data TyVarBndr = PlainTV Name -- ^ @a@ | KindedTV Name Kind -- ^ @(a :: k)@ - deriving( Show, Eq, Data, Typeable ) + deriving( Show, Eq, Data, Typeable, Generic ) data TyLit = NumTyLit Integer -- ^ @2@ | StrTyLit String -- ^ @"Hello"@ - deriving ( Show, Eq, Data, Typeable ) + deriving ( Show, Eq, Data, Typeable, Generic ) -- | Role annotations data Role = NominalR -- ^ @nominal@ | RepresentationalR -- ^ @representational@ | PhantomR -- ^ @phantom@ | InferR -- ^ @_@ - deriving( Show, Eq, Data, Typeable ) + deriving( Show, Eq, Data, Typeable, Generic ) -- | Annotation target for reifyAnnotations data AnnLookup = AnnLookupModule Module | AnnLookupName Name - deriving( Show, Eq, Data, Typeable ) + deriving( Show, Eq, Data, Typeable, Generic ) -- | To avoid duplication between kinds and types, they -- are defined to be the same. Naturally, you would never diff --git a/libraries/time b/libraries/time -Subproject 991e6be84974b02d7f968601ab02d2e2b3e1419 +Subproject ab6475cb94260f4303afbbd4b770cbd14ec2f57 diff --git a/libraries/transformers b/libraries/transformers -Subproject 87d9892a604b56d687ce70f1d1abc7848f78c6e +Subproject c55953c1298a5b63e250dfcd402154f6d187825 diff --git a/mk/config.mk.in b/mk/config.mk.in index 4d860ec1da..4f22c56cc5 100644 --- a/mk/config.mk.in +++ b/mk/config.mk.in @@ -230,7 +230,7 @@ ExtraMakefileSanityChecks = NO # Options for Libraries # Which directory (in libraries/) contains the integer library? -INTEGER_LIBRARY=integer-gmp +INTEGER_LIBRARY=integer-gmp2 # We build the libraries at least the "vanilla" way (way "v") GhcLibWays = v diff --git a/mk/validate-settings.mk b/mk/validate-settings.mk index 52aa648893..e06135b30c 100644 --- a/mk/validate-settings.mk +++ b/mk/validate-settings.mk @@ -108,6 +108,9 @@ libraries/stm_dist-install_EXTRA_HC_OPTS += -fno-warn-unused-imports libraries/parallel_dist-install_EXTRA_HC_OPTS += -fno-warn-unused-imports libraries/vector_dist-install_EXTRA_HC_OPTS += -fno-warn-unused-imports +# haddock's attoparsec uses deprecated `inlinePerformIO` +utils/haddock_dist_EXTRA_HC_OPTS += -fno-warn-deprecations + # bytestring has identities at the moment libraries/bytestring_dist-install_EXTRA_HC_OPTS += -fno-warn-identities @@ -163,6 +166,11 @@ libraries/dph/dph-lifted-common-install_EXTRA_HC_OPTS += -Wwarn # We need to turn of deprecated warnings for SafeHaskell transition libraries/array_dist-install_EXTRA_HC_OPTS += -fno-warn-warnings-deprecations +# Turn of trustworthy-safe warning +libraries/base_dist-install_EXTRA_HC_OPTS += -fno-warn-trustworthy-safe +libraries/ghc-prim_dist-install_EXTRA_HC_OPTS += -fno-warn-trustworthy-safe +libraries/unix_dist-install_EXTRA_HC_OPTS += -fno-warn-trustworthy-safe + # Temporarely disable inline rule shadowing warning libraries/bytestring_dist-install_EXTRA_HC_OPTS += -fno-warn-inline-rule-shadowing libraries/template-haskell_dist-install_EXTRA_HC_OPTS += -fno-warn-inline-rule-shadowing diff --git a/rts/Capability.c b/rts/Capability.c index 289eeb2c5b..21f63f39d9 100644 --- a/rts/Capability.c +++ b/rts/Capability.c @@ -297,6 +297,10 @@ initCapability( Capability *cap, nat i ) cap->r.rCCCS = NULL; #endif + // cap->r.rCurrentTSO is charged for calls to allocate(), so we + // don't want it set when not running a Haskell thread. + cap->r.rCurrentTSO = NULL; + traceCapCreate(cap); traceCapsetAssignCap(CAPSET_OSPROCESS_DEFAULT, i); traceCapsetAssignCap(CAPSET_CLOCKDOMAIN_DEFAULT, i); diff --git a/rts/HeapStackCheck.cmm b/rts/HeapStackCheck.cmm index 0659fed89f..a1fb5d446d 100644 --- a/rts/HeapStackCheck.cmm +++ b/rts/HeapStackCheck.cmm @@ -100,7 +100,9 @@ stg_gc_noregs CurrentNursery = bdescr_link(CurrentNursery); OPEN_NURSERY(); if (Capability_context_switch(MyCapability()) != 0 :: CInt || - Capability_interrupt(MyCapability()) != 0 :: CInt) { + Capability_interrupt(MyCapability()) != 0 :: CInt || + (StgTSO_alloc_limit(CurrentTSO) `lt` (0::I64) && + (TO_W_(StgTSO_flags(CurrentTSO)) & TSO_ALLOC_LIMIT) != 0)) { ret = ThreadYielding; goto sched; } else { diff --git a/rts/Linker.c b/rts/Linker.c index 7d029c62ac..2c74a0dd35 100644 --- a/rts/Linker.c +++ b/rts/Linker.c @@ -1264,6 +1264,10 @@ typedef struct _RtsSymbolVal { SymI_HasProto(rtsSupportsBoundThreads) \ SymI_HasProto(rts_isProfiled) \ SymI_HasProto(rts_isDynamic) \ + SymI_HasProto(rts_getThreadAllocationCounter) \ + SymI_HasProto(rts_setThreadAllocationCounter) \ + SymI_HasProto(rts_enableThreadAllocationLimit) \ + SymI_HasProto(rts_disableThreadAllocationLimit) \ SymI_HasProto(setProgArgv) \ SymI_HasProto(startupHaskell) \ SymI_HasProto(shutdownHaskell) \ diff --git a/rts/Prelude.h b/rts/Prelude.h index 0c54148ba2..614c255af5 100644 --- a/rts/Prelude.h +++ b/rts/Prelude.h @@ -37,6 +37,7 @@ extern StgClosure ZCMain_main_closure; PRELUDE_CLOSURE(base_GHCziIOziException_stackOverflow_closure); PRELUDE_CLOSURE(base_GHCziIOziException_heapOverflow_closure); +PRELUDE_CLOSURE(base_GHCziIOziException_allocationLimitExceeded_closure); PRELUDE_CLOSURE(base_GHCziIOziException_blockedIndefinitelyOnThrowTo_closure); PRELUDE_CLOSURE(base_GHCziIOziException_blockedIndefinitelyOnMVar_closure); PRELUDE_CLOSURE(base_GHCziIOziException_blockedIndefinitelyOnSTM_closure); @@ -101,6 +102,7 @@ PRELUDE_INFO(base_GHCziStable_StablePtr_con_info); #define stackOverflow_closure DLL_IMPORT_DATA_REF(base_GHCziIOziException_stackOverflow_closure) #define heapOverflow_closure DLL_IMPORT_DATA_REF(base_GHCziIOziException_heapOverflow_closure) +#define allocationLimitExceeded_closure DLL_IMPORT_DATA_REF(base_GHCziIOziException_allocationLimitExceeded_closure) #define blockedIndefinitelyOnMVar_closure DLL_IMPORT_DATA_REF(base_GHCziIOziException_blockedIndefinitelyOnMVar_closure) #define blockedIndefinitelyOnSTM_closure DLL_IMPORT_DATA_REF(base_GHCziIOziException_blockedIndefinitelyOnSTM_closure) #define nonTermination_closure DLL_IMPORT_DATA_REF(base_ControlziExceptionziBase_nonTermination_closure) diff --git a/rts/RaiseAsync.c b/rts/RaiseAsync.c index 10585c89fa..3b206ffa7e 100644 --- a/rts/RaiseAsync.c +++ b/rts/RaiseAsync.c @@ -89,6 +89,60 @@ suspendComputation (Capability *cap, StgTSO *tso, StgUpdateFrame *stop_here) } /* ----------------------------------------------------------------------------- + throwToSelf + + Useful for throwing an async exception in a thread from the + runtime. It handles unlocking the throwto message returned by + throwTo(). + + Note [Throw to self when masked] + + When a StackOverflow occurs when the thread is masked, we want to + defer the exception to when the thread becomes unmasked/hits an + interruptible point. We already have a mechanism for doing this, + the blocked_exceptions list, but the use here is a bit unusual, + because an exception is normally only added to this list upon + an asynchronous 'throwTo' call (with all of the relevant + multithreaded nonsense). Morally, a stack overflow should be an + asynchronous exception sent by a thread to itself, and it should + have the same semantics. But there are a few key differences: + + - If you actually tried to send an asynchronous exception to + yourself using throwTo, the exception would actually immediately + be delivered. This is because throwTo itself is considered an + interruptible point, so the exception is always deliverable. Thus, + ordinarily, we never end up with a message to onesself in the + blocked_exceptions queue. + + - In the case of a StackOverflow, we don't actually care about the + wakeup semantics; when an exception is delivered, the thread that + originally threw the exception should be woken up, since throwTo + blocks until the exception is successfully thrown. Fortunately, + it is harmless to wakeup a thread that doesn't actually need waking + up, e.g. ourselves. + + - No synchronization is necessary, because we own the TSO and the + capability. You can observe this by tracing through the execution + of throwTo. We skip synchronizing the message and inter-capability + communication. + + We think this doesn't break any invariants, but do be careful! + -------------------------------------------------------------------------- */ + +void +throwToSelf (Capability *cap, StgTSO *tso, StgClosure *exception) +{ + MessageThrowTo *m; + + m = throwTo(cap, tso, tso, exception); + + if (m != NULL) { + // throwTo leaves it locked + unlockClosure((StgClosure*)m, &stg_MSG_THROWTO_info); + } +} + +/* ----------------------------------------------------------------------------- throwTo This function may be used to throw an exception from one thread to diff --git a/rts/RaiseAsync.h b/rts/RaiseAsync.h index e2763d0cb8..6bfed8d6ca 100644 --- a/rts/RaiseAsync.h +++ b/rts/RaiseAsync.h @@ -28,6 +28,10 @@ void throwToSingleThreaded_ (Capability *cap, StgClosure *exception, rtsBool stop_at_atomically); +void throwToSelf (Capability *cap, + StgTSO *tso, + StgClosure *exception); + void suspendComputation (Capability *cap, StgTSO *tso, StgUpdateFrame *stop_here); diff --git a/rts/RtsFlags.c b/rts/RtsFlags.c index 44c05cec3b..82e90e5b0e 100644 --- a/rts/RtsFlags.c +++ b/rts/RtsFlags.c @@ -137,6 +137,7 @@ void initRtsFlagsDefaults(void) #else RtsFlags.GcFlags.heapBase = 0; /* means don't care */ #endif + RtsFlags.GcFlags.allocLimitGrace = (100*1024) / BLOCK_SIZE; #ifdef DEBUG RtsFlags.DebugFlags.scheduler = rtsFalse; @@ -403,6 +404,8 @@ usage_text[] = { " +PAPI_EVENT - collect papi preset event PAPI_EVENT", " #NATIVE_EVENT - collect native event NATIVE_EVENT (in hex)", #endif +" -xq The allocation limit given to a thread after it receives", +" an AllocationLimitExceeded exception. (default: 100k)", "", "RTS options may also be specified using the GHCRTS environment variable.", "", @@ -1361,6 +1364,13 @@ error = rtsTrue; /* The option prefix '-xx' is reserved for future extension. KSW 1999-11. */ + case 'q': + OPTION_UNSAFE; + RtsFlags.GcFlags.allocLimitGrace + = decodeSize(rts_argv[arg], 3, BLOCK_SIZE, HS_INT_MAX) + / BLOCK_SIZE; + break; + default: OPTION_SAFE; errorBelch("unknown RTS option: %s",rts_argv[arg]); diff --git a/rts/RtsStartup.c b/rts/RtsStartup.c index 32bed5af8f..b8201e1651 100644 --- a/rts/RtsStartup.c +++ b/rts/RtsStartup.c @@ -214,6 +214,7 @@ hs_init_ghc(int *argc, char **argv[], RtsConfig rts_config) getStablePtr((StgPtr)blockedIndefinitelyOnMVar_closure); getStablePtr((StgPtr)nonTermination_closure); getStablePtr((StgPtr)blockedIndefinitelyOnSTM_closure); + getStablePtr((StgPtr)allocationLimitExceeded_closure); getStablePtr((StgPtr)nestedAtomically_closure); getStablePtr((StgPtr)runSparks_closure); diff --git a/rts/Schedule.c b/rts/Schedule.c index b11270832d..e9b0289599 100644 --- a/rts/Schedule.c +++ b/rts/Schedule.c @@ -481,6 +481,10 @@ run_thread: // happened. So find the new location: t = cap->r.rCurrentTSO; + // cap->r.rCurrentTSO is charged for calls to allocate(), so we + // don't want it set when not running a Haskell thread. + cap->r.rCurrentTSO = NULL; + // And save the current errno in this thread. // XXX: possibly bogus for SMP because this thread might already // be running again, see code below. @@ -1078,6 +1082,21 @@ schedulePostRunThread (Capability *cap, StgTSO *t) } } + // + // If the current thread's allocation limit has run out, send it + // the AllocationLimitExceeded exception. + + if (t->alloc_limit < 0 && (t->flags & TSO_ALLOC_LIMIT)) { + // Use a throwToSelf rather than a throwToSingleThreaded, because + // it correctly handles the case where the thread is currently + // inside mask. Also the thread might be blocked (e.g. on an + // MVar), and throwToSingleThreaded doesn't unblock it + // correctly in that case. + throwToSelf(cap, t, allocationLimitExceeded_closure); + t->alloc_limit = (StgInt64)RtsFlags.GcFlags.allocLimitGrace + * BLOCK_SIZE; + } + /* some statistics gathering in the parallel case */ } @@ -2214,6 +2233,9 @@ suspendThread (StgRegTable *reg, rtsBool interruptible) task->incall->suspended_tso = tso; task->incall->suspended_cap = cap; + // Otherwise allocate() will write to invalid memory. + cap->r.rCurrentTSO = NULL + ACQUIRE_LOCK(&cap->lock); suspendTask(cap,task); diff --git a/rts/Threads.c b/rts/Threads.c index 76e844a3f6..90efd9ce4e 100644 --- a/rts/Threads.c +++ b/rts/Threads.c @@ -110,6 +110,8 @@ createThread(Capability *cap, W_ size) tso->stackobj = stack; tso->tot_stack_size = stack->stack_size; + tso->alloc_limit = 0; + tso->trec = NO_TREC; #ifdef PROFILING @@ -164,6 +166,31 @@ rts_getThreadId(StgPtr tso) return ((StgTSO *)tso)->id; } +/* --------------------------------------------------------------------------- + * Getting & setting the thread allocation limit + * ------------------------------------------------------------------------ */ +HsInt64 rts_getThreadAllocationCounter(StgPtr tso) +{ + // NB. doesn't take into account allocation in the current nursery + // block, so it might be off by up to 4k. + return ((StgTSO *)tso)->alloc_limit; +} + +void rts_setThreadAllocationCounter(StgPtr tso, HsInt64 i) +{ + ((StgTSO *)tso)->alloc_limit = i; +} + +void rts_enableThreadAllocationLimit(StgPtr tso) +{ + ((StgTSO *)tso)->flags |= TSO_ALLOC_LIMIT; +} + +void rts_disableThreadAllocationLimit(StgPtr tso) +{ + ((StgTSO *)tso)->flags &= ~TSO_ALLOC_LIMIT; +} + /* ----------------------------------------------------------------------------- Remove a thread from a queue. Fails fatally if the TSO is not on the queue. @@ -524,21 +551,8 @@ threadStackOverflow (Capability *cap, StgTSO *tso) stg_min(tso->stackobj->stack + tso->stackobj->stack_size, tso->stackobj->sp+64))); - if (tso->flags & TSO_BLOCKEX) { - // NB. StackOverflow exceptions must be deferred if the thread is - // inside Control.Exception.mask. See bug #767 and bug #8303. - // This implementation is a minor hack, see Note [Throw to self when masked] - MessageThrowTo *msg = (MessageThrowTo*)allocate(cap, sizeofW(MessageThrowTo)); - SET_HDR(msg, &stg_MSG_THROWTO_info, CCS_SYSTEM); - msg->source = tso; - msg->target = tso; - msg->exception = (StgClosure *)stackOverflow_closure; - blockedThrowTo(cap, tso, msg); - } else { - // Send this thread the StackOverflow exception - throwToSingleThreaded(cap, tso, (StgClosure *)stackOverflow_closure); - return; - } + // Note [Throw to self when masked], also #767 and #8303. + throwToSelf(cap, tso, (StgClosure *)stackOverflow_closure); } @@ -669,39 +683,6 @@ threadStackOverflow (Capability *cap, StgTSO *tso) // IF_DEBUG(scheduler,printTSO(new_tso)); } -/* Note [Throw to self when masked] - * - * When a StackOverflow occurs when the thread is masked, we want to - * defer the exception to when the thread becomes unmasked/hits an - * interruptible point. We already have a mechanism for doing this, - * the blocked_exceptions list, but the use here is a bit unusual, - * because an exception is normally only added to this list upon - * an asynchronous 'throwTo' call (with all of the relevant - * multithreaded nonsense). Morally, a stack overflow should be an - * asynchronous exception sent by a thread to itself, and it should - * have the same semantics. But there are a few key differences: - * - * - If you actually tried to send an asynchronous exception to - * yourself using throwTo, the exception would actually immediately - * be delivered. This is because throwTo itself is considered an - * interruptible point, so the exception is always deliverable. Thus, - * ordinarily, we never end up with a message to onesself in the - * blocked_exceptions queue. - * - * - In the case of a StackOverflow, we don't actually care about the - * wakeup semantics; when an exception is delivered, the thread that - * originally threw the exception should be woken up, since throwTo - * blocks until the exception is successfully thrown. Fortunately, - * it is harmless to wakeup a thread that doesn't actually need waking - * up, e.g. ourselves. - * - * - No synchronization is necessary, because we own the TSO and the - * capability. You can observe this by tracing through the execution - * of throwTo. We skip synchronizing the message and inter-capability - * communication. - * - * We think this doesn't break any invariants, but do be careful! - */ /* --------------------------------------------------------------------------- diff --git a/rts/package.conf.in b/rts/package.conf.in index 82d2870cde..ce44a09651 100644 --- a/rts/package.conf.in +++ b/rts/package.conf.in @@ -99,6 +99,7 @@ ld-options: , "-Wl,-u,_base_ControlziExceptionziBase_nonTermination_closure" , "-Wl,-u,_base_GHCziIOziException_blockedIndefinitelyOnMVar_closure" , "-Wl,-u,_base_GHCziIOziException_blockedIndefinitelyOnSTM_closure" + , "-Wl,-u,_base_GHCziIOziException_allocationLimitExceeded_closure" , "-Wl,-u,_base_ControlziExceptionziBase_nestedAtomically_closure" , "-Wl,-u,_base_GHCziEventziThread_blockedOnBadFD_closure" , "-Wl,-u,_base_GHCziWeak_runFinalizzerBatch_closure" @@ -140,6 +141,7 @@ ld-options: , "-Wl,-u,base_ControlziExceptionziBase_nonTermination_closure" , "-Wl,-u,base_GHCziIOziException_blockedIndefinitelyOnMVar_closure" , "-Wl,-u,base_GHCziIOziException_blockedIndefinitelyOnSTM_closure" + , "-Wl,-u,base_GHCziIOziException_allocationLimitExceeded_closure" , "-Wl,-u,base_ControlziExceptionziBase_nestedAtomically_closure" , "-Wl,-u,base_GHCziEventziThread_blockedOnBadFD_closure" , "-Wl,-u,base_GHCziWeak_runFinalizzerBatch_closure" diff --git a/rts/sm/Storage.c b/rts/sm/Storage.c index 379d9da769..afb171b568 100644 --- a/rts/sm/Storage.c +++ b/rts/sm/Storage.c @@ -684,7 +684,10 @@ StgPtr allocate (Capability *cap, W_ n) TICK_ALLOC_HEAP_NOCTR(WDS(n)); CCS_ALLOC(cap->r.rCCCS,n); - + if (cap->r.rCurrentTSO != NULL) { + cap->r.rCurrentTSO->alloc_limit -= n*sizeof(W_); + } + if (n >= LARGE_OBJECT_THRESHOLD/sizeof(W_)) { // The largest number of words such that // the computation of req_blocks will not overflow. @@ -829,6 +832,9 @@ allocatePinned (Capability *cap, W_ n) TICK_ALLOC_HEAP_NOCTR(WDS(n)); CCS_ALLOC(cap->r.rCCCS,n); + if (cap->r.rCurrentTSO != NULL) { + cap->r.rCurrentTSO->alloc_limit -= n*sizeof(W_); + } bd = cap->pinned_object_block; diff --git a/rts/win32/libHSbase.def b/rts/win32/libHSbase.def index 8140528c70..2091e85c9c 100644 --- a/rts/win32/libHSbase.def +++ b/rts/win32/libHSbase.def @@ -32,11 +32,12 @@ EXPORTS base_GHCziTopHandler_flushStdHandles_closure - base_GHCziWeak_runFinalizzerBatch_closure + base_GHCziWeak_runFinalizzerBatch_closure base_GHCziPack_unpackCString_closure base_GHCziIOziException_blockedIndefinitelyOnMVar_closure base_GHCziIOziException_blockedIndefinitelyOnSTM_closure - base_GHCziIOziException_stackOverflow_closure + base_GHCziIOziException_allocationLimitExceeded_closure + base_GHCziIOziException_stackOverflow_closure base_ControlziExceptionziBase_nonTermination_closure base_ControlziExceptionziBase_nestedAtomically_closure diff --git a/rules/foreachLibrary.mk b/rules/foreachLibrary.mk index cdd54962db..254321e3b0 100644 --- a/rules/foreachLibrary.mk +++ b/rules/foreachLibrary.mk @@ -31,6 +31,7 @@ # - bin-package-db # - ghc-prim # - integer-gmp +# - integer-gmp2 # - integer-simple # - template-haskell @@ -41,6 +42,7 @@ $$(foreach hashline,libraries/bin-package-db#-#no-remote-repo#no-vcs \ libraries/base#-#no-remote-repo#no-vcs \ libraries/ghc-prim#-#no-remote-repo#no-vcs \ libraries/integer-gmp#-#no-remote-repo#no-vcs \ + libraries/integer-gmp2#-#no-remote-repo#no-vcs \ libraries/integer-simple#-#no-remote-repo#no-vcs \ libraries/template-haskell#-#no-remote-repo#no-vcs \ $$(shell grep '^libraries/' packages | sed 's/ */#/g'),\ diff --git a/testsuite/.gitignore b/testsuite/.gitignore index 3a5d81654a..a07a376b26 100644 --- a/testsuite/.gitignore +++ b/testsuite/.gitignore @@ -1098,6 +1098,7 @@ mk/ghcconfig*_inplace_bin_ghc-stage2.exe.mk /tests/patsyn/should_run/ex-prov-run /tests/patsyn/should_run/match /tests/patsyn/should_run/match-unboxed +/tests/patsyn/should_run/unboxed-wrapper /tests/perf/compiler/T1969.comp.stats /tests/perf/compiler/T3064.comp.stats /tests/perf/compiler/T3294.comp.stats diff --git a/testsuite/tests/cabal/Makefile b/testsuite/tests/cabal/Makefile index 062850f76f..1e4cd6970d 100644 --- a/testsuite/tests/cabal/Makefile +++ b/testsuite/tests/cabal/Makefile @@ -244,9 +244,9 @@ ghcpkg07: $(LOCAL_GHC_PKG07) init $(PKGCONF07) $(LOCAL_GHC_PKG07) register --force test.pkg 2>/dev/null $(LOCAL_GHC_PKG07) register --force test7a.pkg 2>/dev/null - $(LOCAL_GHC_PKG07) field testpkg7a reexported-modules + $(LOCAL_GHC_PKG07) field testpkg7a exposed-modules $(LOCAL_GHC_PKG07) register --force test7b.pkg 2>/dev/null - $(LOCAL_GHC_PKG07) field testpkg7b reexported-modules + $(LOCAL_GHC_PKG07) field testpkg7b exposed-modules recache_reexport: @rm -rf recache_reexport_db/package.cache diff --git a/testsuite/tests/cabal/ghcpkg07.stdout b/testsuite/tests/cabal/ghcpkg07.stdout index b76e795388..717a9971a1 100644 --- a/testsuite/tests/cabal/ghcpkg07.stdout +++ b/testsuite/tests/cabal/ghcpkg07.stdout @@ -1,9 +1,10 @@ Reading package info from "test.pkg" ... done. Reading package info from "test7a.pkg" ... done. -reexported-modules: testpkg-1.2.3.4-XXX:A as A - testpkg-1.2.3.4-XXX:A as A1 testpkg7a-1.0-XXX:E as E2 +exposed-modules: + E, A from testpkg-1.2.3.4-XXX:A, A1 from testpkg-1.2.3.4-XXX:A, + E2 from testpkg7a-1.0-XXX:E Reading package info from "test7b.pkg" ... done. -reexported-modules: testpkg-1.2.3.4-XXX:A as F1 - testpkg7a-1.0-XXX:A as F2 testpkg7a-1.0-XXX:A1 as F3 - testpkg7a-1.0-XXX:E as F4 testpkg7a-1.0-XXX:E as E - testpkg7a-1.0-XXX:E2 as E3 +exposed-modules: + F1 from testpkg-1.2.3.4-XXX:A, F2 from testpkg7a-1.0-XXX:A, + F3 from testpkg7a-1.0-XXX:A1, F4 from testpkg7a-1.0-XXX:E, + E from testpkg7a-1.0-XXX:E, E3 from testpkg7a-1.0-XXX:E2 diff --git a/testsuite/tests/cabal/test7a.pkg b/testsuite/tests/cabal/test7a.pkg index b94f76673e..7eaeea2a8a 100644 --- a/testsuite/tests/cabal/test7a.pkg +++ b/testsuite/tests/cabal/test7a.pkg @@ -12,8 +12,6 @@ description: A Test Package category: none author: simonmar@microsoft.com exposed: True -exposed-modules: E -reexported-modules: testpkg-1.2.3.4-XXX:A as A, testpkg-1.2.3.4-XXX:A as A1, - testpkg7a-1.0-XXX:E as E2 +exposed-modules: E, A from testpkg-1.2.3.4-XXX:A, A1 from testpkg-1.2.3.4-XXX:A, E2 from testpkg7a-1.0-XXX:E hs-libraries: testpkg7a-1.0 depends: testpkg-1.2.3.4-XXX diff --git a/testsuite/tests/cabal/test7b.pkg b/testsuite/tests/cabal/test7b.pkg index 8089bd4e7e..f0bc6871f0 100644 --- a/testsuite/tests/cabal/test7b.pkg +++ b/testsuite/tests/cabal/test7b.pkg @@ -12,8 +12,6 @@ description: A Test Package category: none author: simonmar@microsoft.com exposed: True -reexported-modules: testpkg-1.2.3.4-XXX:A as F1, testpkg7a-1.0-XXX:A as F2, - testpkg7a-1.0-XXX:A1 as F3, testpkg7a-1.0-XXX:E as F4, - testpkg7a-1.0-XXX:E as E, testpkg7a-1.0-XXX:E2 as E3 +exposed-modules: F1 from testpkg-1.2.3.4-XXX:A, F2 from testpkg7a-1.0-XXX:A, F3 from testpkg7a-1.0-XXX:A1, F4 from testpkg7a-1.0-XXX:E, E from testpkg7a-1.0-XXX:E, E3 from testpkg7a-1.0-XXX:E2 hs-libraries: testpkg7b-1.0 depends: testpkg-1.2.3.4-XXX, testpkg7a-1.0-XXX diff --git a/testsuite/tests/concurrent/should_run/all.T b/testsuite/tests/concurrent/should_run/all.T index 166c232766..e72bffea91 100644 --- a/testsuite/tests/concurrent/should_run/all.T +++ b/testsuite/tests/concurrent/should_run/all.T @@ -88,6 +88,17 @@ test('threadstatus-9333', [omit_ways(['threaded2'])], compile_and_run, ['']) test('T9379', normal, compile_and_run, ['']) +test('allocLimit1', exit_code(1), compile_and_run, ['']) +test('allocLimit2', normal, compile_and_run, ['']) + +# The non-threaded RTS on Windows doesn't handle throwing exceptions at I/O +# operations very well, and ends up duplicating the I/O, giving wrong results. +test('allocLimit3', [ when(opsys('mingw32'), only_ways(threaded_ways)), + exit_code(1) ], compile_and_run, ['']) + +test('allocLimit4', [ extra_run_opts('+RTS -xq300k -RTS') ], + compile_and_run, ['']) + # ----------------------------------------------------------------------------- # These tests we only do for a full run @@ -252,3 +263,4 @@ test('setnumcapabilities001', # omit ghci, which can't handle unboxed tuples: test('compareAndSwap', [omit_ways(['ghci','hpc']), reqlib('primitive')], compile_and_run, ['']) + diff --git a/testsuite/tests/concurrent/should_run/allocLimit1.hs b/testsuite/tests/concurrent/should_run/allocLimit1.hs new file mode 100644 index 0000000000..b1c8fa6035 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/allocLimit1.hs @@ -0,0 +1,9 @@ +module Main (main) where + +import GHC.Conc + +main = do + setAllocationCounter (10*1024) + enableAllocationLimit + print (length [1..]) + diff --git a/testsuite/tests/concurrent/should_run/allocLimit1.stderr b/testsuite/tests/concurrent/should_run/allocLimit1.stderr new file mode 100644 index 0000000000..2133e14ce1 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/allocLimit1.stderr @@ -0,0 +1 @@ +allocLimit1: allocation limit exceeded diff --git a/testsuite/tests/concurrent/should_run/allocLimit2.hs b/testsuite/tests/concurrent/should_run/allocLimit2.hs new file mode 100644 index 0000000000..4fd117b615 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/allocLimit2.hs @@ -0,0 +1,17 @@ +module Main (main) where + +import GHC.Conc +import Control.Concurrent +import Control.Exception +import System.Exit + +main = do + m <- newEmptyMVar + let action = do setAllocationCounter (10*1024) + enableAllocationLimit + print (length [1..]) + forkFinally action (putMVar m) + r <- takeMVar m + case r of + Left e | Just AllocationLimitExceeded <- fromException e -> return () + _ -> print r >> exitFailure diff --git a/testsuite/tests/concurrent/should_run/allocLimit3.hs b/testsuite/tests/concurrent/should_run/allocLimit3.hs new file mode 100644 index 0000000000..28881dc016 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/allocLimit3.hs @@ -0,0 +1,15 @@ +module Main (main) where + +import GHC.Conc +import Control.Concurrent +import Control.Exception + +main = do + setAllocationCounter (10*1024) + enableAllocationLimit + + -- alloc limit overflow while masked: should successfully print the + -- result, and then immediately raise the exception + r <- mask_ $ try $ print (length [1..100000]) + + print (r :: Either SomeException ()) diff --git a/testsuite/tests/concurrent/should_run/allocLimit3.stderr b/testsuite/tests/concurrent/should_run/allocLimit3.stderr new file mode 100644 index 0000000000..27ae0a9480 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/allocLimit3.stderr @@ -0,0 +1 @@ +allocLimit3: allocation limit exceeded diff --git a/testsuite/tests/concurrent/should_run/allocLimit3.stdout b/testsuite/tests/concurrent/should_run/allocLimit3.stdout new file mode 100644 index 0000000000..f7393e847d --- /dev/null +++ b/testsuite/tests/concurrent/should_run/allocLimit3.stdout @@ -0,0 +1 @@ +100000 diff --git a/testsuite/tests/concurrent/should_run/allocLimit4.hs b/testsuite/tests/concurrent/should_run/allocLimit4.hs new file mode 100644 index 0000000000..b589ffa4af --- /dev/null +++ b/testsuite/tests/concurrent/should_run/allocLimit4.hs @@ -0,0 +1,31 @@ +module Main (main) where + +import GHC.Conc +import Control.Concurrent +import Control.Exception +import System.Exit +import Control.Monad + +-- check that +RTS -xq is doing the right thing: the test requires +-- +RTS -xq300k + +main = do + m <- newEmptyMVar + let action = do + e <- try $ do + setAllocationCounter (10*1024) + enableAllocationLimit + print (length [1..]) + case e of + Left AllocationLimitExceeded{} -> do + c <- getAllocationCounter + when (c < 250*1024 || c > 350*1024) $ fail "wrong limit grace" + print (length [2..]) + Right _ -> + fail "didn't catch AllocationLimitExceeded" + + forkFinally action (putMVar m) + r <- takeMVar m + case r of + Left e | Just AllocationLimitExceeded <- fromException e -> return () + _ -> print r >> exitFailure diff --git a/testsuite/tests/ffi/should_run/all.T b/testsuite/tests/ffi/should_run/all.T index 6fe087884d..04996317f5 100644 --- a/testsuite/tests/ffi/should_run/all.T +++ b/testsuite/tests/ffi/should_run/all.T @@ -209,3 +209,7 @@ test('T8083', compile_and_run, ['T8083_c.c']) +test('ffi023', [ omit_ways(['ghci']), + extra_clean(['ffi023_c.o']), + extra_run_opts('1000 4') ], + compile_and_run, ['ffi023_c.c']) diff --git a/testsuite/tests/ffi/should_run/ffi023.hs b/testsuite/tests/ffi/should_run/ffi023.hs new file mode 100644 index 0000000000..96a6092301 --- /dev/null +++ b/testsuite/tests/ffi/should_run/ffi023.hs @@ -0,0 +1,23 @@ +-- Tests for a bug fixed in + +module Main where + +import System.Environment +import Control.Concurrent +import Control.Monad + +foreign import ccall safe "out" + out :: Int -> IO Int + +foreign export ccall "incall" incall :: Int -> IO Int + +incall :: Int -> IO Int +incall x = return $ x + 1 + +main = do + [n, m] <- fmap (fmap read) getArgs + ms <- replicateM m $ do + v <- newEmptyMVar + forkIO $ do mapM out [0..n]; putMVar v () + return v + mapM_ takeMVar ms diff --git a/testsuite/tests/ffi/should_run/ffi023_c.c b/testsuite/tests/ffi/should_run/ffi023_c.c new file mode 100644 index 0000000000..a8a5a15447 --- /dev/null +++ b/testsuite/tests/ffi/should_run/ffi023_c.c @@ -0,0 +1,9 @@ +#include "ffi023_stub.h" +#include "HsFFI.h" +#include "Rts.h" + +HsInt out (HsInt x) +{ + performMajorGC(); + return incall(x); +} diff --git a/testsuite/tests/ghc-api/show-srcspan/.gitignore b/testsuite/tests/ghc-api/show-srcspan/.gitignore new file mode 100644 index 0000000000..e135b85087 --- /dev/null +++ b/testsuite/tests/ghc-api/show-srcspan/.gitignore @@ -0,0 +1,5 @@ +showsrcspan +*.hi +*.o +*.run.* +*.normalised diff --git a/testsuite/tests/ghc-api/show-srcspan/Makefile b/testsuite/tests/ghc-api/show-srcspan/Makefile new file mode 100644 index 0000000000..e467b61d75 --- /dev/null +++ b/testsuite/tests/ghc-api/show-srcspan/Makefile @@ -0,0 +1,13 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + +clean: + rm -f *.o *.hi + +showsrcspan: clean + '$(TEST_HC)' $(TEST_HC_OPTS) --make -v0 -package ghc showsrcspan + ./showsrcspan "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" + + +.PHONY: clean diff --git a/testsuite/tests/ghc-api/show-srcspan/all.T b/testsuite/tests/ghc-api/show-srcspan/all.T new file mode 100644 index 0000000000..fbb8d04cde --- /dev/null +++ b/testsuite/tests/ghc-api/show-srcspan/all.T @@ -0,0 +1 @@ +test('showsrcspan', normal, run_command, ['$MAKE -s --no-print-directory showsrcspan'])
\ No newline at end of file diff --git a/testsuite/tests/ghc-api/show-srcspan/showsrcspan.hs b/testsuite/tests/ghc-api/show-srcspan/showsrcspan.hs new file mode 100644 index 0000000000..bf73b59f18 --- /dev/null +++ b/testsuite/tests/ghc-api/show-srcspan/showsrcspan.hs @@ -0,0 +1,33 @@ +module Main where + +import Data.Data +import System.IO +import GHC +import FastString +import SrcLoc +import MonadUtils +import Outputable +import Bag (filterBag,isEmptyBag) +import System.Directory (removeFile) +import System.Environment( getArgs ) + +main::IO() +main = do + let + loc1 = mkSrcLoc (mkFastString "filename") 1 3 + loc2 = mkSrcLoc (mkFastString "filename") 1 5 + loc3 = mkSrcLoc (mkFastString "filename") 10 1 + badLoc = mkGeneralSrcLoc (mkFastString "bad loc") + + pointSpan = mkSrcSpan loc1 loc1 + lineSpan = mkSrcSpan loc1 loc2 + multiSpan = mkSrcSpan loc2 loc3 + badSpan = mkGeneralSrcSpan (mkFastString "bad span") + + print $ show loc1 + print $ show loc2 + print $ show badLoc + print $ show pointSpan + print $ show lineSpan + print $ show multiSpan + print $ show badSpan diff --git a/testsuite/tests/ghc-api/show-srcspan/showsrcspan.stdout b/testsuite/tests/ghc-api/show-srcspan/showsrcspan.stdout new file mode 100644 index 0000000000..f89656598a --- /dev/null +++ b/testsuite/tests/ghc-api/show-srcspan/showsrcspan.stdout @@ -0,0 +1,7 @@ +"RealSrcLoc SrcLoc \"filename\" 1 3" +"RealSrcLoc SrcLoc \"filename\" 1 5" +"UnhelpfulLoc \"bad loc\"" +"RealSrcSpan SrcSpanPoint \"filename\" 1 3" +"RealSrcSpan SrcSpanOneLine \"filename\" 1 3 5" +"RealSrcSpan SrcSpanMultiLine \"filename\" 1 5 10 1" +"UnhelpfulSpan \"bad span\"" diff --git a/testsuite/tests/ghci/scripts/T5979.stderr b/testsuite/tests/ghci/scripts/T5979.stderr index c8fc7c2208..9be85736e6 100644 --- a/testsuite/tests/ghci/scripts/T5979.stderr +++ b/testsuite/tests/ghci/scripts/T5979.stderr @@ -2,6 +2,6 @@ <no location info>: Could not find module ‘Control.Monad.Trans.State’ Perhaps you meant - Control.Monad.Trans.State (from transformers-0.4.1.0@trans_<HASH>) - Control.Monad.Trans.Class (from transformers-0.4.1.0@trans_<HASH>) - Control.Monad.Trans.Cont (from transformers-0.4.1.0@trans_<HASH>) + Control.Monad.Trans.State (from transformers-0.4.2.0@trans_<HASH>) + Control.Monad.Trans.Class (from transformers-0.4.2.0@trans_<HASH>) + Control.Monad.Trans.Cont (from transformers-0.4.2.0@trans_<HASH>) diff --git a/testsuite/tests/ghci/scripts/ghci025.stdout b/testsuite/tests/ghci/scripts/ghci025.stdout index e5654b3734..532a3347cc 100644 --- a/testsuite/tests/ghci/scripts/ghci025.stdout +++ b/testsuite/tests/ghci/scripts/ghci025.stdout @@ -56,9 +56,9 @@ Prelude.length :: Data.Foldable.Foldable t => forall a. t a -> GHC.Types.Int -- imported via T data T.Integer - = integer-gmp-0.5.1.0:GHC.Integer.Type.S# GHC.Prim.Int# - | integer-gmp-0.5.1.0:GHC.Integer.Type.J# GHC.Prim.Int# - GHC.Prim.ByteArray# + = integer-gmp-1.0.0.0:GHC.Integer.Type.S# !GHC.Prim.Int# + | integer-gmp-1.0.0.0:GHC.Integer.Type.Jp# {-# UNPACK #-}integer-gmp-1.0.0.0:GHC.Integer.Type.BigNat + | integer-gmp-1.0.0.0:GHC.Integer.Type.Jn# {-# UNPACK #-}integer-gmp-1.0.0.0:GHC.Integer.Type.BigNat T.length :: Data.ByteString.Internal.ByteString -> GHC.Types.Int :browse! T -- defined locally diff --git a/testsuite/tests/ghci/scripts/ghci046.script b/testsuite/tests/ghci/scripts/ghci046.script index f07e06f330..28c5cde050 100644 --- a/testsuite/tests/ghci/scripts/ghci046.script +++ b/testsuite/tests/ghci/scripts/ghci046.script @@ -12,8 +12,8 @@ type instance OR HTrue HTrue = HTrue type instance OR HTrue HFalse = HTrue type instance OR HFalse HTrue = HTrue type instance OR HFalse HFalse = HFalse -:t undefined :: AND HTrue HTrue -:t undefined :: AND (OR HFalse HTrue) (OR HTrue HFalse) +:kind! AND HTrue HTrue +:kind! AND (OR HFalse HTrue) (OR HTrue HFalse) let t = undefined :: AND HTrue HTrue let f = undefined :: AND HTrue HFalse type instance AND HTrue HTrue = HFalse diff --git a/testsuite/tests/ghci/scripts/ghci046.stdout b/testsuite/tests/ghci/scripts/ghci046.stdout index d600596b71..c4e7cf3fc7 100644 --- a/testsuite/tests/ghci/scripts/ghci046.stdout +++ b/testsuite/tests/ghci/scripts/ghci046.stdout @@ -1,4 +1,6 @@ -undefined :: AND HTrue HTrue :: HTrue -undefined :: AND (OR HFalse HTrue) (OR HTrue HFalse) :: HTrue +AND HTrue HTrue :: * += HTrue +AND (OR HFalse HTrue) (OR HTrue HFalse) :: * += HTrue t :: HTrue t :: HFalse diff --git a/testsuite/tests/ghci/scripts/ghci059.stdout b/testsuite/tests/ghci/scripts/ghci059.stdout index ffc893f363..6b2c8f886e 100644 --- a/testsuite/tests/ghci/scripts/ghci059.stdout +++ b/testsuite/tests/ghci/scripts/ghci059.stdout @@ -1,6 +1,4 @@ type role Coercible representational representational class Coercible (a :: k) (b :: k) -- Defined in ‘GHC.Types’ -coerce :: - forall (k :: BOX) (a :: k) (b :: k). Coercible a b => a -> b - -- Defined in ‘GHC.Prim’ +coerce :: Coercible a b => a -> b -- Defined in ‘GHC.Prim’ diff --git a/testsuite/tests/indexed-types/should_compile/T9662.hs b/testsuite/tests/indexed-types/should_compile/T9662.hs new file mode 100644 index 0000000000..2972eca22f --- /dev/null +++ b/testsuite/tests/indexed-types/should_compile/T9662.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleContexts #-} + +module T9662 where + +data Exp a = Exp +data (a:.b) = a:.b + +type family Plain e :: * +type instance Plain (Exp a) = a +type instance Plain (a:.b) = Plain a :. Plain b + +class (Plain (Unlifted pattern) ~ Tuple pattern) => Unlift pattern where + type Unlifted pattern + type Tuple pattern + +modify :: (Unlift pattern) => + pattern -> + (Unlifted pattern -> a) -> + Exp (Tuple pattern) -> Exp (Plain a) +modify p f = undefined + + +data Atom a = Atom + +atom :: Atom a +atom = Atom + + +instance (Unlift pa, int ~ Atom Int) => Unlift (pa :. int) where + type Unlifted (pa :. int) = Unlifted pa :. Exp Int + type Tuple (pa :. int) = Tuple pa :. Int + + +data Shape sh = Shape + +backpermute :: + (Exp sh -> Exp sh') -> + (Exp sh' -> Exp sh) -> + Shape sh -> Shape sh' +backpermute = undefined + +test :: Shape (sh:.k:.m:.n) -> Shape (sh:.m:.n:.k) +test = + backpermute + (modify (atom:.atom:.atom:.atom) + (\(sh:.k:.m:.n) -> (sh:.m:.n:.k))) + id + +-- With this arg instead of just 'id', it worked +-- (modify (atom:.atom:.atom:.atom) +-- (\(ix:.m:.n:.k) -> (ix:.k:.m:.n))) diff --git a/testsuite/tests/indexed-types/should_fail/ClosedFam3.stderr b/testsuite/tests/indexed-types/should_fail/ClosedFam3.stderr index 04435ba962..3b9539e19e 100644 --- a/testsuite/tests/indexed-types/should_fail/ClosedFam3.stderr +++ b/testsuite/tests/indexed-types/should_fail/ClosedFam3.stderr @@ -25,3 +25,4 @@ ClosedFam3.hs-boot:12:1: Baz Int = Bool Boot file: type family Baz (a :: k) :: * where Baz * Int = Bool + The types have different kinds diff --git a/testsuite/tests/indexed-types/should_fail/T7862.hs b/testsuite/tests/indexed-types/should_fail/T7862.hs new file mode 100644 index 0000000000..98b99ab632 --- /dev/null +++ b/testsuite/tests/indexed-types/should_fail/T7862.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE TypeFamilies, FlexibleContexts #-} + +module T7862 where + +type family Scalar t + +newtype Tower s a = Tower [a] + +type instance Scalar (Tower s a) = a + +class (Num (Scalar t), Num t) => Mode t where + (<+>) :: t -> t -> t + +instance (Num a) => Mode (Tower s a) where + Tower as <+> _ = undefined + where + _ = (Tower as) <+> (Tower as) + +instance Num a => Num (Tower s a) where diff --git a/testsuite/tests/indexed-types/should_fail/T7862.stderr b/testsuite/tests/indexed-types/should_fail/T7862.stderr new file mode 100644 index 0000000000..c2583d8e91 --- /dev/null +++ b/testsuite/tests/indexed-types/should_fail/T7862.stderr @@ -0,0 +1,17 @@ + +T7862.hs:17:24: + Overlapping instances for Num (Tower s0 a) + arising from a use of ‘<+>’ + Matching givens (or their superclasses): + (Num (Tower s a)) + bound by the instance declaration at T7862.hs:14:10-36 + Matching instances: + instance Num a => Num (Tower s a) -- Defined at T7862.hs:19:10 + (The choice depends on the instantiation of ‘a, s0’) + In the expression: (Tower as) <+> (Tower as) + In a pattern binding: _ = (Tower as) <+> (Tower as) + In an equation for ‘<+>’: + (Tower as) <+> _ + = undefined + where + _ = (Tower as) <+> (Tower as) diff --git a/testsuite/tests/indexed-types/should_fail/T9662.hs b/testsuite/tests/indexed-types/should_fail/T9662.hs new file mode 100644 index 0000000000..2972eca22f --- /dev/null +++ b/testsuite/tests/indexed-types/should_fail/T9662.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleContexts #-} + +module T9662 where + +data Exp a = Exp +data (a:.b) = a:.b + +type family Plain e :: * +type instance Plain (Exp a) = a +type instance Plain (a:.b) = Plain a :. Plain b + +class (Plain (Unlifted pattern) ~ Tuple pattern) => Unlift pattern where + type Unlifted pattern + type Tuple pattern + +modify :: (Unlift pattern) => + pattern -> + (Unlifted pattern -> a) -> + Exp (Tuple pattern) -> Exp (Plain a) +modify p f = undefined + + +data Atom a = Atom + +atom :: Atom a +atom = Atom + + +instance (Unlift pa, int ~ Atom Int) => Unlift (pa :. int) where + type Unlifted (pa :. int) = Unlifted pa :. Exp Int + type Tuple (pa :. int) = Tuple pa :. Int + + +data Shape sh = Shape + +backpermute :: + (Exp sh -> Exp sh') -> + (Exp sh' -> Exp sh) -> + Shape sh -> Shape sh' +backpermute = undefined + +test :: Shape (sh:.k:.m:.n) -> Shape (sh:.m:.n:.k) +test = + backpermute + (modify (atom:.atom:.atom:.atom) + (\(sh:.k:.m:.n) -> (sh:.m:.n:.k))) + id + +-- With this arg instead of just 'id', it worked +-- (modify (atom:.atom:.atom:.atom) +-- (\(ix:.m:.n:.k) -> (ix:.k:.m:.n))) diff --git a/testsuite/tests/indexed-types/should_fail/T9662.stderr b/testsuite/tests/indexed-types/should_fail/T9662.stderr new file mode 100644 index 0000000000..984a2ea4b7 --- /dev/null +++ b/testsuite/tests/indexed-types/should_fail/T9662.stderr @@ -0,0 +1,84 @@ + +T9662.hs:47:8: + Couldn't match type ‘k’ with ‘Int’ + ‘k’ is a rigid type variable bound by + the type signature for + test :: Shape (((sh :. k) :. m) :. n) + -> Shape (((sh :. m) :. n) :. k) + at T9662.hs:44:9 + Expected type: Exp (((sh :. k) :. m) :. n) + -> Exp (((sh :. m) :. n) :. k) + Actual type: Exp + (Tuple (((Atom a0 :. Atom Int) :. Atom Int) :. Atom Int)) + -> Exp + (Plain (((Unlifted (Atom a0) :. Exp Int) :. Exp Int) :. Exp Int)) + Relevant bindings include + test :: Shape (((sh :. k) :. m) :. n) + -> Shape (((sh :. m) :. n) :. k) + (bound at T9662.hs:45:1) + In the first argument of ‘backpermute’, namely + ‘(modify + (atom :. atom :. atom :. atom) + (\ (sh :. k :. m :. n) -> (sh :. m :. n :. k)))’ + In the expression: + backpermute + (modify + (atom :. atom :. atom :. atom) + (\ (sh :. k :. m :. n) -> (sh :. m :. n :. k))) + id + +T9662.hs:47:8: + Couldn't match type ‘m’ with ‘Int’ + ‘m’ is a rigid type variable bound by + the type signature for + test :: Shape (((sh :. k) :. m) :. n) + -> Shape (((sh :. m) :. n) :. k) + at T9662.hs:44:9 + Expected type: Exp (((sh :. k) :. m) :. n) + -> Exp (((sh :. m) :. n) :. k) + Actual type: Exp + (Tuple (((Atom a0 :. Atom Int) :. Atom Int) :. Atom Int)) + -> Exp + (Plain (((Unlifted (Atom a0) :. Exp Int) :. Exp Int) :. Exp Int)) + Relevant bindings include + test :: Shape (((sh :. k) :. m) :. n) + -> Shape (((sh :. m) :. n) :. k) + (bound at T9662.hs:45:1) + In the first argument of ‘backpermute’, namely + ‘(modify + (atom :. atom :. atom :. atom) + (\ (sh :. k :. m :. n) -> (sh :. m :. n :. k)))’ + In the expression: + backpermute + (modify + (atom :. atom :. atom :. atom) + (\ (sh :. k :. m :. n) -> (sh :. m :. n :. k))) + id + +T9662.hs:47:8: + Couldn't match type ‘n’ with ‘Int’ + ‘n’ is a rigid type variable bound by + the type signature for + test :: Shape (((sh :. k) :. m) :. n) + -> Shape (((sh :. m) :. n) :. k) + at T9662.hs:44:9 + Expected type: Exp (((sh :. k) :. m) :. n) + -> Exp (((sh :. m) :. n) :. k) + Actual type: Exp + (Tuple (((Atom a0 :. Atom Int) :. Atom Int) :. Atom Int)) + -> Exp + (Plain (((Unlifted (Atom a0) :. Exp Int) :. Exp Int) :. Exp Int)) + Relevant bindings include + test :: Shape (((sh :. k) :. m) :. n) + -> Shape (((sh :. m) :. n) :. k) + (bound at T9662.hs:45:1) + In the first argument of ‘backpermute’, namely + ‘(modify + (atom :. atom :. atom :. atom) + (\ (sh :. k :. m :. n) -> (sh :. m :. n :. k)))’ + In the expression: + backpermute + (modify + (atom :. atom :. atom :. atom) + (\ (sh :. k :. m :. n) -> (sh :. m :. n :. k))) + id diff --git a/testsuite/tests/indexed-types/should_fail/all.T b/testsuite/tests/indexed-types/should_fail/all.T index f06060efd0..286360a57f 100644 --- a/testsuite/tests/indexed-types/should_fail/all.T +++ b/testsuite/tests/indexed-types/should_fail/all.T @@ -129,4 +129,5 @@ test('T9371', normal, compile_fail, ['']) test('T9433', normal, compile_fail, ['']) test('BadSock', normal, compile_fail, ['']) test('T9580', normal, multimod_compile_fail, ['T9580', '']) - +test('T9662', normal, compile_fail, ['']) +test('T7862', normal, compile_fail, ['']) diff --git a/testsuite/tests/lib/integer/all.T b/testsuite/tests/lib/integer/all.T index 7b5e5f2dbe..55154265fc 100644 --- a/testsuite/tests/lib/integer/all.T +++ b/testsuite/tests/lib/integer/all.T @@ -1,7 +1,8 @@ test('integerBits', normal, compile_and_run, ['']) test('integerConversions', normal, compile_and_run, ['']) +## 'integerGmpInternals' disabled till the extra primitives are re-implemented # skip ghci as it doesn't support unboxed tuples -test('integerGmpInternals', [reqlib('integer-gmp'), omit_ways('ghci')], compile_and_run, ['']) +# test('integerGmpInternals', [reqlib('integer-gmp'), omit_ways('ghci')], compile_and_run, ['']) test('integerConstantFolding', [ extra_clean(['integerConstantFolding.simpl']) , when(compiler_debugged(), expect_broken(8525))], diff --git a/testsuite/tests/llvm/should_compile/all.T b/testsuite/tests/llvm/should_compile/all.T index e9154196f0..b630645f1e 100644 --- a/testsuite/tests/llvm/should_compile/all.T +++ b/testsuite/tests/llvm/should_compile/all.T @@ -7,7 +7,7 @@ setTestOpts(f) test('T5054', reqlib('hmatrix'), compile, ['-package hmatrix']) test('T5054_2', reqlib('hmatrix'), compile, ['-package hmatrix']) -test('T5486', reqlib('integer-gmp'), compile, ['']) +# test('T5486', reqlib('integer-gmp'), compile, ['']) test('T5681', normal, compile, ['']) test('T6158', [reqlib('vector'), reqlib('primitive')], compile, ['-package vector -package primitive']) test('T7571', cmm_src, compile, ['']) diff --git a/testsuite/tests/patsyn/should_compile/T9732.hs b/testsuite/tests/patsyn/should_compile/T9732.hs new file mode 100644 index 0000000000..7fd0515fcf --- /dev/null +++ b/testsuite/tests/patsyn/should_compile/T9732.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE PatternSynonyms, MagicHash #-} +module ShouldCompile where + +pattern P = 0# diff --git a/testsuite/tests/patsyn/should_compile/all.T b/testsuite/tests/patsyn/should_compile/all.T index d851bc3ac8..55e3b83302 100644 --- a/testsuite/tests/patsyn/should_compile/all.T +++ b/testsuite/tests/patsyn/should_compile/all.T @@ -10,3 +10,5 @@ test('incomplete', normal, compile, ['']) test('export', normal, compile, ['']) test('T8966', normal, compile, ['']) test('T9023', normal, compile, ['']) +test('unboxed-bind-bang', normal, compile, ['']) +test('T9732', normal, compile, ['']) diff --git a/testsuite/tests/patsyn/should_compile/unboxed-bind-bang.hs b/testsuite/tests/patsyn/should_compile/unboxed-bind-bang.hs new file mode 100644 index 0000000000..a972b21548 --- /dev/null +++ b/testsuite/tests/patsyn/should_compile/unboxed-bind-bang.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE PatternSynonyms, MagicHash, BangPatterns #-} +module ShouldCompile where + +import GHC.Base + +data Foo = MkFoo Int# Int# + +pattern P x = MkFoo 0# x + +f x = let !(P arg) = x in arg diff --git a/testsuite/tests/patsyn/should_fail/all.T b/testsuite/tests/patsyn/should_fail/all.T index ea671dcc58..b38776e9c3 100644 --- a/testsuite/tests/patsyn/should_fail/all.T +++ b/testsuite/tests/patsyn/should_fail/all.T @@ -1,4 +1,3 @@ - test('mono', normal, compile_fail, ['']) test('unidir', normal, compile_fail, ['']) test('local', normal, compile_fail, ['']) @@ -8,3 +7,5 @@ test('T9161-1', normal, compile_fail, ['']) test('T9161-2', normal, compile_fail, ['']) test('T9705-1', normal, compile_fail, ['']) test('T9705-2', normal, compile_fail, ['']) +test('unboxed-bind', normal, compile_fail, ['']) +test('unboxed-wrapper-naked', normal, compile_fail, ['']) diff --git a/testsuite/tests/patsyn/should_fail/unboxed-bind.hs b/testsuite/tests/patsyn/should_fail/unboxed-bind.hs new file mode 100644 index 0000000000..ef1b070d49 --- /dev/null +++ b/testsuite/tests/patsyn/should_fail/unboxed-bind.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE PatternSynonyms, MagicHash #-} +module ShouldFail where + +import GHC.Base + +data Foo = MkFoo Int# Int# + +pattern P x = MkFoo 0# x + +f x = let P arg = x in arg diff --git a/testsuite/tests/patsyn/should_fail/unboxed-bind.stderr b/testsuite/tests/patsyn/should_fail/unboxed-bind.stderr new file mode 100644 index 0000000000..17ca7afd3b --- /dev/null +++ b/testsuite/tests/patsyn/should_fail/unboxed-bind.stderr @@ -0,0 +1,6 @@ + +unboxed-bind.hs:10:11: + Pattern bindings containing unlifted types should use an outermost bang pattern: + P arg = x + In the expression: let P arg = x in arg + In an equation for ‘f’: f x = let P arg = x in arg diff --git a/testsuite/tests/patsyn/should_fail/unboxed-wrapper-naked.hs b/testsuite/tests/patsyn/should_fail/unboxed-wrapper-naked.hs new file mode 100644 index 0000000000..6e7cc94391 --- /dev/null +++ b/testsuite/tests/patsyn/should_fail/unboxed-wrapper-naked.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE PatternSynonyms, MagicHash #-} +module ShouldFail where + +import GHC.Base + +pattern P1 = 42# + +x = P1 diff --git a/testsuite/tests/patsyn/should_fail/unboxed-wrapper-naked.stderr b/testsuite/tests/patsyn/should_fail/unboxed-wrapper-naked.stderr new file mode 100644 index 0000000000..e8d89500a8 --- /dev/null +++ b/testsuite/tests/patsyn/should_fail/unboxed-wrapper-naked.stderr @@ -0,0 +1,3 @@ + +unboxed-wrapper-naked.hs:8:1: + Top-level bindings for unlifted types aren't allowed: x = P1 diff --git a/testsuite/tests/patsyn/should_run/all.T b/testsuite/tests/patsyn/should_run/all.T index 9c3f16b0ea..40ec3e3b4e 100644 --- a/testsuite/tests/patsyn/should_run/all.T +++ b/testsuite/tests/patsyn/should_run/all.T @@ -4,3 +4,5 @@ test('ex-prov-run', normal, compile_and_run, ['']) test('bidir-explicit', normal, compile_and_run, ['']) test('bidir-explicit-scope', normal, compile_and_run, ['']) test('T9783', normal, compile_and_run, ['']) +test('match-unboxed', normal, compile_and_run, ['']) +test('unboxed-wrapper', normal, compile_and_run, ['']) diff --git a/testsuite/tests/patsyn/should_run/match-unboxed.hs b/testsuite/tests/patsyn/should_run/match-unboxed.hs new file mode 100644 index 0000000000..ec6de0cd70 --- /dev/null +++ b/testsuite/tests/patsyn/should_run/match-unboxed.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE PatternSynonyms, MagicHash #-} +module Main where + +import GHC.Base + +pattern P1 <- 0# +pattern P2 <- 1# + +f :: Int# -> Int# +f P1 = 42# +f P2 = 44# + +g :: Int# -> Int +g P1 = 42 +g P2 = 44 + +main = do + print $ I# (f 0#) + print $ I# (f 1#) + print $ g 0# + print $ g 1# diff --git a/testsuite/tests/patsyn/should_run/match-unboxed.stdout b/testsuite/tests/patsyn/should_run/match-unboxed.stdout new file mode 100644 index 0000000000..da4a47e1f3 --- /dev/null +++ b/testsuite/tests/patsyn/should_run/match-unboxed.stdout @@ -0,0 +1,4 @@ +42 +44 +42 +44 diff --git a/testsuite/tests/patsyn/should_run/unboxed-wrapper.hs b/testsuite/tests/patsyn/should_run/unboxed-wrapper.hs new file mode 100644 index 0000000000..367c8ccebd --- /dev/null +++ b/testsuite/tests/patsyn/should_run/unboxed-wrapper.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE PatternSynonyms, MagicHash #-} +module Main where + +import GHC.Base + +pattern P1 = 42# + +main = do + print $ I# P1 diff --git a/testsuite/tests/patsyn/should_run/unboxed-wrapper.stdout b/testsuite/tests/patsyn/should_run/unboxed-wrapper.stdout new file mode 100644 index 0000000000..d81cc0710e --- /dev/null +++ b/testsuite/tests/patsyn/should_run/unboxed-wrapper.stdout @@ -0,0 +1 @@ +42 diff --git a/testsuite/tests/perf/compiler/all.T b/testsuite/tests/perf/compiler/all.T index f6f52d737d..92d1326e93 100644 --- a/testsuite/tests/perf/compiler/all.T +++ b/testsuite/tests/perf/compiler/all.T @@ -167,22 +167,24 @@ test('T3294', test('T4801', [ # expect_broken(5224), # temporarily unbroken (#5227) - compiler_stats_num_field('peak_megabytes_allocated',# Note [residency] - [(platform('x86_64-apple-darwin'), 70, 1), - # expected value: 58 (amd64/OS X) - # 13/01/2014 - 70 - (wordsize(32), 30, 20), - (wordsize(64), 48, 20)]), - # prev: 50 (amd64/Linux) - # 19/10/2012: 64 (amd64/Linux) - # (^ REASON UNKNOWN!) - # 12/11/2012: 49 (amd64/Linux) - # (^ REASON UNKNOWN!) - # 28/8/13: 60 (amd64/Linux) - # (^ REASON UNKNOWN!) - # 2014-09-10: 55 post-AMP-cleanup - # 2014-10-08: 62 (jumps between 55 and 71 observed -- GC tipping point?) - # 2014-10-13: 48 stricter seqDmdType +################################### +# deactivated for now, as this metric became too volatile recently +# compiler_stats_num_field('peak_megabytes_allocated',# Note [residency] +# [(platform('x86_64-apple-darwin'), 70, 1), +# # expected value: 58 (amd64/OS X) +# # 13/01/2014 - 70 +# (wordsize(32), 30, 20), +# (wordsize(64), 48, 20)]), +# # prev: 50 (amd64/Linux) +# # 19/10/2012: 64 (amd64/Linux) +# # (^ REASON UNKNOWN!) +# # 12/11/2012: 49 (amd64/Linux) +# # (^ REASON UNKNOWN!) +# # 28/8/13: 60 (amd64/Linux) +# # (^ REASON UNKNOWN!) +# # 2014-09-10: 55 post-AMP-cleanup +# # 2014-10-08: 62 (jumps between 55 and 71 observed -- GC tipping point?) +# # 2014-10-13: 48 stricter seqDmdType compiler_stats_num_field('bytes allocated', [(platform('x86_64-apple-darwin'), 464872776, 5), @@ -200,7 +202,7 @@ test('T4801', # 2014-10-08: 382056344 (amd64/Linux) stricter foldr2 488e95b ################################### -# deactivated for now, as this metric became to volatile recently +# deactivated for now, as this metric became too volatile recently # # compiler_stats_num_field('max_bytes_used', # [(platform('x86_64-apple-darwin'), 25145320, 5), diff --git a/testsuite/tests/perf/should_run/all.T b/testsuite/tests/perf/should_run/all.T index 749e8aefe6..d8af52bbef 100644 --- a/testsuite/tests/perf/should_run/all.T +++ b/testsuite/tests/perf/should_run/all.T @@ -169,8 +169,9 @@ test('T5549', [stats_num_field('bytes allocated', [(wordsize(32), 3362958676, 5), # expected value: 3362958676 (Windows) - (wordsize(64), 6725846120, 5)]), + (wordsize(64), 8193140752, 5)]), # expected value: 6725846120 (amd64/Linux) + # 8193140752 (amd64/Linux) integer-gmp2 only_ways(['normal']) ], compile_and_run, diff --git a/testsuite/tests/perf/space_leaks/all.T b/testsuite/tests/perf/space_leaks/all.T index ac60c8fa58..af7eefccc5 100644 --- a/testsuite/tests/perf/space_leaks/all.T +++ b/testsuite/tests/perf/space_leaks/all.T @@ -4,7 +4,8 @@ test('space_leak_001', # Now it's: 3 (amd64/Linux) # 4 (x86/OS X) # 5 (x86/Linux) - [stats_num_field('peak_megabytes_allocated', (4, 1)), + [stats_num_field('peak_megabytes_allocated', (3, 1)), + # 3 (amd64/Linux, integer-gmp2) stats_num_field('max_bytes_used', [(wordsize(64), 440000, 15), # 440224 (amd64/Linux) @@ -14,11 +15,12 @@ test('space_leak_001', (wordsize(32), 405650, 10)]), # 2013-02-10 372072 (x86/OSX) # 2013-02-10 439228 (x86/OSX) - stats_num_field('bytes allocated', (9079316016, 1)), + stats_num_field('bytes allocated', (11315747416, 1)), # expected value: 9079316016 (amd64/Linux) # 9331570416 (x86/Linux) # 9329073952 (x86/OS X) # 9327959840 (x86/Windows) + # 11315747416 (amd64/Lnx, integer-gmp2) omit_ways(['profasm','profthreaded','threaded1','threaded2']) ], compile_and_run, diff --git a/testsuite/tests/rename/should_fail/T9077.hs b/testsuite/tests/rename/should_fail/T9077.hs new file mode 100644 index 0000000000..d30a5ca24c --- /dev/null +++ b/testsuite/tests/rename/should_fail/T9077.hs @@ -0,0 +1,4 @@ +module T9077 where + +main :: IO {} +main = print "hello" diff --git a/testsuite/tests/rename/should_fail/T9077.stderr b/testsuite/tests/rename/should_fail/T9077.stderr new file mode 100644 index 0000000000..a3a9d49ece --- /dev/null +++ b/testsuite/tests/rename/should_fail/T9077.stderr @@ -0,0 +1,2 @@ + +T9077.hs:3:12: Record syntax is illegal here: {} diff --git a/testsuite/tests/rename/should_fail/all.T b/testsuite/tests/rename/should_fail/all.T index 72331e7a64..f2664dc2bf 100644 --- a/testsuite/tests/rename/should_fail/all.T +++ b/testsuite/tests/rename/should_fail/all.T @@ -118,3 +118,4 @@ test('T9156', normal, compile_fail, ['']) test('T9177', normal, compile_fail, ['']) test('T9436', normal, compile_fail, ['']) test('T9437', normal, compile_fail, ['']) +test('T9077', normal, compile_fail, ['']) diff --git a/testsuite/tests/rename/should_fail/rnfail055.stderr b/testsuite/tests/rename/should_fail/rnfail055.stderr index c7b51a1d1f..1c002ac276 100644 --- a/testsuite/tests/rename/should_fail/rnfail055.stderr +++ b/testsuite/tests/rename/should_fail/rnfail055.stderr @@ -10,34 +10,38 @@ RnFail055.hs-boot:4:1: and its hs-boot file Main module: f1 :: Int -> Float Boot file: f1 :: Float -> Int + The two types are different RnFail055.hs-boot:6:1: Type constructor ‘S1’ has conflicting definitions in the module and its hs-boot file Main module: type S1 a b = (a, b) Boot file: type S1 a b c = (a, b) + The types have different kinds RnFail055.hs-boot:8:1: Type constructor ‘S2’ has conflicting definitions in the module and its hs-boot file Main module: type S2 a b = forall a1. (a1, b) Boot file: type S2 a b = forall b1. (a, b1) + The roles do not match. Roles default to ‘representational’ in boot files RnFail055.hs-boot:12:1: Type constructor ‘T1’ has conflicting definitions in the module and its hs-boot file Main module: data T1 a b = T1 [b] [a] Boot file: data T1 a b = T1 [a] [b] + The constructors do not match: The types for ‘T1’ differ RnFail055.hs-boot:14:1: Type constructor ‘T2’ has conflicting definitions in the module and its hs-boot file Main module: type role T2 representational nominal - data Eq b => T2 a b - = T2 a + data Eq b => T2 a b = T2 a Boot file: type role T2 nominal representational - data Eq a => T2 a b - = T2 a + data Eq a => T2 a b = T2 a + The roles do not match. Roles default to ‘representational’ in boot files + The datatype contexts do not match RnFail055.hs-boot:16:11: T3 is exported by the hs-boot file, but not exported by the module @@ -50,12 +54,16 @@ RnFail055.hs-boot:21:1: and its hs-boot file Main module: data T5 a = T5 {field5 :: a} Boot file: data T5 a = T5 a + The constructors do not match: + The record label lists for ‘T5’ differ RnFail055.hs-boot:23:1: Type constructor ‘T6’ has conflicting definitions in the module and its hs-boot file Main module: data T6 = T6 Int Boot file: data T6 = T6 !Int + The constructors do not match: + The strictness annotations for ‘T6’ differ RnFail055.hs-boot:25:1: Type constructor ‘T7’ has conflicting definitions in the module @@ -64,6 +72,8 @@ RnFail055.hs-boot:25:1: data T7 a where T7 :: a1 -> T7 a Boot file: data T7 a = T7 a + The roles do not match. Roles default to ‘representational’ in boot files + The constructors do not match: The types for ‘T7’ differ RnFail055.hs-boot:27:22: RnFail055.m1 is exported by the hs-boot file, but not exported by the module @@ -76,9 +86,11 @@ RnFail055.hs-boot:28:1: m2' :: a -> b Boot file: class C2 a b where m2 :: a -> b + The methods do not match: There are different numbers of methods RnFail055.hs-boot:29:1: Class ‘C3’ has conflicting definitions in the module and its hs-boot file Main module: class (Eq a, Ord a) => C3 a Boot file: class (Ord a, Eq a) => C3 a + The class constraints do not match diff --git a/testsuite/tests/roles/should_fail/Makefile b/testsuite/tests/roles/should_fail/Makefile index 8f80de39c3..14d6720060 100644 --- a/testsuite/tests/roles/should_fail/Makefile +++ b/testsuite/tests/roles/should_fail/Makefile @@ -7,3 +7,7 @@ include $(TOP)/mk/test.mk Roles12: '$(TEST_HC)' $(TEST_HC_OPTS) -c Roles12.hs-boot -'$(TEST_HC)' $(TEST_HC_OPTS) -c Roles12.hs + +T9204: + '$(TEST_HC)' $(TEST_HC_OPTS) -c T9204.hs-boot + -'$(TEST_HC)' $(TEST_HC_OPTS) -c T9204.hs diff --git a/testsuite/tests/roles/should_fail/Roles12.stderr b/testsuite/tests/roles/should_fail/Roles12.stderr index 9b0f2cfdb5..874ddca1d3 100644 --- a/testsuite/tests/roles/should_fail/Roles12.stderr +++ b/testsuite/tests/roles/should_fail/Roles12.stderr @@ -5,3 +5,4 @@ Roles12.hs:5:1: Main module: type role T phantom data T a Boot file: abstract T a + The roles do not match. Roles default to ‘representational’ in boot files diff --git a/testsuite/tests/roles/should_fail/T9204.hs b/testsuite/tests/roles/should_fail/T9204.hs new file mode 100644 index 0000000000..e2351a277f --- /dev/null +++ b/testsuite/tests/roles/should_fail/T9204.hs @@ -0,0 +1,6 @@ + +module T9204 where + +import {-# SOURCE #-} T9204 + +data D a diff --git a/testsuite/tests/roles/should_fail/T9204.hs-boot b/testsuite/tests/roles/should_fail/T9204.hs-boot new file mode 100644 index 0000000000..7ee0f1db3e --- /dev/null +++ b/testsuite/tests/roles/should_fail/T9204.hs-boot @@ -0,0 +1,4 @@ + +module T9204 where + +data D a diff --git a/testsuite/tests/roles/should_fail/T9204.stderr b/testsuite/tests/roles/should_fail/T9204.stderr new file mode 100644 index 0000000000..9936839284 --- /dev/null +++ b/testsuite/tests/roles/should_fail/T9204.stderr @@ -0,0 +1,8 @@ + +T9204.hs:6:1: + Type constructor ‘D’ has conflicting definitions in the module + and its hs-boot file + Main module: type role D phantom + data D a + Boot file: abstract D a + The roles do not match. Roles default to ‘representational’ in boot files diff --git a/testsuite/tests/roles/should_fail/all.T b/testsuite/tests/roles/should_fail/all.T index d0d5c4d17c..1c69b7c48c 100644 --- a/testsuite/tests/roles/should_fail/all.T +++ b/testsuite/tests/roles/should_fail/all.T @@ -7,4 +7,6 @@ test('Roles11', normal, compile_fail, ['']) test('Roles12', extra_clean(['Roles12.o-boot', 'Roles12.hi-boot']), run_command, ['$MAKE --no-print-directory -s Roles12']) -test('T8773', normal, compile_fail, [''])
\ No newline at end of file +test('T8773', normal, compile_fail, ['']) +test('T9204', extra_clean(['T9204.o-boot', 'T9204.hi-boot']), + run_command, ['$MAKE --no-print-directory -s T9204']) diff --git a/testsuite/tests/rts/linker_error.c b/testsuite/tests/rts/linker_error.c index 60d24a5aca..715eabd184 100644 --- a/testsuite/tests/rts/linker_error.c +++ b/testsuite/tests/rts/linker_error.c @@ -2,6 +2,9 @@ #include <stdio.h> #include <stdlib.h> #include "Rts.h" +#if defined(mingw32_HOST_OS) +#include <malloc.h> +#endif #define ITERATIONS 10 diff --git a/testsuite/tests/rts/linker_unload.c b/testsuite/tests/rts/linker_unload.c index 4980eeb47f..8d1984f117 100644 --- a/testsuite/tests/rts/linker_unload.c +++ b/testsuite/tests/rts/linker_unload.c @@ -2,6 +2,9 @@ #include <stdio.h> #include <stdlib.h> #include "Rts.h" +#if defined(mingw32_HOST_OS) +#include <malloc.h> +#endif #define ITERATIONS 10000 diff --git a/testsuite/tests/safeHaskell/check/Check09.stderr b/testsuite/tests/safeHaskell/check/Check09.stderr index 6954dd1f89..75803cf80d 100644 --- a/testsuite/tests/safeHaskell/check/Check09.stderr +++ b/testsuite/tests/safeHaskell/check/Check09.stderr @@ -5,4 +5,4 @@ Check09.hs:4:1: Check09.hs:5:1: Data.ByteString.Char8: Can't be safely imported! - The package (bytestring-0.10.4.0) the module resides in isn't trusted. + The package (bytestring-0.10.5.0) the module resides in isn't trusted. diff --git a/testsuite/tests/safeHaskell/check/pkg01/ImpSafe01.hs b/testsuite/tests/safeHaskell/check/pkg01/ImpSafe01.hs index deb0d57f8d..107881b2d8 100644 --- a/testsuite/tests/safeHaskell/check/pkg01/ImpSafe01.hs +++ b/testsuite/tests/safeHaskell/check/pkg01/ImpSafe01.hs @@ -1,6 +1,6 @@ {-# LANGUAGE Safe #-} {-# LANGUAGE NoImplicitPrelude #-} -module ImpSafe ( MyWord ) where +module ImpSafe01 ( MyWord ) where -- While Data.Word is safe it imports trustworthy -- modules in base, hence base needs to be trusted. diff --git a/testsuite/tests/safeHaskell/check/pkg01/ImpSafe02.hs b/testsuite/tests/safeHaskell/check/pkg01/ImpSafe02.hs index deb0d57f8d..c6ba0968d0 100644 --- a/testsuite/tests/safeHaskell/check/pkg01/ImpSafe02.hs +++ b/testsuite/tests/safeHaskell/check/pkg01/ImpSafe02.hs @@ -1,6 +1,6 @@ {-# LANGUAGE Safe #-} {-# LANGUAGE NoImplicitPrelude #-} -module ImpSafe ( MyWord ) where +module ImpSafe02 ( MyWord ) where -- While Data.Word is safe it imports trustworthy -- modules in base, hence base needs to be trusted. diff --git a/testsuite/tests/safeHaskell/check/pkg01/ImpSafe03.hs b/testsuite/tests/safeHaskell/check/pkg01/ImpSafe03.hs new file mode 100644 index 0000000000..485e9e238c --- /dev/null +++ b/testsuite/tests/safeHaskell/check/pkg01/ImpSafe03.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE Trustworthy #-} +module Main where + +import safe Prelude +import safe ImpSafe03_A + +main = putStrLn "test" + diff --git a/testsuite/tests/safeHaskell/check/pkg01/ImpSafe03.stderr b/testsuite/tests/safeHaskell/check/pkg01/ImpSafe03.stderr new file mode 100644 index 0000000000..0a012f7105 --- /dev/null +++ b/testsuite/tests/safeHaskell/check/pkg01/ImpSafe03.stderr @@ -0,0 +1,4 @@ +[2 of 2] Compiling Main ( ImpSafe03.hs, ImpSafe03.o ) + +<no location info>: + The package (bytestring-0.10.5.0) is required to be trusted but it isn't! diff --git a/testsuite/tests/safeHaskell/check/pkg01/ImpSafe03_A.hs b/testsuite/tests/safeHaskell/check/pkg01/ImpSafe03_A.hs new file mode 100644 index 0000000000..06f5d39754 --- /dev/null +++ b/testsuite/tests/safeHaskell/check/pkg01/ImpSafe03_A.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE Trustworthy #-} +module ImpSafe03_A where + +import safe Prelude +import safe qualified Data.ByteString.Char8 as BS + +s = BS.pack "Hello World" + diff --git a/testsuite/tests/safeHaskell/check/pkg01/ImpSafe04.hs b/testsuite/tests/safeHaskell/check/pkg01/ImpSafe04.hs new file mode 100644 index 0000000000..3a8882905f --- /dev/null +++ b/testsuite/tests/safeHaskell/check/pkg01/ImpSafe04.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE NoImplicitPrelude #-} +module ImpSafe04 ( MyWord ) where + +-- While Data.Word is safe it imports trustworthy +-- modules in base, hence base needs to be trusted. +-- Note: Worthwhile giving out better error messages for cases +-- like this if I can. +import safe Data.Word +import System.IO.Unsafe + +type MyWord = Word + diff --git a/testsuite/tests/safeHaskell/check/pkg01/ImpSafe04.stderr b/testsuite/tests/safeHaskell/check/pkg01/ImpSafe04.stderr new file mode 100644 index 0000000000..50a12e027b --- /dev/null +++ b/testsuite/tests/safeHaskell/check/pkg01/ImpSafe04.stderr @@ -0,0 +1,4 @@ + +ImpSafe04.hs:9:1: + Data.Word: Can't be safely imported! + The package (base-4.8.0.0) the module resides in isn't trusted. diff --git a/testsuite/tests/safeHaskell/check/pkg01/ImpSafeOnly07.stderr b/testsuite/tests/safeHaskell/check/pkg01/ImpSafeOnly07.stderr index 884f080866..3dd6759d2f 100644 --- a/testsuite/tests/safeHaskell/check/pkg01/ImpSafeOnly07.stderr +++ b/testsuite/tests/safeHaskell/check/pkg01/ImpSafeOnly07.stderr @@ -3,4 +3,4 @@ The package (base-4.8.0.0) is required to be trusted but it isn't! <no location info>: - The package (bytestring-0.10.4.0) is required to be trusted but it isn't! + The package (bytestring-0.10.5.0) is required to be trusted but it isn't! diff --git a/testsuite/tests/safeHaskell/check/pkg01/ImpSafeOnly08.stderr b/testsuite/tests/safeHaskell/check/pkg01/ImpSafeOnly08.stderr index 884f080866..3dd6759d2f 100644 --- a/testsuite/tests/safeHaskell/check/pkg01/ImpSafeOnly08.stderr +++ b/testsuite/tests/safeHaskell/check/pkg01/ImpSafeOnly08.stderr @@ -3,4 +3,4 @@ The package (base-4.8.0.0) is required to be trusted but it isn't! <no location info>: - The package (bytestring-0.10.4.0) is required to be trusted but it isn't! + The package (bytestring-0.10.5.0) is required to be trusted but it isn't! diff --git a/testsuite/tests/safeHaskell/check/pkg01/all.T b/testsuite/tests/safeHaskell/check/pkg01/all.T index 604a5cc777..e1ed80dd7c 100644 --- a/testsuite/tests/safeHaskell/check/pkg01/all.T +++ b/testsuite/tests/safeHaskell/check/pkg01/all.T @@ -40,6 +40,7 @@ test('safePkg01', normalise_errmsg_fun(ignoreLdOutput), normalise_fun( normaliseArrayPackage, + normaliseIntegerPackage, normaliseBytestringPackage)], run_command, ['$MAKE -s --no-print-directory safePkg01 ' + make_args]) @@ -50,6 +51,15 @@ test('ImpSafe01', normal, compile_fail, ['-fpackage-trust -distrust base']) # Succeed since we don't enable package trust test('ImpSafe02', normal, compile, ['-distrust base']) +# Fail since we don't trust base of bytestring +test('ImpSafe03', normal, multi_compile_fail, + ['ImpSafe03 -trust base -distrust bytestring', [ + ('ImpSafe03_A.hs', ' -trust base -trust bytestring') + ], '-fpackage-trust' ]) + +# Fail same as ImpSafe01 but testing with -XTrustworthy now +test('ImpSafe04', normal, compile_fail, ['-fpackage-trust -distrust base']) + test('ImpSafeOnly01', [pre_cmd('$MAKE -s --no-print-directory mkPackageDatabase.ImpSafeOnly01 ' + make_args), clean_cmd('$MAKE -s --no-print-directory cleanPackageDatabase.ImpSafeOnly01')], @@ -94,7 +104,7 @@ test('ImpSafeOnly07', clean_cmd('$MAKE -s --no-print-directory cleanPackageDatabase.ImpSafeOnly07'), normalise_errmsg_fun(normaliseBytestringPackage)], compile_fail, - ['-fpackage-trust -package-db pdb.ImpSafeOnly07/local.db -trust safePkg01']) + ['-fpackage-trust -package-db pdb.ImpSafeOnly07/local.db -trust safePkg01 -distrust bytestring']) test('ImpSafeOnly08', [pre_cmd('$MAKE -s --no-print-directory mkPackageDatabase.ImpSafeOnly08 ' + make_args), clean_cmd('$MAKE -s --no-print-directory cleanPackageDatabase.ImpSafeOnly08'), diff --git a/testsuite/tests/safeHaskell/check/pkg01/safePkg01.stdout b/testsuite/tests/safeHaskell/check/pkg01/safePkg01.stdout index 44ea89fec9..1567b60dda 100644 --- a/testsuite/tests/safeHaskell/check/pkg01/safePkg01.stdout +++ b/testsuite/tests/safeHaskell/check/pkg01/safePkg01.stdout @@ -29,17 +29,17 @@ trusted: safe require own pkg trusted: True M_SafePkg6 -package dependencies: array-0.5.0.1 base-4.8.0.0* bytestring-0.10.4.0* deepseq-1.3.0.3 ghc-prim-0.3.1.0 integer-gmp-0.5.1.0 +package dependencies: array-0.5.0.1 base-4.8.0.0* bytestring-0.10.5.0* deepseq-1.4.0.0 ghc-prim-0.3.1.0 integer-gmp-0.5.1.0 trusted: trustworthy require own pkg trusted: False M_SafePkg7 -package dependencies: array-0.5.0.1 base-4.8.0.0* bytestring-0.10.4.0* deepseq-1.3.0.3 ghc-prim-0.3.1.0 integer-gmp-0.5.1.0 +package dependencies: array-0.5.0.1 base-4.8.0.0* bytestring-0.10.5.0* deepseq-1.4.0.0 ghc-prim-0.3.1.0 integer-gmp-0.5.1.0 trusted: safe require own pkg trusted: False M_SafePkg8 -package dependencies: array-0.5.0.1 base-4.8.0.0 bytestring-0.10.4.0* deepseq-1.3.0.3 ghc-prim-0.3.1.0 integer-gmp-0.5.1.0 +package dependencies: array-0.5.0.1 base-4.8.0.0 bytestring-0.10.5.0* deepseq-1.4.0.0 ghc-prim-0.3.1.0 integer-gmp-0.5.1.0 trusted: trustworthy require own pkg trusted: False diff --git a/testsuite/tests/safeHaskell/safeInfered/SafeWarn01.hs b/testsuite/tests/safeHaskell/safeInfered/SafeWarn01.hs new file mode 100644 index 0000000000..507367929b --- /dev/null +++ b/testsuite/tests/safeHaskell/safeInfered/SafeWarn01.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE Unsafe #-} +{-# OPTIONS_GHC -fwarn-safe #-} +{-# OPTIONS_GHC -fwarn-unsafe #-} +{-# OPTIONS_GHC -fenable-rewrite-rules #-} + +-- | Trivial Safe Module +module SafeWarn01 where + +g :: Int +g = 1 + diff --git a/testsuite/tests/safeHaskell/safeInfered/SafeWarn01.stderr b/testsuite/tests/safeHaskell/safeInfered/SafeWarn01.stderr new file mode 100644 index 0000000000..e9849d9eef --- /dev/null +++ b/testsuite/tests/safeHaskell/safeInfered/SafeWarn01.stderr @@ -0,0 +1,3 @@ + +SafeWarn01.hs:2:16: Warning: + ‘SafeWarn01’ has been inferred as safe! diff --git a/testsuite/tests/safeHaskell/safeInfered/TrustworthySafe01.hs b/testsuite/tests/safeHaskell/safeInfered/TrustworthySafe01.hs new file mode 100644 index 0000000000..6d65130a84 --- /dev/null +++ b/testsuite/tests/safeHaskell/safeInfered/TrustworthySafe01.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE Trustworthy #-} + +-- | This module is marked trustworthy but should be inferable as -XSafe. +-- But no warning enabled. +module TrustworthySafe01 where + +g :: Int +g = 1 + diff --git a/testsuite/tests/safeHaskell/safeInfered/TrustworthySafe02.hs b/testsuite/tests/safeHaskell/safeInfered/TrustworthySafe02.hs new file mode 100644 index 0000000000..9dfaccd950 --- /dev/null +++ b/testsuite/tests/safeHaskell/safeInfered/TrustworthySafe02.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE Trustworthy #-} +{-# OPTIONS_GHC -fwarn-trustworthy-safe #-} + +-- | This module is marked trustworthy but should be inferable as -XSafe. +-- Warning enabled. +module TrustworthySafe02 where + +g :: Int +g = 1 + diff --git a/testsuite/tests/safeHaskell/safeInfered/TrustworthySafe02.stderr b/testsuite/tests/safeHaskell/safeInfered/TrustworthySafe02.stderr new file mode 100644 index 0000000000..68bf4e998e --- /dev/null +++ b/testsuite/tests/safeHaskell/safeInfered/TrustworthySafe02.stderr @@ -0,0 +1,3 @@ + +TrustworthySafe02.hs:1:14: Warning: + ‘TrustworthySafe02’ is marked as Trustworthy but has been inferred as safe! diff --git a/testsuite/tests/safeHaskell/safeInfered/TrustworthySafe03.hs b/testsuite/tests/safeHaskell/safeInfered/TrustworthySafe03.hs new file mode 100644 index 0000000000..ad63e090e1 --- /dev/null +++ b/testsuite/tests/safeHaskell/safeInfered/TrustworthySafe03.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE Trustworthy #-} +{-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_GHC -fwarn-trustworthy-safe #-} -- temp broken by 452d6aa95 + +-- | This module is marked trustworthy but should be inferable as -XSafe. +-- Warning enabled through `-W`. +module TrustworthySafe03 where + +g :: Int +g = 1 + diff --git a/testsuite/tests/safeHaskell/safeInfered/TrustworthySafe03.stderr b/testsuite/tests/safeHaskell/safeInfered/TrustworthySafe03.stderr new file mode 100644 index 0000000000..9505d06031 --- /dev/null +++ b/testsuite/tests/safeHaskell/safeInfered/TrustworthySafe03.stderr @@ -0,0 +1,3 @@ + +TrustworthySafe03.hs:1:14: Warning: + ‘TrustworthySafe03’ is marked as Trustworthy but has been inferred as safe! diff --git a/testsuite/tests/safeHaskell/safeInfered/TrustworthySafe04.hs b/testsuite/tests/safeHaskell/safeInfered/TrustworthySafe04.hs new file mode 100644 index 0000000000..0b96de1d2a --- /dev/null +++ b/testsuite/tests/safeHaskell/safeInfered/TrustworthySafe04.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE Trustworthy #-} +{-# OPTIONS_GHC -W -fno-warn-trustworthy-safe #-} + +-- | This module is marked trustworthy but should be inferable as -XSafe. +-- Warning enabled through `-W` but then disabled with `-fno-warn...`. +module TrustworthySafe04 where + +g :: Int +g = 1 + diff --git a/testsuite/tests/safeHaskell/safeInfered/UnsafeWarn01.hs b/testsuite/tests/safeHaskell/safeInfered/UnsafeWarn01.hs new file mode 100644 index 0000000000..afe188db4f --- /dev/null +++ b/testsuite/tests/safeHaskell/safeInfered/UnsafeWarn01.hs @@ -0,0 +1,11 @@ +{-# OPTIONS_GHC -fwarn-safe #-} +{-# OPTIONS_GHC -fwarn-unsafe #-} + +-- | Trivial Unsafe Module +module UnsafeWarn01 where + +import System.IO.Unsafe + +f :: IO a -> a +f = unsafePerformIO + diff --git a/testsuite/tests/safeHaskell/safeInfered/UnsafeWarn01.stderr b/testsuite/tests/safeHaskell/safeInfered/UnsafeWarn01.stderr new file mode 100644 index 0000000000..1ef043a9fd --- /dev/null +++ b/testsuite/tests/safeHaskell/safeInfered/UnsafeWarn01.stderr @@ -0,0 +1,7 @@ + +UnsafeWarn01.hs:2:16: Warning: + ‘UnsafeWarn01’ has been inferred as unsafe! + Reason: + UnsafeWarn01.hs:7:1: + System.IO.Unsafe: Can't be safely imported! + The module itself isn't safe. diff --git a/testsuite/tests/safeHaskell/safeInfered/UnsafeWarn02.hs b/testsuite/tests/safeHaskell/safeInfered/UnsafeWarn02.hs new file mode 100644 index 0000000000..6f62ca5c94 --- /dev/null +++ b/testsuite/tests/safeHaskell/safeInfered/UnsafeWarn02.hs @@ -0,0 +1,10 @@ +{-# OPTIONS_GHC -fwarn-safe #-} +{-# OPTIONS_GHC -fwarn-unsafe #-} + +{-# LANGUAGE TemplateHaskell #-} +-- | Unsafe as uses TH +module UnsafeWarn02 where + +f :: Int +f = 1 + diff --git a/testsuite/tests/safeHaskell/safeInfered/UnsafeWarn02.stderr b/testsuite/tests/safeHaskell/safeInfered/UnsafeWarn02.stderr new file mode 100644 index 0000000000..7421ad0333 --- /dev/null +++ b/testsuite/tests/safeHaskell/safeInfered/UnsafeWarn02.stderr @@ -0,0 +1,6 @@ + +UnsafeWarn02.hs:2:16: Warning: + ‘UnsafeWarn02’ has been inferred as unsafe! + Reason: + UnsafeWarn02.hs:4:14: + -XTemplateHaskell is not allowed in Safe Haskell diff --git a/testsuite/tests/safeHaskell/safeInfered/UnsafeWarn03.hs b/testsuite/tests/safeHaskell/safeInfered/UnsafeWarn03.hs new file mode 100644 index 0000000000..ded02de888 --- /dev/null +++ b/testsuite/tests/safeHaskell/safeInfered/UnsafeWarn03.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE Trustworthy #-} +{-# OPTIONS_GHC -fwarn-safe #-} +{-# OPTIONS_GHC -fwarn-unsafe #-} + +-- | Trivial Unsafe Module +module UnsafeWarn03 where + +import System.IO.Unsafe + +f :: IO a -> a +f = unsafePerformIO + diff --git a/testsuite/tests/safeHaskell/safeInfered/UnsafeWarn03.stderr b/testsuite/tests/safeHaskell/safeInfered/UnsafeWarn03.stderr new file mode 100644 index 0000000000..a3d44ba375 --- /dev/null +++ b/testsuite/tests/safeHaskell/safeInfered/UnsafeWarn03.stderr @@ -0,0 +1,7 @@ + +UnsafeWarn03.hs:3:16: Warning: + ‘UnsafeWarn03’ has been inferred as unsafe! + Reason: + UnsafeWarn03.hs:8:1: + System.IO.Unsafe: Can't be safely imported! + The module itself isn't safe. diff --git a/testsuite/tests/safeHaskell/safeInfered/UnsafeWarn04.hs b/testsuite/tests/safeHaskell/safeInfered/UnsafeWarn04.hs new file mode 100644 index 0000000000..d8e8b84fa5 --- /dev/null +++ b/testsuite/tests/safeHaskell/safeInfered/UnsafeWarn04.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE Trustworthy #-} +{-# OPTIONS_GHC -fwarn-trustworthy-safe #-} +{-# OPTIONS_GHC -fwarn-unsafe #-} + +-- | Trivial Unsafe Module +module UnsafeWarn04 where + +import System.IO.Unsafe + +f :: IO a -> a +f = unsafePerformIO + diff --git a/testsuite/tests/safeHaskell/safeInfered/UnsafeWarn04.stderr b/testsuite/tests/safeHaskell/safeInfered/UnsafeWarn04.stderr new file mode 100644 index 0000000000..66deff4edc --- /dev/null +++ b/testsuite/tests/safeHaskell/safeInfered/UnsafeWarn04.stderr @@ -0,0 +1,7 @@ + +UnsafeWarn04.hs:3:16: Warning: + ‘UnsafeWarn04’ has been inferred as unsafe! + Reason: + UnsafeWarn04.hs:8:1: + System.IO.Unsafe: Can't be safely imported! + The module itself isn't safe. diff --git a/testsuite/tests/safeHaskell/safeInfered/UnsafeWarn05.hs b/testsuite/tests/safeHaskell/safeInfered/UnsafeWarn05.hs new file mode 100644 index 0000000000..76258d362b --- /dev/null +++ b/testsuite/tests/safeHaskell/safeInfered/UnsafeWarn05.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE Unsafe #-} +{-# OPTIONS_GHC -fwarn-trustworthy-safe #-} +{-# OPTIONS_GHC -fwarn-safe #-} +{-# OPTIONS_GHC -fwarn-unsafe #-} +{-# OPTIONS_GHC -fenable-rewrite-rules #-} + +-- | Trivial Unsafe Module +module UnsafeWarn05 where + +import System.IO.Unsafe + +f :: IO a -> a +f = unsafePerformIO + +{-# RULES "g" g = undefined #-} +{-# NOINLINE [1] g #-} +g :: Int +g = 1 + diff --git a/testsuite/tests/safeHaskell/safeInfered/UnsafeWarn05.stderr b/testsuite/tests/safeHaskell/safeInfered/UnsafeWarn05.stderr new file mode 100644 index 0000000000..229ce3d56f --- /dev/null +++ b/testsuite/tests/safeHaskell/safeInfered/UnsafeWarn05.stderr @@ -0,0 +1,14 @@ + +UnsafeWarn05.hs:4:16: Warning: + ‘UnsafeWarn05’ has been inferred as unsafe! + Reason: + UnsafeWarn05.hs:10:1: + System.IO.Unsafe: Can't be safely imported! + The module itself isn't safe. + +UnsafeWarn05.hs:4:16: Warning: + ‘UnsafeWarn05’ has been inferred as unsafe! + Reason: + UnsafeWarn05.hs:15:11: Warning: + Rule "g" ignored + User defined rules are disabled under Safe Haskell diff --git a/testsuite/tests/safeHaskell/safeInfered/UnsafeWarn06.hs b/testsuite/tests/safeHaskell/safeInfered/UnsafeWarn06.hs new file mode 100644 index 0000000000..671a64822b --- /dev/null +++ b/testsuite/tests/safeHaskell/safeInfered/UnsafeWarn06.hs @@ -0,0 +1,12 @@ +{-# OPTIONS_GHC -fenable-rewrite-rules #-} +{-# OPTIONS_GHC -fwarn-safe #-} +{-# OPTIONS_GHC -fwarn-unsafe #-} + +-- | Unsafe as uses RULES +module UnsafeWarn06 where + +{-# RULES "f" f = undefined #-} +{-# NOINLINE [1] f #-} +f :: Int +f = 1 + diff --git a/testsuite/tests/safeHaskell/safeInfered/UnsafeWarn06.stderr b/testsuite/tests/safeHaskell/safeInfered/UnsafeWarn06.stderr new file mode 100644 index 0000000000..8fde73ee0b --- /dev/null +++ b/testsuite/tests/safeHaskell/safeInfered/UnsafeWarn06.stderr @@ -0,0 +1,7 @@ + +UnsafeWarn06.hs:3:16: Warning: + ‘UnsafeWarn06’ has been inferred as unsafe! + Reason: + UnsafeWarn06.hs:8:11: Warning: + Rule "f" ignored + User defined rules are disabled under Safe Haskell diff --git a/testsuite/tests/safeHaskell/safeInfered/UnsafeWarn07.hs b/testsuite/tests/safeHaskell/safeInfered/UnsafeWarn07.hs new file mode 100644 index 0000000000..43982939b8 --- /dev/null +++ b/testsuite/tests/safeHaskell/safeInfered/UnsafeWarn07.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE Trustworthy #-} +{-# OPTIONS_GHC -fenable-rewrite-rules #-} +{-# OPTIONS_GHC -fwarn-safe #-} +{-# OPTIONS_GHC -fwarn-unsafe #-} + +-- | Unsafe as uses RULES +module UnsafeWarn07 where + +{-# RULES "f" f = undefined #-} +{-# NOINLINE [1] f #-} +f :: Int +f = 1 + diff --git a/testsuite/tests/safeHaskell/safeInfered/UnsafeWarn07.stderr b/testsuite/tests/safeHaskell/safeInfered/UnsafeWarn07.stderr new file mode 100644 index 0000000000..c5c5e632d7 --- /dev/null +++ b/testsuite/tests/safeHaskell/safeInfered/UnsafeWarn07.stderr @@ -0,0 +1,7 @@ + +UnsafeWarn07.hs:4:16: Warning: + ‘UnsafeWarn07’ has been inferred as unsafe! + Reason: + UnsafeWarn07.hs:9:11: Warning: + Rule "f" ignored + User defined rules are disabled under Safe Haskell diff --git a/testsuite/tests/safeHaskell/safeInfered/all.T b/testsuite/tests/safeHaskell/safeInfered/all.T index c2222a3549..12e80a7fde 100644 --- a/testsuite/tests/safeHaskell/safeInfered/all.T +++ b/testsuite/tests/safeHaskell/safeInfered/all.T @@ -73,3 +73,21 @@ test('Mixed01', normal, compile_fail, ['']) test('Mixed02', normal, compile_fail, ['']) test('Mixed03', normal, compile_fail, ['']) +# Trustworthy Safe modules +test('TrustworthySafe01', normal, compile, ['']) +test('TrustworthySafe02', normal, compile, ['']) +test('TrustworthySafe03', normal, compile, ['']) +test('TrustworthySafe04', normal, compile, ['']) + +# Check -fwarn-unsafe works +test('UnsafeWarn01', normal, compile, ['']) +test('UnsafeWarn02', normal, compile, ['']) +test('UnsafeWarn03', normal, compile, ['']) +test('UnsafeWarn04', normal, compile, ['']) +test('UnsafeWarn05', normal, compile, ['']) +test('UnsafeWarn06', normal, compile, ['']) +test('UnsafeWarn07', normal, compile, ['']) + +# Chck -fwa-safe works +test('SafeWarn01', normal, compile, ['']) + diff --git a/testsuite/tests/safeHaskell/safeLanguage/SafeLang18.hs b/testsuite/tests/safeHaskell/safeLanguage/SafeLang18.hs new file mode 100644 index 0000000000..330a80d069 --- /dev/null +++ b/testsuite/tests/safeHaskell/safeLanguage/SafeLang18.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 703 +{-# LANGUAGE Safe #-} +#endif +module SafeLang18 where + +#define p377 toPair + +data StrictPair a b = !a :*: !b + +toPair :: StrictPair a b -> (a, b) +toPair (x :*: y) = (x, y) +{-# INLINE p377 #-} + diff --git a/testsuite/tests/safeHaskell/safeLanguage/all.T b/testsuite/tests/safeHaskell/safeLanguage/all.T index 926c576434..8dad0efee6 100644 --- a/testsuite/tests/safeHaskell/safeLanguage/all.T +++ b/testsuite/tests/safeHaskell/safeLanguage/all.T @@ -51,6 +51,8 @@ test('SafeLang17', multimod_compile_fail, ['SafeLang17', '']) +test('SafeLang18', normal, compile, ['']) + # Test building a package, that trust values are set correctly # and can be changed correctly #test('SafeRecomp01', diff --git a/testsuite/tests/safeHaskell/unsafeLibs/BadImport08.hs b/testsuite/tests/safeHaskell/unsafeLibs/BadImport08.hs index 18c50dfab8..d2688fab80 100644 --- a/testsuite/tests/safeHaskell/unsafeLibs/BadImport08.hs +++ b/testsuite/tests/safeHaskell/unsafeLibs/BadImport08.hs @@ -2,7 +2,7 @@ -- | Import unsafe module Control.ST to make sure it fails module Main where -import Control.Monad.ST +import Control.Monad.ST.Unsafe f :: Int f = 2 diff --git a/testsuite/tests/safeHaskell/unsafeLibs/BadImport08.stderr b/testsuite/tests/safeHaskell/unsafeLibs/BadImport08.stderr index d3f193cff7..aa8b5a57f4 100644 --- a/testsuite/tests/safeHaskell/unsafeLibs/BadImport08.stderr +++ b/testsuite/tests/safeHaskell/unsafeLibs/BadImport08.stderr @@ -1,4 +1,4 @@ BadImport08.hs:5:1: - Control.Monad.ST: Can't be safely imported! + Control.Monad.ST.Unsafe: Can't be safely imported! The module itself isn't safe. diff --git a/testsuite/tests/safeHaskell/unsafeLibs/BadImport09.hs b/testsuite/tests/safeHaskell/unsafeLibs/BadImport09.hs new file mode 100644 index 0000000000..90d1c49090 --- /dev/null +++ b/testsuite/tests/safeHaskell/unsafeLibs/BadImport09.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE Safe #-} +-- | Import unsafe module Control.ST to make sure it fails +module Main where + +import Control.Monad.ST.Lazy.Unsafe + +f :: Int +f = 2 + +main :: IO () +main = putStrLn $ "X is: " ++ show f + diff --git a/testsuite/tests/safeHaskell/unsafeLibs/BadImport09.stderr b/testsuite/tests/safeHaskell/unsafeLibs/BadImport09.stderr new file mode 100644 index 0000000000..88556c8997 --- /dev/null +++ b/testsuite/tests/safeHaskell/unsafeLibs/BadImport09.stderr @@ -0,0 +1,4 @@ + +BadImport09.hs:5:1: + Control.Monad.ST.Lazy.Unsafe: Can't be safely imported! + The module itself isn't safe. diff --git a/testsuite/tests/safeHaskell/unsafeLibs/all.T b/testsuite/tests/safeHaskell/unsafeLibs/all.T index 4ed5aab700..03ca0e4d18 100644 --- a/testsuite/tests/safeHaskell/unsafeLibs/all.T +++ b/testsuite/tests/safeHaskell/unsafeLibs/all.T @@ -23,6 +23,7 @@ test('BadImport05', normal, compile_fail, ['']) test('BadImport06', normal, compile_fail, ['']) test('BadImport07', normal, compile_fail, ['']) test('BadImport08', normal, compile_fail, ['']) +test('BadImport09', normal, compile_fail, ['']) # check safe modules are marked safe test('GoodImport01', normal, compile, ['']) diff --git a/testsuite/tests/simplCore/should_run/AmapCoerce.hs b/testsuite/tests/simplCore/should_run/AmapCoerce.hs new file mode 100644 index 0000000000..01a9a5d5c6 --- /dev/null +++ b/testsuite/tests/simplCore/should_run/AmapCoerce.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE MagicHash #-} + +import GHC.Exts +import Unsafe.Coerce +import Data.Array + +newtype Age = Age Int + +fooAge :: Array Int Int -> Array Int Age +fooAge = fmap Age +fooCoerce :: Array Int Int -> Array Int Age +fooCoerce = fmap coerce +fooUnsafeCoerce :: Array Int Int -> Array Int Age +fooUnsafeCoerce = fmap unsafeCoerce + +same :: a -> b -> IO () +same x y = case reallyUnsafePtrEquality# (unsafeCoerce x) y of + 1# -> putStrLn "yes" + _ -> putStrLn "no" + +main = do + let l = listArray (1,3) [1,2,3] + same (fooAge l) l + same (fooCoerce l) l + same (fooUnsafeCoerce l) l diff --git a/testsuite/tests/simplCore/should_run/AmapCoerce.stdout b/testsuite/tests/simplCore/should_run/AmapCoerce.stdout new file mode 100644 index 0000000000..55f7ebb441 --- /dev/null +++ b/testsuite/tests/simplCore/should_run/AmapCoerce.stdout @@ -0,0 +1,3 @@ +yes +yes +yes diff --git a/testsuite/tests/simplCore/should_run/T5603.hs b/testsuite/tests/simplCore/should_run/T5603.hs index 635de33d6a..c1545d2c39 100644 --- a/testsuite/tests/simplCore/should_run/T5603.hs +++ b/testsuite/tests/simplCore/should_run/T5603.hs @@ -12,4 +12,5 @@ main = (encodeDouble 0 :: Double) `seq` return () {-# INLINE encodeDouble #-} encodeDouble :: Integer -> Double encodeDouble (S# _) = D# 3.0## -encodeDouble (J# _ _) = D# 4.0## +encodeDouble (Jp# _) = D# 4.0## +encodeDouble (Jn# _) = D# 5.0## diff --git a/testsuite/tests/simplCore/should_run/all.T b/testsuite/tests/simplCore/should_run/all.T index 93dc4c66f9..364dfd694f 100644 --- a/testsuite/tests/simplCore/should_run/all.T +++ b/testsuite/tests/simplCore/should_run/all.T @@ -53,6 +53,7 @@ test('T5441', extra_clean(['T5441a.o','T5441a.hi']), multimod_compile_and_run, ['T5441','']) test('T5603', normal, compile_and_run, ['']) test('T2110', normal, compile_and_run, ['']) +test('AmapCoerce', normal, compile_and_run, ['']) # Run these tests *without* optimisation too test('T5625', [ only_ways(['normal','optasm']), exit_code(1) ], compile_and_run, ['']) diff --git a/testsuite/tests/th/T8100.hs b/testsuite/tests/th/T8100.hs new file mode 100644 index 0000000000..debc2f7166 --- /dev/null +++ b/testsuite/tests/th/T8100.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE TemplateHaskell, StandaloneDeriving #-} + +module T8100 where + +import Language.Haskell.TH + +data Foo a = Foo a +data Bar = Bar Int + +$( do decs <- [d| deriving instance Eq a => Eq (Foo a) + deriving instance Ord a => Ord (Foo a) |] + return ( StandaloneDerivD [] (ConT ''Eq `AppT` ConT ''Bar) + : StandaloneDerivD [] (ConT ''Ord `AppT` ConT ''Bar) + : decs ) ) + +blah :: Ord a => Foo a -> Foo a -> Ordering +blah = compare + +buzz :: Bar -> Bar -> Ordering +buzz = compare diff --git a/testsuite/tests/th/T9064.hs b/testsuite/tests/th/T9064.hs new file mode 100644 index 0000000000..3451e2e77e --- /dev/null +++ b/testsuite/tests/th/T9064.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE TemplateHaskell, DefaultSignatures #-} + +module T9064 where + +import Language.Haskell.TH +import System.IO + +$( [d| class C a where + foo :: a -> String + default foo :: Show a => a -> String + foo = show |] ) + +data Bar = Bar deriving Show +instance C Bar + +x :: Bar -> String +x = foo + +$( do info <- reify ''C + runIO $ do + putStrLn $ pprint info + hFlush stdout + return [] ) diff --git a/testsuite/tests/th/T9064.stderr b/testsuite/tests/th/T9064.stderr new file mode 100644 index 0000000000..f9c171683d --- /dev/null +++ b/testsuite/tests/th/T9064.stderr @@ -0,0 +1,7 @@ +class T9064.C (a_0 :: *) + where T9064.foo :: forall (a_0 :: *) . T9064.C a_0 => + a_0 -> GHC.Base.String + default T9064.foo :: forall (a_0 :: *) . (T9064.C a_0, + GHC.Show.Show a_0) => + a_0 -> GHC.Base.String +instance T9064.C T9064.Bar diff --git a/testsuite/tests/th/T9066.hs b/testsuite/tests/th/T9066.hs new file mode 100644 index 0000000000..2e46fe5724 --- /dev/null +++ b/testsuite/tests/th/T9066.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE TemplateHaskell #-} + +module T9066 where + +$([d| data Blargh = (:<=>) Int Int + infix 4 :<=> + + type Foo a b = Either a b + infix 5 `Foo` + |]) diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T index a35e1261d0..90efcbd427 100644 --- a/testsuite/tests/th/all.T +++ b/testsuite/tests/th/all.T @@ -336,3 +336,6 @@ test('T8953', normal, compile, ['-v0']) test('T9084', normal, compile_fail, ['-v0']) test('T9738', normal, compile, ['-v0']) test('T9081', normal, compile, ['-v0']) +test('T9066', normal, compile, ['-v0']) +test('T8100', normal, compile, ['-v0']) +test('T9064', normal, compile, ['-v0']) diff --git a/testsuite/tests/typecheck/should_fail/T7220.hs b/testsuite/tests/typecheck/should_compile/T7220.hs index 36ae54a61d..36ae54a61d 100644 --- a/testsuite/tests/typecheck/should_fail/T7220.hs +++ b/testsuite/tests/typecheck/should_compile/T7220.hs diff --git a/testsuite/tests/typecheck/should_compile/T9404.hs b/testsuite/tests/typecheck/should_compile/T9404.hs new file mode 100644 index 0000000000..4cb530a492 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T9404.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE UnboxedTuples #-} + +module T9404 where + +foo _ = case seq () (# #) of (# #) -> () +foo2 _ = case () `seq` (# #) of (# #) -> () diff --git a/testsuite/tests/typecheck/should_compile/T9404b.hs b/testsuite/tests/typecheck/should_compile/T9404b.hs new file mode 100644 index 0000000000..f9db0a3897 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T9404b.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE RankNTypes, TypeFamilies #-} + +module T9404b where + +type family ListTF x where + ListTF x = [x] + +bar :: (forall x. ListTF x -> Int) -> () +bar _ = () + +myconst :: ((forall r. ListTF r -> Int) -> ()) -> x -> (forall r. ListTF r -> Int) -> () +myconst x _ = x + +foo = (bar `myconst` ()) $ length +foo2 = (myconst bar ()) $ length diff --git a/testsuite/tests/typecheck/should_compile/all.T b/testsuite/tests/typecheck/should_compile/all.T index a6cb78a3cd..ef830d14d5 100644 --- a/testsuite/tests/typecheck/should_compile/all.T +++ b/testsuite/tests/typecheck/should_compile/all.T @@ -422,3 +422,6 @@ test('T8856', normal, compile, ['']) test('T9117', normal, compile, ['']) test('T9117_2', expect_broken('9117'), compile, ['']) test('T9708', normal, compile_fail, ['']) +test('T9404', normal, compile, ['']) +test('T9404b', normal, compile, ['']) +test('T7220', normal, compile, ['']) diff --git a/testsuite/tests/typecheck/should_fail/T3468.stderr b/testsuite/tests/typecheck/should_fail/T3468.stderr index 26ec1920a6..9284df2fb4 100644 --- a/testsuite/tests/typecheck/should_fail/T3468.stderr +++ b/testsuite/tests/typecheck/should_fail/T3468.stderr @@ -6,3 +6,4 @@ T3468.hs-boot:3:1: data Tool d where F :: a -> Tool d Boot file: abstract Tool + The types have different kinds diff --git a/testsuite/tests/typecheck/should_fail/T5095.stderr b/testsuite/tests/typecheck/should_fail/T5095.stderr index 82613e64d9..701bd761d3 100644 --- a/testsuite/tests/typecheck/should_fail/T5095.stderr +++ b/testsuite/tests/typecheck/should_fail/T5095.stderr @@ -56,8 +56,10 @@ T5095.hs:9:11: instance Eq Ordering -- Defined in ‘GHC.Classes’ instance Eq Word -- Defined in ‘GHC.Classes’ instance Eq a => Eq [a] -- Defined in ‘GHC.Classes’ + instance Eq integer-gmp-1.0.0.0:GHC.Integer.Type.BigNat + -- Defined in ‘integer-gmp-1.0.0.0:GHC.Integer.Type’ instance Eq Integer - -- Defined in ‘integer-gmp-0.5.1.0:GHC.Integer.Type’ + -- Defined in ‘integer-gmp-1.0.0.0:GHC.Integer.Type’ (The choice depends on the instantiation of ‘a’ To pick the first instance above, use IncoherentInstances when compiling the other instance declarations) diff --git a/testsuite/tests/typecheck/should_fail/T5570.stderr b/testsuite/tests/typecheck/should_fail/T5570.stderr index 21a4e0cfbe..15d5c8a19e 100644 --- a/testsuite/tests/typecheck/should_fail/T5570.stderr +++ b/testsuite/tests/typecheck/should_fail/T5570.stderr @@ -2,7 +2,7 @@ T5570.hs:7:16: Couldn't match kind ‘*’ with ‘#’ When matching types - s0 :: * + r0 :: * Double# :: # In the second argument of ‘($)’, namely ‘D# $ 3.0##’ In the expression: print $ D# $ 3.0## diff --git a/testsuite/tests/typecheck/should_fail/T7220.stderr b/testsuite/tests/typecheck/should_fail/T7220.stderr deleted file mode 100644 index 86c4c5f1cb..0000000000 --- a/testsuite/tests/typecheck/should_fail/T7220.stderr +++ /dev/null @@ -1,9 +0,0 @@ - -T7220.hs:24:6: - Cannot instantiate unification variable ‘b0’ - with a type involving foralls: forall b. (C A b, TF b ~ Y) => b - Perhaps you want ImpredicativeTypes - In the expression: f :: (forall b. (C A b, TF b ~ Y) => b) -> X - In the expression: (f :: (forall b. (C A b, TF b ~ Y) => b) -> X) u - In an equation for ‘v’: - v = (f :: (forall b. (C A b, TF b ~ Y) => b) -> X) u diff --git a/testsuite/tests/typecheck/should_fail/T7857.stderr b/testsuite/tests/typecheck/should_fail/T7857.stderr index 6517b774f9..698d280ad9 100644 --- a/testsuite/tests/typecheck/should_fail/T7857.stderr +++ b/testsuite/tests/typecheck/should_fail/T7857.stderr @@ -1,10 +1,10 @@ T7857.hs:8:11: - Could not deduce (PrintfType s0) arising from a use of ‘printf’ + Could not deduce (PrintfType r0) arising from a use of ‘printf’ from the context (PrintfArg t) bound by the inferred type of g :: PrintfArg t => t -> b at T7857.hs:8:1-21 - The type variable ‘s0’ is ambiguous + The type variable ‘r0’ is ambiguous Note: there are several potential instances: instance [safe] (PrintfArg a, PrintfType r) => PrintfType (a -> r) -- Defined in ‘Text.Printf’ diff --git a/testsuite/tests/typecheck/should_fail/all.T b/testsuite/tests/typecheck/should_fail/all.T index f30bbb2481..2b128dc004 100644 --- a/testsuite/tests/typecheck/should_fail/all.T +++ b/testsuite/tests/typecheck/should_fail/all.T @@ -291,7 +291,6 @@ test('T6161', normal, compile_fail, ['']) test('T7368', normal, compile_fail, ['']) test('T7264', normal, compile_fail, ['']) test('T6069', normal, compile_fail, ['']) -test('T7220', normal, compile_fail, ['']) test('T7410', normal, compile_fail, ['']) test('T7453', normal, compile_fail, ['']) test('T7525', normal, compile_fail, ['']) diff --git a/testsuite/tests/typecheck/should_fail/tcfail072.stderr b/testsuite/tests/typecheck/should_fail/tcfail072.stderr index d5eb4aa87f..c9b1d10b2b 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail072.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail072.stderr @@ -10,6 +10,6 @@ tcfail072.hs:23:13: instance Ord a => Ord (Maybe a) -- Defined in ‘GHC.Base’ instance Ord () -- Defined in ‘GHC.Classes’ instance (Ord a, Ord b) => Ord (a, b) -- Defined in ‘GHC.Classes’ - ...plus 22 others + ...plus 23 others In the expression: g A In an equation for ‘g’: g (B _ _) = g A diff --git a/testsuite/tests/typecheck/should_fail/tcfail133.stderr b/testsuite/tests/typecheck/should_fail/tcfail133.stderr index 058b06392f..0198f3c67c 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail133.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail133.stderr @@ -3,8 +3,8 @@ tcfail133.hs:2:61: Warning: -XDatatypeContexts is deprecated: It was widely considered a misfeature, and has been removed from the Haskell language. tcfail133.hs:68:7: - No instance for (Show s0) arising from a use of ‘show’ - The type variable ‘s0’ is ambiguous + No instance for (Show r0) arising from a use of ‘show’ + The type variable ‘r0’ is ambiguous Note: there are several potential instances: instance Show Zero -- Defined at tcfail133.hs:8:29 instance Show One -- Defined at tcfail133.hs:9:28 @@ -17,7 +17,7 @@ tcfail133.hs:68:7: foo = show $ add (One :@ Zero) (One :@ One) tcfail133.hs:68:14: - No instance for (AddDigit (Zero :@ (One :@ One)) One s0) + No instance for (AddDigit (Zero :@ (One :@ One)) One r0) arising from a use of ‘add’ In the second argument of ‘($)’, namely ‘add (One :@ Zero) (One :@ One)’ diff --git a/testsuite/tests/typecheck/should_fail/tcfail220.stderr b/testsuite/tests/typecheck/should_fail/tcfail220.stderr index aea79067c2..e565cc7af6 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail220.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail220.stderr @@ -5,9 +5,11 @@ tcfail220.hsig:4:1: and its hsig file Main module: data Bool = False | GHC.Types.True Hsig file: data Bool a b c d = False + The types have different kinds tcfail220.hsig:5:1: Type constructor ‘Maybe’ has conflicting definitions in the module and its hsig file Main module: data Maybe a = Nothing | GHC.Base.Just a Hsig file: data Maybe a b = Nothing + The types have different kinds diff --git a/utils/deriveConstants/DeriveConstants.hs b/utils/deriveConstants/DeriveConstants.hs index 72605d755e..486f497572 100644 --- a/utils/deriveConstants/DeriveConstants.hs +++ b/utils/deriveConstants/DeriveConstants.hs @@ -413,6 +413,7 @@ wanteds = concat ,closureField C "StgTSO" "flags" ,closureField C "StgTSO" "dirty" ,closureField C "StgTSO" "bq" + ,closureField Both "StgTSO" "alloc_limit" ,closureField_ Both "StgTSO_cccs" "StgTSO" "prof.cccs" ,closureField Both "StgTSO" "stackobj" diff --git a/utils/ghc-cabal/Main.hs b/utils/ghc-cabal/Main.hs index 1847aafce5..8729fd42be 100644 --- a/utils/ghc-cabal/Main.hs +++ b/utils/ghc-cabal/Main.hs @@ -418,11 +418,15 @@ generate directory distdir dll0Modules config_args transitiveDepNames = map (display . packageName) transitive_dep_ids libraryDirs = forDeps Installed.libraryDirs + -- temporary hack to support two in-tree versions of `integer-gmp` + isIntegerGmp2 = any ("integer-gmp2" `isInfixOf`) libraryDirs -- The mkLibraryRelDir function is a bit of a hack. -- Ideally it should be handled in the makefiles instead. mkLibraryRelDir "rts" = "rts/dist/build" mkLibraryRelDir "ghc" = "compiler/stage2/build" mkLibraryRelDir "Cabal" = "libraries/Cabal/Cabal/dist-install/build" + mkLibraryRelDir "integer-gmp" + | isIntegerGmp2 = mkLibraryRelDir "integer-gmp2" mkLibraryRelDir l = "libraries/" ++ l ++ "/dist-install/build" libraryRelDirs = map mkLibraryRelDir transitiveDepNames wrappedIncludeDirs <- wrap $ forDeps Installed.includeDirs diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs index dd00429470..a67dbb2330 100644 --- a/utils/ghc-pkg/Main.hs +++ b/utils/ghc-pkg/Main.hs @@ -1020,27 +1020,16 @@ convertPackageInfoToCacheFormat pkg = GhcPkg.includeDirs = includeDirs pkg, GhcPkg.haddockInterfaces = haddockInterfaces pkg, GhcPkg.haddockHTMLs = haddockHTMLs pkg, - GhcPkg.exposedModules = exposedModules pkg, + GhcPkg.exposedModules = map convertExposed (exposedModules pkg), GhcPkg.hiddenModules = hiddenModules pkg, - GhcPkg.reexportedModules = map convertModuleReexport - (reexportedModules pkg), GhcPkg.exposed = exposed pkg, GhcPkg.trusted = trusted pkg } - where - convertModuleReexport :: ModuleReexport - -> GhcPkg.ModuleExport String ModuleName - convertModuleReexport - ModuleReexport { - moduleReexportName = m, - moduleReexportDefiningPackage = ipid', - moduleReexportDefiningName = m' - } - = GhcPkg.ModuleExport { - exportModuleName = m, - exportOriginalPackageId = display ipid', - exportOriginalModuleName = m' - } + where convertExposed (ExposedModule n reexport sig) = + GhcPkg.ExposedModule n (fmap convertOriginal reexport) + (fmap convertOriginal sig) + convertOriginal (OriginalModule ipid m) = + GhcPkg.OriginalModule (display ipid) m instance GhcPkg.BinaryStringRep ModuleName where fromStringRep = ModuleName.fromString . fromUTF8 . BS.unpack @@ -1521,8 +1510,8 @@ checkPackageConfig pkg verbosity db_stack auto_ghci_libs mapM_ (checkFile True "haddock-interfaces") (haddockInterfaces pkg) mapM_ (checkDirURL True "haddock-html") (haddockHTMLs pkg) checkDuplicateModules pkg - checkModuleFiles pkg - checkModuleReexports db_stack pkg + checkExposedModules db_stack pkg + checkOtherModules pkg mapM_ (checkHSLib verbosity (libraryDirs pkg) auto_ghci_libs) (hsLibraries pkg) -- ToDo: check these somehow? -- extra_libraries :: [String], @@ -1656,11 +1645,27 @@ doesFileExistOnPath filenames paths = go fullFilenames go ((p, fp) : xs) = do b <- doesFileExist fp if b then return (Just p) else go xs -checkModuleFiles :: InstalledPackageInfo -> Validate () -checkModuleFiles pkg = do - mapM_ findModule (exposedModules pkg ++ hiddenModules pkg) +-- | Perform validation checks (module file existence checks) on the +-- @hidden-modules@ field. +checkOtherModules :: InstalledPackageInfo -> Validate () +checkOtherModules pkg = mapM_ (checkModuleFile pkg) (hiddenModules pkg) + +-- | Perform validation checks (module file existence checks and module +-- reexport checks) on the @exposed-modules@ field. +checkExposedModules :: PackageDBStack -> InstalledPackageInfo -> Validate () +checkExposedModules db_stack pkg = + mapM_ checkExposedModule (exposedModules pkg) where - findModule modl = + checkExposedModule (ExposedModule modl reexport _sig) = do + let checkOriginal = checkModuleFile pkg modl + checkReexport = checkOriginalModule "module reexport" db_stack pkg + maybe checkOriginal checkReexport reexport + +-- | Validates the existence of an appropriate @hi@ file associated with +-- a module. Used for both @hidden-modules@ and @exposed-modules@ which +-- are not reexports. +checkModuleFile :: InstalledPackageInfo -> ModuleName -> Validate () +checkModuleFile pkg modl = -- there's no interface file for GHC.Prim unless (modl == ModuleName.fromString "GHC.Prim") $ do let files = [ ModuleName.toFilePath modl <.> extension @@ -1669,6 +1674,11 @@ checkModuleFiles pkg = do when (isNothing m) $ verror ForceFiles ("cannot find any of " ++ show files) +-- | Validates that @exposed-modules@ and @hidden-modules@ do not have duplicate +-- entries. +-- ToDo: this needs updating for signatures: signatures can validly show up +-- multiple times in the @exposed-modules@ list as long as their backing +-- implementations agree. checkDuplicateModules :: InstalledPackageInfo -> Validate () checkDuplicateModules pkg | null dups = return () @@ -1676,42 +1686,57 @@ checkDuplicateModules pkg unwords (map display dups)) where dups = [ m | (m:_:_) <- group (sort mods) ] - mods = exposedModules pkg ++ hiddenModules pkg - ++ map moduleReexportName (reexportedModules pkg) - -checkModuleReexports :: PackageDBStack -> InstalledPackageInfo -> Validate () -checkModuleReexports db_stack pkg = - mapM_ checkReexport (reexportedModules pkg) - where - all_pkgs = allPackagesInStack db_stack - ipix = PackageIndex.fromList all_pkgs - - checkReexport ModuleReexport { - moduleReexportDefiningPackage = definingPkgId, - moduleReexportDefiningName = definingModule - } = case if definingPkgId == installedPackageId pkg - then Just pkg - else PackageIndex.lookupInstalledPackageId ipix definingPkgId of - Nothing - -> verror ForceAll ("module re-export refers to a non-existent " ++ + mods = map exposedName (exposedModules pkg) ++ hiddenModules pkg + +-- | Validates an original module entry, either the origin of a module reexport +-- or the backing implementation of a signature, by checking that it exists, +-- really is an original definition, and is accessible from the dependencies of +-- the package. +-- ToDo: If the original module in question is a backing signature +-- implementation, then we should also check that the original module in +-- question is NOT a signature (however, if it is a reexport, then it's fine +-- for the original module to be a signature.) +checkOriginalModule :: String + -> PackageDBStack + -> InstalledPackageInfo + -> OriginalModule + -> Validate () +checkOriginalModule fieldName db_stack pkg + (OriginalModule definingPkgId definingModule) = + let mpkg = if definingPkgId == installedPackageId pkg + then Just pkg + else PackageIndex.lookupInstalledPackageId ipix definingPkgId + in case mpkg of + Nothing + -> verror ForceAll (fieldName ++ " refers to a non-existent " ++ "defining package: " ++ display definingPkgId) - Just definingPkg - | not (isIndirectDependency definingPkgId) - -> verror ForceAll ("module re-export refers to a defining " ++ + Just definingPkg + | not (isIndirectDependency definingPkgId) + -> verror ForceAll (fieldName ++ " refers to a defining " ++ "package that is not a direct (or indirect) " ++ "dependency of this package: " ++ display definingPkgId) - | definingModule `notElem` exposedModules definingPkg - -> verror ForceAll ("module (self) re-export refers to a module " ++ + | otherwise + -> case find ((==definingModule).exposedName) + (exposedModules definingPkg) of + Nothing -> + verror ForceAll (fieldName ++ " refers to a module " ++ + display definingModule ++ " " ++ + "that is not exposed in the " ++ + "defining package " ++ display definingPkgId) + Just (ExposedModule {exposedReexport = Just _} ) -> + verror ForceAll (fieldName ++ " refers to a module " ++ display definingModule ++ " " ++ - "that is not defined and exposed in the " ++ + "that is reexported but not defined in the " ++ "defining package " ++ display definingPkgId) + _ -> return () - | otherwise - -> return () + where + all_pkgs = allPackagesInStack db_stack + ipix = PackageIndex.fromList all_pkgs isIndirectDependency pkgid = fromMaybe False $ do thispkg <- graphVertex (installedPackageId pkg) diff --git a/utils/haddock b/utils/haddock -Subproject 199936af5bb902c81f822b2dc57308dc25e18cf +Subproject 9cdf19bad54a6cc4b322396fdd06f4c1ee045b2 @@ -157,9 +157,9 @@ if [ $no_clean -eq 0 ]; then fi if [ $use_dph -eq 1 ]; then - /usr/bin/perl -w boot --validate --required-tag=dph + perl -w boot --validate --required-tag=dph else - /usr/bin/perl -w boot --validate + perl -w boot --validate fi ./configure --prefix="$INSTDIR" $config_args fi @@ -299,4 +299,3 @@ Please fix them before pushing/sending patches. EOF exit 1 fi - |