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
  • MTaimoorZaeem/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
651 results
Show changes
Showing
with 6738 additions and 24 deletions
{-# LANGUAGE GADTs, RankNTypes, GeneralizedNewtypeDeriving #-}
module Supercompile.Drive.Process2 (supercompile) where
import Supercompile.Drive.Match
import Supercompile.Drive.Split
import Supercompile.Drive.Process
import Supercompile.Core.FreeVars
import Supercompile.Core.Renaming
import Supercompile.Core.Syntax
import Supercompile.Core.Tag
import Supercompile.Evaluator.Deeds
import Supercompile.Evaluator.Residualise
import Supercompile.Evaluator.Syntax
import Supercompile.Termination.TagBag (stateTags)
import Supercompile.Termination.Combinators
import Supercompile.Utilities
import Id (mkLocalId)
import Name (Name, mkSystemVarName)
import FastString (mkFastString)
import qualified State as State
import qualified Data.Map as M
import Data.Monoid (mempty)
data LeafTy a
data DelayStructure sh f where
Leaf :: f a -> DelayStructure (LeafTy a) f
Branch :: DelayStructure sh1 f -> DelayStructure sh2 f -> DelayStructure (sh1, sh2) f
--newtype I a = I { unI :: a }
newtype QM m a = QM { unQM :: m (DelayM m a) }
-- If you don't want DelayM to have Monad structure, you can nuke the nested use of DelayM,
-- and make some of the consumers simpler. I actually want this generalisation, though.
data DelayM m r = Done r
| forall sh. Delayed (DelayStructure sh (QM m)) (DelayStructure sh Identity -> DelayM m r)
instance Functor (DelayM m) where
fmap f x = pure f <*> x
instance Applicative (DelayM m) where
pure = return
Done f <*> Done x = Done (f x)
Delayed qs k <*> Done x = Delayed qs (\as -> k as <*> Done x)
Done f <*> Delayed qs k = Delayed qs (\as -> Done f <*> k as)
Delayed qs1 k1 <*> Delayed qs2 k2 = Delayed (Branch qs1 qs2) (\(Branch as1 as2) -> k1 as1 <*> k2 as2)
instance Monad (DelayM m) where
return = Done
Done x >>= fxmy = fxmy x
Delayed qs k >>= fxmy = Delayed qs (\as -> k as >>= fxmy)
delay :: m (DelayM m a) -> DelayM m a
delay q = Delayed (Leaf (QM q)) (\(Leaf (I a)) -> pure a)
runDelayM :: (Applicative m, Monad m)
=> (DelayM m r -> DelayM m r) -- ^ Chooses the evaluation strategy
-> DelayM m r -> m r
runDelayM choose_some = go
where
go = go' . choose_some
go' (Done x) = pure x
go' (Delayed qs k) = mungeDS qs >>= \mx -> go (mx >>= k)
fmapNT :: Applicative m
=> (forall a. f a -> m (g a))
-> DelayStructure sh f
-> m (DelayStructure sh g)
fmapNT f (Leaf x) = fmap Leaf (f x)
fmapNT f (Branch qs1 qs2) = liftA2 Branch (fmapNT f qs1) (fmapNT f qs2)
mungeDS :: Applicative n
=> DelayStructure sh (QM n)
-> n (DelayM n (DelayStructure sh Identity))
mungeDS = unComp . fmapNT (Comp . fmap (fmap I) . unQM)
{-
mungeDS (Leaf (QM mx)) = fmap (fmap (Leaf . I)) mx
mungeDS (Branch qs1 qs2) = liftA2 (liftA2 Branch) (mungeDS qs1) (mungeDS qs2)
-}
delayDS :: DelayStructure sh (QM n)
-> DelayM n (DelayStructure sh Identity)
delayDS = fmapNT (fmap I . delay . unQM)
{-
delayDS (Leaf (QM mx)) = fmap (Leaf . I) (delay mx)
delayDS (Branch qs1 qs2) = liftA2 Branch (delayDS qs1) (delayDS qs2)
-}
depthFirst :: DelayM m r -> DelayM m r
depthFirst (Done x) = Done x
depthFirst (Delayed qs k) = delayTail qs >>= k
where
delayTail :: DelayStructure sh (QM m) -> DelayM m (DelayStructure sh Identity)
delayTail (Leaf (QM q)) = fmap (Leaf . I) (delay q)
delayTail (Branch qs1 qs2) = liftM2 Branch (delayTail qs1) (delayDS qs2)
breadthFirst :: DelayM m r -> DelayM m r
breadthFirst = id
delayStateT :: Functor m
=> (forall a. m (n a) -> n a)
-> m (StateT s n a) -> StateT s n a
delayStateT delay mx = StateT $ \s -> delay (fmap (($ s) . unStateT) mx)
{-
-- NB: you can't implement this for all monad transformers
-- (in particular the continuation monad transformer).
-- But if you can, we can derive a delayStateT equivalent from it:
fiddle :: (forall b. m b -> n b)
-> StateT s m a -> StateT s n a
fiddle f mx = ST $ \s -> f (unStateT mx s)
lifty :: Monad m => m a -> DelayM m a
lifty = delay . liftM return
mx :: m (StateT s (DelayM m) a)
liftStateT mx :: StateT s m (StateT s (DelayM m) a)
fiddle lifty :: forall a. Monad m => StateT s m a -> StateT s (DelayM m) a
fiddle lifty (liftStateT mx) :: Monad m => StateT s (DelayM m) (StateT s (DelayM m) a)
join (fiddle lifty (liftStateT mx)) :: Monad m => StateT s (DelayM m) a
Therefore:
delayStateT :: Monad m => m (StateT s (DelayM m) a) -> StateT s (DelayM m) a
delayStateT = join . fiddle lifty . liftStateT
-}
delayContT :: Functor m
=> (forall a. m (n a) -> n a)
-> m (ContT r n b) -> ContT r n b
delayContT delay mx = ContT $ \k -> delay (fmap (flip unContT k) mx)
callCCish :: (Applicative n, Applicative m) => ((b -> a -> ContT (n r) m b) -> ContT (n r) m a) -> ContT (n r) m a
callCCish f = ContT $ \k -> unContT (f (\b a -> ContT $ \k' -> liftA2 (*>) (k' b) (k a))) k
delayReaderT :: Functor m
=> (forall a. m (n a) -> n a)
-> m (ReaderT r n a) -> ReaderT r n a
delayReaderT delay mx = ReaderT $ \r -> delay (fmap (($ r) . unReaderT) mx)
liftCallCCReaderT :: (((forall b. a -> m b) -> m a) -> m a)
-> ((forall b. a -> ReaderT r m b) -> ReaderT r m a) -> ReaderT r m a
liftCallCCReaderT call_cc f = ReaderT $ \r -> call_cc $ \c -> runReaderT r (f (ReaderT . const . c))
newtype RollbackScpM = RB { doRB :: LevelM (Deeds, Out FVedTerm) -> LevelM (Deeds, Out FVedTerm) -> ProcessM (LevelM (Deeds, Out FVedTerm)) }
type ProcessHistory = GraphicalHistory (NodeKey, (State, RollbackScpM)) -- TODO: GraphicalHistory
pROCESS_HISTORY :: ProcessHistory
pROCESS_HISTORY = mkGraphicalHistory (cofmap fst wQO)
type HistoryEnvM = (->) ProcessHistory
runHistoryEnvM :: HistoryEnvM a -> a
runHistoryEnvM = flip ($) pROCESS_HISTORY
type HistoryThreadM = State.State ProcessHistory
withHistory :: (ProcessHistory -> (ProcessHistory, a)) -> HistoryThreadM a
withHistory f = State.state (swap . f)
where swap = uncurry (flip (,))
runHistoryThreadM :: HistoryThreadM a -> a
runHistoryThreadM = flip State.evalState pROCESS_HISTORY
type Parent = NodeKey
terminateM :: Parent -> State -> RollbackScpM -> (Parent -> a) -> (Parent -> State -> RollbackScpM -> ProcessM a) -> ProcessM a
terminateM parent state rb k_continue k_stop = withHistory' $ \hist -> trace (show hist) $ case terminate hist (parent, (state, rb)) of
Continue hist' -> return (hist', k_continue (generatedKey hist'))
Stop (shallow_parent, (shallow_state, shallow_rb)) -> liftM ((,) hist) $ k_stop shallow_parent shallow_state shallow_rb
where
withHistory' :: (ProcessHistory -> ProcessM (ProcessHistory, a)) -> ProcessM a
withHistory' act = lift (lift State.get) >>= \hist -> act hist >>= \(hist', x) -> lift (lift (State.put hist')) >> return x
data Promise = P {
fun :: Var, -- Name assigned in output program
abstracted :: [AbsVar], -- Abstracted over these variables
meaning :: State -- Minimum adequate term
}
data MemoState = MS {
promises :: [Promise],
hNames :: Stream Name
}
type MemoT = StateT MemoState
runMemoT :: Functor m => MemoT m a -> m a
runMemoT mx = fmap fst $ unStateT mx MS { promises = [], hNames = h_names }
where h_names = listToStream $ zipWith (\i uniq -> mkSystemVarName uniq (mkFastString ('h' : show (i :: Int))))
[1..] (uniqsFromSupply hFunctionsUniqSupply)
newtype FulfilmentState = FS {
fulfilments :: M.Map Var FVedTerm
}
type FulfilmentT = StateT FulfilmentState
fulfill :: Monad m => Promise -> (Deeds, FVedTerm) -> FulfilmentT m (Deeds, FVedTerm)
fulfill p (deeds, e_body) = StateT $ \fs ->
let fs' | fun p `M.member` fulfilments fs = fs
| otherwise = FS { fulfilments = M.insert (fun p) (absVarLambdas (abstracted p) e_body) (fulfilments fs) }
in return ((deeds, applyAbsVars (fun p) Nothing (abstracted p)), fs')
runFulfilmentT :: Monad m => FulfilmentT m FVedTerm -> m FVedTerm
runFulfilmentT mx = liftM (\(e, fs) -> letRec (M.toList (fulfilments fs)) e) $ unStateT mx (FS { fulfilments = M.empty })
promise :: State -> MemoState -> (Promise, MemoState)
promise state ms = (p, ms')
where (vs_list, h_ty) = stateAbsVars Nothing state
h_name :< h_names' = hNames ms
x = mkLocalId h_name h_ty
p = P {
fun = x,
abstracted = vs_list,
meaning = state
}
ms' = MS {
promises = p : promises ms,
hNames = h_names'
}
instance MonadStatics LevelM where
--bindCapturedFloats fvs mx | isEmptyVarSet fvs = liftM ((,) []) mx
-- | otherwise = pprPanic "bindCapturedFloats: does not support statics" (ppr fvs)
bindCapturedFloats _fvs mx = liftM ((,) []) mx -- FIXME: do something other than hope for the best
monitorFVs = liftM ((,) emptyVarSet)
memo :: (MonadTrans t1, Monad (t1 (MemoT t2)), Applicative t2, Monad t2)
=> (State -> t1 (MemoT t2) (LevelM (Deeds, Out FVedTerm)))
-> State -> t1 (MemoT t2) (LevelM (Deeds, Out FVedTerm))
memo opt state = do
mb_res <- lift $ StateT $ \ms ->
-- NB: If tb contains a dead PureHeap binding (hopefully impossible) then it may have a free variable that
-- I can't rename, so "rename" will cause an error. Not observed in practice yet.
case [ (p, (releaseStateDeed state, applyAbsVars (fun p) (Just (mkRenaming rn_lr)) (abstracted p)))
| p <- promises ms
, Just rn_lr <- [(\res -> if isNothing res then pprTraceSC "no match:" (ppr (fun p)) res else res) $
match (meaning p) state]
] of (p, res):_ -> pure (Right (do { traceRenderScpM "=sc" (fun p, PrettyDoc (pPrintFullState fullStatePrettiness state), res)
; return res }), ms)
_ -> pure (Left p, ms')
where (p, ms') = promise state ms
case mb_res of
Right res -> return res
Left p -> flip liftM (opt state) $ \mres ->
(do { traceRenderScpM ">sc" (fun p, PrettyDoc (pPrintFullState quietStatePrettiness state))
; res <- mres
; traceRenderScpM "<sc" (fun p, PrettyDoc (pPrintFullState quietStatePrettiness state), res)
; fulfill p res })
type SpecT = ReaderT AlreadySpeculated
runSpecT :: SpecT m a -> m a
runSpecT = runReaderT nothingSpeculated
speculated :: State -> (State -> SpecT m a) -> SpecT m a
speculated s k = ReaderT $ \already -> case speculate already (mempty, s) of (already, (_stats, s')) -> unReaderT (k s') already
liftSpeculatedStateT :: (forall a. State -> (State -> m a) -> m a)
-> State -> (State -> StateT s m a) -> StateT s m a
liftSpeculatedStateT speculated state k = StateT $ \s -> speculated state (\state' -> unStateT (k state') s)
type LevelM = FulfilmentT (SpecT ScpM)
-- NB: monads *within* the ContT are persistent over a rollback. Ones outside get reset.
type ProcessM = ContT (FulfilmentT Identity (Out FVedTerm)) (MemoT HistoryThreadM)
type ScpM = DelayM ProcessM
traceRenderScpM :: (Outputable a, Applicative t) => String -> a -> t ()
traceRenderScpM msg x = pprTraceSC msg (pPrint x) $ pure () -- TODO: include depth, refine to ScpM monad only
runScpM :: (Applicative m, Monad m) => m (DelayM m a) -> m a
runScpM mx = mx >>= runDelayM eval_strat
where
-- Doing things this way prevents GHC bleating about depthFirst being unused
eval_strat | False = depthFirst
| otherwise = breadthFirst
-- callCC :: ((forall b. a -> ContT r m b) -> ContT r m a) -> ContT r m a
-- callCC f = ContT $ \k -> unContT (f (\a -> ContT $ \_k -> k a)) k
-- newtype ContT r m a = ContT { unContT :: (a -> m r) -> m r }
sc' :: Parent -> State -> ProcessM (LevelM (Deeds, Out FVedTerm))
sc' parent state = callCCish (\k -> try (RB k))
where
trce how shallow_state = pprTraceSC ("sc-stop(" ++ how ++ ")") (ppr (stateTags shallow_state) <+> text "<|" <+> ppr (stateTags state) $$
pPrintFullState fullStatePrettiness shallow_state $$ pPrintFullState fullStatePrettiness state)
try :: RollbackScpM -> ProcessM (LevelM (Deeds, Out FVedTerm))
try rb = terminateM parent state rb
(\parent -> liftSpeculatedStateT speculated state $ \state' -> my_split (reduce state') (sc'' parent))
-- (\_ shallow_state _ -> return $ maybe (trce "split" shallow_state $ split state) (trce "gen" shallow_state) (generalise (mK_GENERALISER shallow_state state) state) (delayStateT (delayReaderT delay) . sc parent))
(\shallow_parent shallow_state shallow_rb -> trace "rb" $ doRB shallow_rb (my_split state (sc'' parent))
(maybe (trce "split" shallow_state $ my_split shallow_state) (trce "gen" shallow_state) (my_generalise (mK_GENERALISER shallow_state state) shallow_state) (sc'' shallow_parent)))
sc'' :: Parent -> State -> LevelM (Deeds, Out FVedTerm)
sc'' parent = delayStateT (delayReaderT delay) . sc parent
my_generalise gen = liftM (\splt -> liftM (\(_, deeds, e') -> (deeds, e')) . splt) . generalise gen
my_split opt = liftM (\(_, deeds, e') -> (deeds, e')) . split opt
sc :: Parent -> State -> ProcessM (LevelM (Deeds, Out FVedTerm))
sc parent = memo (sc' parent) . gc -- Garbage collection necessary because normalisation might have made some stuff dead
foo :: LevelM (Out FVedTerm) -> ScpM (FulfilmentT Identity (Out FVedTerm))
foo = undefined
supercompile :: M.Map Var Term -> Term -> Term
supercompile unfoldings e = fVedTermToTerm $ bindManyMixedLiftedness fvedTermFreeVars to_bind $ unI $ runFulfilmentT $ runHistoryThreadM $ runMemoT $ runContT $ runScpM $ liftM (foo . fmap snd) $ sc 0 state
where (_, (to_bind, _preinit_with, state), _) = prepareTerm unfoldings e
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
module Supercompile.Evaluator.Deeds where
import Supercompile.StaticFlags
import Supercompile.Utilities
import Data.Monoid (Monoid(mappend, mempty))
-- | Number of unclaimed deeds. Invariant: always greater than or equal to 0
type Unclaimed = Int
-- | A deed supply shared amongst all expressions
data Deeds = Deeds {
sizeLimit :: {-# UNPACK #-} !Int,
stepLimit :: {-# UNPACK #-} !Int
} deriving (Eq)
instance Outputable Deeds where
ppr d = ppr (sizeLimit d, stepLimit d)
instance Monoid Deeds where
mempty = emptyDeeds
mappend = plusDeeds
instance Bounded Deeds where
maxBound = Deeds { sizeLimit = maxBound `div` 2, stepLimit = maxBound `div` 2 } -- Try to avoid overflow :-)
minBound = emptyDeeds
emptyDeeds :: Deeds
emptyDeeds = Deeds { sizeLimit = 0, stepLimit = 0 }
plusDeeds :: Deeds -> Deeds -> Deeds
plusDeeds d1 d2 = d1 `seq` d2 `seq` Deeds { sizeLimit = sizeLimit d1 + sizeLimit d2, stepLimit = stepLimit d1 + stepLimit d2 }
plusDeedss :: [Deeds] -> Deeds
plusDeedss = foldr plusDeeds emptyDeeds
claimStep :: Deeds -> Maybe Deeds
claimStep deeds = guard (stepLimit deeds > 0) >> return (deeds { stepLimit = stepLimit deeds - 1 })
-- NB: it is OK if the number of deeds to claim is negative -- that just causes some deeds to be released
claimDeeds :: Deeds -> Int -> Maybe Deeds
claimDeeds deeds want = guard (not dEEDS || sizeLimit deeds >= want) >> return (deeds { sizeLimit = sizeLimit deeds - want })
releaseDeeds :: Deeds -> Int -> Deeds
releaseDeeds deeds release = deeds { sizeLimit = sizeLimit deeds + release }
apportionDeeds :: Deeds -> [Int] -> [Deeds]
apportionDeeds deeds weights = zipWith Deeds (apportion (sizeLimit deeds) weights) (apportion (stepLimit deeds) weights)
splitDeeds :: Deeds -> [Size] -> [Deeds]
splitDeeds _ [] = error "splitDeeds: no sizes"
splitDeeds deeds (size:sizes) = case dEEDS_POLICY of
Proportional -> apportionDeeds deeds (size:sizes)
FCFS -> deeds : map (const emptyDeeds) sizes
noChange, noGain :: Deeds -> Deeds -> Bool
noChange = (==)
noGain d1 d2 = (sizeLimit d1 >= sizeLimit d2) && (stepLimit d1 >= stepLimit d2)
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
module Supercompile.Termination.Generaliser where
import Supercompile.Core.Syntax (Var)
import Supercompile.Core.Renaming (Out)
import Supercompile.Evaluator.Syntax
import Supercompile.Utilities (Nat, Tagged, tag, Tag, tagInt, injectTag, FinMap, FinSet)
import Outputable
import qualified Data.IntMap as IM
import qualified Data.IntSet as IS
data Generaliser = Generaliser {
generaliseStackFrame :: Tagged StackFrame -> Bool,
generaliseHeapBinding :: Out Var -> HeapBinding -> Bool
}
generaliseNothing :: Generaliser
generaliseNothing = Generaliser (\_ -> False) (\_ _ -> False)
generaliserFromGrowing :: (a -> FinMap Nat) -> a -> a -> Generaliser
generaliserFromGrowing extract x y | IS.null generalise_what = pprTrace "no growth" (ppr generalise_what) generaliseNothing
| otherwise = generaliserFromFinSet generalise_what
where generalise_what = IM.keysSet (IM.filter id (IM.intersectionWith (<) (extract x) (extract y)))
generaliserFromFinSet :: FinSet -> Generaliser
generaliserFromFinSet generalise_what = Generaliser {
generaliseStackFrame = \kf -> should_generalise (stackFrameTag' kf),
generaliseHeapBinding = \_ hb -> maybe False (should_generalise . pureHeapBindingTag') $ heapBindingTag hb
}
where should_generalise tg = IS.member (tagInt tg) generalise_what
{-# INLINE pureHeapBindingTag' #-}
pureHeapBindingTag' :: Tag -> Tag
pureHeapBindingTag' = injectTag 5
{-# INLINE stackFrameTag' #-}
stackFrameTag' :: Tagged StackFrame -> Tag
stackFrameTag' = injectTag 3 . tag
{-# INLINE qaTag' #-}
qaTag' :: Anned QA -> Tag
qaTag' = injectTag 2 . annedTag
This diff is collapsed.
This diff is collapsed.
Name: chsc-plugin
Version: 1.0
License: BSD3
Synopsis: A plugin for GHC that performs supercompilation.
Cabal-Version: >= 1.2
Build-Type: Simple
Author: Max Bolingbroke <batterseapower@hotmail.com>
Maintainer: Max Bolingbroke <batterseapower@hotmail.com>
Source-Repository head
type: git
location: http://darcs.haskell.org/ghc.git
branch: supercompiler
Library
Exposed-Modules:
CHSC
Other-Modules:
Supercompile.Core.FreeVars
Supercompile.Core.Renaming
Supercompile.Core.Size
Supercompile.Core.Syntax
Supercompile.Core.Tag
Supercompile.Drive.Match
Supercompile.Drive.Process
Supercompile.Drive.Split
Supercompile.Evaluator.Deeds
Supercompile.Evaluator.Evaluate
Supercompile.Evaluator.FreeVars
Supercompile.Evaluator.Residualise
Supercompile.Evaluator.Syntax
Supercompile.StaticFlags
Supercompile.Termination.Combinators
Supercompile.Termination.Generaliser
Supercompile.Termination.TagBag
Supercompile.Utilities
Supercompile
Extensions:
CPP,
PatternGuards,
ExistentialQuantification,
ScopedTypeVariables,
FlexibleInstances,
RankNTypes,
DeriveDataTypeable
Build-Depends:
base >= 4.3 && < 4.4,
containers >= 0.4 && < 0.5,
ghc >= 7.1 && < 7.2
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.