Skip to content
Snippets Groups Projects

Compare revisions

Changes are shown as if the source revision was being merged into the target revision. Learn more about comparing revisions.

Source

Select target project
No results found

Target

Select target project
  • ghc/ghc
  • bgamari/ghc
  • syd/ghc
  • ggreif/ghc
  • watashi/ghc
  • RolandSenn/ghc
  • mpickering/ghc
  • DavidEichmann/ghc
  • carter/ghc
  • harpocrates/ghc
  • ethercrow/ghc
  • mijicd/ghc
  • adamse/ghc
  • alexbiehl/ghc
  • gridaphobe/ghc
  • trofi/ghc
  • supersven/ghc
  • ppk/ghc
  • ulysses4ever/ghc
  • AndreasK/ghc
  • ghuntley/ghc
  • shayne-fletcher-da/ghc
  • fgaz/ghc
  • yav/ghc
  • osa1/ghc
  • mbbx6spp/ghc
  • JulianLeviston/ghc
  • reactormonk/ghc
  • rae/ghc
  • takenobu-hs/ghc
  • michalt/ghc
  • andrewthad/ghc
  • hsyl20/ghc
  • scottgw/ghc
  • sjakobi/ghc
  • angerman/ghc
  • RyanGlScott/ghc
  • hvr/ghc
  • howtonotwin/ghc
  • chessai/ghc
  • m-renaud/ghc
  • brprice/ghc
  • stevehartdata/ghc
  • sighingnow/ghc
  • kgardas/ghc
  • ckoparkar/ghc
  • alp/ghc
  • smaeul/ghc
  • kakkun61/ghc
  • sykloid/ghc
  • newhoggy/ghc
  • toonn/ghc
  • nineonine/ghc
  • Phyx/ghc
  • ezyang/ghc
  • tweag/ghc
  • langston/ghc
  • ndmitchell/ghc
  • rockbmb/ghc
  • artempyanykh/ghc
  • mniip/ghc
  • mynguyenbmc/ghc
  • alexfmpe/ghc
  • crockeea/ghc
  • nh2/ghc
  • vaibhavsagar/ghc
  • phadej/ghc
  • Haskell-mouse/ghc
  • lolotp/ghc
  • spacekitteh/ghc
  • michaelpj/ghc
  • mgsloan/ghc
  • HPCohen/ghc
  • tmobile/ghc
  • radrow/ghc
  • simonmar/ghc
  • _deepfire/ghc
  • Ericson2314/ghc
  • leitao/ghc
  • fumieval/ghc
  • trac-isovector/ghc
  • cblp/ghc
  • xich/ghc
  • ciil/ghc
  • erthalion/ghc
  • xldenis/ghc
  • autotaker/ghc
  • haskell-wasm/ghc
  • kcsongor/ghc
  • agander/ghc
  • Baranowski/ghc
  • trac-dredozubov/ghc
  • 23Skidoo/ghc
  • iustin/ghc
  • ningning/ghc
  • josefs/ghc
  • kabuhr/ghc
  • gallais/ghc
  • dten/ghc
  • expipiplus1/ghc
  • Pluralia/ghc
  • rohanjr/ghc
  • intricate/ghc
  • kirelagin/ghc
  • Javran/ghc
  • DanielG/ghc
  • trac-mizunashi_mana/ghc
  • pparkkin/ghc
  • bollu/ghc
  • ntc2/ghc
  • jaspervdj/ghc
  • JoshMeredith/ghc
  • wz1000/ghc
  • zkourouma/ghc
  • code5hot/ghc
  • jdprice/ghc
  • tdammers/ghc
  • J-mie6/ghc
  • trac-lantti/ghc
  • ch1bo/ghc
  • cgohla/ghc
  • lucamolteni/ghc
  • acairncross/ghc
  • amerocu/ghc
  • chreekat/ghc
  • txsmith/ghc
  • trupill/ghc
  • typetetris/ghc
  • sergv/ghc
  • fryguybob/ghc
  • erikd/ghc
  • trac-roland/ghc
  • setupminimal/ghc
  • Friede80/ghc
  • SkyWriter/ghc
  • xplorld/ghc
  • abrar/ghc
  • obsidiansystems/ghc
  • Icelandjack/ghc
  • adinapoli/ghc
  • trac-matthewbauer/ghc
  • heatsink/ghc
  • dwijnand/ghc
  • Cmdv/ghc
  • alinab/ghc
  • pepeiborra/ghc
  • fommil/ghc
  • luochen1990/ghc
  • rlupton20/ghc
  • applePrincess/ghc
  • lehins/ghc
  • ronmrdechai/ghc
  • leeadam/ghc
  • harendra/ghc
  • mightymosquito1991/ghc
  • trac-gershomb/ghc
  • lucajulian/ghc
  • Rizary/ghc
  • VictorCMiraldo/ghc
  • jamesbrock/ghc
  • andrewdmeier/ghc
  • luke/ghc
  • pranaysashank/ghc
  • cocreature/ghc
  • hithroc/ghc
  • obreitwi/ghc
  • slrtbtfs/ghc
  • kaol/ghc
  • yairchu/ghc
  • Mathemagician98/ghc
  • trac-taylorfausak/ghc
  • leungbk/ghc
  • MichaWiedenmann/ghc
  • chris-martin/ghc
  • TDecki/ghc
  • adithyaov/ghc
  • trac-gelisam/ghc
  • Lysxia/ghc
  • complyue/ghc
  • bwignall/ghc
  • sternmull/ghc
  • sonika/ghc
  • leif/ghc
  • broadwaylamb/ghc
  • myszon/ghc
  • danbroooks/ghc
  • Mechachleopteryx/ghc
  • zardyh/ghc
  • trac-vdukhovni/ghc
  • OmarKhaledAbdo/ghc
  • arrowd/ghc
  • Bodigrim/ghc
  • matheus23/ghc
  • cardenaso11/ghc
  • trac-Athas/ghc
  • mb720/ghc
  • DylanZA/ghc
  • liff/ghc
  • typedrat/ghc
  • trac-claude/ghc
  • jbm/ghc
  • Gertjan423/ghc
  • PHO/ghc
  • JKTKops/ghc
  • kockahonza/ghc
  • msakai/ghc
  • Sir4ur0n/ghc
  • barambani/ghc
  • vishnu.c/ghc
  • dcoutts/ghc
  • trac-runeks/ghc
  • trac-MaxGabriel/ghc
  • lexi.lambda/ghc
  • strake/ghc
  • spavikevik/ghc
  • JakobBruenker/ghc
  • rmanne/ghc
  • gdziadkiewicz/ghc
  • ani/ghc
  • iliastsi/ghc
  • smunix/ghc
  • judah/ghc
  • blackgnezdo/ghc
  • emilypi/ghc
  • trac-bpfoley/ghc
  • muesli4/ghc
  • trac-gkaracha/ghc
  • Kleidukos/ghc
  • nek0/ghc
  • TristanCacqueray/ghc
  • dwulive/ghc
  • mbakke/ghc
  • arybczak/ghc
  • Yang123321/ghc
  • maksbotan/ghc
  • QuietMisdreavus/ghc
  • trac-olshanskydr/ghc
  • emekoi/ghc
  • samuela/ghc
  • josephcsible/ghc
  • dramforever/ghc
  • lpsmith/ghc
  • DenisFrezzato/ghc
  • michivi/ghc
  • jneira/ghc
  • jeffhappily/ghc
  • Ivan-Yudin/ghc
  • nakaji-dayo/ghc
  • gdevanla/ghc
  • galen/ghc
  • fendor/ghc
  • yaitskov/ghc
  • rcythr/ghc
  • awpr/ghc
  • jeremyschlatter/ghc
  • Aver1y/ghc
  • mitchellvitez/ghc
  • merijn/ghc
  • tomjaguarpaw1/ghc
  • trac-NoidedSuper/ghc
  • erewok/ghc
  • trac-junji.hashimoto/ghc
  • adamwespiser/ghc
  • bjaress/ghc
  • jhrcek/ghc
  • leonschoorl/ghc
  • lukasz-golebiewski/ghc
  • sheaf/ghc
  • last-g/ghc
  • carassius1014/ghc
  • eschwartz/ghc
  • dwincort/ghc
  • felixwiemuth/ghc
  • TimWSpence/ghc
  • marcusmonteirodesouza/ghc
  • WJWH/ghc
  • vtols/ghc
  • theobat/ghc
  • BinderDavid/ghc
  • ckoparkar0/ghc
  • alexander-kjeldaas/ghc
  • dme2/ghc
  • philderbeast/ghc
  • aaronallen8455/ghc
  • rayshih/ghc
  • benkard/ghc
  • mpardalos/ghc
  • saidelman/ghc
  • leiftw/ghc
  • ca333/ghc
  • bwroga/ghc
  • nmichael44/ghc
  • trac-crobbins/ghc
  • felixonmars/ghc
  • adityagupta1089/ghc
  • hgsipiere/ghc
  • treeowl/ghc
  • alexpeits/ghc
  • CraigFe/ghc
  • dnlkrgr/ghc
  • kerckhove_ts/ghc
  • cptwunderlich/ghc
  • eiais/ghc
  • hahohihu/ghc
  • sanchayan/ghc
  • lemmih/ghc
  • sehqlr/ghc
  • trac-dbeacham/ghc
  • luite/ghc
  • trac-f-a/ghc
  • vados/ghc
  • luntain/ghc
  • fatho/ghc
  • alexbiehl-gc/ghc
  • dcbdan/ghc
  • tvh/ghc
  • liam-ly/ghc
  • timbobbarnes/ghc
  • GovanifY/ghc
  • shanth2600/ghc
  • gliboc/ghc
  • duog/ghc
  • moxonsghost/ghc
  • zander/ghc
  • masaeedu/ghc
  • georgefst/ghc
  • guibou/ghc
  • nicuveo/ghc
  • mdebruijne/ghc
  • stjordanis/ghc
  • emiflake/ghc
  • wygulmage/ghc
  • frasertweedale/ghc
  • coot/ghc
  • aratamizuki/ghc
  • tsandstr/ghc
  • mrBliss/ghc
  • Anton-Latukha/ghc
  • tadfisher/ghc
  • vapourismo/ghc
  • Sorokin-Anton/ghc
  • basile-henry/ghc
  • trac-mightybyte/ghc
  • AbsoluteNikola/ghc
  • cobrien99/ghc
  • songzh/ghc
  • blamario/ghc
  • aj4ayushjain/ghc
  • trac-utdemir/ghc
  • tangcl/ghc
  • hdgarrood/ghc
  • maerwald/ghc
  • arjun/ghc
  • ratherforky/ghc
  • haskieLambda/ghc
  • EmilGedda/ghc
  • Bogicevic/ghc
  • eddiejessup/ghc
  • kozross/ghc
  • AlistairB/ghc
  • 3Rafal/ghc
  • christiaanb/ghc
  • trac-bit/ghc
  • matsumonkie/ghc
  • trac-parsonsmatt/ghc
  • chisui/ghc
  • jaro/ghc
  • trac-kmiyazato/ghc
  • davidsd/ghc
  • Tritlo/ghc
  • I-B-3/ghc
  • lykahb/ghc
  • AriFordsham/ghc
  • turion1/ghc
  • berberman/ghc
  • christiantakle/ghc
  • zyklotomic/ghc
  • trac-ocramz/ghc
  • CSEdd/ghc
  • doyougnu/ghc
  • mmhat/ghc
  • why-not-try-calmer/ghc
  • plutotulp/ghc
  • kjekac/ghc
  • Manvi07/ghc
  • teo/ghc
  • cactus/ghc
  • CarrieMY/ghc
  • abel/ghc
  • yihming/ghc
  • tsakki/ghc
  • jessicah/ghc
  • oliverbunting/ghc
  • meld/ghc
  • friedbrice/ghc
  • Joald/ghc
  • abarbu/ghc
  • DigitalBrains1/ghc
  • sterni/ghc
  • alexDarcy/ghc
  • hexchain/ghc
  • minimario/ghc
  • zliu41/ghc
  • tommd/ghc
  • jazcarate/ghc
  • peterbecich/ghc
  • alirezaghey/ghc
  • solomon/ghc
  • mikael.urankar/ghc
  • davjam/ghc
  • int-index/ghc
  • MorrowM/ghc
  • nrnrnr/ghc
  • Sonfamm/ghc-test-only
  • afzt1/ghc
  • nguyenhaibinh-tpc/ghc
  • trac-lierdakil/ghc
  • MichaWiedenmann1/ghc
  • jmorag/ghc
  • Ziharrk/ghc
  • trac-MitchellSalad/ghc
  • juampe/ghc
  • jwaldmann/ghc
  • snowleopard/ghc
  • juhp/ghc
  • normalcoder/ghc
  • ksqsf/ghc
  • trac-jberryman/ghc
  • roberth/ghc
  • 1ntEgr8/ghc
  • epworth/ghc
  • MrAdityaAlok/ghc
  • JunmingZhao42/ghc
  • jappeace/ghc
  • trac-Gabriel439/ghc
  • alt-romes/ghc
  • HugoPeters1024/ghc
  • 10ne1/ghc-fork
  • agentultra/ghc
  • Garfield1002/ghc
  • ChickenProp/ghc
  • clyring/ghc
  • MaxHearnden/ghc
  • jumper149/ghc
  • vem/ghc
  • ketzacoatl/ghc
  • Rosuavio/ghc
  • jackohughes/ghc
  • p4l1ly/ghc
  • konsumlamm/ghc
  • shlevy/ghc
  • torsten.schmits/ghc
  • andremarianiello/ghc
  • amesgen/ghc
  • googleson78/ghc
  • InfiniteVerma/ghc
  • uhbif19/ghc
  • yiyunliu/ghc
  • raehik/ghc
  • mrkun/ghc
  • telser/ghc
  • 1Jajen1/ghc
  • slotThe/ghc
  • WinstonHartnett/ghc
  • mpilgrem/ghc
  • dreamsmasher/ghc
  • schuelermine/ghc
  • trac-Viwor/ghc
  • undergroundquizscene/ghc
  • evertedsphere/ghc
  • coltenwebb/ghc
  • oberblastmeister/ghc
  • agrue/ghc
  • lf-/ghc
  • zacwood9/ghc
  • steshaw/ghc
  • high-cloud/ghc
  • SkamDart/ghc
  • PiDelport/ghc
  • maoif/ghc
  • RossPaterson/ghc
  • CharlesTaylor7/ghc
  • ribosomerocker/ghc
  • trac-ramirez7/ghc
  • daig/ghc
  • NicolasT/ghc
  • FinleyMcIlwaine/ghc
  • lawtonnichols/ghc
  • jmtd/ghc
  • ozkutuk/ghc
  • wildsebastian/ghc
  • lrzlin/ghc
  • tobias/ghc
  • fw/ghc
  • hawkinsw/ghc
  • type-dance/ghc
  • rui314/ghc
  • ocharles/ghc
  • wavewave/ghc
  • TheKK/ghc
  • nomeata/ghc
  • trac-csabahruska/ghc
  • jonathanjameswatson/ghc
  • L-as/ghc
  • Axman6/ghc
  • barracuda156/ghc
  • trac-jship/ghc
  • jake-87/ghc
  • meooow/ghc
  • rebeccat/ghc
  • hamana55/ghc
  • Enigmage/ghc
  • kokobd/ghc
  • agevelt/ghc
  • gshen42/ghc
  • chrismwendt/ghc
  • MangoIV/ghc
  • teto/ghc
  • Sookr1/ghc
  • trac-thomasjm/ghc
  • barci2/ghc-dev
  • trac-m4dc4p/ghc
  • dixonary/ghc
  • breakerzirconia/ghc
  • alexsio27444/ghc
  • glocq/ghc
  • sourabhxyz/ghc
  • ryantrinkle/ghc
  • Jade/ghc
  • scedfaliako/ghc
  • martijnbastiaan/ghc
  • trac-george.colpitts/ghc
  • ammarbinfaisal/ghc
  • mimi.vx/ghc
  • lortabac/ghc
  • trac-zyla/ghc
  • benbellick/ghc
  • aadaa-fgtaa/ghc
  • jvanbruegge/ghc
  • archbung/ghc
  • gilmi/ghc
  • mfonism/ghc
  • alex-mckenna/ghc
  • Ei30metry/ghc
  • DiegoDiverio/ghc
  • jorgecunhamendes/ghc
  • liesnikov/ghc
  • akrmn/ghc
  • trac-simplifierticks/ghc
  • jacco/ghc
  • rhendric/ghc
  • damhiya/ghc
  • ryndubei/ghc
  • DaveBarton/ghc
  • trac-Profpatsch/ghc
  • GZGavinZhao/ghc
  • ncfavier/ghc
  • jameshaydon/ghc
  • ajccosta/ghc
  • dschrempf/ghc
  • cydparser/ghc
  • LinuxUserGD/ghc
  • elodielander/ghc
  • facundominguez/ghc
  • psilospore/ghc
  • lachrimae/ghc
  • dylan-thinnes/ghc-type-errors-plugin
  • hamishmack/ghc
  • Leary/ghc
  • lzszt/ghc
  • lyokha/ghc
  • trac-glaubitz/ghc
  • Rewbert/ghc
  • andreabedini/ghc
  • Jasagredo/ghc
  • sol/ghc
  • OlegAlexander/ghc
  • trac-sthibaul/ghc
  • avdv/ghc
  • Wendaolee/ghc
  • ur4t/ghc
  • daylily/ghc
  • boltzmannrain/ghc
  • mmzk1526/ghc
  • trac-fizzixnerd/ghc
  • soulomoon/ghc
  • rwmjones/ghc
  • j14i/ghc
  • tracsis/ghc
  • gesh/ghc
  • flip101/ghc
  • eldritch-cookie/ghc
  • LemonjamesD/ghc
  • pgujjula/ghc
  • skeuchel/ghc
  • noteed/ghc
  • Torrekie/ghc
  • jlwoodwa/ghc
  • ayanamists/ghc
  • husong998/ghc
  • trac-edmundnoble/ghc
  • josephf/ghc
  • contrun/ghc
  • baulig/ghc
  • edsko/ghc
  • mzschr/ghc-issue-24732
  • ulidtko/ghc
  • Arsen/ghc
  • trac-sjoerd_visscher/ghc
  • crumbtoo/ghc
  • L0neGamer/ghc
  • DrewFenwick/ghc
  • benz0li/ghc
  • MaciejWas/ghc
  • jordanrule/ghc
  • trac-qqwy/ghc
  • LiamGoodacre/ghc
  • isomorpheme/ghc
  • trac-danidiaz/ghc
  • Kariim/ghc
  • taimoorzaeem/ghc
  • hololeap/ghc
  • ticat-fp/ghc
  • meritamen/ghc
  • criskell/ghc
  • trac-kraai/ghc
  • aergus/ghc
  • jdral/ghc
  • SamB/ghc
  • Tristian/ghc
  • ywgrit/ghc
  • KatsuPatrick/ghc
  • OsePedro/ghc
  • mpscholten/ghc
  • zaquest/ghc
  • fangyi-zhou/ghc
  • augyg/ghc
  • rkirkman/ghc
  • gulin.serge/ghc-windows-aarch64-bootstrap
  • iris/ghc
  • kwxm/ghc
  • maralorn/ghc
  • rafl/ghc
  • nikshalark/ghc
  • mrcjkb/ghc
  • blackheaven/ghc
  • laurenyim/ghc
  • bolt12/ghc
  • Xitian9/ghc
  • wenkokke/ghc
  • kephas/ghc
  • rmullanix/ghc
652 results
Show changes
Commits on Source (127)
Showing
with 468 additions and 309 deletions
============================================================== =============================================================
The (Interactive) Glasgow Haskell Compiler -- version 6.10.1 The (Interactive) Glasgow Haskell Compiler -- version 7.6.1
============================================================== =============================================================
The GHC Team is pleased to announce a new major release of GHC. There The GHC Team is pleased to announce a new major release of GHC, 7.6.1.
have been a number of significant changes since the last major release,
including:
* Some new language features have been implemented: Here are some of the highlights of the 7.6 branch since 7.4:
* Record syntax: wild-card patterns, punning, and field disambiguation
* Generalised quasi-quotes
* Generalised list comprehensions
* View patterns
* Type families have been completely re-implemented * Polymorphic kinds and data promotion are now fully implemented and
supported features.
* Now comes with Haddock 2, which supports all GHC extensions * Windows 64bit is now a supported platform.
* Parallel garbage collection * It is now possible to defer type errors until runtime using the
-fdefer-type-errors flag.
* Base provides extensible exceptions * The RTS now supports changing the number of capabilities at runtime
with Control.Concurrent.setNumCapabilities.
* The GHC API is easier to use Full release notes are here:
* External core (output only) now works again http://www.haskell.org/ghc/docs/7.6.1/html/users_guide/release-7-6-1.html
* Data Parallel Haskell (DPH) comes as part of GHC
The full release notes are here:
http://haskell.org/ghc/docs/6.10.1/html/users_guide/release-6-10-1.html
How to get it How to get it
~~~~~~~~~~~~~ ~~~~~~~~~~~~~
......
...@@ -71,7 +71,7 @@ module BasicTypes( ...@@ -71,7 +71,7 @@ module BasicTypes(
Activation(..), isActive, isActiveIn, Activation(..), isActive, isActiveIn,
isNeverActive, isAlwaysActive, isEarlyActive, isNeverActive, isAlwaysActive, isEarlyActive,
RuleMatchInfo(..), isConLike, isFunLike, RuleMatchInfo(..), isConLike, isFunLike,
InlineSpec(..), InlineSpec(..), isEmptyInlineSpec,
InlinePragma(..), defaultInlinePragma, alwaysInlinePragma, InlinePragma(..), defaultInlinePragma, alwaysInlinePragma,
neverInlinePragma, dfunInlinePragma, neverInlinePragma, dfunInlinePragma,
isDefaultInlinePragma, isDefaultInlinePragma,
......
...@@ -45,8 +45,8 @@ module DataCon ( ...@@ -45,8 +45,8 @@ module DataCon (
deepSplitProductType_maybe, deepSplitProductType_maybe,
-- ** Promotion related functions -- ** Promotion related functions
promoteType, isPromotableType, isPromotableTyCon, isPromotableTyCon, promoteTyCon,
buildPromotedTyCon, buildPromotedDataCon, promoteDataCon, promoteDataCon_maybe
) where ) where
#include "HsVersions.h" #include "HsVersions.h"
...@@ -386,9 +386,12 @@ data DataCon ...@@ -386,9 +386,12 @@ data DataCon
-- An entirely separate wrapper function is built in TcTyDecls -- An entirely separate wrapper function is built in TcTyDecls
dcIds :: DataConIds, dcIds :: DataConIds,
dcInfix :: Bool -- True <=> declared infix dcInfix :: Bool, -- True <=> declared infix
-- Used for Template Haskell and 'deriving' only -- Used for Template Haskell and 'deriving' only
-- The actual fixity is stored elsewhere -- The actual fixity is stored elsewhere
dcPromoted :: Maybe TyCon -- The promoted TyCon if this DataCon is promotable
-- See Note [Promoted data constructors] in TyCon
} }
deriving Data.Typeable.Typeable deriving Data.Typeable.Typeable
...@@ -519,10 +522,7 @@ mkDataCon name declared_infix ...@@ -519,10 +522,7 @@ mkDataCon name declared_infix
-- so the error is detected properly... it's just that asaertions here -- so the error is detected properly... it's just that asaertions here
-- are a little dodgy. -- are a little dodgy.
= -- ASSERT( not (any isEqPred theta) ) = con
-- We don't currently allow any equality predicates on
-- a data constructor (apart from the GADT ones in eq_spec)
con
where where
is_vanilla = null ex_tvs && null eq_spec && null theta is_vanilla = null ex_tvs && null eq_spec && null theta
con = MkData {dcName = name, dcUnique = nameUnique name, con = MkData {dcName = name, dcUnique = nameUnique name,
...@@ -537,7 +537,8 @@ mkDataCon name declared_infix ...@@ -537,7 +537,8 @@ mkDataCon name declared_infix
dcStrictMarks = arg_stricts, dcStrictMarks = arg_stricts,
dcRepStrictness = rep_arg_stricts, dcRepStrictness = rep_arg_stricts,
dcFields = fields, dcTag = tag, dcRepType = ty, dcFields = fields, dcTag = tag, dcRepType = ty,
dcIds = ids } dcIds = ids,
dcPromoted = mb_promoted }
-- Strictness marks for source-args -- Strictness marks for source-args
-- *after unboxing choices*, -- *after unboxing choices*,
...@@ -559,6 +560,17 @@ mkDataCon name declared_infix ...@@ -559,6 +560,17 @@ mkDataCon name declared_infix
mkFunTys rep_arg_tys $ mkFunTys rep_arg_tys $
mkTyConApp rep_tycon (mkTyVarTys univ_tvs) mkTyConApp rep_tycon (mkTyVarTys univ_tvs)
mb_promoted -- See Note [Promoted data constructors] in TyCon
| all (isLiftedTypeKind . tyVarKind) (univ_tvs ++ ex_tvs)
-- No kind polymorphism, and all of kind *
, null full_theta -- No constraints
, all isPromotableType orig_arg_tys
= Just (mkPromotedDataCon con name (getUnique name) prom_kind arity)
| otherwise
= Nothing
prom_kind = promoteType (dataConUserType con)
arity = dataConSourceArity con
eqSpecPreds :: [(TyVar,Type)] -> ThetaType eqSpecPreds :: [(TyVar,Type)] -> ThetaType
eqSpecPreds spec = [ mkEqPred (mkTyVarTy tv) ty | (tv,ty) <- spec ] eqSpecPreds spec = [ mkEqPred (mkTyVarTy tv) ty | (tv,ty) <- spec ]
...@@ -978,24 +990,22 @@ computeRep stricts tys ...@@ -978,24 +990,22 @@ computeRep stricts tys
%* * %* *
%************************************************************************ %************************************************************************
These two 'buildPromoted..' functions are here because These two 'promoted..' functions are here because
* They belong together * They belong together
* 'buildPromotedTyCon' is used by promoteType * 'promoteTyCon' is used by promoteType
* 'buildPromotedTyCon' depends on DataCon stuff * 'prmoteDataCon' depends on DataCon stuff
\begin{code} \begin{code}
buildPromotedTyCon :: TyCon -> TyCon promoteDataCon :: DataCon -> TyCon
buildPromotedTyCon tc promoteDataCon (MkData { dcPromoted = Just tc }) = tc
= mkPromotedTyCon tc (promoteKind (tyConKind tc)) promoteDataCon dc = pprPanic "promoteDataCon" (ppr dc)
promoteDataCon_maybe :: DataCon -> Maybe TyCon
promoteDataCon_maybe (MkData { dcPromoted = mb_tc }) = mb_tc
buildPromotedDataCon :: DataCon -> TyCon promoteTyCon :: TyCon -> TyCon
buildPromotedDataCon dc promoteTyCon tc
= ASSERT ( isPromotableType ty ) = mkPromotedTyCon tc (promoteKind (tyConKind tc))
mkPromotedDataCon dc (getName dc) (getUnique dc) kind arity
where
ty = dataConUserType dc
kind = promoteType ty
arity = dataConSourceArity dc
\end{code} \end{code}
Note [Promoting a Type to a Kind] Note [Promoting a Type to a Kind]
...@@ -1017,16 +1027,11 @@ The transformation from type to kind is done by promoteType ...@@ -1017,16 +1027,11 @@ The transformation from type to kind is done by promoteType
\begin{code} \begin{code}
isPromotableType :: Type -> Bool isPromotableType :: Type -> Bool
isPromotableType ty isPromotableType (TyConApp tc tys)
= all (isLiftedTypeKind . tyVarKind) tvs | Just n <- isPromotableTyCon tc = tys `lengthIs` n && all isPromotableType tys
&& go rho isPromotableType (FunTy arg res) = isPromotableType arg && isPromotableType res
where isPromotableType (TyVarTy {}) = True
(tvs, rho) = splitForAllTys ty isPromotableType _ = False
go (TyConApp tc tys) | Just n <- isPromotableTyCon tc
= tys `lengthIs` n && all go tys
go (FunTy arg res) = go arg && go res
go (TyVarTy tvar) = tvar `elem` tvs
go _ = False
-- If tc's kind is [ *^n -> * ] returns [ Just n ], else returns [ Nothing ] -- If tc's kind is [ *^n -> * ] returns [ Just n ], else returns [ Nothing ]
isPromotableTyCon :: TyCon -> Maybe Int isPromotableTyCon :: TyCon -> Maybe Int
...@@ -1048,7 +1053,7 @@ promoteType ty ...@@ -1048,7 +1053,7 @@ promoteType ty
kvs = [ mkKindVar (tyVarName tv) superKind | tv <- tvs ] kvs = [ mkKindVar (tyVarName tv) superKind | tv <- tvs ]
env = zipVarEnv tvs kvs env = zipVarEnv tvs kvs
go (TyConApp tc tys) = mkTyConApp (buildPromotedTyCon tc) (map go tys) go (TyConApp tc tys) = mkTyConApp (promoteTyCon tc) (map go tys)
go (FunTy arg res) = mkArrowKind (go arg) (go res) go (FunTy arg res) = mkArrowKind (go arg) (go res)
go (TyVarTy tv) | Just kv <- lookupVarEnv env tv go (TyVarTy tv) | Just kv <- lookupVarEnv env tv
= TyVarTy kv = TyVarTy kv
......
...@@ -749,9 +749,14 @@ mkPrimOpId prim_op ...@@ -749,9 +749,14 @@ mkPrimOpId prim_op
id = mkGlobalId (PrimOpId prim_op) name ty info id = mkGlobalId (PrimOpId prim_op) name ty info
info = noCafIdInfo info = noCafIdInfo
`setSpecInfo` mkSpecInfo (primOpRules prim_op name) `setSpecInfo` mkSpecInfo (primOpRules prim_op name)
`setArityInfo` arity `setArityInfo` arity
`setStrictnessInfo` Just strict_sig `setStrictnessInfo` Just strict_sig
`setInlinePragInfo` neverInlinePragma
-- We give PrimOps a NOINLINE pragma so that we don't
-- get silly warnings from Desugar.dsRule (the inline_shadows_rule
-- test) about a RULE conflicting with a possible inlining
-- cf Trac #7287
-- For each ccall we manufacture a separate CCallOpId, giving it -- For each ccall we manufacture a separate CCallOpId, giving it
-- a fresh unique, a type that is correct for this particular ccall, -- a fresh unique, a type that is correct for this particular ccall,
......
...@@ -585,26 +585,25 @@ mkGlobalRdrEnv gres ...@@ -585,26 +585,25 @@ mkGlobalRdrEnv gres
(nameOccName (gre_name gre)) (nameOccName (gre_name gre))
gre gre
findLocalDupsRdrEnv :: GlobalRdrEnv -> [OccName] -> (GlobalRdrEnv, [[Name]]) findLocalDupsRdrEnv :: GlobalRdrEnv -> [OccName] -> [[Name]]
-- ^ For each 'OccName', see if there are multiple local definitions -- ^ For each 'OccName', see if there are multiple local definitions
-- for it. If so, remove all but one (to suppress subsequent error messages) -- for it; return a list of all such
-- and return a list of the duplicate bindings -- and return a list of the duplicate bindings
findLocalDupsRdrEnv rdr_env occs findLocalDupsRdrEnv rdr_env occs
= go rdr_env [] occs = go rdr_env [] occs
where where
go rdr_env dups [] = (rdr_env, dups) go _ dups [] = dups
go rdr_env dups (occ:occs) go rdr_env dups (occ:occs)
= case filter isLocalGRE gres of = case filter isLocalGRE gres of
[] -> WARN( True, ppr occ <+> ppr rdr_env ) [] -> go rdr_env dups occs
go rdr_env dups occs -- Weird! No binding for occ [_] -> go rdr_env dups occs -- The common case
[_] -> go rdr_env dups occs -- The common case dup_gres -> go rdr_env' (map gre_name dup_gres : dups) occs
dup_gres -> go (extendOccEnv rdr_env occ (head dup_gres : nonlocal_gres))
(map gre_name dup_gres : dups)
occs
where where
gres = lookupOccEnv rdr_env occ `orElse` [] gres = lookupOccEnv rdr_env occ `orElse` []
nonlocal_gres = filterOut isLocalGRE gres rdr_env' = delFromOccEnv rdr_env occ
-- The delFromOccEnv avoids repeating the same
-- complaint twice, when occs itself has a duplicate
-- which is a common case
insertGRE :: GlobalRdrElt -> [GlobalRdrElt] -> [GlobalRdrElt] insertGRE :: GlobalRdrElt -> [GlobalRdrElt] -> [GlobalRdrElt]
insertGRE new_g [] = [new_g] insertGRE new_g [] = [new_g]
......
...@@ -43,7 +43,7 @@ module CmmUtils( ...@@ -43,7 +43,7 @@ module CmmUtils(
cmmNegate, cmmNegate,
cmmULtWord, cmmUGeWord, cmmUGtWord, cmmSubWord, cmmULtWord, cmmUGeWord, cmmUGtWord, cmmSubWord,
cmmNeWord, cmmEqWord, cmmOrWord, cmmAndWord, cmmNeWord, cmmEqWord, cmmOrWord, cmmAndWord,
cmmUShrWord, cmmAddWord, cmmMulWord, cmmUShrWord, cmmAddWord, cmmMulWord, cmmQuotWord,
isTrivialCmmExpr, hasNoGlobalRegs, isTrivialCmmExpr, hasNoGlobalRegs,
...@@ -290,7 +290,7 @@ cmmLoadIndexW base off ty = CmmLoad (cmmOffsetW base off) ty ...@@ -290,7 +290,7 @@ cmmLoadIndexW base off ty = CmmLoad (cmmOffsetW base off) ty
----------------------- -----------------------
cmmULtWord, cmmUGeWord, cmmUGtWord, cmmSubWord, cmmULtWord, cmmUGeWord, cmmUGtWord, cmmSubWord,
cmmNeWord, cmmEqWord, cmmOrWord, cmmAndWord, cmmNeWord, cmmEqWord, cmmOrWord, cmmAndWord,
cmmUShrWord, cmmAddWord, cmmMulWord cmmUShrWord, cmmAddWord, cmmMulWord, cmmQuotWord
:: CmmExpr -> CmmExpr -> CmmExpr :: CmmExpr -> CmmExpr -> CmmExpr
cmmOrWord e1 e2 = CmmMachOp mo_wordOr [e1, e2] cmmOrWord e1 e2 = CmmMachOp mo_wordOr [e1, e2]
cmmAndWord e1 e2 = CmmMachOp mo_wordAnd [e1, e2] cmmAndWord e1 e2 = CmmMachOp mo_wordAnd [e1, e2]
...@@ -304,6 +304,7 @@ cmmUShrWord e1 e2 = CmmMachOp mo_wordUShr [e1, e2] ...@@ -304,6 +304,7 @@ cmmUShrWord e1 e2 = CmmMachOp mo_wordUShr [e1, e2]
cmmAddWord e1 e2 = CmmMachOp mo_wordAdd [e1, e2] cmmAddWord e1 e2 = CmmMachOp mo_wordAdd [e1, e2]
cmmSubWord e1 e2 = CmmMachOp mo_wordSub [e1, e2] cmmSubWord e1 e2 = CmmMachOp mo_wordSub [e1, e2]
cmmMulWord e1 e2 = CmmMachOp mo_wordMul [e1, e2] cmmMulWord e1 e2 = CmmMachOp mo_wordMul [e1, e2]
cmmQuotWord e1 e2 = CmmMachOp mo_wordUQuot [e1, e2]
cmmNegate :: CmmExpr -> CmmExpr cmmNegate :: CmmExpr -> CmmExpr
cmmNegate (CmmLit (CmmInt n rep)) = CmmLit (CmmInt (-n) rep) cmmNegate (CmmLit (CmmInt n rep)) = CmmLit (CmmInt (-n) rep)
......
...@@ -34,6 +34,7 @@ import FastString ...@@ -34,6 +34,7 @@ import FastString
import StaticFlags import StaticFlags
import Control.Monad import Control.Monad
import Data.Bits
-- --------------------------------------------------------------------------- -- ---------------------------------------------------------------------------
-- Code generation for PrimOps -- Code generation for PrimOps
...@@ -829,8 +830,7 @@ doWritePtrArrayOp addr idx val ...@@ -829,8 +830,7 @@ doWritePtrArrayOp addr idx val
cmmOffsetExpr cmmOffsetExpr
(cmmOffsetExprW (cmmOffsetB addr arrPtrsHdrSize) (cmmOffsetExprW (cmmOffsetB addr arrPtrsHdrSize)
(loadArrPtrsSize addr)) (loadArrPtrsSize addr))
(CmmMachOp mo_wordUShr [idx, (card idx)
CmmLit (mkIntCLit mUT_ARR_PTRS_CARD_BITS)])
) (CmmLit (CmmInt 1 W8)) ) (CmmLit (CmmInt 1 W8))
loadArrPtrsSize :: CmmExpr -> CmmExpr loadArrPtrsSize :: CmmExpr -> CmmExpr
...@@ -1002,10 +1002,8 @@ emitCloneArray info_p res_r src0 src_off0 n0 live = do ...@@ -1002,10 +1002,8 @@ emitCloneArray info_p res_r src0 src_off0 n0 live = do
src_off <- assignTemp_ src_off0 src_off <- assignTemp_ src_off0
n <- assignTemp_ n0 n <- assignTemp_ n0
card_words <- assignTemp $ (n `cmmUShrWord` card_bytes <- assignTemp $ cardRoundUp n
(CmmLit (mkIntCLit mUT_ARR_PTRS_CARD_BITS))) size <- assignTemp $ n `cmmAddWord` bytesToWordsRoundUp card_bytes
`cmmAddWord` CmmLit (mkIntCLit 1)
size <- assignTemp $ n `cmmAddWord` card_words
words <- assignTemp $ arrPtrsHdrSizeW `cmmAddWord` size words <- assignTemp $ arrPtrsHdrSizeW `cmmAddWord` size
arr_r <- newTemp bWord arr_r <- newTemp bWord
...@@ -1029,14 +1027,13 @@ emitCloneArray info_p res_r src0 src_off0 n0 live = do ...@@ -1029,14 +1027,13 @@ emitCloneArray info_p res_r src0 src_off0 n0 live = do
emitMemsetCall (cmmOffsetExprW dst_p n) emitMemsetCall (cmmOffsetExprW dst_p n)
(CmmLit (mkIntCLit 1)) (CmmLit (mkIntCLit 1))
(card_words `cmmMulWord` wordSize) card_bytes
(CmmLit (mkIntCLit wORD_SIZE)) (CmmLit (mkIntCLit wORD_SIZE))
live live
stmtC $ CmmAssign (CmmLocal res_r) arr stmtC $ CmmAssign (CmmLocal res_r) arr
where where
arrPtrsHdrSizeW = CmmLit $ mkIntCLit $ fixedHdrSize + arrPtrsHdrSizeW = CmmLit $ mkIntCLit $ fixedHdrSize +
(sIZEOF_StgMutArrPtrs_NoHdr `div` wORD_SIZE) (sIZEOF_StgMutArrPtrs_NoHdr `div` wORD_SIZE)
wordSize = CmmLit (mkIntCLit wORD_SIZE)
myCapability = CmmReg baseReg `cmmSubWord` myCapability = CmmReg baseReg `cmmSubWord`
CmmLit (mkIntCLit oFFSET_Capability_r) CmmLit (mkIntCLit oFFSET_Capability_r)
...@@ -1048,13 +1045,24 @@ emitSetCards dst_start dst_cards_start n live = do ...@@ -1048,13 +1045,24 @@ emitSetCards dst_start dst_cards_start n live = do
start_card <- assignTemp $ card dst_start start_card <- assignTemp $ card dst_start
emitMemsetCall (dst_cards_start `cmmAddWord` start_card) emitMemsetCall (dst_cards_start `cmmAddWord` start_card)
(CmmLit (mkIntCLit 1)) (CmmLit (mkIntCLit 1))
((card (dst_start `cmmAddWord` n) `cmmSubWord` start_card) (cardRoundUp n)
`cmmAddWord` CmmLit (mkIntCLit 1)) (CmmLit (mkIntCLit 1)) -- no alignment (1 byte)
(CmmLit (mkIntCLit wORD_SIZE))
live live
where
-- Convert an element index to a card index -- Convert an element index to a card index
card i = i `cmmUShrWord` (CmmLit (mkIntCLit mUT_ARR_PTRS_CARD_BITS)) card :: CmmExpr -> CmmExpr
card i = i `cmmUShrWord` (CmmLit (mkIntCLit mUT_ARR_PTRS_CARD_BITS))
-- Convert a number of elements to a number of cards, rounding up
cardRoundUp :: CmmExpr -> CmmExpr
cardRoundUp i = card (i `cmmAddWord` (CmmLit (mkIntCLit ((1 `shiftL` mUT_ARR_PTRS_CARD_BITS) - 1))))
bytesToWordsRoundUp :: CmmExpr -> CmmExpr
bytesToWordsRoundUp e = (e `cmmAddWord` CmmLit (mkIntCLit (wORD_SIZE - 1)))
`cmmQuotWord` wordSize
wordSize :: CmmExpr
wordSize = CmmLit (mkIntCLit wORD_SIZE)
-- | Emit a call to @memcpy@. -- | Emit a call to @memcpy@.
emitMemcpyCall :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> StgLiveVars emitMemcpyCall :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> StgLiveVars
......
...@@ -50,6 +50,7 @@ import StaticFlags ...@@ -50,6 +50,7 @@ import StaticFlags
import Util import Util
import Control.Monad (liftM) import Control.Monad (liftM)
import Data.Bits
------------------------------------------------------------------------ ------------------------------------------------------------------------
-- Primitive operations and foreign calls -- Primitive operations and foreign calls
...@@ -1080,10 +1081,8 @@ emitCloneArray info_p res_r src0 src_off0 n0 = do ...@@ -1080,10 +1081,8 @@ emitCloneArray info_p res_r src0 src_off0 n0 = do
src_off <- assignTempE src_off0 src_off <- assignTempE src_off0
n <- assignTempE n0 n <- assignTempE n0
card_words <- assignTempE $ (n `cmmUShrWord` card_bytes <- assignTempE $ cardRoundUp n
(CmmLit (mkIntCLit mUT_ARR_PTRS_CARD_BITS))) size <- assignTempE $ n `cmmAddWord` bytesToWordsRoundUp card_bytes
`cmmAddWord` CmmLit (mkIntCLit 1)
size <- assignTempE $ n `cmmAddWord` card_words
words <- assignTempE $ arrPtrsHdrSizeW `cmmAddWord` size words <- assignTempE $ arrPtrsHdrSizeW `cmmAddWord` size
arr_r <- newTemp bWord arr_r <- newTemp bWord
...@@ -1106,13 +1105,12 @@ emitCloneArray info_p res_r src0 src_off0 n0 = do ...@@ -1106,13 +1105,12 @@ emitCloneArray info_p res_r src0 src_off0 n0 = do
emitMemsetCall (cmmOffsetExprW dst_p n) emitMemsetCall (cmmOffsetExprW dst_p n)
(CmmLit (mkIntCLit 1)) (CmmLit (mkIntCLit 1))
(card_words `cmmMulWord` wordSize) card_bytes
(CmmLit (mkIntCLit wORD_SIZE)) (CmmLit (mkIntCLit wORD_SIZE))
emit $ mkAssign (CmmLocal res_r) arr emit $ mkAssign (CmmLocal res_r) arr
where where
arrPtrsHdrSizeW = CmmLit $ mkIntCLit $ fixedHdrSize + arrPtrsHdrSizeW = CmmLit $ mkIntCLit $ fixedHdrSize +
(sIZEOF_StgMutArrPtrs_NoHdr `div` wORD_SIZE) (sIZEOF_StgMutArrPtrs_NoHdr `div` wORD_SIZE)
wordSize = CmmLit (mkIntCLit wORD_SIZE)
myCapability = CmmReg baseReg `cmmSubWord` myCapability = CmmReg baseReg `cmmSubWord`
CmmLit (mkIntCLit oFFSET_Capability_r) CmmLit (mkIntCLit oFFSET_Capability_r)
...@@ -1124,12 +1122,23 @@ emitSetCards dst_start dst_cards_start n = do ...@@ -1124,12 +1122,23 @@ emitSetCards dst_start dst_cards_start n = do
start_card <- assignTempE $ card dst_start start_card <- assignTempE $ card dst_start
emitMemsetCall (dst_cards_start `cmmAddWord` start_card) emitMemsetCall (dst_cards_start `cmmAddWord` start_card)
(CmmLit (mkIntCLit 1)) (CmmLit (mkIntCLit 1))
((card (dst_start `cmmAddWord` n) `cmmSubWord` start_card) (cardRoundUp n)
`cmmAddWord` CmmLit (mkIntCLit 1)) (CmmLit (mkIntCLit 1)) -- no alignment (1 byte)
(CmmLit (mkIntCLit wORD_SIZE))
where -- Convert an element index to a card index
-- Convert an element index to a card index card :: CmmExpr -> CmmExpr
card i = i `cmmUShrWord` (CmmLit (mkIntCLit mUT_ARR_PTRS_CARD_BITS)) card i = i `cmmUShrWord` (CmmLit (mkIntCLit mUT_ARR_PTRS_CARD_BITS))
-- Convert a number of elements to a number of cards, rounding up
cardRoundUp :: CmmExpr -> CmmExpr
cardRoundUp i = card (i `cmmAddWord` (CmmLit (mkIntCLit ((1 `shiftL` mUT_ARR_PTRS_CARD_BITS) - 1))))
bytesToWordsRoundUp :: CmmExpr -> CmmExpr
bytesToWordsRoundUp e = (e `cmmAddWord` CmmLit (mkIntCLit (wORD_SIZE - 1)))
`cmmQuotWord` wordSize
wordSize :: CmmExpr
wordSize = CmmLit (mkIntCLit wORD_SIZE)
-- | Emit a call to @memcpy@. -- | Emit a call to @memcpy@.
emitMemcpyCall :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> FCode () emitMemcpyCall :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> FCode ()
......
...@@ -163,7 +163,7 @@ mkUnfolding src top_lvl is_bottoming expr ...@@ -163,7 +163,7 @@ mkUnfolding src top_lvl is_bottoming expr
, not (exprIsTrivial expr) , not (exprIsTrivial expr)
= NoUnfolding -- See Note [Do not inline top-level bottoming functions] = NoUnfolding -- See Note [Do not inline top-level bottoming functions]
| otherwise | otherwise
= CoreUnfolding { uf_tmpl = occ_anald_expr, = CoreUnfolding { uf_tmpl = occurAnalyseExpr expr,
uf_src = src, uf_src = src,
uf_arity = arity, uf_arity = arity,
uf_is_top = top_lvl, uf_is_top = top_lvl,
...@@ -173,19 +173,35 @@ mkUnfolding src top_lvl is_bottoming expr ...@@ -173,19 +173,35 @@ mkUnfolding src top_lvl is_bottoming expr
uf_is_work_free = exprIsWorkFree expr, uf_is_work_free = exprIsWorkFree expr,
uf_guidance = guidance } uf_guidance = guidance }
where where
occ_anald_expr = occurAnalyseExpr expr (arity, guidance) = calcUnfoldingGuidance expr
(arity, guidance) = calcUnfoldingGuidance occ_anald_expr -- NB: *not* (calcUnfoldingGuidance (occurAnalyseExpr expr))!
-- Sometimes during simplification, there's a large let-bound thing -- See Note [Calculate unfolding guidance on the non-occ-anal'd expression]
-- which has been substituted, and so is now dead; so 'expr' contains
-- two copies of the thing while the occurrence-analysed expression doesn't
-- Nevertheless, we *don't* occ-analyse before computing the size because the
-- size computation bales out after a while, whereas occurrence analysis does not.
--
-- This can occasionally mean that the guidance is very pessimistic;
-- it gets fixed up next round. And it should be rare, because large
-- let-bound things that are dead are usually caught by preInlineUnconditionally
\end{code} \end{code}
Note [Calculate unfolding guidance on the non-occ-anal'd expression]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Notice that we give the non-occur-analysed expression to
calcUnfoldingGuidance. In some ways it'd be better to occur-analyse
first; for example, sometimes during simplification, there's a large
let-bound thing which has been substituted, and so is now dead; so
'expr' contains two copies of the thing while the occurrence-analysed
expression doesn't.
Nevertheless, we *don't* and *must not* occ-analyse before computing
the size because
a) The size computation bales out after a while, whereas occurrence
analysis does not.
b) Residency increases sharply if you occ-anal first. I'm not
100% sure why, but it's a large effect. Compiling Cabal went
from residency of 534M to over 800M with this one change.
This can occasionally mean that the guidance is very pessimistic;
it gets fixed up next round. And it should be rare, because large
let-bound things that are dead are usually caught by preInlineUnconditionally
%************************************************************************ %************************************************************************
%* * %* *
\subsection{The UnfoldingGuidance type} \subsection{The UnfoldingGuidance type}
...@@ -237,9 +253,17 @@ calcUnfoldingGuidance expr ...@@ -237,9 +253,17 @@ calcUnfoldingGuidance expr
, ug_size = iBox size , ug_size = iBox size
, ug_res = iBox scrut_discount } , ug_res = iBox scrut_discount }
discount cbs bndr discount :: Bag (Id,Int) -> Id -> Int
= foldlBag (\acc (b',n) -> if bndr==b' then acc+n else acc) discount cbs bndr = foldlBag combine 0 cbs
0 cbs where
combine acc (bndr', disc)
| bndr == bndr' = acc `plus_disc` disc
| otherwise = acc
plus_disc :: Int -> Int -> Int
plus_disc | isFunTy (idType bndr) = max
| otherwise = (+)
-- See Note [Function and non-function discounts]
in in
(n_val_bndrs, guidance) } (n_val_bndrs, guidance) }
\end{code} \end{code}
...@@ -549,8 +573,8 @@ funSize top_args fun n_val_args ...@@ -549,8 +573,8 @@ funSize top_args fun n_val_args
-- the allocation cost, as in let(rec) -- the allocation cost, as in let(rec)
-- DISCOUNTS -- DISCOUNTS
-- See Note [Function application discounts] -- See Note [Function and non-function discounts]
arg_discount | some_val_args && one_call fun top_args arg_discount | some_val_args && fun `elem` top_args
= unitBag (fun, opt_UF_FunAppDiscount) = unitBag (fun, opt_UF_FunAppDiscount)
| otherwise = emptyBag | otherwise = emptyBag
-- If the function is an argument and is applied -- If the function is an argument and is applied
...@@ -560,12 +584,6 @@ funSize top_args fun n_val_args ...@@ -560,12 +584,6 @@ funSize top_args fun n_val_args
| otherwise = 0 | otherwise = 0
-- If the function is partially applied, show a result discount -- If the function is partially applied, show a result discount
one_call _ [] = False
one_call fun (arg:args) | fun==arg = case idOccInfo arg of
OneOcc _ one_branch _ -> one_branch
_ -> False
| otherwise = one_call fun args
conSize :: DataCon -> Int -> ExprSize conSize :: DataCon -> Int -> ExprSize
conSize dc n_val_args conSize dc n_val_args
| n_val_args == 0 = SizeIs (_ILIT(0)) emptyBag (_ILIT(10)) -- Like variables | n_val_args == 0 = SizeIs (_ILIT(0)) emptyBag (_ILIT(10)) -- Like variables
...@@ -615,8 +633,8 @@ shrank binary sizes by 0.5% it also made spectral/boyer allocate 5% ...@@ -615,8 +633,8 @@ shrank binary sizes by 0.5% it also made spectral/boyer allocate 5%
more. All other changes were very small. So it's not a big deal but I more. All other changes were very small. So it's not a big deal but I
didn't adopt the idea. didn't adopt the idea.
Note [Function application discount] Note [Function and non-function discounts]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We want a discount if the function is applied. A good example is We want a discount if the function is applied. A good example is
monadic combinators with continuation arguments, where inlining is monadic combinators with continuation arguments, where inlining is
quite important. quite important.
...@@ -627,8 +645,15 @@ big it won't be inlined at its many call sites and no benefit results. ...@@ -627,8 +645,15 @@ big it won't be inlined at its many call sites and no benefit results.
Indeed, we can get exponentially big inlinings this way; that is what Indeed, we can get exponentially big inlinings this way; that is what
Trac #6048 is about. Trac #6048 is about.
So, we only give a function-application discount when the function appears On the other hand, for data-valued arguments, if there are lots of
textually once, albeit possibly inside a lambda. case expressions in the body, each one will get smaller if we apply
the function to a constructor application, so we *want* a big discount
if the argument is scrutinised by many case expressions.
Conclusion:
- For functions, take the max of the discounts
- For data values, take the sum of the discounts
Note [Literal integer size] Note [Literal integer size]
~~~~~~~~~~~~~~~~~~~~~~~~~~~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~
......
...@@ -102,14 +102,14 @@ infixl 4 `mkCoreApp`, `mkCoreApps` ...@@ -102,14 +102,14 @@ infixl 4 `mkCoreApp`, `mkCoreApps`
\begin{code} \begin{code}
sortQuantVars :: [Var] -> [Var] sortQuantVars :: [Var] -> [Var]
-- Sort the variables (KindVars, TypeVars, and Ids) -- Sort the variables (KindVars, TypeVars, and Ids)
-- into order: Type, then Kind, then Id -- into order: Kind, then Type, then Id
sortQuantVars = sortBy (comparing withCategory) sortQuantVars = sortBy (comparing withCategory)
where where
withCategory v = (category v, v) withCategory v = (category v, v)
category :: Var -> Int category :: Var -> Int
category v category v
| isTyVar v = 1 | isKindVar v = 1
| isKindVar v = 2 | isTyVar v = 2
| otherwise = 3 | otherwise = 3
-- | Bind a binding group over an expression, using a @let@ or @case@ as -- | Bind a binding group over an expression, using a @let@ or @case@ as
......
...@@ -229,7 +229,8 @@ make_lit dflags l = ...@@ -229,7 +229,8 @@ make_lit dflags l =
MachWord64 i -> C.Lint i t MachWord64 i -> C.Lint i t
MachFloat r -> C.Lrational r t MachFloat r -> C.Lrational r t
MachDouble r -> C.Lrational r t MachDouble r -> C.Lrational r t
_ -> error "MkExternalCore died: make_lit" LitInteger i _ -> C.Lint i t
_ -> pprPanic "MkExternalCore died: make_lit" (ppr l)
where where
t = make_ty dflags (literalType l) t = make_ty dflags (literalType l)
......
...@@ -844,13 +844,14 @@ ds_tc_coercion subst tc_co ...@@ -844,13 +844,14 @@ ds_tc_coercion subst tc_co
ds_scc :: CvSubst -> SCC EvBind -> CvSubst ds_scc :: CvSubst -> SCC EvBind -> CvSubst
ds_scc subst (AcyclicSCC (EvBind v ev_term)) ds_scc subst (AcyclicSCC (EvBind v ev_term))
= extendCvSubstAndInScope subst v (ds_ev_term subst ev_term) = extendCvSubstAndInScope subst v (ds_co_term subst ev_term)
ds_scc _ (CyclicSCC other) = pprPanic "ds_scc:cyclic" (ppr other $$ ppr tc_co) ds_scc _ (CyclicSCC other) = pprPanic "ds_scc:cyclic" (ppr other $$ ppr tc_co)
ds_ev_term :: CvSubst -> EvTerm -> Coercion ds_co_term :: CvSubst -> EvTerm -> Coercion
ds_ev_term subst (EvCoercion tc_co) = ds_tc_coercion subst tc_co ds_co_term subst (EvCoercion tc_co) = ds_tc_coercion subst tc_co
ds_ev_term subst (EvId v) = ds_ev_id subst v ds_co_term subst (EvId v) = ds_ev_id subst v
ds_ev_term _ other = pprPanic "ds_ev_term" (ppr other $$ ppr tc_co) ds_co_term subst (EvCast tm co) = mkCoCast (ds_co_term subst tm) (ds_tc_coercion subst co)
ds_co_term _ other = pprPanic "ds_co_term" (ppr other $$ ppr tc_co)
ds_ev_id :: CvSubst -> EqVar -> Coercion ds_ev_id :: CvSubst -> EqVar -> Coercion
ds_ev_id subst v ds_ev_id subst v
......
...@@ -131,11 +131,12 @@ repTopDs group ...@@ -131,11 +131,12 @@ repTopDs group
val_ds <- rep_val_binds (hs_valds group) ; val_ds <- rep_val_binds (hs_valds group) ;
tycl_ds <- mapM repTyClD (concat (hs_tyclds group)) ; tycl_ds <- mapM repTyClD (concat (hs_tyclds group)) ;
inst_ds <- mapM repInstD (hs_instds group) ; inst_ds <- mapM repInstD (hs_instds group) ;
for_ds <- mapM repForD (hs_fords group) ; rule_ds <- mapM repRuleD (hs_ruleds group) ;
for_ds <- mapM repForD (hs_fords group) ;
-- more needed -- more needed
return (de_loc $ sort_by_loc $ return (de_loc $ sort_by_loc $
val_ds ++ catMaybes tycl_ds ++ fix_ds val_ds ++ catMaybes tycl_ds ++ fix_ds
++ inst_ds ++ for_ds) }) ; ++ inst_ds ++ rule_ds ++ for_ds) }) ;
decl_ty <- lookupType decQTyConName ; decl_ty <- lookupType decQTyConName ;
let { core_list = coreList' decl_ty decls } ; let { core_list = coreList' decl_ty decls } ;
...@@ -411,6 +412,25 @@ repFixD (L loc (FixitySig name (Fixity prec dir))) ...@@ -411,6 +412,25 @@ repFixD (L loc (FixitySig name (Fixity prec dir)))
; dec <- rep2 rep_fn [prec', name'] ; dec <- rep2 rep_fn [prec', name']
; return (loc, dec) } ; return (loc, dec) }
repRuleD :: LRuleDecl Name -> DsM (SrcSpan, Core TH.DecQ)
repRuleD (L loc (HsRule n act bndrs lhs _ rhs _))
= do { n' <- coreStringLit $ unpackFS n
; phases <- repPhases act
; bndrs' <- mapM repRuleBndr bndrs >>= coreList ruleBndrQTyConName
; lhs' <- repLE lhs
; rhs' <- repLE rhs
; pragma <- repPragRule n' bndrs' lhs' rhs' phases
; return (loc, pragma) }
repRuleBndr :: RuleBndr Name -> DsM (Core TH.RuleBndrQ)
repRuleBndr (RuleBndr n)
= do { MkC n' <- lookupLOcc n
; rep2 ruleVarName [n'] }
repRuleBndr (RuleBndrSig n (HsWB { hswb_cts = ty }))
= do { MkC n' <- lookupLOcc n
; MkC ty' <- repLTy ty
; rep2 typedRuleVarName [n', ty'] }
ds_msg :: SDoc ds_msg :: SDoc
ds_msg = ptext (sLit "Cannot desugar this Template Haskell declaration:") ds_msg = ptext (sLit "Cannot desugar this Template Haskell declaration:")
...@@ -541,6 +561,7 @@ rep_sig (L _ (GenericSig nm _)) = failWithDs msg ...@@ -541,6 +561,7 @@ rep_sig (L _ (GenericSig nm _)) = failWithDs msg
rep_sig (L loc (InlineSig nm ispec)) = rep_inline nm ispec loc rep_sig (L loc (InlineSig nm ispec)) = rep_inline nm ispec loc
rep_sig (L loc (SpecSig nm ty ispec)) = rep_specialise nm ty ispec loc 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 _ = return [] rep_sig _ = return []
rep_ty_sig :: SrcSpan -> LHsType Name -> Located Name rep_ty_sig :: SrcSpan -> LHsType Name -> Located Name
...@@ -570,9 +591,11 @@ rep_inline :: Located Name ...@@ -570,9 +591,11 @@ rep_inline :: Located Name
-> SrcSpan -> SrcSpan
-> DsM [(SrcSpan, Core TH.DecQ)] -> DsM [(SrcSpan, Core TH.DecQ)]
rep_inline nm ispec loc rep_inline nm ispec loc
= do { nm1 <- lookupLOcc nm = do { nm1 <- lookupLOcc nm
; ispec1 <- rep_InlinePrag ispec ; inline <- repInline $ inl_inline ispec
; pragma <- repPragInl nm1 ispec1 ; rm <- repRuleMatch $ inl_rule ispec
; phases <- repPhases $ inl_act ispec
; pragma <- repPragInl nm1 inline rm phases
; return [(loc, pragma)] ; return [(loc, pragma)]
} }
...@@ -581,43 +604,39 @@ rep_specialise :: Located Name -> LHsType Name -> InlinePragma -> SrcSpan ...@@ -581,43 +604,39 @@ rep_specialise :: Located Name -> LHsType Name -> InlinePragma -> SrcSpan
rep_specialise nm ty ispec loc rep_specialise nm ty ispec loc
= do { nm1 <- lookupLOcc nm = do { nm1 <- lookupLOcc nm
; ty1 <- repLTy ty ; ty1 <- repLTy ty
; pragma <- if isDefaultInlinePragma ispec ; phases <- repPhases $ inl_act ispec
then repPragSpec nm1 ty1 -- SPECIALISE ; let inline = inl_inline ispec
else do { ispec1 <- rep_InlinePrag ispec -- SPECIALISE INLINE ; pragma <- if isEmptyInlineSpec inline
; repPragSpecInl nm1 ty1 ispec1 } then -- SPECIALISE
repPragSpec nm1 ty1 phases
else -- SPECIALISE INLINE
do { inline1 <- repInline inline
; repPragSpecInl nm1 ty1 inline1 phases }
; return [(loc, pragma)] ; return [(loc, pragma)]
} }
rep_specialiseInst :: LHsType Name -> SrcSpan -> DsM [(SrcSpan, Core TH.DecQ)]
rep_specialiseInst ty loc
= do { ty1 <- repLTy ty
; pragma <- repPragSpecInst ty1
; return [(loc, pragma)] }
repInline :: InlineSpec -> DsM (Core TH.Inline) repInline :: InlineSpec -> DsM (Core TH.Inline)
repInline NoInline = dataCon noInlineDataConName repInline NoInline = dataCon noInlineDataConName
repInline Inline = dataCon inlineDataConName repInline Inline = dataCon inlineDataConName
repInline Inlinable = dataCon inlinableDataConName repInline Inlinable = dataCon inlinableDataConName
repInline spec = notHandled "repInline" (ppr spec) repInline spec = notHandled "repInline" (ppr spec)
-- Extract all the information needed to build a TH.InlinePrag repRuleMatch :: RuleMatchInfo -> DsM (Core TH.RuleMatch)
-- repRuleMatch ConLike = dataCon conLikeDataConName
rep_InlinePrag :: InlinePragma -- Never defaultInlinePragma repRuleMatch FunLike = dataCon funLikeDataConName
-> DsM (Core TH.InlineSpecQ)
rep_InlinePrag (InlinePragma { inl_act = activation, inl_rule = match, inl_inline = inline })
| Just (flag, phase) <- activation1
= do { inline1 <- repInline inline
; repInlineSpecPhase inline1 match1 flag phase }
| otherwise
= do { inline1 <- repInline inline
; repInlineSpecNoPhase inline1 match1 }
where
match1 = coreBool (rep_RuleMatchInfo match)
activation1 = rep_Activation activation
rep_RuleMatchInfo FunLike = False
rep_RuleMatchInfo ConLike = True
rep_Activation NeverActive = Nothing -- We never have NOINLINE/AlwaysActive
rep_Activation AlwaysActive = Nothing -- or INLINE/NeverActive
rep_Activation (ActiveBefore phase) = Just (coreBool False,
MkC $ mkIntExprInt phase)
rep_Activation (ActiveAfter phase) = Just (coreBool True,
MkC $ mkIntExprInt phase)
repPhases :: Activation -> DsM (Core TH.Phases)
repPhases (ActiveBefore i) = do { MkC arg <- coreIntLit i
; dataCon' beforePhaseDataConName [arg] }
repPhases (ActiveAfter i) = do { MkC arg <- coreIntLit i
; dataCon' fromPhaseDataConName [arg] }
repPhases _ = dataCon allPhasesDataConName
------------------------------------------------------- -------------------------------------------------------
-- Types -- Types
...@@ -1389,9 +1408,12 @@ rep2 :: Name -> [ CoreExpr ] -> DsM (Core a) ...@@ -1389,9 +1408,12 @@ rep2 :: Name -> [ CoreExpr ] -> DsM (Core a)
rep2 n xs = do { id <- dsLookupGlobalId n rep2 n xs = do { id <- dsLookupGlobalId n
; return (MkC (foldl App (Var id) xs)) } ; return (MkC (foldl App (Var id) xs)) }
dataCon' :: Name -> [CoreExpr] -> DsM (Core a)
dataCon' n args = do { id <- dsLookupDataCon n
; return $ MkC $ mkConApp id args }
dataCon :: Name -> DsM (Core a) dataCon :: Name -> DsM (Core a)
dataCon n = do { id <- dsLookupDataCon n dataCon n = dataCon' n []
; return $ MkC $ mkConApp id [] }
-- Then we make "repConstructors" which use the phantom types for each of the -- Then we make "repConstructors" which use the phantom types for each of the
-- smart constructors of the Meta.Meta datatypes. -- smart constructors of the Meta.Meta datatypes.
...@@ -1603,16 +1625,28 @@ repClass :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr] ...@@ -1603,16 +1625,28 @@ repClass :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr]
repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC fds) (MkC ds) repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC fds) (MkC ds)
= rep2 classDName [cxt, cls, tvs, fds, ds] = rep2 classDName [cxt, cls, tvs, fds, ds]
repPragInl :: Core TH.Name -> Core TH.InlineSpecQ -> DsM (Core TH.DecQ) repPragInl :: Core TH.Name -> Core TH.Inline -> Core TH.RuleMatch
repPragInl (MkC nm) (MkC ispec) = rep2 pragInlDName [nm, ispec] -> Core TH.Phases -> DsM (Core TH.DecQ)
repPragInl (MkC nm) (MkC inline) (MkC rm) (MkC phases)
= rep2 pragInlDName [nm, inline, rm, phases]
repPragSpec :: Core TH.Name -> Core TH.TypeQ -> Core TH.Phases
-> DsM (Core TH.DecQ)
repPragSpec (MkC nm) (MkC ty) (MkC phases)
= rep2 pragSpecDName [nm, ty, phases]
repPragSpec :: Core TH.Name -> Core TH.TypeQ -> DsM (Core TH.DecQ) repPragSpecInl :: Core TH.Name -> Core TH.TypeQ -> Core TH.Inline
repPragSpec (MkC nm) (MkC ty) = rep2 pragSpecDName [nm, ty] -> Core TH.Phases -> DsM (Core TH.DecQ)
repPragSpecInl (MkC nm) (MkC ty) (MkC inline) (MkC phases)
= rep2 pragSpecInlDName [nm, ty, inline, phases]
repPragSpecInl :: Core TH.Name -> Core TH.TypeQ -> Core TH.InlineSpecQ repPragSpecInst :: Core TH.TypeQ -> DsM (Core TH.DecQ)
-> DsM (Core TH.DecQ) repPragSpecInst (MkC ty) = rep2 pragSpecInstDName [ty]
repPragSpecInl (MkC nm) (MkC ty) (MkC ispec)
= rep2 pragSpecInlDName [nm, ty, ispec] repPragRule :: Core String -> Core [TH.RuleBndrQ] -> Core TH.ExpQ
-> Core TH.ExpQ -> Core TH.Phases -> DsM (Core TH.DecQ)
repPragRule (MkC nm) (MkC bndrs) (MkC lhs) (MkC rhs) (MkC phases)
= rep2 pragRuleDName [nm, bndrs, lhs, rhs, phases]
repFamilyNoKind :: Core TH.FamFlavour -> Core TH.Name -> Core [TH.TyVarBndr] repFamilyNoKind :: Core TH.FamFlavour -> Core TH.Name -> Core [TH.TyVarBndr]
-> DsM (Core TH.DecQ) -> DsM (Core TH.DecQ)
...@@ -1625,16 +1659,6 @@ repFamilyKind :: Core TH.FamFlavour -> Core TH.Name -> Core [TH.TyVarBndr] ...@@ -1625,16 +1659,6 @@ repFamilyKind :: Core TH.FamFlavour -> Core TH.Name -> Core [TH.TyVarBndr]
repFamilyKind (MkC flav) (MkC nm) (MkC tvs) (MkC ki) repFamilyKind (MkC flav) (MkC nm) (MkC tvs) (MkC ki)
= rep2 familyKindDName [flav, nm, tvs, ki] = rep2 familyKindDName [flav, nm, tvs, ki]
repInlineSpecNoPhase :: Core TH.Inline -> Core Bool
-> DsM (Core TH.InlineSpecQ)
repInlineSpecNoPhase (MkC inline) (MkC conlike)
= rep2 inlineSpecNoPhaseName [inline, conlike]
repInlineSpecPhase :: Core TH.Inline -> Core Bool -> Core Bool -> Core Int
-> DsM (Core TH.InlineSpecQ)
repInlineSpecPhase (MkC inline) (MkC conlike) (MkC beforeFrom) (MkC phase)
= rep2 inlineSpecPhaseName [inline, conlike, beforeFrom, phase]
repFunDep :: Core [TH.Name] -> Core [TH.Name] -> DsM (Core TH.FunDep) repFunDep :: Core [TH.Name] -> Core [TH.Name] -> DsM (Core TH.FunDep)
repFunDep (MkC xs) (MkC ys) = rep2 funDepName [xs, ys] repFunDep (MkC xs) (MkC ys) = rep2 funDepName [xs, ys]
...@@ -1851,11 +1875,7 @@ nonEmptyCoreList xs@(MkC x:_) = MkC (mkListExpr (exprType x) (map unC xs)) ...@@ -1851,11 +1875,7 @@ nonEmptyCoreList xs@(MkC x:_) = MkC (mkListExpr (exprType x) (map unC xs))
coreStringLit :: String -> DsM (Core String) coreStringLit :: String -> DsM (Core String)
coreStringLit s = do { z <- mkStringExpr s; return(MkC z) } coreStringLit s = do { z <- mkStringExpr s; return(MkC z) }
------------ Bool, Literals & Variables ------------------- ------------ Literals & Variables -------------------
coreBool :: Bool -> Core Bool
coreBool False = MkC $ mkConApp falseDataCon []
coreBool True = MkC $ mkConApp trueDataCon []
coreIntLit :: Int -> DsM (Core Int) coreIntLit :: Int -> DsM (Core Int)
coreIntLit i = return (MkC (mkIntExprInt i)) coreIntLit i = return (MkC (mkIntExprInt i))
...@@ -1923,7 +1943,8 @@ templateHaskellNames = [ ...@@ -1923,7 +1943,8 @@ templateHaskellNames = [
-- Dec -- Dec
funDName, valDName, dataDName, newtypeDName, tySynDName, funDName, valDName, dataDName, newtypeDName, tySynDName,
classDName, instanceDName, sigDName, forImpDName, classDName, instanceDName, sigDName, forImpDName,
pragInlDName, pragSpecDName, pragSpecInlDName, pragInlDName, pragSpecDName, pragSpecInlDName, pragSpecInstDName,
pragRuleDName,
familyNoKindDName, familyKindDName, dataInstDName, newtypeInstDName, familyNoKindDName, familyKindDName, dataInstDName, newtypeInstDName,
tySynInstDName, infixLDName, infixRDName, infixNDName, tySynInstDName, infixLDName, infixRDName, infixNDName,
-- Cxt -- Cxt
...@@ -1957,8 +1978,12 @@ templateHaskellNames = [ ...@@ -1957,8 +1978,12 @@ templateHaskellNames = [
interruptibleName, interruptibleName,
-- Inline -- Inline
noInlineDataConName, inlineDataConName, inlinableDataConName, noInlineDataConName, inlineDataConName, inlinableDataConName,
-- InlineSpec -- RuleMatch
inlineSpecNoPhaseName, inlineSpecPhaseName, conLikeDataConName, funLikeDataConName,
-- Phases
allPhasesDataConName, fromPhaseDataConName, beforePhaseDataConName,
-- RuleBndr
ruleVarName, typedRuleVarName,
-- FunDep -- FunDep
funDepName, funDepName,
-- FamFlavour -- FamFlavour
...@@ -1971,7 +1996,7 @@ templateHaskellNames = [ ...@@ -1971,7 +1996,7 @@ templateHaskellNames = [
varStrictTypeQTyConName, typeQTyConName, expTyConName, decTyConName, varStrictTypeQTyConName, typeQTyConName, expTyConName, decTyConName,
typeTyConName, tyVarBndrTyConName, matchTyConName, clauseTyConName, typeTyConName, tyVarBndrTyConName, matchTyConName, clauseTyConName,
patQTyConName, fieldPatQTyConName, fieldExpQTyConName, funDepTyConName, patQTyConName, fieldPatQTyConName, fieldExpQTyConName, funDepTyConName,
predQTyConName, decsQTyConName, predQTyConName, decsQTyConName, ruleBndrQTyConName,
-- Quasiquoting -- Quasiquoting
quoteDecName, quoteTypeName, quoteExpName, quotePatName] quoteDecName, quoteTypeName, quoteExpName, quotePatName]
...@@ -2130,29 +2155,31 @@ parSName = libFun (fsLit "parS") parSIdKey ...@@ -2130,29 +2155,31 @@ parSName = libFun (fsLit "parS") parSIdKey
-- data Dec = ... -- data Dec = ...
funDName, valDName, dataDName, newtypeDName, tySynDName, classDName, funDName, valDName, dataDName, newtypeDName, tySynDName, classDName,
instanceDName, sigDName, forImpDName, pragInlDName, pragSpecDName, instanceDName, sigDName, forImpDName, pragInlDName, pragSpecDName,
pragSpecInlDName, familyNoKindDName, familyKindDName, dataInstDName, pragSpecInlDName, pragSpecInstDName, pragRuleDName, familyNoKindDName,
newtypeInstDName, tySynInstDName, familyKindDName, dataInstDName, newtypeInstDName, tySynInstDName,
infixLDName, infixRDName, infixNDName :: Name infixLDName, infixRDName, infixNDName :: Name
funDName = libFun (fsLit "funD") funDIdKey funDName = libFun (fsLit "funD") funDIdKey
valDName = libFun (fsLit "valD") valDIdKey valDName = libFun (fsLit "valD") valDIdKey
dataDName = libFun (fsLit "dataD") dataDIdKey dataDName = libFun (fsLit "dataD") dataDIdKey
newtypeDName = libFun (fsLit "newtypeD") newtypeDIdKey newtypeDName = libFun (fsLit "newtypeD") newtypeDIdKey
tySynDName = libFun (fsLit "tySynD") tySynDIdKey tySynDName = libFun (fsLit "tySynD") tySynDIdKey
classDName = libFun (fsLit "classD") classDIdKey classDName = libFun (fsLit "classD") classDIdKey
instanceDName = libFun (fsLit "instanceD") instanceDIdKey instanceDName = libFun (fsLit "instanceD") instanceDIdKey
sigDName = libFun (fsLit "sigD") sigDIdKey sigDName = libFun (fsLit "sigD") sigDIdKey
forImpDName = libFun (fsLit "forImpD") forImpDIdKey forImpDName = libFun (fsLit "forImpD") forImpDIdKey
pragInlDName = libFun (fsLit "pragInlD") pragInlDIdKey pragInlDName = libFun (fsLit "pragInlD") pragInlDIdKey
pragSpecDName = libFun (fsLit "pragSpecD") pragSpecDIdKey pragSpecDName = libFun (fsLit "pragSpecD") pragSpecDIdKey
pragSpecInlDName = libFun (fsLit "pragSpecInlD") pragSpecInlDIdKey pragSpecInlDName = libFun (fsLit "pragSpecInlD") pragSpecInlDIdKey
familyNoKindDName= libFun (fsLit "familyNoKindD")familyNoKindDIdKey pragSpecInstDName = libFun (fsLit "pragSpecInstD") pragSpecInstDIdKey
familyKindDName = libFun (fsLit "familyKindD") familyKindDIdKey pragRuleDName = libFun (fsLit "pragRuleD") pragRuleDIdKey
dataInstDName = libFun (fsLit "dataInstD") dataInstDIdKey familyNoKindDName = libFun (fsLit "familyNoKindD") familyNoKindDIdKey
newtypeInstDName = libFun (fsLit "newtypeInstD") newtypeInstDIdKey familyKindDName = libFun (fsLit "familyKindD") familyKindDIdKey
tySynInstDName = libFun (fsLit "tySynInstD") tySynInstDIdKey dataInstDName = libFun (fsLit "dataInstD") dataInstDIdKey
infixLDName = libFun (fsLit "infixLD") infixLDIdKey newtypeInstDName = libFun (fsLit "newtypeInstD") newtypeInstDIdKey
infixRDName = libFun (fsLit "infixRD") infixRDIdKey tySynInstDName = libFun (fsLit "tySynInstD") tySynInstDIdKey
infixNDName = libFun (fsLit "infixND") infixNDIdKey infixLDName = libFun (fsLit "infixLD") infixLDIdKey
infixRDName = libFun (fsLit "infixRD") infixRDIdKey
infixNDName = libFun (fsLit "infixND") infixNDIdKey
-- type Ctxt = ... -- type Ctxt = ...
cxtName :: Name cxtName :: Name
...@@ -2243,10 +2270,21 @@ noInlineDataConName = thCon (fsLit "NoInline") noInlineDataConKey ...@@ -2243,10 +2270,21 @@ noInlineDataConName = thCon (fsLit "NoInline") noInlineDataConKey
inlineDataConName = thCon (fsLit "Inline") inlineDataConKey inlineDataConName = thCon (fsLit "Inline") inlineDataConKey
inlinableDataConName = thCon (fsLit "Inlinable") inlinableDataConKey inlinableDataConName = thCon (fsLit "Inlinable") inlinableDataConKey
-- data InlineSpec = ... -- data RuleMatch = ...
inlineSpecNoPhaseName, inlineSpecPhaseName :: Name conLikeDataConName, funLikeDataConName :: Name
inlineSpecNoPhaseName = libFun (fsLit "inlineSpecNoPhase") inlineSpecNoPhaseIdKey conLikeDataConName = thCon (fsLit "ConLike") conLikeDataConKey
inlineSpecPhaseName = libFun (fsLit "inlineSpecPhase") inlineSpecPhaseIdKey funLikeDataConName = thCon (fsLit "FunLike") funLikeDataConKey
-- data Phases = ...
allPhasesDataConName, fromPhaseDataConName, beforePhaseDataConName :: Name
allPhasesDataConName = thCon (fsLit "AllPhases") allPhasesDataConKey
fromPhaseDataConName = thCon (fsLit "FromPhase") fromPhaseDataConKey
beforePhaseDataConName = thCon (fsLit "BeforePhase") beforePhaseDataConKey
-- data RuleBndr = ...
ruleVarName, typedRuleVarName :: Name
ruleVarName = libFun (fsLit ("ruleVar")) ruleVarIdKey
typedRuleVarName = libFun (fsLit ("typedRuleVar")) typedRuleVarIdKey
-- data FunDep = ... -- data FunDep = ...
funDepName :: Name funDepName :: Name
...@@ -2260,12 +2298,13 @@ dataFamName = libFun (fsLit "dataFam") dataFamIdKey ...@@ -2260,12 +2298,13 @@ dataFamName = libFun (fsLit "dataFam") dataFamIdKey
matchQTyConName, clauseQTyConName, expQTyConName, stmtQTyConName, matchQTyConName, clauseQTyConName, expQTyConName, stmtQTyConName,
decQTyConName, conQTyConName, strictTypeQTyConName, decQTyConName, conQTyConName, strictTypeQTyConName,
varStrictTypeQTyConName, typeQTyConName, fieldExpQTyConName, varStrictTypeQTyConName, typeQTyConName, fieldExpQTyConName,
patQTyConName, fieldPatQTyConName, predQTyConName, decsQTyConName :: Name patQTyConName, fieldPatQTyConName, predQTyConName, decsQTyConName,
matchQTyConName = libTc (fsLit "MatchQ") matchQTyConKey ruleBndrQTyConName :: Name
clauseQTyConName = libTc (fsLit "ClauseQ") clauseQTyConKey matchQTyConName = libTc (fsLit "MatchQ") matchQTyConKey
expQTyConName = libTc (fsLit "ExpQ") expQTyConKey clauseQTyConName = libTc (fsLit "ClauseQ") clauseQTyConKey
stmtQTyConName = libTc (fsLit "StmtQ") stmtQTyConKey expQTyConName = libTc (fsLit "ExpQ") expQTyConKey
decQTyConName = libTc (fsLit "DecQ") decQTyConKey stmtQTyConName = libTc (fsLit "StmtQ") stmtQTyConKey
decQTyConName = libTc (fsLit "DecQ") decQTyConKey
decsQTyConName = libTc (fsLit "DecsQ") decsQTyConKey -- Q [Dec] decsQTyConName = libTc (fsLit "DecsQ") decsQTyConKey -- Q [Dec]
conQTyConName = libTc (fsLit "ConQ") conQTyConKey conQTyConName = libTc (fsLit "ConQ") conQTyConKey
strictTypeQTyConName = libTc (fsLit "StrictTypeQ") strictTypeQTyConKey strictTypeQTyConName = libTc (fsLit "StrictTypeQ") strictTypeQTyConKey
...@@ -2275,6 +2314,7 @@ fieldExpQTyConName = libTc (fsLit "FieldExpQ") fieldExpQTyConKey ...@@ -2275,6 +2314,7 @@ fieldExpQTyConName = libTc (fsLit "FieldExpQ") fieldExpQTyConKey
patQTyConName = libTc (fsLit "PatQ") patQTyConKey patQTyConName = libTc (fsLit "PatQ") patQTyConKey
fieldPatQTyConName = libTc (fsLit "FieldPatQ") fieldPatQTyConKey fieldPatQTyConName = libTc (fsLit "FieldPatQ") fieldPatQTyConKey
predQTyConName = libTc (fsLit "PredQ") predQTyConKey predQTyConName = libTc (fsLit "PredQ") predQTyConKey
ruleBndrQTyConName = libTc (fsLit "RuleBndrQ") ruleBndrQTyConKey
-- quasiquoting -- quasiquoting
quoteExpName, quotePatName, quoteDecName, quoteTypeName :: Name quoteExpName, quotePatName, quoteDecName, quoteTypeName :: Name
...@@ -2292,7 +2332,7 @@ expTyConKey, matchTyConKey, clauseTyConKey, qTyConKey, expQTyConKey, ...@@ -2292,7 +2332,7 @@ expTyConKey, matchTyConKey, clauseTyConKey, qTyConKey, expQTyConKey,
decTyConKey, varStrictTypeQTyConKey, strictTypeQTyConKey, decTyConKey, varStrictTypeQTyConKey, strictTypeQTyConKey,
fieldExpTyConKey, fieldPatTyConKey, nameTyConKey, patQTyConKey, fieldExpTyConKey, fieldPatTyConKey, nameTyConKey, patQTyConKey,
fieldPatQTyConKey, fieldExpQTyConKey, funDepTyConKey, predTyConKey, fieldPatQTyConKey, fieldExpQTyConKey, funDepTyConKey, predTyConKey,
predQTyConKey, decsQTyConKey :: Unique predQTyConKey, decsQTyConKey, ruleBndrQTyConKey :: Unique
expTyConKey = mkPreludeTyConUnique 200 expTyConKey = mkPreludeTyConUnique 200
matchTyConKey = mkPreludeTyConUnique 201 matchTyConKey = mkPreludeTyConUnique 201
clauseTyConKey = mkPreludeTyConUnique 202 clauseTyConKey = mkPreludeTyConUnique 202
...@@ -2320,6 +2360,7 @@ predTyConKey = mkPreludeTyConUnique 223 ...@@ -2320,6 +2360,7 @@ predTyConKey = mkPreludeTyConUnique 223
predQTyConKey = mkPreludeTyConUnique 224 predQTyConKey = mkPreludeTyConUnique 224
tyVarBndrTyConKey = mkPreludeTyConUnique 225 tyVarBndrTyConKey = mkPreludeTyConUnique 225
decsQTyConKey = mkPreludeTyConUnique 226 decsQTyConKey = mkPreludeTyConUnique 226
ruleBndrQTyConKey = mkPreludeTyConUnique 227
-- IdUniques available: 200-499 -- IdUniques available: 200-499
-- If you want to change this, make sure you check in PrelNames -- If you want to change this, make sure you check in PrelNames
...@@ -2443,7 +2484,8 @@ parSIdKey = mkPreludeMiscIdUnique 323 ...@@ -2443,7 +2484,8 @@ parSIdKey = mkPreludeMiscIdUnique 323
-- data Dec = ... -- data Dec = ...
funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey, funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey,
classDIdKey, instanceDIdKey, sigDIdKey, forImpDIdKey, pragInlDIdKey, classDIdKey, instanceDIdKey, sigDIdKey, forImpDIdKey, pragInlDIdKey,
pragSpecDIdKey, pragSpecInlDIdKey, familyNoKindDIdKey, familyKindDIdKey, pragSpecDIdKey, pragSpecInlDIdKey, pragSpecInstDIdKey, pragRuleDIdKey,
familyNoKindDIdKey, familyKindDIdKey,
dataInstDIdKey, newtypeInstDIdKey, tySynInstDIdKey, dataInstDIdKey, newtypeInstDIdKey, tySynInstDIdKey,
infixLDIdKey, infixRDIdKey, infixNDIdKey :: Unique infixLDIdKey, infixRDIdKey, infixNDIdKey :: Unique
funDIdKey = mkPreludeMiscIdUnique 330 funDIdKey = mkPreludeMiscIdUnique 330
...@@ -2458,6 +2500,8 @@ forImpDIdKey = mkPreludeMiscIdUnique 338 ...@@ -2458,6 +2500,8 @@ forImpDIdKey = mkPreludeMiscIdUnique 338
pragInlDIdKey = mkPreludeMiscIdUnique 339 pragInlDIdKey = mkPreludeMiscIdUnique 339
pragSpecDIdKey = mkPreludeMiscIdUnique 340 pragSpecDIdKey = mkPreludeMiscIdUnique 340
pragSpecInlDIdKey = mkPreludeMiscIdUnique 341 pragSpecInlDIdKey = mkPreludeMiscIdUnique 341
pragSpecInstDIdKey = mkPreludeMiscIdUnique 412
pragRuleDIdKey = mkPreludeMiscIdUnique 413
familyNoKindDIdKey = mkPreludeMiscIdUnique 342 familyNoKindDIdKey = mkPreludeMiscIdUnique 342
familyKindDIdKey = mkPreludeMiscIdUnique 343 familyKindDIdKey = mkPreludeMiscIdUnique 343
dataInstDIdKey = mkPreludeMiscIdUnique 344 dataInstDIdKey = mkPreludeMiscIdUnique 344
...@@ -2556,10 +2600,16 @@ noInlineDataConKey = mkPreludeDataConUnique 40 ...@@ -2556,10 +2600,16 @@ noInlineDataConKey = mkPreludeDataConUnique 40
inlineDataConKey = mkPreludeDataConUnique 41 inlineDataConKey = mkPreludeDataConUnique 41
inlinableDataConKey = mkPreludeDataConUnique 42 inlinableDataConKey = mkPreludeDataConUnique 42
-- data InlineSpec = -- data RuleMatch = ...
inlineSpecNoPhaseIdKey, inlineSpecPhaseIdKey :: Unique conLikeDataConKey, funLikeDataConKey :: Unique
inlineSpecNoPhaseIdKey = mkPreludeMiscIdUnique 412 conLikeDataConKey = mkPreludeDataConUnique 43
inlineSpecPhaseIdKey = mkPreludeMiscIdUnique 413 funLikeDataConKey = mkPreludeDataConUnique 44
-- data Phases = ...
allPhasesDataConKey, fromPhaseDataConKey, beforePhaseDataConKey :: Unique
allPhasesDataConKey = mkPreludeDataConUnique 45
fromPhaseDataConKey = mkPreludeDataConUnique 46
beforePhaseDataConKey = mkPreludeDataConUnique 47
-- data FunDep = ... -- data FunDep = ...
funDepIdKey :: Unique funDepIdKey :: Unique
...@@ -2576,3 +2626,8 @@ quoteExpKey = mkPreludeMiscIdUnique 418 ...@@ -2576,3 +2626,8 @@ quoteExpKey = mkPreludeMiscIdUnique 418
quotePatKey = mkPreludeMiscIdUnique 419 quotePatKey = mkPreludeMiscIdUnique 419
quoteDecKey = mkPreludeMiscIdUnique 420 quoteDecKey = mkPreludeMiscIdUnique 420
quoteTypeKey = mkPreludeMiscIdUnique 421 quoteTypeKey = mkPreludeMiscIdUnique 421
-- data RuleBndr = ...
ruleVarIdKey, typedRuleVarIdKey :: Unique
ruleVarIdKey = mkPreludeMiscIdUnique 422
typedRuleVarIdKey = mkPreludeMiscIdUnique 423
...@@ -49,7 +49,7 @@ Library ...@@ -49,7 +49,7 @@ Library
Exposed: False Exposed: False
Build-Depends: base >= 4 && < 5, Build-Depends: base >= 4 && < 5,
directory >= 1 && < 1.2, directory >= 1 && < 1.3,
process >= 1 && < 1.2, process >= 1 && < 1.2,
bytestring >= 0.9 && < 0.11, bytestring >= 0.9 && < 0.11,
time < 1.5, time < 1.5,
......
...@@ -749,7 +749,7 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do ...@@ -749,7 +749,7 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
-- In such case, we return a best approximation: -- In such case, we return a best approximation:
-- ignore the unpointed args, and recover the pointeds -- ignore the unpointed args, and recover the pointeds
-- This preserves laziness, and should be safe. -- This preserves laziness, and should be safe.
traceTR (text "Nothing" <+> ppr dcname) traceTR (text "Not constructor" <+> ppr dcname)
let dflags = hsc_dflags hsc_env let dflags = hsc_dflags hsc_env
tag = showPpr dflags dcname tag = showPpr dflags dcname
vars <- replicateM (length$ elems$ ptrs clos) vars <- replicateM (length$ elems$ ptrs clos)
...@@ -758,7 +758,7 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do ...@@ -758,7 +758,7 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
| (i, tv) <- zip [0..] vars] | (i, tv) <- zip [0..] vars]
return (Term my_ty (Left ('<' : tag ++ ">")) a subTerms) return (Term my_ty (Left ('<' : tag ++ ">")) a subTerms)
Just dc -> do Just dc -> do
traceTR (text "Just" <+> ppr dc) traceTR (text "Is constructor" <+> (ppr dc $$ ppr my_ty))
subTtypes <- getDataConArgTys dc my_ty subTtypes <- getDataConArgTys dc my_ty
subTerms <- extractSubTerms (\ty -> go (pred max_depth) ty ty) clos subTtypes subTerms <- extractSubTerms (\ty -> go (pred max_depth) ty ty) clos subTtypes
return (Term my_ty (Right dc) a subTerms) return (Term my_ty (Right dc) a subTerms)
...@@ -936,14 +936,16 @@ getDataConArgTys :: DataCon -> Type -> TR [Type] ...@@ -936,14 +936,16 @@ getDataConArgTys :: DataCon -> Type -> TR [Type]
-- not be fully known. Moreover, the arg types might involve existentials; -- not be fully known. Moreover, the arg types might involve existentials;
-- if so, make up fresh RTTI type variables for them -- if so, make up fresh RTTI type variables for them
getDataConArgTys dc con_app_ty getDataConArgTys dc con_app_ty
= do { (_, ex_tys, _) <- instTyVars ex_tvs = do { (_, ex_tys, ex_subst) <- instTyVars ex_tvs
; let UnaryRep rep_con_app_ty = repType con_app_ty ; let UnaryRep rep_con_app_ty = repType con_app_ty
; traceTR (text "getDataConArgTys 1" <+> (ppr con_app_ty $$ ppr rep_con_app_ty))
; ty_args <- case tcSplitTyConApp_maybe rep_con_app_ty of ; ty_args <- case tcSplitTyConApp_maybe rep_con_app_ty of
Just (tc, ty_args) | dataConTyCon dc == tc Just (tc, ty_args) | dataConTyCon dc == tc
-> ASSERT( univ_tvs `equalLength` ty_args) -> ASSERT( univ_tvs `equalLength` ty_args)
return ty_args return ty_args
_ -> do { (_, ty_args, subst) <- instTyVars univ_tvs _ -> do { (_, ty_args, univ_subst) <- instTyVars univ_tvs
; let res_ty = substTy subst (dataConOrigResTy dc) ; let res_ty = substTy ex_subst (substTy univ_subst (dataConOrigResTy dc))
-- See Note [Constructor arg types]
; addConstraint rep_con_app_ty res_ty ; addConstraint rep_con_app_ty res_ty
; return ty_args } ; return ty_args }
-- It is necessary to check dataConTyCon dc == tc -- It is necessary to check dataConTyCon dc == tc
...@@ -951,11 +953,38 @@ getDataConArgTys dc con_app_ty ...@@ -951,11 +953,38 @@ getDataConArgTys dc con_app_ty
-- newtype and tcSplitTyConApp has not removed it. In -- newtype and tcSplitTyConApp has not removed it. In
-- that case, we happily give up and don't match -- that case, we happily give up and don't match
; let subst = zipTopTvSubst (univ_tvs ++ ex_tvs) (ty_args ++ ex_tys) ; let subst = zipTopTvSubst (univ_tvs ++ ex_tvs) (ty_args ++ ex_tys)
; traceTR (text "getDataConArgTys 2" <+> (ppr rep_con_app_ty $$ ppr ty_args $$ ppr subst))
; return (substTys subst (dataConRepArgTys dc)) } ; return (substTys subst (dataConRepArgTys dc)) }
where where
univ_tvs = dataConUnivTyVars dc univ_tvs = dataConUnivTyVars dc
ex_tvs = dataConExTyVars dc ex_tvs = dataConExTyVars dc
{- Note [Constructor arg types]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider a GADT (cf Trac #7386)
data family D a b
data instance D [a] b where
MkT :: b -> D [a] (Maybe b)
In getDataConArgTys
* con_app_ty is the known type (from outside) of the constructor application,
say D [Int] Bool
* The data constructor MkT has a (representation) dataConTyCon = DList,
say where
data DList a b where
MkT :: b -> DList a (Maybe b)
So the dataConTyCon of the data constructor, DList, differs from
the "outside" type, D. So we can't straightforwardly decompose the
"outside" type, and we end up in the "_" branch of the case.
Then we match the dataConOrigResTy of the data constructor against the
outside type, hoping to get a substituion that tells how to instantiate
the *representation* type constructor. This looks a bit delicate to
me, but it seems to work.
-}
-- Soundness checks -- Soundness checks
-------------------- --------------------
{- {-
......
...@@ -157,8 +157,7 @@ cvtDec (TH.InfixD fx nm) ...@@ -157,8 +157,7 @@ cvtDec (TH.InfixD fx nm)
; returnL (Hs.SigD (FixSig (FixitySig nm' (cvtFixity fx)))) } ; returnL (Hs.SigD (FixSig (FixitySig nm' (cvtFixity fx)))) }
cvtDec (PragmaD prag) cvtDec (PragmaD prag)
= do { prag' <- cvtPragmaD prag = cvtPragmaD prag
; returnL $ Hs.SigD prag' }
cvtDec (TySynD tc tvs rhs) cvtDec (TySynD tc tvs rhs)
= do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs = do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs
...@@ -410,38 +409,69 @@ cvt_conv TH.StdCall = StdCallConv ...@@ -410,38 +409,69 @@ cvt_conv TH.StdCall = StdCallConv
-- Pragmas -- Pragmas
------------------------------------------ ------------------------------------------
cvtPragmaD :: Pragma -> CvtM (Sig RdrName) cvtPragmaD :: Pragma -> CvtM (LHsDecl RdrName)
cvtPragmaD (InlineP nm ispec) cvtPragmaD (InlineP nm inline rm phases)
= do { nm' <- vNameL nm = do { nm' <- vNameL nm
; return $ InlineSig nm' (cvtInlineSpec (Just ispec)) } ; let dflt = dfltActivation inline
; let ip = InlinePragma { inl_inline = cvtInline inline
cvtPragmaD (SpecialiseP nm ty opt_ispec) , inl_rule = cvtRuleMatch rm
, inl_act = cvtPhases phases dflt
, inl_sat = Nothing }
; returnL $ Hs.SigD $ InlineSig nm' ip }
cvtPragmaD (SpecialiseP nm ty inline phases)
= do { nm' <- vNameL nm = do { nm' <- vNameL nm
; ty' <- cvtType ty ; ty' <- cvtType ty
; return $ SpecSig nm' ty' (cvtInlineSpec opt_ispec) } ; let (inline', dflt) = case inline of
Just inline1 -> (cvtInline inline1, dfltActivation inline1)
cvtInlineSpec :: Maybe TH.InlineSpec -> Hs.InlinePragma Nothing -> (EmptyInlineSpec, AlwaysActive)
cvtInlineSpec Nothing ; let ip = InlinePragma { inl_inline = inline'
= defaultInlinePragma , inl_rule = Hs.FunLike
cvtInlineSpec (Just (TH.InlineSpec inline conlike opt_activation)) , inl_act = cvtPhases phases dflt
= InlinePragma { inl_act = opt_activation', inl_rule = matchinfo , inl_sat = Nothing }
, inl_inline = inl_spec, inl_sat = Nothing } ; returnL $ Hs.SigD $ SpecSig nm' ty' ip }
where
matchinfo = cvtRuleMatchInfo conlike cvtPragmaD (SpecialiseInstP ty)
opt_activation' = cvtActivation opt_activation = do { ty' <- cvtType ty
; returnL $ Hs.SigD $ SpecInstSig ty' }
cvtRuleMatchInfo False = FunLike
cvtRuleMatchInfo True = ConLike cvtPragmaD (RuleP nm bndrs lhs rhs phases)
= do { let nm' = mkFastString nm
inl_spec = case inline of ; let act = cvtPhases phases AlwaysActive
TH.NoInline -> Hs.NoInline ; bndrs' <- mapM cvtRuleBndr bndrs
TH.Inline -> Hs.Inline ; lhs' <- cvtl lhs
TH.Inlinable -> Hs.Inlinable ; rhs' <- cvtl rhs
; returnL $ Hs.RuleD $ HsRule nm' act bndrs'
lhs' placeHolderNames
rhs' placeHolderNames
}
cvtActivation Nothing | inline == TH.NoInline = NeverActive dfltActivation :: TH.Inline -> Activation
| otherwise = AlwaysActive dfltActivation TH.NoInline = NeverActive
cvtActivation (Just (False, phase)) = ActiveBefore phase dfltActivation _ = AlwaysActive
cvtActivation (Just (True , phase)) = ActiveAfter phase
cvtInline :: TH.Inline -> Hs.InlineSpec
cvtInline TH.NoInline = Hs.NoInline
cvtInline TH.Inline = Hs.Inline
cvtInline TH.Inlinable = Hs.Inlinable
cvtRuleMatch :: TH.RuleMatch -> RuleMatchInfo
cvtRuleMatch TH.ConLike = Hs.ConLike
cvtRuleMatch TH.FunLike = Hs.FunLike
cvtPhases :: TH.Phases -> Activation -> Activation
cvtPhases AllPhases dflt = dflt
cvtPhases (FromPhase i) _ = ActiveAfter i
cvtPhases (BeforePhase i) _ = ActiveBefore i
cvtRuleBndr :: TH.RuleBndr -> CvtM (Hs.RuleBndr RdrName)
cvtRuleBndr (RuleVar n)
= do { n' <- vNameL n
; return $ Hs.RuleBndr n' }
cvtRuleBndr (TypedRuleVar n ty)
= do { n' <- vNameL n
; ty' <- cvtType ty
; return $ Hs.RuleBndrSig n' $ mkHsWithBndrs ty' }
--------------------------------------------------- ---------------------------------------------------
-- Declarations -- Declarations
......
...@@ -573,22 +573,6 @@ Check if signatures overlap; this is used when checking for duplicate ...@@ -573,22 +573,6 @@ Check if signatures overlap; this is used when checking for duplicate
signatures. Since some of the signatures contain a list of names, testing for signatures. Since some of the signatures contain a list of names, testing for
equality is not enough -- we have to check if they overlap. equality is not enough -- we have to check if they overlap.
\begin{code}
overlapHsSig :: Eq a => LSig a -> LSig a -> Bool
overlapHsSig sig1 sig2 = case (unLoc sig1, unLoc sig2) of
(FixSig (FixitySig n1 _), FixSig (FixitySig n2 _)) -> unLoc n1 == unLoc n2
(IdSig n1, IdSig n2) -> n1 == n2
(TypeSig ns1 _, TypeSig ns2 _) -> ns1 `overlaps_with` ns2
(GenericSig ns1 _, GenericSig ns2 _) -> ns1 `overlaps_with` ns2
(InlineSig n1 _, InlineSig n2 _) -> unLoc n1 == unLoc n2
-- For specialisations, we don't have equality over HsType, so it's not
-- convenient to spot duplicate specialisations here. Check for this later,
-- when we're in Type land
(_other1, _other2) -> False
where
ns1 `overlaps_with` ns2 = not (null (intersect (map unLoc ns1) (map unLoc ns2)))
\end{code}
\begin{code} \begin{code}
instance (OutputableBndr name) => Outputable (Sig name) where instance (OutputableBndr name) => Outputable (Sig name) where
ppr sig = ppr_sig sig ppr sig = ppr_sig sig
......
...@@ -24,6 +24,7 @@ module IfaceSyn ( ...@@ -24,6 +24,7 @@ module IfaceSyn (
-- Misc -- Misc
ifaceDeclImplicitBndrs, visibleIfConDecls, ifaceDeclImplicitBndrs, visibleIfConDecls,
ifaceDeclFingerprints,
-- Free Names -- Free Names
freeNamesIfDecl, freeNamesIfRule, freeNamesIfFamInst, freeNamesIfDecl, freeNamesIfRule, freeNamesIfFamInst,
...@@ -51,6 +52,10 @@ import Outputable ...@@ -51,6 +52,10 @@ import Outputable
import FastString import FastString
import Module import Module
import TysWiredIn ( eqTyConName ) import TysWiredIn ( eqTyConName )
import Fingerprint
import Binary
import GHC.IO (unsafeDupablePerformIO)
infixl 3 &&& infixl 3 &&&
\end{code} \end{code}
...@@ -448,6 +453,23 @@ ifaceDeclImplicitBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_tc_occ, ...@@ -448,6 +453,23 @@ ifaceDeclImplicitBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_tc_occ,
ifaceDeclImplicitBndrs _ = [] ifaceDeclImplicitBndrs _ = []
-- -----------------------------------------------------------------------------
-- The fingerprints of an IfaceDecl
-- We better give each name bound by the declaration a
-- different fingerprint! So we calculate the fingerprint of
-- each binder by combining the fingerprint of the whole
-- declaration with the name of the binder. (#5614, #7215)
ifaceDeclFingerprints :: Fingerprint -> IfaceDecl -> [(OccName,Fingerprint)]
ifaceDeclFingerprints hash decl
= (ifName decl, hash) :
[ (occ, computeFingerprint' (hash,occ))
| occ <- ifaceDeclImplicitBndrs decl ]
where
computeFingerprint' =
unsafeDupablePerformIO
. computeFingerprint (panic "ifaceDeclFingerprints")
----------------------------- Printing IfaceDecl ------------------------------ ----------------------------- Printing IfaceDecl ------------------------------
instance Outputable IfaceDecl where instance Outputable IfaceDecl where
......
...@@ -195,7 +195,7 @@ pprParendIfaceType = ppr_ty tYCON_PREC ...@@ -195,7 +195,7 @@ pprParendIfaceType = ppr_ty tYCON_PREC
isIfacePredTy :: IfaceType -> Bool isIfacePredTy :: IfaceType -> Bool
isIfacePredTy _ = False isIfacePredTy _ = False
-- FIXME: fix this to print iface pred tys correctly -- FIXME: fix this to print iface pred tys correctly
-- isIfacePredTy ty = ifaceTypeKind ty `eqKind` constraintKind -- isIfacePredTy ty = isConstraintKind (ifaceTypeKind ty)
ppr_ty :: Int -> IfaceType -> SDoc ppr_ty :: Int -> IfaceType -> SDoc
ppr_ty _ (IfaceTyVar tyvar) = ppr tyvar ppr_ty _ (IfaceTyVar tyvar) = ppr tyvar
......
...@@ -530,25 +530,12 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls ...@@ -530,25 +530,12 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls
-- to assign fingerprints to all the OccNames that it binds, to -- to assign fingerprints to all the OccNames that it binds, to
-- use when referencing those OccNames in later declarations. -- use when referencing those OccNames in later declarations.
-- --
-- We better give each name bound by the declaration a
-- different fingerprint! So we calculate the fingerprint of
-- each binder by combining the fingerprint of the whole
-- declaration with the name of the binder. (#5614)
extend_hash_env :: OccEnv (OccName,Fingerprint) extend_hash_env :: OccEnv (OccName,Fingerprint)
-> (Fingerprint,IfaceDecl) -> (Fingerprint,IfaceDecl)
-> IO (OccEnv (OccName,Fingerprint)) -> IO (OccEnv (OccName,Fingerprint))
extend_hash_env env0 (hash,d) = do extend_hash_env env0 (hash,d) = do
let return (foldr (\(b,fp) env -> extendOccEnv env b (b,fp)) env0
sub_bndrs = ifaceDeclImplicitBndrs d (ifaceDeclFingerprints hash d))
fp_sub_bndr occ = computeFingerprint putNameLiterally (hash,occ)
--
sub_fps <- mapM fp_sub_bndr sub_bndrs
return (foldr (\(b,fp) env -> extendOccEnv env b (b,fp)) env1
(zip sub_bndrs sub_fps))
where
decl_name = ifName d
item = (decl_name, hash)
env1 = extendOccEnv env0 decl_name item
-- --
(local_env, decls_w_hashes) <- (local_env, decls_w_hashes) <-
...@@ -1498,8 +1485,12 @@ tyConToIfaceDecl env tycon ...@@ -1498,8 +1485,12 @@ tyConToIfaceDecl env tycon
(syn_rhs, syn_ki) (syn_rhs, syn_ki)
= case synTyConRhs tycon of = case synTyConRhs tycon of
SynFamilyTyCon -> (Nothing, tidyToIfaceType env1 (synTyConResKind tycon)) SynFamilyTyCon ->
SynonymTyCon ty -> (Just (toIfaceType ty), tidyToIfaceType env1 (typeKind ty)) ( Nothing
, tidyToIfaceType env1 (synTyConResKind tycon) )
SynonymTyCon ty ->
( Just (tidyToIfaceType env1 ty)
, tidyToIfaceType env1 (typeKind ty) )
ifaceConDecls (NewTyCon { data_con = con }) = IfNewTyCon (ifaceConDecl con) ifaceConDecls (NewTyCon { data_con = con }) = IfNewTyCon (ifaceConDecl con)
ifaceConDecls (DataTyCon { data_cons = cons }) = IfDataTyCon (map ifaceConDecl cons) ifaceConDecls (DataTyCon { data_cons = cons }) = IfDataTyCon (map ifaceConDecl cons)
...@@ -1517,16 +1508,19 @@ tyConToIfaceDecl env tycon ...@@ -1517,16 +1508,19 @@ tyConToIfaceDecl env tycon
ifConUnivTvs = toIfaceTvBndrs univ_tvs', ifConUnivTvs = toIfaceTvBndrs univ_tvs',
ifConExTvs = toIfaceTvBndrs ex_tvs', ifConExTvs = toIfaceTvBndrs ex_tvs',
ifConEqSpec = to_eq_spec eq_spec, ifConEqSpec = to_eq_spec eq_spec,
ifConCtxt = tidyToIfaceContext env3 theta, ifConCtxt = tidyToIfaceContext env2 theta,
ifConArgTys = map (tidyToIfaceType env3) arg_tys, ifConArgTys = map (tidyToIfaceType env2) arg_tys,
ifConFields = map getOccName ifConFields = map getOccName
(dataConFieldLabels data_con), (dataConFieldLabels data_con),
ifConStricts = dataConStrictMarks data_con } ifConStricts = dataConStrictMarks data_con }
where where
(univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _) = dataConFullSig data_con (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _) = dataConFullSig data_con
(env2, univ_tvs') = tidyTyClTyVarBndrs env1 univ_tvs
(env3, ex_tvs') = tidyTyVarBndrs env2 ex_tvs -- Start with 'emptyTidyEnv' not 'env1', because the type of the
to_eq_spec spec = [ (getOccName (tidyTyVar env3 tv), tidyToIfaceType env3 ty) -- data constructor is fully standalone
(env1, univ_tvs') = tidyTyVarBndrs emptyTidyEnv univ_tvs
(env2, ex_tvs') = tidyTyVarBndrs env1 ex_tvs
to_eq_spec spec = [ (getOccName (tidyTyVar env2 tv), tidyToIfaceType env2 ty)
| (tv,ty) <- spec] | (tv,ty) <- spec]
......