seqaid (empty) → 0.1.1
raw patch · 20 files changed
+5840/−0 lines, 20 filesdep +Cabaldep +arraydep +basesetup-changed
Dependencies added: Cabal, array, base, containers, deepseq-bounded, directory, generics-sop, ghc, hashable, hashtables, modulespection, mtl, process, regex-base, regex-pcre, syb, template-haskell, temporary, th-expand-syns
Files
- HTML/combout.html +38/−0
- HTML/extra.html +148/−0
- HTML/index.html +17/−0
- HTML/seqaid.html +394/−0
- HTML/style.css +27/−0
- HTML/style2.css +27/−0
- LICENSE +30/−0
- README +101/−0
- Seqaid/Ann.hs +99/−0
- Seqaid/Config.hs +57/−0
- Seqaid/Core.hs +1645/−0
- Seqaid/Demo.hs +43/−0
- Seqaid/Global.hs +194/−0
- Seqaid/Optim.hs +447/−0
- Seqaid/Plugin.hs +81/−0
- Seqaid/Prepro.hs +681/−0
- Seqaid/Runtime.hs +265/−0
- Seqaid/TH.hs +1244/−0
- Setup.hs +2/−0
- seqaid.cabal +300/−0
+ HTML/combout.html view
@@ -0,0 +1,38 @@+<!DOCTYPE html>+<html>+<head>+<title>Seqaid : Haskell Leak Eradicator</title>+<link rel="stylesheet" href="style.css" />+</head>+<body>++<!--div style="margin-left: 15px;">+Want to cut to the chase?<br>+See the bottom of the page for a concise <a href="#contrib">contribution statement</a>.+</div-->++<h2>Combing Out Global DeepSeq</h2>++Control.DeepSeq and related generics/TH modules are a great tool for debugging space leaks, and also a great temptation for evading them.+A common strategy is to start at a high level in leaking code (in the sense of high in the parse tree), finding a place where a forcing function will squash your leaks, and then working the forcer further down until the offending code has been discovered.+For didactic purposes, let's suppose your forcing function is deepseq.+Sometimes more than one site will have leaky code, so as the deepseq is moved down, it may have to be duplicated and branch out as well.+<p>+It would be nice to automate this process of refining the locations of deepseq.+Something simple that should work is a binary partitioning of descendant expressions, into those which propagate the deepseq, and those which do not.+Auto-recompilation and auto-profile-analysis can determine whether the change maintains leak-free behaviour, guiding the search for the smallest expressions which need forcing.+The developer may prefer to force at a higher level, in case this minimal set is highly [ramified/-?-] (high cardinality), but mostly we're interested in those expressions deepest in the parse tree that, forced, suffice to staunch the leak.++<p>++The <a href="index.html">Heaply</a> page has more info on a nascent implementation.++<p>++Andrew Seniuk 2014+<br>+<tt>rasfar@gmail.com</tt>++</body>+</html>+
+ HTML/extra.html view
@@ -0,0 +1,148 @@+<!DOCTYPE html>+<html>+<head>+<title>Seqaid : Space leak diagnostic and remedial tool - Contrived?</title>+<link rel="stylesheet" href="style.css" />+</head>+<body>+<!--body style="width: 800px;"-->++<div class="main">++<h3 style="margin-top: 50px; margin-bottom: 30px; color: #666;">+Is the <tt>leaky</tt> Example Contrived?+</h3>++Some words may be in order about where <tt>seqaid</tt> and <tt>leaky</tt> came from, and how this all fits together.+<tt>seqaid</tt> was the first of this group of projects, started in June (2014).+At that time, it was a GHC API application, and there's been a fair amount of water under the bridge since then.+In July I conceived of <tt>deepseq-bounded</tt> based on considerations while pushing <tt>seqaid</tt>.+August I was on hiatus, then finished <tt>deepseq-bounded</tt>, but wanted to see if I could plug it in to <tt>seqaid</tt> and maybe release them together.++<p>+Up till then, I'd been using <tt>Anatomy</tt> as my main space leak example, but it stopped leaking in GHC 7.8.1 (if not sooner).+<!-- hide/show+I was also unaccountably unable to get it to leak for me anymore with GHC 7.6.3, and I still don't understand...+(It's <em>not</em> a path problem this time!)+-->+I needed a good, robust space leak example to test my work on.++<p>+At the same time, I was dissatisfied with <tt>seqaid</tt> as a GHC API executable, because I wanted something more seamless to the user, like GHC plugins.+So I foolishly went down a very deep rabbit hole to re-write <tt>seqaid</tt> as a GHC plugin, which finally was only possible by also using Template Haskell <em>and</em> a text-level (regex) pre-processor (GHC -F option).+It is seamless to the user, but the code is quite a bit less elegant than the GHC API executable.+(Which wasn't elegant to begin with.)+<!-- hide/show+In retrospect I should have spent that effort making the GHC API executable work as a stand-in for GHC, so in your project .cabal file you'd specify seqaid as an alternative compiler.+Oh well.+Probably discussion will help decide the best future course.+-->+I don't regret learning TH and Core, and the several other things learned on this adventure.+But I would not recommend programming in Core unless you really need to, or you know (really know) that what you need to do is well-supported that late in the compilation pipeline.++<p>+So, I was making adventures into GHC plugins, and I needed a dependable leak example.+<!-- hide/show+I guess that was September.+September/October was a bit disrupted, as I moved across the country, but then had a funeral to return for.+-->+What I did was take my most recent GHC (7.8.1), and try to write a small program that exhibited a space leak, because I didn't have a single small example, although I have numerous large ones. :)+I documented this process (I always keep a play-by-play text file with any project or subproject), but I won't review it now.+Suffice it to say, <tt>leaky</tt> was designed to "resemble a real-world program" (in the choice of data types, and in the "steady-state, long-running" behaviour, with state-to-state evolution).+I didn't rest until I had it leaking with GHC 7.8.1 under -O2, even with all strict fields in the data structures.+(It still leaks in 7.8.3.)++<p>+During that battle of wits with the compiler, I wasn't really thinking about <tt>deepseq-bounded</tt> or <tt>seqaid</tt>, so the leak example was not contrived with these tools in mind (although they already existed, particularly <tt>deepseq-bounded</tt> which was finished).++<p>+Now that I had a leak example, I was ready to test my leak-plugging tools.+I added a deep list to the state, so that while <tt>NFData.force</tt> could be used to plug the leak, it incurred an arbitrarily-large performance hit.+In this respect, there was some contrivance, as I wanted to show how <tt>NFDataN</tt> could outperform <tt>NFData</tt> when used in a similar manner.+Then of course I wanted to show how <tt>NFDataP</tt> could outperform them both.+I adorned the state with some large strict blobs, which <tt>NFDataN</tt> cannot avoid, but <tt>NFDataP</tt> can.+The optimal forcing pattern used with <tt>NFDataP</tt> was hand-written.+To date, the optimiser part of <tt>seqaid</tt> is planned but still unimplemented.++<p>+I think the example is valid (realistic), notwithstanding these "contrivances".+There hasn't been time yet to put the new tools to work on my real projects.+<tt>seqaid</tt> in particular is just breaking out of its shell.+I'll be reporting progress as it becomes feasible.++<p>+The following shows the output of <tt>seqaid</tt> with <tt>leaky</tt>.+It is also a wee bit contrived, as I sweep <tt>NFDataN</tt> <tt>n</tt> value to a fixed depth, and then the fixed (hand-optimised) pattern is developed by replaying iterated <tt>shrinkPat</tt> in reverse.+But it does summarise the results nicely.++<p>+Using <tt>NFDataN.forcen</tt> <em>N</em>:+<pre>+ live alloc type+ N 0 357828 3350236 TA+ N 1 686376 3316512 TA+ N 2 909104 4942636 TA+ N 3 1121052 4979364 TA+ N 4 1301872 5560432 TA+ N 5 1609760 53440684 TA+ N 6 151460 54431296 TA+ N 7 139240 53374284 TA+ N 8 129440 53405380 TA+</pre>+<p>+Using <tt>NFDataP.forcep</tt> <em>P</em>:+<pre>+ live alloc type+ P . 457296 3341600 TA+ P .{...} 698872 5220200 TA+ P .{.{...}..} 954252 6063164 TA+ P .{.{...{.}}..} 1243156 6572740 TA+ P .{.{...{.{.#..}}}..{..}} 1452016 8829248 TA+ P .{.{..{.}.{.{.{.}#..{.}}}}..{..{.}}} 319744 10577588 TA+ P .{.{..{.}.{.{.{.}#..{.}}}}..{..{.}}} 159284 8870360 TA+ P .{.{..{.}.{.{.{.}#..{.}}}}..{..{.}}} 150004 8826904 TA+ P .{.{..{.}.{.{.{.}#..{.}}}}..{..{.}}} 190012 8748076 TA+ P .{.{..{.}.{.{.{.}#..{.}}}}..{..{.}}} 128232 8867404 TA+</pre>++<p>+A few remarks:+<ul>+<li>You can see the space leak as a steady, substantial growth in the heap size, from N=0 through N=5, and again in the first five pattern lines.+<li>You can see the first large, strict blobs get hit at a depth of 5 (with <tt>forcen</tt>).+<li>Unfortunately :) it is not until a depth of 6 that the leak can be plugged. (Well, you can plug it without forcing the spine, using let-lifting, but <tt>seqaid</tt> doesn't do that yet.) So <tt>NFDataN</tt> is not a feasible solution for this leak.+<li><tt>NFDataP.forcep</tt> successfully plugs the leak without hitting the big strict blobs.+<li>This output doesn't show how <tt>NFData</tt> would perform worse, but for large N there is additional penalty due to the presence of some long lists (not strict, but deep) in the state.+<!--<li>It may appear there is still a slight leak in the heap, with the final pattern, but if the run is extended, this space is reclaimed periodically.+I don't quite understand this, since I am using <tt>performGC</tt> before each stats line is printed, but the fact is there is no longitudinal net growth.+(Oops, I don't see it in this paste anyways...).-->+</ul>++<div class="footer">+Andrew Seniuk 2014+<br>+<tt>rasfar@gmail.com</tt>+</div>++</div>++<script language="javascript">+function toggle(id1){+ var ele_s = document.getElementById(id1+"s");+ var ele_h = document.getElementById(id1+"h");+ var ele = document.getElementById(id1);+ if( ele.style.display == "inline-block" ){+ ele.style.display = "none";+ ele_s.style.display = "inline-block";+ ele_h.style.display = "none";+ }else{+ ele.style.display = "inline-block";+ ele_s.style.display = "none";+ ele_h.style.display = "block";+ }+}+</script>++</body>+</html>+
+ HTML/index.html view
@@ -0,0 +1,17 @@+<!DOCTYPE html>+<html>+<head>+<title>Seqaid : Haskell Leak Eradicator</title>+<link rel="stylesheet" href="style.css" />+</head>+<body>++<!--div style="color: #F33; margin-top: 40px; font-size: 16pt;">+(Notes to self.)+</div-->++<script>document.location = "seqaid.html";</script>++</body>+</html>+
+ HTML/seqaid.html view
@@ -0,0 +1,394 @@+<!DOCTYPE html>+<html>+<head>+<title>Seqaid : Space leak diagnostic and remedial tool</title>+<link rel="stylesheet" href="style.css" />+</head>+<body>+<!--body style="width: 800px;"-->++<div class="main">++<h2 style="margin-top: 50px; margin-bottom: 10px;">Seqaid</h2>+<h3 style="margin-top: 12px; color: #666;">Space Leak Diagnostic and Remedial Tool</h3>++If you're reading this, you probably don't need to be told that space leak is the bane of lazy languages like Haskell.++<!-- http://neilmitchell.blogspot.ca/2013/11/acm-article-leaking-space.html -->+Quoting briefly from Neil Mitchell's 2013 <a href="http://queue.acm.org/detail.cfm?id=2538488">article</a> in <em>ACM Queue</em>:++<p>+<em style="display: block; margin-left: 15px; margin-right: 100px;">+<p>+"[Writers of] compilers for lazy functional languages have been dealing with space leaks for more than 30 years and have developed a number of strategies to help.+...+Despite all the improvements, space leaks remain a thorn in the side of lazy evaluation, producing a significant disadvantage to weigh against the benefits."+<p>+"Pinpointing space leaks is a skill that takes practice and perseverance. Better tools could significantly simplify the process."+</em>++<p>++Seqaid (package <a href="http://hackage.haskell.org/package/seqaid">seqaid</a> on hackage) is a tool to help debug space leak in Haskell projects.++<p>++The key contribution of <!--a href="http://hackage.haskell.org/package/seqaid"-->seqaid<!--/a--> is runtime strictness optimisation, through dynamic, principled forcing, as supported by <a href="http://hackage.haskell.org/package/deepseq-bounded">deepseq-bounded</a>.++<p>++This package consists of+<ul>+<a id="r1"></a>+<li>a GHC plugin (to automate the instrumentation of modules)+<li>a small library (used by the plugin; and can be used to manually instrument)+</ul>++<p>++Seqaid can auto-plug many <span>leaks. <a href="#1">[1]</a></span>+<!--But there's still many it cannot help you with, at least without some coaxing on your part.-->+However, not all leaks can be addressed by adding strictness;+and, although most can in my experience, usually these could also be addressed by refactoring in such a way that no added strictness was required.+It may be that clues to such refactorings are offered by observation of optimal forcing patterns.++<p>++I believe that seqaid has potential to be a useful resource, but this is only a bare-bones first-version.+<a id="r2"></a>+The ultimate goal would be to see some evolution of this make it into compilers (perhaps even the GHC RTS), supposing a better solution hasn't arrived first.++<p>++Seqaid is more general-purpose than just a space leak tool.+It contains TH and GHC plugin code to <span>automatically <a href="#2">[2]</a></span>+instrument Haskell packages with an arbitrary wrapper function around select expressions.+There's nothing (much) to stop you from substituting your own wrapper functions.+When the dust settles here, I should probably try to split off a wrapper-agnostic auto-instrumentation tool.+<p>+We do not have the luxury of changing the types of the functions we're instrumenting, so passing extra state in any pure way is out of the question.+In seqaid specifically, per-call-site data is maintained by judicious use of unsafe <tt>IORef</tt> operations.+<!-- However, there are no safety implications in this case, as proven elsewhere. <a href="#3">[3]</a> -->+The unsafe operations are no more dangerous than <tt>seq</tt> (no matter how wrong things go).+<a id="r3"></a>+But it is true that, technically, program semantics can be affected by strictification — specifically, adding strictness to a program may introduce bottoms (in addition to any that might already be lurking).+<p>+<a id="using"></a>+On the bright side, although <tt>seq</tt> breaks free theorems, <span>seqaid does not. <a href="#3">[3]</a></span>++<!--You can do any IO you wish via manual instrumentation.-->++<!--div style="margin-left: 15px;">+Want to cut to the chase?<br>+See the bottom of the page for a concise <a href="#contrib">contribution statement</a>.+</div-->++<!--++<h3><red>OLD</red> (June 2014) Combing Out Global DeepSeq</h3>++Control.DeepSeq and related generics/TH modules are a great tool for debugging space leaks, and also a great temptation for evading them.+A common strategy is to start at a high level in leaking code (in the sense of high in the parse tree), finding a place where a forcing function will squash your leaks, and then working the forcer further down until the offending code has been discovered.+For didactic purposes, let's suppose your forcing function is deepseq.+Sometimes more than one site will have leaky code, so as the deepseq is moved down, it may have to be duplicated and branch out as well.+<p>+It would be nice to automate this process of refining the locations of deepseq.+Something simple that should work is a binary partitioning of descendant expressions, into those which propagate the deepseq, and those which do not.+Auto-recompilation and auto-profile-analysis can determine whether the change maintains leak-free behaviour, guiding the search for the smallest expressions which need forcing.+The developer may prefer to force at a higher level, in case this minimal set is highly ramified (high cardinality), but mostly we're interested in those expressions deepest in the parse tree that, forced, suffice to staunch the leak.++<p>++The <a href="index.html">Heaply</a> page has more info on a nascent implementation.++-->++<p>++<h3>Dynamically Configurable Parallelism</h3>++With recent upgrades to <tt>deepseq-bounded</tt>, (the) dynamically-configurable parallelisation harness now comes for free, and should also prove useful.+The strictness harness machinery of seqaid will work without change for this purpose, including the optimiser, and promises some interesting experiments!++<h3>How to Use Seqaid</h3>++A good introduction to using seqaid is generated by running <tt>seqaid demo</tt>.+This will create a fresh, uniquely-named subdirectory in the current directory, and populate it with a sample project (<a href="http://hackage.haskell.org/package/leaky">leaky</a>), build it with seqaid auto-instrumentation in effect, and run it.+The <tt>README</tt> file in the generated directory has more information about the meaning of the output.+<!--The <tt>leaky.cabal</tt> file in the generated directory shows how to configure the plugin.-->+<a id="r4"></a>++<p>++Note the file <tt>seqaid.config</tt>, a small text file with a very simple format which you write to control seqaid.+Here is the <tt>seqaid.config</tt> file for leaky:++<pre>+package leaky+module Main+ binds duty+ types Types.TA+instances Types.TA, Types.TB, Types.TC+</pre>++<p>+This file instructs the seqaid preprocessor to build with a conditional forcing wrapper (strictness harness) for all subexpressions of type <tt>TA</tt> occurring in the equations of the bind <tt>duty</tt> in module <tt>Main</tt>.+It furthermore instructs seqaid to automatically derive necessary instances for instrumenting user-defined data types <tt>Types.TA</tt> <span>etc. <a href="#4">[4]</a></span>+<!--+Note the file <tt>SeqaidTypes.hs</tt>, which is a stub you need to create, with imports of all types you want to be able to force through.+(Most common types already have <tt>NFDataP</tt> instances provided, similar to <tt>NFData</tt>.)+The actual meta-boilerplate to derive <tt>NFDataP</tt> instances of your types is auto-generated, which is perhaps a first for generic deriving support!+The <tt>SeqaidTypes.hs</tt> stub, and the plugin options in the <tt>.cabal</tt> file, are the only edits required to use seqaid on your own project.+-->++<p>++Besides the <tt>seqaid.config</tt> file, all that is needed to use seqaid on your own project is some additions to the .cabal file.+This includes some extra dependencies (notably, seqaid; possibly a few others; Cabal will let you know), and the following GHC options:++<pre>+ ghc-options: -fplugin=Seqaid.Plugin+ -F -pgmF seqaidpp+ -XTemplateHaskell+ -with-rtsopts=-T+</pre>++<p>+Manual instrumentation is also supported, should you prefer.+Simply wrap any expressions you'd like in harness with a <tt>seqaid</tt> application.+<tt>seqaid</tt> is not an actual function, it's a pattern the preprocessor will recognise.+For technical reasons <span style="font-size: 80%">[no good reason really...]</span>, this presently also requires adding a <a href="http://hackage.haskell.org/package/seqaid/docs/Seqaid-Ann.html#SeqaidAnnManual"><tt>SeqaidAnnManual</tt></a> annotation for each bind you edit.+<!--span style="font-size: 80%;">[That document is still not written, but <tt>leaky</tt> at <tt>FORCING_STRATEGY=4</tt> is a demonstation.]</span-->++<h3><tt>leaky</tt> Contrived to Showcase <tt>seqaid</tt>?</h3>++Some words about the derivation of <tt>leaky</tt> are <a href="extra.html">here</a>, where the output of seqaid applied to <tt>leaky</tt> is also discussed.++<h3>Work in Progress...</h3>++<a id="dig01s" class="dig-toggle-show" href='javascript:toggle("dig01");' style="margin-left: 20px;">Show</a>+<div id="dig01" class="digression" style="margin-left: 20px;">+<a id="dig01h" class="dig-toggle-hide" href='javascript:toggle("dig01");'>Hide</a><p>+I'm just fretting that I should have investigated using a GHC API app as a GHC replacement instead, if by chance it can be done light-weight.+Well, at worst the GHC program is only a bit over 1 MB in size.+Er ... but compiling it is a serious build, this is not like any old cabal install from hackage...+But also, it seems GHC API can be used with TH.+The problem seems to be that due to staging restrictions you still cannot modify existing declarations this way.+Best bet is really some plugin facility between Parser and Renamer/TC.+</div>+<p>+Most all the work up till now has been to get the basic infrastructure in place.++<p>+I hustled this preliminary version of seqaid together in the wake of writing the <a href="http://hackage.haskell.org/package/deepseq-bounded">deepseq-bounded</a> library, just as proof of concept.+Unfortunately, auto-instrumentation turned out to be a nightmare, particularly as I had no TH or Core programming experience, setting me back by more than a month...++<p>+So I've determined to release <a href="http://hackage.haskell.org/package/deepseq-bounded">leaky</a>, <a href="http://hackage.haskell.org/package/deepseq-bounded">deepseq-bounded</a>, and <a href="http://hackage.haskell.org/package/seqaid">seqaid</a> without further delay.++<p>+After a much-needed vacation from these topics (which are not my interest; I'm an applications programmer!...), there are a few more things I'm intending to do.++<p>+<a style="display: none;" id="dig02s" class="dig-toggle-show" href='javascript:toggle("dig02");'>Show</a>+<div style="display: inline-block;" id="dig02" class="digression" style="margin: 20px 100px 0px 30px;">+<a style="display: block;" id="dig02h" class="dig-toggle-hide" href='javascript:toggle("dig02");'>Hide</a><p>+From this point on (including note <a href="#3">[3]</a>), I may be talking nonsense in places.<br />+I'll ammend this preliminary stuff subject to discussion and new learning.+</div>++<h4>Immediate priorities</h4>++Two necessary things are still pending:++<ul>+<li>+Dynamic optimisation of forcing patterns (easy, from here).+<li>+Exploiting heap entity info (perhaps via <a href="http://hackage.haskell.org/package/ghc-heap-view">ghc-heap-view</a>).+</ul>++<h4>Other issues and plans</h4>++<ul>+<!--+<li>+Seqaid currently wraps whole RHS's of declarations.+This is ineffectual for monadic functions.+Monadic functions can be manually instrumented by wrapping ("injecting at") subexpressions.+Getting demand propagation right might be tricky.+As for automating, the plugin already handles lambdas differently than other expressions, so monadic expressions could also be given special accomodation.+-->+<li>+No performance tuning has been done yet.+We need to see if it pays to run the plugin after the Core-to-Core optimisation phase — running it earlier may well interfere with GHC optimisation tactics.+<li>+There are a few desperate <tt>String/Regex</tt> hacks, at least some of which can probably be solved without resorting to that.+<li>+For top-level bind harnessing, seqaid currently issues a warning for (and omits wrapping of) any declaration having polymorphic type.+These can however be manually instrumented.+Working on automating for polymorphic types...+This has become less of an issue with subexpression injection.+<li>+It is possible to transform away the deepseq-bounded code generated by seqaid, leaving only <tt>let</tt> and <tt>seq</tt>.+If you were to accept a (constant) strictification offered by seqaid, you could emit it as a static <tt>let</tt>-and-<tt>seq</tt> code transformation.+The point is, if your code was Haskell 98 to begin with, it will still be Haskell 98 afterwards, and also be significantly more performant than the high-level forcing harness of seqaid.+<br />+<!--p-->+<a id="dig03s" class="dig-toggle-show" href='javascript:toggle("dig03");' style="margin: 10px 100px 10px 30px;">Show</a>+<div id="dig03" class="digression" style="margin: 10px 100px 10px 30px;">+<a id="dig03h" class="dig-toggle-hide" href='javascript:toggle("dig03");'>Hide</a><p>+There is nothing intrinsically non-H98 about deepseq-bounded, but for generic deriving support GHC is needed.+You could write your own NFDataP and superclass instances, and be H98 all the way.+deepseq-bounded can be built in H98 mode with the flag HASKELL98_FRAGMENT...+</div>+<li>+There is a whole program algebra around manipulating strictness (see for instance+<a href="http://www.fremissant.net/deepseq-bounded/deepseq-bounded.html#fusion">fusion rules</a> in <tt>deepseq-bounded</tt>, and the <a href="http://hackage.haskell.org/package/deepseq-bounded/docs/Control-DeepSeq-Bounded-PatAlg.html">PatAlg</a> API; or, for more theoretical depth, the many articles published over the last 50 years on abstract interpretation, demand propagation, strictness analysis, evaluation transformers...).+Whether before or after transforming to <tt>let</tt>-and-<tt>seq</tt>, there are opportunities for simplifying the forcing harness, while preserving strictness and value semantics.+</ul>++<h4>Maybe...</h4>++It would be interesting to see whether instrumentation could be pushed further down the compilation pipeline, or even implemented "from the other side" in the RTS.+We might say that RTS can perform reciprocal injection,+and think of this as another level of injection deferral.++<p>+But the RTS is not a compilation stage of your code;+it is a virtual machine (mostly written in C) which evaluates your code, so implementing seqaid in the RTS will probably be quite a departure from the above.++<p>+The new <tt>Seqable</tt> module of <tt>deepseq-bounded</tt> is a step in the right direction, but I've not had time to really investigate it let alone document it.++<p>+And anyway, it turns out <tt>seq</tt> is completely desugared by the time it hits the simplifier, so we're dealing with Core <tt>let</tt> versus <tt>case</tt> techniques, and not even function applications.++<h3 style="margin-top: 50px; margin-bottom: 8px;">Notes</h3>++<table>++<tr id="1">+<td>+[1]+</td>+<td>+See for example the <a href="http://www.haskell.org/haskellwiki/Space_Leak">Space Leak</a> haskellwiki <span>page. <a href="#r1">⇪</a></span>+</td>+</tr>++<tr id="2">+<td>+[2]+</td>+<td>+A preprocessor takes care of all necessary pragmas and imports.+The TH and Core (plugin) code then work in tandem to complete the <span>refactoring. <a href="#r2">⇪</a></span>+<br />+<!--p-->+<!-- a glitch with my version of chromium perhaps? (the padding) -->+<!--span id="dig05s" onclick='toggle("dig05");' class="dig-toggle-show" style="margin-left: 30px; margin-top: 10px;">Show</span-->+<!--+<a id="dig05s" class="dig-toggle-show" href='javascript:toggle("dig05");' style="margin-left: 30px; margin-top: 10px;">Show</a>+<div id="dig05" class="digression" style="margin-left: 30px; margin-right: 100px; padding-bottom: 1px; margin-top: 10px;">+<a id="dig05h" class="dig-toggle-hide" href='javascript:toggle("dig05");' style="margin-bottom: 6px;">Hide</a><p>+LATER: See writings in /work/Projects/MiniProjects/Metaboiler/000-readme.+I've looked into it, and basically, yes we can avoid ALMOST all user edits to intrumentation target source modules.+But if you have datatypes involved, and they don't have instances for Typeable, Data, and Generic, you will have to add these to the deriving clauses.+<p>+Or, better, add a single file importing all the types you need in instrumented code, and use -XStandaloneDeriving to "top them up" with instances.+Then you only need to add this import to your instrumentation target source modules.+And, as the preprocessor can inject imports, you need only provide the name as an argument to the preprocessor (or use a standard, fixed "Seqaid..." name), so actually STILL NO EDITS (excepting preprocessor) ARE NEEDED TO ANY ORIGINAL SOURCE FILES. Whew! It seems like there is always a way out...+<p>+All this is only needed for the <tt>deriveGeneric ''T</tt> for your types <tt>T</tt>.+But we cannot avoid the user having to add at least the "deriving instance" lines for their types, because TH cannot splice a "deriving instance" (-XStandaloneDeriving) to date (and TH cannot add/augment "deriving" clauses of existing types). [It looks like it's just coming down the pipes however.]+<p>+[Old sentences, used to be in body of document:]+The TH and Core (plugin) code work in tandem to make this possible, with the addition of two lines of code to each module the user wants instrumented.+And these two lines are both constants, and can safely be automatically inserted by an editing script.+(There's no way to do that with the GHC tools, that I know of. -F -pgmF -optF, but still isn't there some issue about temp files? I seem to recall from FreeSect...)+-->+</div>+</td>+</tr>++<tr id="3">+<td>+[3]+</td>+<td>+Patricia Johann and Janis Voigtländer (2004),<br />+<em>Free Theorems in the Presence of <tt class="virgin">seq</tt></em>+<ul>+<li>+<a href="http://www.researchgate.net/publication/2898699_Free_Theorems_in_the_Presence_of_seq">Paper</a>+<li>+<a href="http://www.janis-voigtlaender.eu/papers/TheImpactOfSeqOnFreeTheoremsBasedProgramTransformations.pdf">Another...</a>+<li>+<a href="http://www.janis-voigtlaender.eu/seq-slides.pdf">...with Slides</a>+</ul>++We avoid this problem entirely, because seqaid never modifies the original source code:+generic strictifying code is injected during compilation, and then configured dynamically.+Thus there is no impediment to program transformation based on free theorems.+Since parts of the GHC simplifier depend on free theorems, it is necessary to inject seqaid instrumentation after these optimisation phases.+This also seems to indicate the desireability of an RTS solution.+<p>+Of course, FT transformations may affect the space use behaviour of your program, resulting in shifts in optimal forcing patterns, like rocks tumbling in the freshet will shift the rapids.+If performance tuning was your game, you could even turn the tide and use feedback from seqaid to search for optimising transformations...+<p style="margin-bottom: 0px;">+In case you are somehow able to perform your transformations at runtime, even that is no problem.+You don't even need to turn off the plugin!+The forcing harness can be made truly transparent+<!-- (<em>i.e.</em> not a single <tt>seq</tt> introduced) -->+by simply asking it, dynamically and selectively, to lay off while you <span>transform. <a href="#r3">⇪</a></span>+</td>+</tr>++<tr id="4">+<td>+[4]+</td>+<td>+The instances required are some subset of <tt>Typeable</tt>, <a href="http://hackage.haskell.org/package/generics-sop">SOP</a> <tt>Generic</tt>, and <tt>NFDataP</tt> and superclasses, and the exact set currently depends on Cabal flags.+<p>+Another point to note about the seqaid preprocessor concerns inlining.+GHC inlines very aggressively, even across module boundaries.+If you've requested instrumentation of bind <tt>duty</tt>, but somehow <tt>duty</tt> is inlined before the Core plugin runs, the expressions you hoped to harness will slip through the net.+If you can afford a complete (blanket) harness, this problem will never arise, as it has to be inlined <em>somewhere</em>!+Another possible solution would be to have TH add a <tt>NOINLINE</tt> pragma to any binds mentioned in <tt>seqaid.config</tt>;+but weakening the inlining powers of a functional language compiler is generally a bad idea — not just for the function call overhead: it blocks potential optimisations at the call site.+So both of these solutions come at a performance cost, but both guarantee your fish will go to <span>market. <a href="#r4">⇪</a></span>+</td>+</tr>++</table>++<div class="footer" style="margin-top: 20px;">+Andrew Seniuk 2014+<br>+<tt>rasfar@gmail.com</tt>+</div>++</div>++<script language="javascript">+function toggle(id1){+ var ele_s = document.getElementById(id1+"s");+ var ele_h = document.getElementById(id1+"h");+ var ele = document.getElementById(id1);+ if( ele.style.display == "inline-block" ){+ ele.style.display = "none";+ ele_s.style.display = "inline-block";+ ele_h.style.display = "none";+ }else{+ ele.style.display = "inline-block";+ ele_s.style.display = "none";+ ele_h.style.display = "block";+ }+}+</script>++</body>+</html>+
+ HTML/style.css view
@@ -0,0 +1,27 @@+pre { font-size: 12pt; margin-left: 20px; padding-left: 10px; padding-right: 10px; padding-top: 10px; padding-bottom: 10px; background-color: #DDD; }+tt { padding-left: 2px; padding-right: 2px; font-size: 85%; background-color: rgba(220,220,220,0.5); }+tt.virgin { padding-left: 0px; padding-right: 0px; font-size: 85%; background-color: transparent; }+/* Works, but not nicely:+red { color: #f00; }+*/+.red { color: #f00; }+div.outdated { display: inline-block; padding-left: 2px; padding-right: 2px; padding-top: 2px; font-size: 80%; background-color: #EEC; }+div.digression { display: none; padding: 8px 8px 8px 8px; font-size: 80%; background-color: #EDD; }+div.digression-closed { display: inline-block; padding: 8px 8px 8px 8px; font-size: 80%; background-color: #EDD; }+.dig-toggle-show { outline: 0; text-decoration: none; color: #33E; display: inline-block; padding: 8px 8px 8px 8px; font-size: 11pt; background-color: #EDD; }+.dig-toggle-hide { outline: 0; text-decoration: none; color: #33E; display: inline-block; padding: 0px 0px 4px 0px; font-size: 11pt; background-color: #EDD; }+a { text-decoration: none; }+div.main { font-size: 18pt; margin-left: 10px; margin-right: 100px; margin-bottom: 40px; }+h2 { margin-top: 30px; color: #777; }+h3 { margin-top: 30px; color: #444; }+h4 { margin-top: 40px; color: #222; }+div.footer { font-size: 12pt; margin-top: 30px; }+/*+table.table { text-align: top; vertical-align: top; }+table.table > tr { text-align: top; vertical-align: top; }+table.table > tr > td { text-align: top; vertical-align: top; }+*/+/* table { border-collapse: collapse; } */+tr { text-align: top; vertical-align: top; }+td { text-align: top; vertical-align: top; padding-left: 8px; padding-top: 16px; }+li { margin-top: 4px; }
+ HTML/style2.css view
@@ -0,0 +1,27 @@+pre { font-size: 14pt; margin-left: 20px; padding-left: 10px; padding-right: 10px; padding-top: 10px; padding-bottom: 10px; background-color: #DDD; }+tt { padding-left: 2px; padding-right: 2px; font-size: 100%; background-color: rgba(220,220,220,0.5); }+tt.virgin { padding-left: 0px; padding-right: 0px; font-size: 100%; background-color: transparent; }+/* Works, but not nicely:+red { color: #f00; }+*/+.red { color: #f00; }+div.outdated { display: inline-block; padding-left: 2px; padding-right: 2px; padding-top: 2px; font-size: 80%; background-color: #EEC; }+div.digression { display: none; padding: 8px 8px 8px 8px; font-size: 80%; background-color: #EDD; }+div.digression-closed { display: inline-block; padding: 8px 8px 8px 8px; font-size: 80%; background-color: #EDD; }+.dig-toggle-show { outline: 0; text-decoration: none; color: #33E; display: inline-block; padding: 8px 8px 8px 8px; font-size: 11pt; background-color: #EDD; }+.dig-toggle-hide { outline: 0; text-decoration: none; color: #33E; display: inline-block; padding: 0px 0px 4px 0px; font-size: 11pt; background-color: #EDD; }+a { text-decoration: none; }+div.main { font-size: 16pt; margin-left: 10px; margin-right: 100px; margin-bottom: 40px; }+h2 { margin-top: 30px; color: #777; }+h3 { margin-top: 30px; color: #444; }+h4 { margin-top: 40px; color: #222; }+div.footer { font-size: 12pt; margin-top: 30px; }+/*+table.table { text-align: top; vertical-align: top; }+table.table > tr { text-align: top; vertical-align: top; }+table.table > tr > td { text-align: top; vertical-align: top; }+*/+/* table { border-collapse: collapse; } */+tr { text-align: top; vertical-align: top; }+td { text-align: top; vertical-align: top; padding-left: 8px; padding-top: 16px; }+li { margin-top: 4px; }
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2014, Andrew Seniuk++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Andrew Seniuk nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README view
@@ -0,0 +1,101 @@++ ----------------------------------------------------------++ Seqaid : Space Leak Diagnostic and Remedial Tool++ Andrew Seniuk+ rasfar@gmail.com+ 2014++ ----------------------------------------------------------++ The easiest way to get started with seqaid is++ cabal install seqaid+ seqaid demo++ This will create a fresh directory, populate+ it with the <leaky> test project, and configure,+ build and run it with seqaid instrumentation.+ Consult the leaky.cabal, README, and leaky.hs files+ in that directory for additional information.+ (The README explains the console output.)++ ----------------------------------------------------------++ To instrument your own project ("myapp" for didactic purposes),+ typically the following steps suffice:++ 1. cabal install seqaid, of course.++ 2. Add the following (at the appropriate level of indentation)+ to your myapp.cabal file:++ default-extensions: TemplateHaskell+ ghc-options: -fplugin=Seqaid.Plugin+ ghc-options: -F -pgmF seqaidpp+ ghc-options: -with-rtsopts=-T++ 3. Create a seqaid.config file in the project dir.+ The preprocessor will parse this, and control+ the extent of the instrumentation harness.++ There is no mechanism yet for real blanket+ instrumentation: You must name at least+ the modules you want instrumented, and the+ types you're interested in. All binds in+ a module will be covered however.++ Looking at the seqaid.config file for leaky:++ package leaky+ module Main+ binds duty+ types Types.TA+ instances Types.TA, Types.TB, Types.TC++ is this was changed to++ package leaky+ module Main+ types Types.TA+ instances Types.TA, Types.TB, Types.TC++ then all binds in module Main will be instrumented at+ all subexpressions having type Types.TA.++ The instances line names types you need to be able+ to force through. If you get missing instance errors+ when you build, then you probably need to add those+ types to this list.++ ----------------------------------------------------------++ When the preprocessor runs, it will parse the configuration+ from seqaid.config, and perform the requisite insertions and+ substitutions behind the scenes.++ NOTE: This will never ever edit your source files directly!+ GHC takes care of running the preprocessor (-F option) on+ its own temporary files, in the natural course of the+ compilation pipeline.++ ----------------------------------------------------------++ The other project inseparable from this is <deepseq-bounded>.++ More specific information resides in+ - the <seqaid>, <leaky> and <deepseq-bounded> homepages+ - the Haddock API docs for <seqaid> and <deepseq-bounded>+ - haskell-cafe thread(s): <>+ - reddit thread(s): <>++ And to a lesser extent, sporadic bits of information can also+ be found in files in the source distribution+ - the project README and .cabal files+ - comments in the source files [tend to obsolescence]++ Subsequent versions will hopefully be more cohesive.++ ----------------------------------------------------------+
+ Seqaid/Ann.hs view
@@ -0,0 +1,99 @@++-------------------------------------------------------------------------------++ {-# LANGUAGE CPP #-}+ {-# LANGUAGE DeriveDataTypeable #-}++-------------------------------------------------------------------------------++-- |+-- Module : Seqaid.Ann+-- Copyright : (c) 2014, Andrew G. Seniuk+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : Andrew Seniuk <rasfar@gmail.com>+-- Stability : provisional+-- Portability : GHC (portable, though not usefully)+--+-- There are a few user-level annotations here, but mostly+-- @seqaid@ is a non-invasive tool, so it uses a separate+-- @seqaid.config@ file instead.+--+-- See "Seqaid.Config" for details about the @seqaid.config@ file.++ module Seqaid.Ann (++ -- * User annotations++ -- | These are the Seqaid annotations a user can use in their source.++ SeqaidAnnExclude(..)+ , SeqaidAnnManual(..)++ -- * For internal use only++ -- | These annotations are for internal use. They communicate+ -- information between the TH and GHC plugin stages of seqaid.++ , SeqaidAnnIncludeList(..)+ , SeqaidAnnTypes(..)+ , SeqaidAnnAvailableInstances(..)+ , SeqaidAnnBindsIncluded(..)++ ) where++ import Data.Typeable ( Typeable )+ import Data.Data ( Data )++#if TH_TYPE_IN_TYPES_ANN+ import Language.Haskell.TH ( Type )+--import Type ( Type )+#endif++-------------------------------------------------------------------------------++ -- I don't know why the Data instance is needed, but it is (GHC 7.8.1),+ -- but the polymorphism of the ANN pragma expression is likely responsible.++-------------------------------------------------------------------------------++ -- | With blanket top-level bind harnessing, this is a means+ -- to exclude select binds from harness.+ -- The @String@ argument need not (but may) be fully qualified.+ data SeqaidAnnExclude = SeqaidAnnExclude String+ deriving ( Typeable, Data, Show )++ -- | This was used for technical reasons, and is hopefully going+ -- to be deprecated very soon.+ -- At present, when you use 'seqaid' (not a real function, so no link)+ -- to manually wrap an expression for harnessing, you must also give+ -- a 'SeqaidAnnManual' annotation naming the bind you're editing.+ data SeqaidAnnManual = SeqaidAnnManual String+ deriving ( Typeable, Data, Show )++-------------------------------------------------------------------------------++ data SeqaidAnnIncludeList = SeqaidAnnIncludeList [String]+ deriving ( Typeable, Data, Show )++ data SeqaidAnnTypes = SeqaidAnnTypes [String]+ deriving ( Typeable, Data, Show )++#if TH_TYPE_IN_TYPES_ANN+ -- XXX Problem is, getting from TH.Type to Type.Type.+ -- We /could/ send [TH.Type] in the ANN, and try to cope+ -- with translation of it in Core -- at least it would be+ -- more principled than String/regex ad hoc parsing!+ -- But for now will stick to just String/regex.+ data SeqaidAnnAvailableInstances = SeqaidAnnAvailableInstances [Type]+ deriving ( Typeable, Data )+#else+ data SeqaidAnnAvailableInstances = SeqaidAnnAvailableInstances [String]+ deriving ( Typeable, Data, Show )+#endif++ data SeqaidAnnBindsIncluded = SeqaidAnnBindsIncluded [String]+ deriving ( Typeable, Data, Show )++-------------------------------------------------------------------------------+
+ Seqaid/Config.hs view
@@ -0,0 +1,57 @@++-------------------------------------------------------------------------------++ {-# LANGUAGE CPP #-}++-- |+-- Module : Seqaid.Config+-- Copyright : (c) 2014, Andrew G. Seniuk+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : Andrew Seniuk <rasfar@gmail.com>+-- Stability : provisional+-- Portability : portable+--+-- Details concerning the @seqaid.config@ file.+--+-- The purpose of the @seqaid.config@ file is to control+-- the extent of coverage of the automatically injected+-- instrumentation harness.+--+-- At this early stage, additional Cabal flags and even some+-- per-module CPP switches are used to further vary the+-- behaviour of seqaid. These alternatives will become+-- documented as they find a reflection in the @seqaid.config@.+-- Also, see "Seqaid.Ann" for a few user annotations, which+-- will also be deprecated soon...+--+-- The format of @seqaid.config@ is a seqence of lines, which+-- can be one of three kinds:+--+-- * Blank lines (containing only whitespace)+-- * Comment lines (first non-whitespace character is @#@)+-- * Configuration lines+--+-- Configuration lines begin with a keyword, and are followed by+-- one or more arguments. Arguments are comma-separated.+-- Layout is used when keywords generate nested structure.+--+-- For instance, here is the @seqaid.config@ file from the+-- <http://hackage.haskell.org/package/leaky leaky> package:+--+-- > package leaky+-- > module Main+-- > binds duty+-- > types Types.TA+-- > instances Types.TA, Types.TB, Types.TC+--+-- (The extra whitespace after the keywords is purely cosmetic.)+--+-- More documentation is pending, but for additional explanations+-- about this particular example, please refer to+-- <http://www.fremissant.net/seqaid/seqaid.html#using this document>.++ module Seqaid.Config where++-------------------------------------------------------------------------------+
+ Seqaid/Core.hs view
@@ -0,0 +1,1645 @@++{-# LANGUAGE CPP #-}++-- For a SYB worker type signature (probably unnecessary):+{- LANGUAGE FlexibleContexts #-}++{- LANGUAGE PatternGuards #-}++-- XXX In case didn't get around to it, there's some nonsense+-- with SiteID fst3 component: The only assignments that matters+-- are any made by the SYB traversal looking for manual injections.+-- And this traversal will take care of auto-injected ones, too,+-- they will not even need to be distinguished.+-- LATER: Also now, types-based injection sets the id.+-- My point above is that, we set it "early" to essentially bogus value+-- which is ... need to find a moment to review that stuff. Some old+-- code can definitely be removed.++-------------------------------------------------------------------------------++#define DBG 0+#define DBG_BINDS 0+#define DBG_MAP_CREATION 0+#define DBG_MAP_LOOKUP 0+#define DBG_ANNOTATIONS 0+#define DBG_MANUAL 0+#define DBG_SEQINJECT_FUNC 0+#define DBG_OMNI 0++#define SILENT 0+#define MENTION_EXCLUDED 0++-------------------------------------------------------------------------------++-- XXX This (set =1) is probably a bad idea for a default.+-- Try to minimise spurious warnings instead; although we+-- don't expect spurious warnings come to think of it...+#define NO_WARN_SITE_MISSING_INSTANCE 0++-- This should be equal to Seqaid.TH's+-- INJECT_DUMMY_CLASS_AND_INSTANCE_TO_BLOCK_DEAD_CODE_ELIMINATION+#define DO_NOT_ELIDE_ANY_OF_THE_INJECTED_TH_SPLICES 1++-- Hack to try using class method instead of seqaidDispatch intermediary.+#define TRY_NO_SEQAIDDISPATCH_INTERMEDIARY 0+#define TRY_SIMPLY_NFDATA 0++-- Run "as much of thie module's code as possible" without+-- altering the original bindings. (There may be lack-of-demand+-- issues here...).+#define DRY_RUN 0++-- Return guts unmodified; skips most of this module's code.+#define BYPASS 0++-- Not necessary (was trying to simplify debugging at one point).+#define EXCLUDE_COLON_MAIN 0++-------------------------------------------------------------------------------++-- XXX Initially templated from the+-- strict-ghc-plugin (Austin Seipp / thoughtpolice).++-- XXX Comments below are now very old (from like, 1st or 2nd day+-- of working on the plugin):+--+-- -- Overview of the Problem+-- -- =======================+-- --+-- -- Want to inject CoreSyn Expr App of an imported, polymorphic function+-- -- (which uses methods of a certain class), to any suitable expression.+-- -- By suitable, meaning we may assume that the class instance exists+-- -- for the type of the expression, so that (or rather, because) the class+-- -- type constraint is satisfied.+-- --+-- -- The problem is, how to express this with hand-coded core injection?+-- --+-- -- I have some notion that, in Core, an overloaded function is really+-- -- a monomorphic function taking an additional dictionary argument.+-- -- What I can't find a good explanation of is, what, more concretely+-- -- (as befits a person trying to write a plugin, say...) can a person+-- -- do to inject such a function application to (perhaps annotated)+-- -- expressions? I feel this is a good question (even for SO), since+-- -- it's such a natural and powerful thing to want to be able to do+-- -- in a plugin.+-- --+-- -- Well, I could test that I have a good grasp on doing this+-- -- for a MONOMORPHIC function -- but then, aren't I already+-- -- doing that in effect, with my single, Float-specialised seqaid_dud?++-------------------------------------------------------------------------------++-- -- What follows is a wretched hack until further notice.+-- +-- -- 20140930 Getting closer. Dictionary manipulation (or Rules)+-- -- is probably the way to go -- unless there actually are API+-- -- functions to help do this?+-- -- In the meantime, can try to examine at the ctor level,+-- -- what I get as input to Core level ("simplifier?") ... should+-- -- actually double-check where in the pipeline this plugin+-- -- plugs-in...+-- -- And from Seqaid.Plugin.install:+-- -- return $ CoreDoPluginPass "Seqinject" seqinjectProgram : todos+-- -- So we inject (er, another use of the term) the seqaid plugin+-- -- at the very front. So we're interested in what manually-coded+-- -- calls to the injection function will look like at that point.+-- -- In principle, if can imitate that, ab initio, if we're "pure" [?]+-- -- (though we're in a monad...) we should get the same behaviour.+-- -- But environment ... the state of the CoreM monad must be consistent.+-- +-- -- 20140929 A few days into this; so far, it is finally working+-- -- but only for the type of the seqaid_dud declaration (which+-- -- must be monomorphic or you get an error when plugin runs).+-- -- So the code contains working seqaidDispatch injections+-- -- at the original, manually-injected @Bool site, and at (the)+-- -- two @Float sites where we lucked out and had the right type+-- -- specialisation for the expression.+-- -- The other cases seem to "do nothing" (trace in seqaidDispatch+-- -- not printed), but no harm ensues.++ {-# LANGUAGE PatternGuards #-}++ {-# LANGUAGE BangPatterns #-} -- debugging only!++-------------------------------------------------------------------------------++-- |+-- Module : Seqaid.Core+-- Copyright : (c) 2014, Andrew G. Seniuk+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : Andrew Seniuk <rasfar@gmail.com>+-- Stability : provisional+-- Portability : GHC+--+-- Instrument a program with dynamic forcing functions.+--+-- This module is for internal use with the seqaid GHC plugin.+--+-- Refer to+-- <http://hackage.haskell.org/package/deepseq-bounded deepseq-bounded>+-- for more information about this methodology.++-------------------------------------------------------------------------------++ module Seqaid.Core ( seqinjectProgram ) where++ -- XXX for debugging only (prefer deepseq-bounded import, since then+ -- no need to state deepseq (or deepseq-generics) dep in .cabal.+ import Control.DeepSeq.Bounded ( force )+--import Control.DeepSeq.Generics ( force ) -- XXX for debugging only+--import Control.DeepSeq ( force ) -- XXX for debugging only++--import Data.Generics.Shape.SYB++ import GhcPlugins++ import Control.Monad+ import Data.Generics++ import Seqaid.Ann+ import Seqaid.Runtime ( SiteID )++--import qualified Var as GHC+ import qualified GHC+ import qualified FastString as GHC+ import qualified RdrName as GHC+ import qualified Id as GHC+ import qualified RnEnv as GHC+ import qualified HscMain as GHC+--import qualified GHC.Paths as GHC ( libdir ) -- package ghc-paths+ import qualified Type as GHC+ import qualified TyCon as GHC+ import qualified TypeRep as GHC++ import Data.Maybe++ import Data.Dynamic++ import Data.Data++--import GhcMonad ( liftIO )++ import Debug.Trace ( trace )++ import System.IO.Unsafe ( unsafePerformIO )++#if 1+ import qualified Data.Map as Map+ import Data.Map ( Map )+#else+ import Prelude hiding ( lookup )+ import Data.Map hiding ( null, map, (!), filter )+#endif++ import Text.Regex.PCRE+ import Data.Array ( (!) )+ import Data.Array ( indices )+#if 0+ import Text.Regex.PCRE.String+ import Text.Regex.Base+ import Text.Regex.Base.RegexLike+#endif++ import Data.List ( intercalate )+ import Data.List ( deleteBy )+ import Data.List ( isPrefixOf )+ import Data.List ( foldl' )+ import Data.List ( nub )+ import Data.List ( sort )+ import Data.List ( group )++ import Data.Char ( isUpper )+ import Data.Char ( isLower )++#if ! DEMO_MODE+ import Data.Hashable ( hash )+#endif++ import Control.Monad.State.Lazy++-------------------------------------------------------------------------------++ data CoreBindMeta =+ -- (Bool,Bool) = (do_wrap_RHS, do_all_manual_within)+ Incl SiteID (Bool,Bool,Bool) CoreBind+ | Excl SiteID CoreBind+--- | Manual CoreBind+--data CoreBindMeta = Incl SiteID CoreBind | Excl SiteID CoreBind++ unMeta :: CoreBindMeta -> CoreBind+ unMeta (Incl _ _ b) = b+--unMeta (Incl _ b) = b+ unMeta (Excl _ b) = b++-------------------------------------------------------------------------------++ normalMode = 1 :: Int+ preproMode = 2 :: Int++-------------------------------------------------------------------------------++ seqinjectProgram :: [String] -> ModGuts -> CoreM ModGuts+ seqinjectProgram opts' guts = do++ dflags <- getDynFlags++ let thismodname = showSDoc dflags $ ppr $ moduleName $ mg_module guts++ let opts = reverse opts'+#if DBG+ putMsgS $ "plugin opts = " ++ show opts+-- error "Core.hs-DEVEXIT"+#endif+ let (mode,mode_module)+ = let len = length opts in+ if 0 == len then (normalMode,"")+ else+ let modeopt = opts!!0+ (modeopt_mode,modeopt_module)+ = ( takeWhile (/='=') modeopt+ , drop 1 $ dropWhile (/='=') modeopt+ )+ in+ case len of+ 1 -> case modeopt_mode of+ "normal" -> (normalMode,"")+ _ -> error "seqinj: incorrect plugin options (error #1)"+ 3 -> case modeopt_mode of+ "prepro" -> (preproMode,modeopt_module)+ _ -> error "seqinj: incorrect plugin options (error #2)"+ _ -> error "seqinj: incorrect plugin options (error #3)"+ if mode == preproMode && mode_module == thismodname+ then do+ dflags <- getDynFlags+ -- XXX Here we need to traverse the binds, collect the+ -- types of all subexpressions, and dump the (nubbed)+ -- collection to a temp file for seqaidpp to pick up.+-- putMsgS "\nBoo!!\n"+ let omni_types_pname = opts!!1+ let omni_imports_pname = opts!!2+-- putMsgS $ "WOULD WRITE " ++ omni_types_pname+ seqaid_instance_strings <- get_seqaid_instance_strings guts+#if DBG_OMNI+ putMsgS $ " XXX seqaid_instance_strings =\n" ++ intercalate "\n" seqaid_instance_strings+-- error "DEVEXIT"+#endif+ omni_types' <- collectSubexpressionTypes guts+#if DBG_OMNI+ let tmp2 = nubsort $ map (sanitiseTypeString . showSDoc dflags . ppr) $ filter (not . isFunTy) omni_types'+ putMsgS $ " UUU omni_types =\n" ++ intercalate "\n" tmp2+#endif+ let omni_types'' = filter (not . isFunTy) omni_types'+ let omni_types''' = filter (not . isForAllTy) omni_types''+ let omni_types = filter (not . isDictLikeTy) omni_types'''+ -- (Can't nub the [Type], there's no Eq instance for Type.)+ let omni_types_strs = map (showSDoc dflags . ppr) omni_types+#if DBG_OMNI+ putMsgS $ " VVV omni_types_strs =\n" ++ intercalate "\n" omni_types_strs+#endif+ -- sort not nec. to nub, but it's helpful to see them sorted;+ -- wrote nubsort as it's more efficient than (nub . sort).+ let omni_types_strs_nubbed = nubsort omni_types_strs+ let omni_types_strs_nubbed' = map (map (\x -> if x == '\n' then ' ' else x)) omni_types_strs_nubbed+ let compactWhite [] = []+ compactWhite (' ':' ':t) = compactWhite (' ':t)+ compactWhite (h:t) = h:compactWhite t+ let omni_types_strs_nubbed'' = map compactWhite omni_types_strs_nubbed'+ let omni_types_strs_nubbed''' = filter (\x -> not (null x) && not (isLower (head x))) omni_types_strs_nubbed''+ let omni_types_strs_nubbed'''' = omni_types_strs_nubbed'''+ -- XXX Not sure if we should exclude boxed types or what...+ let omni_types_strs_nubbed''''' = filter (not . elem '#') omni_types_strs_nubbed''''+ let omni_types_strs_nubbed'''''' = filter (instancesAvailable seqaid_instance_strings) omni_types_strs_nubbed'''''+ let omni_types_string = intercalate "\n" omni_types_strs_nubbed''''''+#if DBG_OMNI+ putMsgS $ " YYY omni_types_string =\n" ++ omni_types_string+-- error "DEVEXIT"+#endif+ liftIO $ writeFile omni_types_pname omni_types_string+ let omni_imports_string' = generateOmniImports dflags omni_types+ let omni_imports_string = intercalate "\n" omni_imports_string'+-- let omni_imports_string = "" -- XXX thack!+ liftIO $ writeFile omni_imports_pname omni_imports_string+ return guts++ else do++-- XXX Why am I content to just look at the head?+-- I /have/ seen more than one module name in a list!+-- (In fact, there's code someplace below to work around this,+-- or is it in the TH code?...)+ anns <- getAnnotations deserializeWithData guts+ :: CoreM (UniqFM [SeqaidAnnIncludeList]) -- (signature required)+ let annseltss = eltsUFM anns :: [[SeqaidAnnIncludeList]]+ let annselts_ = concat annseltss :: [SeqaidAnnIncludeList]+ let annselts = filter ( \ x -> let SeqaidAnnIncludeList y = x in (not $ null y) && thismodname == takeWhile (/='.') (head y)) annselts_ :: [SeqaidAnnIncludeList]++ -- Support for manually-instrumented code (Seqaid.Runtime.seqaid)+ -- requires also giving the SeqaidAnnManual ANN pragma, for now.+ mananns <- getAnnotations deserializeWithData guts+ :: CoreM (UniqFM [SeqaidAnnManual]) -- (signature required)+ let manannseltss = eltsUFM mananns :: [[SeqaidAnnManual]]+ let manannselts_ = concat manannseltss :: [SeqaidAnnManual]+ -- Drop Manual ANN's which name something outside the current module!+ let manannselts' = filter ( \ (SeqaidAnnManual y) -> not (elem '.' y) || thismodname /= takeWhile (/='.') y ) manannselts_ :: [SeqaidAnnManual]+ -- Now assure all are fully-qualified:+ let manannselts = map ( \ (SeqaidAnnManual y) -> SeqaidAnnManual (if elem '.' y then y else thismodname++"."++y) ) manannselts' :: [SeqaidAnnManual]++ typanns <- getAnnotations deserializeWithData guts+ :: CoreM (UniqFM [SeqaidAnnTypes]) -- (signature required)+ let typannseltss = eltsUFM typanns :: [[SeqaidAnnTypes]]+ let typannselts = foldl' (\ (SeqaidAnnTypes acclst) (SeqaidAnnTypes lst)->SeqaidAnnTypes (acclst++lst)) (SeqaidAnnTypes []) $ concat typannseltss :: SeqaidAnnTypes++ let types = (\ (SeqaidAnnTypes tslst) -> tslst ) typannselts+ let dotypes = not $ null types++ bianns <- getAnnotations deserializeWithData guts+ :: CoreM (UniqFM [SeqaidAnnBindsIncluded]) -- (sig. required)+ let biannseltss = eltsUFM bianns :: [[SeqaidAnnBindsIncluded]]+ let biannselts_ = concat biannseltss :: [SeqaidAnnBindsIncluded]+ let biannselts = map (\ (SeqaidAnnBindsIncluded x) -> SeqaidAnnBindsIncluded $ map (assureFQN thismodname) x) biannselts_ :: [SeqaidAnnBindsIncluded]++#if DBG_ANNOTATIONS+--- putMsgS $ "anns = " ++ show anns+--- putMsgS $ "anns = " ++ showSDoc dflags (ppr anns)+ putMsgS $ "annseltss = " ++ concatMap (('\n':) . show) annseltss+ putMsgS $ "annselts = " ++ concatMap (('\n':) . show) annselts+-- putMsgS $ "annselts = " ++ intercalate " " ( map show annselts )+-- putMsgS $ "annseltss = " ++ intercalate " " ( map (showSDoc dflags . ppr) annseltss )+-- putMsgS $ "annselts = " ++ intercalate " " ( map (showSDoc dflags . ppr) annselts )+ putMsgS $ "manannseltss = " ++ concatMap (('\n':) . show) manannseltss+ putMsgS $ "manannselts = " ++ concatMap (('\n':) . show) manannseltss+ putMsgS $ "typannseltss = " ++ concatMap (('\n':) . show) typannseltss+ putMsgS $ "typannselts = " ++ show typannselts+ putMsgS $ "biannseltss = " ++ concatMap (('\n':) . show) biannseltss+ putMsgS $ "biannselts = " ++ concatMap (('\n':) . show) biannselts+#endif++ if null annselts && null manannselts && ( null types || null biannselts )+-- if null annselts && null manannselts && null types+-- if null annselts && null manannselts && null typannselts+-- if null annselts+ then do+#if MENTION_EXCLUDED+#if ! SILENT+ putMsgS $ "Excluded from seqaid harness: " ++ thismodname+#endif+#endif+ return $ guts+ else do++#if ! SILENT+-- Used to print "Included in seqaid harness: ..." message here.+-- Then, it was moved downstream to become per-bind.+-- But finally, now it's done in TH.hs, so it can appear before+-- other messages from TH.+#endif++ let inclstrs'+ = let l = length annselts in+ case l of+ 0 -> []+ 1 -> let SeqaidAnnIncludeList inlst = head annselts in inlst+ _ -> error $ "seqaid: seqaid internal error!\nAt most one SeqaidAnnIncludeList annotation per module (you have " ++ show l ++ ")."++ let inclstrs+ = inclstrs' +++ let l = length biannselts in+ case l of+ 0 -> []+ 1 -> let SeqaidAnnBindsIncluded inlst = head biannselts in inlst+ _ -> error $ "seqaid: seqaid internal error!\nAt most one SeqaidAnnBindsIncluded annotation per module (you have " ++ show l ++ ")."++ let maninclstrs = map ( \ (SeqaidAnnManual manin) -> manin ) manannselts++ let binds_ = mg_binds guts++#if DBG+ putmess "ppr inclstrs"+ putMsgS $ intercalate "\n" inclstrs+ putendmess+#endif++#if DBG_BINDS+ putmess "ppr binds_"+-- mapM (putStrLn . (prBindWithType dflags)) binds_+ mapM (prBindWithType dflags) binds_+-- mapM (printBind dflags) binds_+-- putMsgS $ showSDoc dflags (ppr binds_)+ putendmess+-- error "STOP"+#endif++ let names = map (nameOfBind dflags) binds_+ let (binds,dbinds,mbinds)+ = separateDummyInstanceDecls thismodname names binds_ ([],[],[])++#if DBG_BINDS+ putmess "ppr binds"+ mapM (printBind dflags) binds+-- putMsgS $ showSDoc dflags (ppr binds)+ putmess "ppr dbinds"+ mapM (printBind dflags) dbinds+ putmess "ppr mbinds"+ mapM (printBind dflags) mbinds+ putendmess+-- error "STOP"+#endif++ let (seqinj_noninst_binds, non_seqinj_binds'')+#if NO_TOP_LEVEL_SEQINJ_DUMMIES+ = collectSeqinjBinds dflags "$cseqinj" mbinds ([],[])+--- = collectSeqinjBinds dflags "$cseqinj" binds ([],[])+---- = collectSeqinjBinds dflags (thismodname++".$cseqinj") binds ([],[])+#else+ = collectSeqinjBinds dflags (thismodname++".seqinj") binds ([],[])+#endif+#if DBG_BINDS+ putmess "ppr seqinj_noninst_binds"+ mapM (printBind dflags) seqinj_noninst_binds+-- putMsgS $ showSDoc dflags (ppr seqinj_noninst_binds)+ putendmess+ putmess "ppr non_seqinj_binds''"+ mapM (printBind dflags) non_seqinj_binds''+-- putMsgS $ showSDoc dflags (ppr non_seqinj_binds'')+ putendmess+#endif+ let (seqinj_inst_binds, non_seqinj_binds')+ = collectSeqinjBinds dflags (thismodname++".seqinjinst") non_seqinj_binds'' ([],[])+#if DBG_BINDS+ putmess "ppr seqinj_inst_binds"+ mapM (printBind dflags) seqinj_inst_binds+-- putMsgS $ showSDoc dflags (ppr seqinj_inst_binds)+ putendmess+ putmess "ppr non_seqinj_binds'"+ mapM (printBind dflags) non_seqinj_binds'+-- putMsgS $ showSDoc dflags (ppr non_seqinj_binds')+ putendmess+#endif+ let seqinj_binds = seqinj_inst_binds ++ seqinj_noninst_binds+#if EXCLUDE_COLON_MAIN+ let deleteColonMainmain [] bs = error "deleteColonMainmain: unexpected!"+ deleteColonMainmain (h:t) bs+ | x@(NonRec n e) <- h, (showSDoc dflags $ ppr n) == ":Main.main"+ = (reverse bs++t, h)+ | otherwise+ = deleteColonMainmain t (h:bs)+ let (non_seqinj_binds, colon_main_bind)+ = deleteColonMainmain non_seqinj_binds' []+#else+ let non_seqinj_binds = non_seqinj_binds'+#endif+#if DBG_BINDS+#if 1+ putmess "ppr seqinj_noninst_binds"+ mapM (printBind dflags) seqinj_noninst_binds+-- putMsgS $ showSDoc dflags (ppr seqinj_noninst_binds)+ putendmess+#endif+#if 1+ putmess "ppr seqinj_inst_binds"+ mapM (printBind dflags) seqinj_inst_binds+-- putMsgS $ showSDoc dflags (ppr seqinj_inst_binds)+ putendmess+#endif+#if 0+ putmess "length seqinj_binds"+ putMsgS $ show $ length seqinj_binds+ putendmess+#endif+#if 1+ putmess "ppr non_seqinj_binds"+ mapM (printBind dflags) non_seqinj_binds+-- putMsgS $ showSDoc dflags (ppr non_seqinj_binds)+ putendmess+#endif+#endif+ let (non_seqinj_binds_synthetic, non_seqinj_binds_user)+ = splitSynthUser dflags non_seqinj_binds ([],[])+#if BYPASS+ return $ guts+#else+ non_seqinj_binds_meta+-- XXX By sending 1 as initial siteid, I'm implicitly subscribing+-- to the dangerous idea that reserving siteid=0 might be useful...+-- As for -ve Int's, I have (according to warning message the TH+-- part issues if user attempts to auto-harness a polymorphic bind)+-- that these are reserved for manual injections (where assuring+-- their uniqueness unfortunately becomes the user's responsibility).+ <- markNonSeqinjBinds dflags dotypes inclstrs maninclstrs non_seqinj_binds_user [] (1,"",0)+#if DBG_BINDS+ putmess "ppr non_seqinj_binds_included"+ mapM (printBind dflags) $ map unMeta non_seqinj_binds_meta+-- putMsgS $ showSDoc dflags (ppr non_seqinj_binds_included)+ putendmess+#endif+-- This is all the local variables referring to some binds!+-- (I'm debugging why my Map is empty at the moment...).+-- Apparently, seqinj_binds is [] at this point!+-- But anyway, seqinj_binds = seqinj_inst_binds ++ seqinj_noninst_binds.+-- And ... and, yeah, both of those on the RHS are indeed (of course), []...+--- binds+--- seqinj_noninst_binds+--- non_seqinj_binds''+--- seqinj_inst_binds+--- non_seqinj_binds'+--- seqinj_binds+--- non_seqinj_binds+--- non_seqinj_binds_synthetic+--- non_seqinj_binds_user+--- non_seqinj_binds_included+--- non_seqinj_binds_excluded+ let seqinj_map = makeMapSeqinjBinds dflags seqinj_binds+ let !_ = force seqinj_map+#if DBG+#if 1+ putmess "ppr seqinj_map"+ putMsgS $ show $ size seqinj_map+ putMsgS $ intercalate "\n" $ map show $ Map.toList seqinj_map+-- putMsgS $ showSDoc dflags (ppr seqinj_map)+ putendmess+#endif+#endif+#if DBG_BINDS+ putmess "ppr non_seqinj_binds_meta"+ mapM (prMetaBind dflags) non_seqinj_binds_meta+-- putMsgS $ showSDoc dflags (ppr non_seqinj_binds_meta)+ putendmess+#endif+-- error "STOP"+ newBinds' <- mapM+ (seqinjectFuncPlus seqinj_map seqinj_binds guts types)+ non_seqinj_binds_meta+-- (map unMeta non_seqinj_binds_meta) -- oops!+ -- Don't do any unnecessary reordering of included and excluded;+ -- implement so can preserve (or restore) original ordering to+ -- declarations, to the greatest possible extent...+ let newBinds''+ = non_seqinj_binds_synthetic+#if DO_NOT_ELIDE_ANY_OF_THE_INJECTED_TH_SPLICES+ -- XXX all are needed! (when last I checked)+ -- or you need some environment modifcn...+ -- (This is when using+ -- INJECT_DUMMY_CLASS_AND_INSTANCE_TO_BLOCK_DEAD_CODE_ELIMINATION+ -- in Seqaid/TH.hs.)+-- As for this, if you don't, then you get duplicate mbinds.+#if ! NO_TOP_LEVEL_SEQINJ_DUMMIES+ ++ seqinj_binds+#endif+ ++ mbinds+ ++ dbinds+#endif+ ++ newBinds' -- which now includes non_seqinj_binds_excluded+ -- interleaved in the original order (nec.)+#if EXCLUDE_COLON_MAIN+ let newBinds = newBinds'' ++ [colon_main_bind]+#else+ let newBinds = newBinds''+#endif+#if DBG_BINDS+#if 1+ putmess "ppr newBinds"+-- mapM (printBind dflags) newBinds -- names only+ putMsgS $ showSDoc dflags (ppr newBinds) -- full decls+ putendmess+#endif+#endif+ return $ guts { mg_binds = newBinds }+#endif+ where+ printBind :: DynFlags -> CoreBind -> CoreM CoreBind+ printBind dflags bndr@(NonRec b _) = do+ putMsgS $ "Non-recursive binding named " ++ showSDoc dflags (ppr b)+ return bndr+ printBind dflags bndr@(Rec bes) = do+ putMsgS $ "Recursive binding named " ++ showSDoc dflags (ppr (fst (head bes)))+ return bndr+ printBind _ bndr = return bndr++-------------------------------------------------------------------------------++ prBind :: DynFlags -> CoreBind -> CoreM ()+ prBind dflags bndr@(NonRec b _) = do+ putMsgS $ "Non-recursive binding named " ++ showSDoc dflags (ppr b)+ prBind dflags bndr@(Rec bes) = do+ putMsgS $ "Recursive binding named " ++ showSDoc dflags (ppr (fst (head bes)))+ prBind _ bndr = error "prBind: unexpected!"++ prBindWithType :: DynFlags -> CoreBind -> CoreM String+ prBindWithType dflags bndr = do+ let name_part+ = case bndr of+ NonRec b _ -> "NR " ++ showSDoc dflags (ppr b)+ Rec bes -> " R " ++ showSDoc dflags (ppr $ fst $ head bes)+ let type_part'' = typeOfBind bndr+ let type_part' = showSDoc dflags (ppr type_part'')+ let type_part = map (\c->if c == '\n' then ' ' else c) type_part'+ let rslt = name_part ++ " :: " ++ type_part+ putMsgS rslt+ return rslt+ prBindWithType _ bndr = error "prBindWithType: unexpected!"++ prMetaBind :: DynFlags -> CoreBindMeta -> CoreM ()+ prMetaBind dflags inex = do+ let (inexstr,sid,dododo,bndr) = case inex of+ Incl sid dododo@(do_wrap,do_man,do_typ) bndr -> ("INCL",sid,dododo,bndr)+ Excl sid bndr -> ("EXCL",sid,(False,False,False),bndr)+ case bndr of+ NonRec b _ -> putMsgS $ inexstr ++ " NR name=" ++ showSDoc dflags (ppr b)+ ++ " sid=" ++ show sid ++ " (do_wrap,do_man,do_typ)=" ++ show dododo+ Rec bes -> putMsgS $ inexstr ++ " R name=" ++ showSDoc dflags (ppr (fst (head bes)))+ ++ " sid=" ++ show sid ++ " (do_wrap,do_man,do_typ)=" ++ show dododo+ prMetaBind _ bndr = error "prMetaBind: unexpected!"++-------------------------------------------------------------------------------++ splitSynthUser :: DynFlags -> [CoreBind] -> ([CoreBind],[CoreBind]) -> ([CoreBind],[CoreBind])+ splitSynthUser dflags [] (ss,us) = (reverse ss,reverse us)+--splitSynthUser dflags [] r@(ss,us) = r+ splitSynthUser dflags (h:t) (ss,us)+ = case h of+ bndr@(NonRec b _) ->+ if head (showSDoc dflags (ppr b)) == '$'+-- if head b == '$'+ then splitSynthUser dflags t (h:ss, us)+ else splitSynthUser dflags t ( ss,h:us)+ bndr@(Rec bes) ->+ if head (showSDoc dflags (ppr bes)) == '$'+ then splitSynthUser dflags t (h:ss, us)+ else splitSynthUser dflags t ( ss,h:us)+-- error "#2093857"++-------------------------------------------------------------------------------++ markNonSeqinjBinds :: DynFlags -> Bool -> [String] -> [String] -> [CoreBind] -> [CoreBindMeta] -> SiteID -> CoreM [CoreBindMeta]+ markNonSeqinjBinds dflags dotypes exorinstrs maninclstrs [] acc siteid = return $ reverse acc+ markNonSeqinjBinds dflags dotypes exorinstrs maninclstrs (h:t) acc siteid+ | bndr@(NonRec b _) <- h+ = do+ let bname = showSDoc dflags (ppr b)+ let dododo@(do_wrap, do_man, do_typ)+ = ( bname `elem` exorinstrs+ , bname `elem` maninclstrs+ , dotypes && do_wrap+ )+ if do_wrap || do_man || do_typ+ then+#if DBG+ trace ("!i! "++bname) $+#endif+ markNonSeqinjBinds dflags dotypes exorinstrs maninclstrs t (Incl siteid dododo h : acc) siteid_next+ else+#if DBG+ trace ("!x! "++bname) $+#endif+ markNonSeqinjBinds dflags dotypes exorinstrs maninclstrs t (Excl siteid h : acc) siteid_next+ | bndr@(Rec bes) <- h+ = do+ let (b,_) = head bes+ let bname = showSDoc dflags (ppr b)+ let dododo@(do_wrap, do_man, do_typ)+ = ( bname `elem` exorinstrs+ , bname `elem` maninclstrs+ , dotypes && do_wrap+ )+ if do_wrap || do_man || do_typ+ then+#if DBG+ trace ("!i! "++bname) $+#endif+ markNonSeqinjBinds dflags dotypes exorinstrs maninclstrs t (Incl siteid dododo h : acc) siteid_next+ else+#if DBG+ trace ("!x! "++bname) $+#endif+ markNonSeqinjBinds dflags dotypes exorinstrs maninclstrs t (Excl siteid h : acc) siteid_next+--- | bndr@(Rec bes) <- h = error "markNonSeqinjBinds: Rec unimplemeted!"+ | otherwise = error "markNonSeqinjBinds: unexpected!"+ where+-- XXX I'm pretty sure all but the name part (snd3 component) are+-- going to get overwritten downstream, now, since planning to+-- support manual injection via SYB renumbering...+-- (That's okay though; and doing this still here will help+-- keep old code working that bit longer while transition...)+ (siteid_idx,siteid_name,_) = siteid+#if DEMO_MODE+ siteid_hash = 0+#else+ siteid_hash = hash (siteid_name++show siteid_idx)+#endif+ siteid_next = (1+siteid_idx, siteid_name, siteid_hash)+-- siteid_next = (1 + fst siteid, snd siteid)++-------------------------------------------------------------------------------++ -- Note this is not general-purpose; it is for getting the RHS's+ -- of seqinj_* binds.+ getBindRHS :: ModGuts -> DynFlags -> CoreBind -> CoreM CoreExpr+ getBindRHS guts dflags bind = do+-- I don't recall seeing these traces for some time, actually?...+#if DBG+ let !_ = trace ( "#$#-bind " ++ (showSDoc dflags $ ppr bind)) $ ()+#endif+ let ecb | x@(NonRec b e) <- bind = e+ | x@(Rec bes) <- bind = snd $ head bes -- shouldn't happen+ | otherwise = trace "BOO!!" $ undefined :: Expr CoreBndr+#if DBG+ let !_ = trace ( "#$#-rhs " ++ (showSDoc dflags $ ppr ecb)) $ ()+#endif+ return ecb++-------------------------------------------------------------------------------++ collectSeqinjBinds :: DynFlags -> String -> [CoreBind] -> ([CoreBind],[CoreBind]) -> ([CoreBind],[CoreBind])+ collectSeqinjBinds dflags nam [] acc@(seqinjbs, nonseqinjbs)+-- XXX not sure why I'm not reversing here; compensating for elsewhere??...+ =+#if DBG+ trace "&&-[]-&&" $+#endif+ (seqinjbs, nonseqinjbs)+-- = (reverse seqinjbs, reverse nonseqinjbs)+ collectSeqinjBinds dflags nam (h:t) acc@(seqinjbs, nonseqinjbs)+ | x@(NonRec n e) <- h+ =+#if DBG+ trace (" &&-NonRec-&& " ++ (showSDoc dflags $ ppr n)) $+#endif+ if (takeWhile (/='_') (showSDoc dflags $ ppr n)) == nam+ then recurs True+ else recurs False+ | x@(Rec nes) <- h+ =+ let (n,e) = head nes in+#if DBG+ trace (" &&-Rec-&& " ++ (showSDoc dflags $ ppr n)) $+#endif+ if (takeWhile (/='_') (showSDoc dflags $ ppr n)) == nam+ then recurs True+ else recurs False+ | otherwise = error $ "collectSeqinjBinds: unexpected!"+ where+ recurs False = collectSeqinjBinds dflags nam t (seqinjbs, h:nonseqinjbs)+ recurs True = collectSeqinjBinds dflags nam t (h:seqinjbs, nonseqinjbs)++-------------------------------------------------------------------------------++ -- We already know it's all NonRec's.+ -- Okay, this is almost right, but it's going to need types.+ -- No use for keys "seqinj_7" etc.! Need keys to be whatever+ -- exprType returns, and we can find out exactly by using+ -- it on those seqinj's RHS's (complicated by the fact that+ -- it's <type> -> <type>, and we only really want <type>).+ makeMapSeqinjBinds :: DynFlags -> [CoreBind] -> Map String Int+ makeMapSeqinjBinds dflags lst+-- = error (intercalate "\n" $ map show $ Map.toList themap2)+ =+#if DBG_MAP_CREATION+ trace ("length lst=" ++ show (length lst) ++ "\n" ++ (intercalate "\n" $ map show $ Map.toList themap2)) $+#endif+ themap2+ where+ themap0 = Map.fromList $ go 0 lst+ themap2 = themap0+ go i [] = []+ go i ((Rec bes):t) = trace ("NonRec: "++sn) $ (se', i) : go (1+i) t+-- go i ((Rec bes):t) = (se', i) : go (1+i) t+ where+-- We only need the name of the bind, and the type of the RHS. Since every+-- binding in the group must have the same type, we only look at the first.+ (n,e) = head bes+ !_ = trace se' $ ()+ e_ = gExpandTypeSynonyms e+ se_ = showSDoc dflags $ ppr e_+ se = sanitiseTypeString se_+ marr = (se =~ "Seqaid.Runtime.seqaidDispatch *@ ") :: MatchArray+ (a,b) = (marr!0)+ se'' = drop (a+b) se+ se''' = reverse $ dropWhile (==' ') $ (\(h:t) -> if h == '.' then dropWhile (/=' ') t else (h:t)) $ reverse $ takeWhile (\c->c/='$'&&c/='\n') se''+ se' = if head se''' == '(' then se''' else "("++se'''++")"+ sn = showSDoc dflags $ ppr n+-- go i ((Rec _):t) = error "makeMapSeqinjBinds: Rec's not yet handled!!"+ go i ((h@(NonRec n e)):t) = (se', i) : go (1+i) t+ where+#if 0 && DBG+ sh = showSDoc dflags $ ppr h+ !_ = trace ("\n%%%%%%%%%%%%%%% sh %\n"++sh) $ ()+ !_ = trace ("\n%%%%%%%%%%%%%%% sn %\n"++sn) $ ()+ !_ = trace ("\n%%%%%%%%%%%%%%% se %\n"++se) $ ()+ !_ = trace ("\n%%%%%%%%%%%%%%% se' %\n"++se') $ ()+--- !_ = trace se' $ ()+---- !_ = trace (showSDoc dflags $ ppr e) $ error "" :: ()+#endif+ e_ = gExpandTypeSynonyms e+ se_ = showSDoc dflags $ ppr e_+ se = sanitiseTypeString se_+#if TRY_NO_SEQAIDDISPATCH_INTERMEDIARY+-- XXX Not tested in a long while.+#if SEQABLE_ONLY+ marr = (se =~ "Control.DeepSeq.Bounded.Seqable.force_ *@ ") :: MatchArray+#else+#if TRY_SIMPLY_NFDATA+ marr = (se =~ "Control.DeepSeq.force *@ ") :: MatchArray+#else+#if NFDATAN_ONLY+ marr = (se =~ "Control.DeepSeq.Bounded.NFDataN.forcen *@ ") :: MatchArray+#else+ marr = (se =~ "Control.DeepSeq.Bounded.NFDataP.forcep *@ ") :: MatchArray+-- marr = (se =~ "Control.DeepSeq.Bounded.NFDataN.forcen *@ ") :: MatchArray+#endif+#endif+#endif+#else+ marr = (se =~ "Seqaid.Runtime.seqaidDispatch *@ ") :: MatchArray+-- marr = (se =~ "Seqaid.Runtime.seqaidDispatch\n *@ ") :: MatchArray+#endif+ (a,b) = (marr!0)+ se'' = drop (a+b) se+ -- this needed for imported types+ se''' = reverse $ dropWhile (==' ') $ (\(h:t) -> if h == '.' then dropWhile (/=' ') t else (h:t)) $ reverse $ takeWhile (\c->c/='$'&&c/='\n') se''+ se' = if head se''' == '(' then se''' else "("++se'''++")"+ sn = showSDoc dflags $ ppr n++-------------------------------------------------------------------------------++ cleanupMap :: [(String,String)] -> Map String Int -> Map String Int+ cleanupMap [] m = m+ cleanupMap ((x,r):t) m = cleanupMap t m'+ where+ mmv = Map.lookup x m+ m' | isNothing mmv = m+ | otherwise = m'''+ where+ Just lav = mmv+ m'' = Map.delete x m+ m''' = Map.insert r lav m''++-------------------------------------------------------------------------------++ seqinjectFuncPlus :: Map String Int -> [CoreBind] -> ModGuts -> [String] -> CoreBindMeta -> CoreM CoreBind+ seqinjectFuncPlus seqinj_map seqinj_binds guts types (Excl siteid b) = return b+ seqinjectFuncPlus seqinj_map seqinj_binds guts types cbm@(Incl siteid dododo@(do_wrap,do_man,do_typ) x) = do+ dflags <- getDynFlags+#if DBG_SEQINJECT_FUNC+ putMsgS "seqinjectFuncPlus:"+ prBind dflags x+#endif+#if INFER_TOP_LEVEL_TYPES+ cb' <- if do_wrap+ then seqinjectFunc seqinj_map seqinj_binds guts cbm+ else return x+#else+ let cb' = x+#endif+ cb <- if do_man || do_typ+ then setManualSiteIDsAndDoTypesBasedSubexpressionInjections dflags dododo seqinj_map seqinj_binds guts types cb'+ else return cb'+ return cb++-------------------------------------------------------------------------------++ seqinjectFunc :: Map String Int -> [CoreBind] -> ModGuts -> CoreBindMeta -> CoreM CoreBind+ seqinjectFunc seqinj_map seqinj_binds guts (Excl siteid b) = return b+ seqinjectFunc seqinj_map seqinj_binds guts (Incl siteid dododo@(do_wrap,do_man,do_typ) (x@(NonRec b e))) = do + dflags <- getDynFlags+ let nb = nameOfBind dflags x+#if DBG_SEQINJECT_FUNC+ putMsgS $ "!!seqinjectFunc!! " ++ nb+#endif+ tstr <- sanitiseTypeStringExpr dflags e+#if 0 || DBG+ let !_ = putMsgS $ "tstr = " ++ tstr+#endif+ let banned_list = [] -- (vestigial)+ if or $ map (flip isPrefixOf tstr) banned_list+ then do+#if DBG_MAP_LOOKUP+ let !_ = trace "-->>banned<<--" $ ()+#endif+ return x+ else do+ let midx =+#if DBG_MAP_LOOKUP+ trace (" ++++++>> " ++ tstr ++ " << " ++ (showSDoc dflags $ ppr (exprType e)) ++ " >> ") $+#endif+ if head tstr == '('+ then Map.lookup ( tstr ) seqinj_map+ else Map.lookup ("("++tstr++")") seqinj_map+ if isNothing midx+ then do+#if ! NO_WARN_SITE_MISSING_INSTANCE+--- #if ! SILENT+#if SEQABLE_ONLY+ putMsgS $ "seqaid: warning: couldn't find SOP Generic instance for type\n " ++ tstr+#else+#if NFDATAN_ONLY+ putMsgS $ "seqaid: warning: couldn't find NFDataN instance for type\n " ++ tstr+#else+ putMsgS $ "seqaid: warning: couldn't find NFDataP instance for type\n " ++ tstr+#endif+#endif+#endif+ return x+ else do+ let idx = fromJust midx+ the_force_var <- getBindRHS guts dflags $ seqinj_binds!!idx+#if 0 || DBG+ let !_ = trace ("\n@@@@@@@@@@@@@@@@\n"++(showSDoc dflags $ ppr x)) $ ()+ let !_ = trace ("\n!!!!!!!!!!!!!!!!\n"++(showSDoc dflags $ ppr the_force_var)) $ ()+ let !_ = trace ("\n????????????????\n"++(showSDoc dflags $ ppr e )++"\n") $ ()+#endif+#if DRY_RUN+ let e' = e+#else+ -- XXX hardcode (however, pad never truncates)+ let bs = pad 10 $ showSDoc dflags $ ppr b+-- let bs = showSDoc dflags $ ppr b+ bse <- mkStringExpr bs+-- We need to inject to the right of any initial lambda bindings;+-- joining us for this occasion:+-- collectBinders :: Expr b -> ([b], Expr b)+-- mkCoreLams :: [CoreBndr] -> CoreExpr -> CoreExpr+ let (ebs,ee) = collectBinders e+ let e'' = mkCoreApp+ ( mkCoreApp+ the_force_var+ ( let idx = fst3 siteid in+ ( mkCoreTup+ [ mkIntExprInt dflags idx+ , bse+#if DEMO_MODE+ , mkIntExprInt dflags 0+#else+ , mkIntExprInt dflags $ hash $ bs ++ show idx+#endif+ ]+ )+ )+ )+ ee+ let e' = mkCoreLams ebs e''+#endif+ return $ NonRec b e'+ seqinjectFunc seqinj_map seqinj_binds guts (Incl siteid dododo (x@(Rec bes))) = do + bes' <- mapM (\ (b,e) -> do { (NonRec b' e') <- seqinjectFunc seqinj_map seqinj_binds guts (Incl siteid dododo (NonRec b e)) ; return (b',e') } ) bes+ return $ Rec bes'++-------------------------------------------------------------------------------++ -- A bit later: Now I'm going to try adding the types-based site+ -- selection to this (seqiad.config). But I'm going to clone the+ -- existing SYB traversal and run a second traversal instead?...+ -- Er, no.+ -- Keep them together, and then can avoid doing double (which would+ -- be a user error anyhow -- if they manually injected, as well as+ -- listed the type in their seqaid.config, they're asking for double,+ -- but may as well code it right and prevent redundant wrapping even+ -- in such cases...+ ------+ -- Note that, at present, this function is only called for binds+ -- which have a {-# ANN module (SeqaidAnnManual "funcname") #-}+ -- present in the same file (typically, but not necessarily,+ -- at the declaration head). Would prefer to auto-detect the+ -- seqaid applications, but don't know how yet (TH staging woes).+ setManualSiteIDsAndDoTypesBasedSubexpressionInjections :: DynFlags -> (Bool,Bool,Bool) -> Map String Int -> [CoreBind] -> ModGuts -> [String] -> CoreBind -> CoreM CoreBind+ setManualSiteIDsAndDoTypesBasedSubexpressionInjections dflags dododo@(do_wrap,do_man,do_typ) seqinj_map seqinj_binds guts types cb = do+ let nb = nameOfBind dflags cb+#if DBG_SEQINJECT_FUNC+ prBind dflags cb+ putMsgS $ nb+#endif+ let nb'= dropQuals nb + if do_man+ then putMsgS $ "Manual seqaid instrumentation found: " ++ nb'+ else putMsgS $ "Harnessing bind: " ++ nb'+ nbe <- mkStringExpr nb+ (cb',!_) <- flip runStateT (1::Int) . everywhereM (mkM (mfg do_man seqinj_map seqinj_binds guts types nb nbe)) $ cb+-- let (cb',!_) = flip runStateT (1::Int) . everywhereM (mkM (mfg do_man seqinj_map seqinj_binds guts types nb nbe)) $ cb+-- let (cb',!_) = flip runState (1::Int) . everywhereM (mkM (mfg do_man seqinj_map seqinj_binds guts types nb nbe)) $ cb+ return cb'++ where++ {- NOINLINE mfg #-}+ -- XXX It would be nice to nudge the SYB traversal along, past+ -- this application of seqaid*, since otherwise there will be+ -- testing some descendants in vain ... but never mind for now;+ -- that's an optimisation...+ mfg ::+ Bool -- process for Manual injection+ -> Map String Int -- seqinj_map ("the Map")+ -> [CoreBind] -- seqinj_binds (seqinj_[0-9]*)+ -> ModGuts -- guts ("the guts")+ -> [String] -- types (from seqaid.config)+ -> String -- nb (name of bind being processed)+ -> CoreExpr -- nbe (mkStringExpr nb)+ -> CoreExpr -- node in Core AST (SYB traversal)+ -> StateT Int CoreM CoreExpr -- result (refactored Core AST)+-- mfg seqinj_map seqinj_binds guts types nb nbe app@App{} = do+-- mfg :: Map String Int -> [CoreBind] -> ModGuts -> [String] -> String -> CoreExpr -> CoreExpr -> State Int CoreExpr++-- XXX decided to just make Manual and types-based mutually-exclusive+-- to start with here... When get to allow both at once again,+-- definitely a single traversal is appropriate. Just for the SiteID+-- indexing if nothing else!...+--- #if ! SEQAIDPP_TYPES++-- XXX note that now, with the types-based coming in, we're not+-- only wrapping App nodes; so the catch-all case below this+-- needs to do wrapping too. But we do need an App-node case+-- because want to avoid redundant wrapping.+ mfg doman@True seqinj_map seqinj_binds guts types nb nbe app@App{} = do+ let (!fun@(Var q1),q2s) = collectArgs app+ let q1str = showSDoc dflags $ ppr q1+ let len = length q2s+#if DBG_MANUAL+ !_ <- trace ("q1str="++q1str++" |q2s|="++show len) $ return ()+-- if q1 /= nam then error "UNEXPECTED!" else return ()+ !_ <- if q1str == "Seqaid.Runtime.seqaidDispatch" then trace ("len="++show len) $ return () else return ()+#endif+ if q1str == "Seqaid.Runtime.seqaidDispatch"+ then do+#if DBG_MANUAL+ !_ <- trace (showSDoc dflags $ ppr app) $ return ()+#endif+ return ()+ else return ()+ if len /= 7 -- XXX won't catch the "seqaid $" wrapper pattern, though!+ then return app+ else do+ if q1str == "Seqaid.Runtime.seqaidDispatch"+ then do+ i <- get+#if 0 && DEMO_MODE+-- This caused Prelude.undefined errors at runtime last I checked.+ -- XXX note that, with this, the State "put" below is conditional,+ -- which is a recipe for a space leak... ("ironically")+ -- XXX This is totally fragile; it's very much a hack demo mode thing!+ if i /= 6 then return app+ else do+#else+ do+#endif+ put (1+i)+-- let tupcon = tupleCon UnboxedTuple 3+ let tupcon = tupleCon BoxedTuple 3+#if DBG_MANUAL+ !_ <- trace "=1==============================" $ return ()+ !_ <- trace (showSDoc dflags $ ppr app) $ return ()+ !_ <- trace "=2==============================" $ return ()+ !_ <- trace (showSDoc dflags $ ppr q2s) $ return ()+ !_ <- trace "=3==============================" $ return ()+#endif+#if DEMO_MODE+ let h = 0+#else+ let h = hash $ nb ++ show i+#endif+#if DBG_MANUAL+ !_ <- trace (show i++" "++show nb++" "++show h) $ return ()+#endif+-- let tuptycon = mkTupleTy UnboxedTuple (map (Type . exprType) blahs)+ let blahs = [ mkIntExprInt dflags i+ , nbe+ , mkIntExprInt dflags h ]+ let arg = mkConApp tupcon $ (map (Type . exprType) blahs) ++ blahs+#if DBG_MANUAL+ !_ <- trace (showSDoc dflags $ ppr arg) $ return ()+ !_ <- trace "=4==============================" $ return ()+#endif+ let fun' = fun+ let app' = mkCoreApps fun' $ (take (-2+len) q2s) ++ [arg] ++ [last q2s]+#if DBG_MANUAL+ !_ <- trace ("app before:\n"++(showSDoc dflags $ ppr app)) $ return ()+ !_ <- trace ("app after:\n"++(showSDoc dflags $ ppr app')) $ return ()+--- !_ <- trace (showSDoc dflags $ ppr app') $ return ()+ !_ <- trace "=5==============================" $ return ()+#endif+#if 0+ (\x -> (return $! x) >>= return) app'+ return app+#else+ return app'+#endif+ else do+#if DBG_MANUAL+ !_ <- trace "= *** 1 ==============================" $ return ()+ !_ <- trace (showSDoc dflags $ ppr app) $ return ()+ !_ <- trace "= *** 2 ==============================" $ return ()+#endif+ return app+ mfg doman@True _ _ _ _ _ _ x = return x++--- #else++ -- x is any CoreExpr except for an App node (which is covered above)+ -- Later: No it isn't covered above! I vaguely recall what I meant+ -- by that at the time, but I don't see it now...+-- mfg doman@False seqinj_map seqinj_binds guts types nb nbe x = do+ mfg doman@False seqinj_map seqinj_binds guts types nb nbe x@App{} = do+--isSaturatedApp :: DynFlags -> Type -> Bool+ let tx = exprType x+ if not $ isSaturatedApp tx+ then do+ return x+ else do+#if 0+ txstr <- showSDoc dflags $ ppr tx+#else+ txstr <- lift $ sanitiseTypeStringExpr dflags x+#endif+#if DBG_SEQINJECT_FUNC+ !_ <- trace (">> App >>>> " ++ txstr ++ " /// " ++ intercalate " " types) $ return ()+#endif+ if not $ txstr `elem` types+ then return x+ else do+ -- XXX User should refrain from ()-ing in seqaid.config; this+ -- is not enough anyway, as they could even go types: (((Int)))...+ let midx =+ if head txstr == '('+ then Map.lookup ( txstr ) seqinj_map+ else Map.lookup ("("++txstr++")") seqinj_map+ if isNothing midx+ then do+#if ! NO_WARN_SITE_MISSING_INSTANCE+--- #if ! SILENT+#if SEQABLE_ONLY+ !_ <- trace ("seqaid: warning: couldn't find SOP Generic instance for type\n " ++ txstr) $ return ()+#else+#if NFDATAN_ONLY+ !_ <- trace ("seqaid: warning: couldn't find NFDataN instance for type\n " ++ txstr) $ return ()+#else+ !_ <- trace ("seqaid: warning: couldn't find NFDataP instance for type\n " ++ txstr) $ return ()+#endif+#endif+#endif+ return x+ else do+#if DBG_SEQINJECT_FUNC+ !_ <- trace ("<< App <<<< " ++ txstr) $ return ()+#endif+ let idx = fromJust midx+ the_force_var <- lift $ getBindRHS guts dflags $ seqinj_binds!!idx+ i <- get+ put (1+i)+-- let tupcon = tupleCon UnboxedTuple 3+ let tupcon = tupleCon BoxedTuple 3+#if DEMO_MODE+ let h = 0+#else+ let h = hash $ nb ++ show i+#endif+ let blahs = [ mkIntExprInt dflags i+ , nbe+ , mkIntExprInt dflags h ]+ let sidarg = mkCoreTup blahs+-- let sidarg = mkConApp tupcon $ (map (Type . exprType) blahs) ++ blahs+ let x' = mkCoreApp+ ( mkCoreApp+ the_force_var+ sidarg+ )+ x+ return x'++ mfg doman@False seqinj_map seqinj_binds guts types nb nbe x@Var{} = do+ if exprIsVarWithFunctionType x+ then return x+ else do+ txstr <- lift $ sanitiseTypeStringExpr dflags x+#if DBG_SEQINJECT_FUNC+ !_ <- trace (">> Var >>>> " ++ txstr ++ " /// " ++ intercalate " " types) $ return ()+#endif+ if not $ txstr `elem` types+ then return x+ else do+ + -- XXX User should refrain from ()-ing in seqaid.config; this+ -- is not enough anyway, as they could even go types: (((Int)))...+ let midx =+ if head txstr == '('+ then Map.lookup ( txstr ) seqinj_map+ else Map.lookup ("("++txstr++")") seqinj_map+ if isNothing midx+ then do+#if ! NO_WARN_SITE_MISSING_INSTANCE+--- #if ! SILENT+#if SEQABLE_ONLY+ !_ <- trace ("seqaid: warning: couldn't find SOP Generic instance for type\n " ++ txstr) $ return ()+#else+#if NFDATAN_ONLY+ !_ <- trace ("seqaid: warning: couldn't find NFDataN instance for type\n " ++ txstr) $ return ()+#else+ !_ <- trace ("seqaid: warning: couldn't find NFDataP instance for type\n " ++ txstr) $ return ()+#endif+#endif+#endif+ return x+ else do+#if DBG_SEQINJECT_FUNC+ !_ <- trace ("<< Var <<<< " ++ txstr) $ return ()+#endif+ let idx = fromJust midx+ the_force_var <- lift $ getBindRHS guts dflags $ seqinj_binds!!idx+ i <- get+ put (1+i)+-- let tupcon = tupleCon UnboxedTuple 3+ let tupcon = tupleCon BoxedTuple 3+#if DEMO_MODE+ let h = 0+#else+ let h = hash $ nb ++ show i+#endif+ let blahs = [ mkIntExprInt dflags i+ , nbe+ , mkIntExprInt dflags h ]+ let sidarg = mkCoreTup blahs+-- let sidarg = mkConApp tupcon $ (map (Type . exprType) blahs) ++ blahs+ let x' = mkCoreApp+ ( mkCoreApp+ the_force_var+ sidarg+ )+ x+ return x'++ mfg doman@False seqinj_map seqinj_binds guts types nb nbe x = return x++--- #endif++-------------------------------------------------------------------------------++ dropQuals :: String -> String+#if 0+ dropQuals = id+#else+ -- XXX WARNING: This is causing errors for some types!+ -- For instance, a type which contains a type-subexpression+ -- which itself contains a qualified type name.+ dropQuals = reverse . takeWhile (/= '.') . reverse+#endif++-------------------------------------------------------------------------------++ sanitiseTypeStringExpr :: DynFlags -> CoreExpr -> CoreM String+ sanitiseTypeStringExpr dflags e = do+ let te__ = exprType e+ -- XXX is there not a GHC API function I saw for this?...+ let te_ = followArrows te__ -- use the result type+ let te = GHC.expandTypeSynonyms te_+ let tstr = showSDoc dflags $ pprType te+#if DBG+ let !_ = trace ("--- " ++ tstr) $ ()+#endif+ let santstr = removeForallPartHack tstr+-- let santstr = tstr+-- let santstr = sanitiseTypeString_old tstr+#if DBG+ let !_ = trace ("+++ " ++ santstr) $ ()+#endif+ return santstr++-------------------------------------------------------------------------------++ -- XXX VERY BAD INDEED!!!+ removeForallPartHack :: String -> String+ removeForallPartHack s = sanitiseTypeString s_+ where+#if 1+ marr1 = (s =~ "^forall ") :: MatchArray+ (a1,b1) = (marr1!0)+ marr2 = (s =~ "=> ") :: MatchArray+ (a2,b2) = (marr2!0)+ s_ | null $ indices marr1 = s+ | null $ indices marr2 = s+ | otherwise+ = dropWhile (\x -> x==' '||x=='\t'||x=='\n')+ $ drop (a2+b2) s+#else+ s_ | let s' = "forall " in s' == take (length s') s+ = dropWhile (\x -> x==' '||x=='\t'||x=='\n')+ $ drop 2+ $ dropWhile (/='=') s+ | otherwise+ = s+#endif++-------------------------------------------------------------------------------++ sanitiseTypeString :: String -> String+ sanitiseTypeString s = s''+ where+ s' = map (\c -> if c=='\n' then ' ' else c) s+ s'' = f s'+ f [] = []+ f (' ':' ':cs) = f (' ':cs)+ f (c:cs) = c : f cs++-------------------------------------------------------------------------------++ putmess :: String -> CoreM ()+ putmess s = do+ let s' = "== " ++ s ++ " "+ let l = length s'+ let n = max (79 - l) 0+ putMsgS $ s' ++ take n (repeat '=')++ putendmess :: CoreM ()+ putendmess = do+ putMsgS $ take 79 (repeat '=')++-------------------------------------------------------------------------------++ -- Not the most efficient but whatever.+ -- Also, I don't like writing monadic code, so the caller computes+ -- the String names of the binds, and passes them.+ separateDummyInstanceDecls :: String -> [String] -> [CoreBind] -> ([CoreBind],[CoreBind],[CoreBind]) -> ([CoreBind],[CoreBind],[CoreBind])+ separateDummyInstanceDecls _ [] [] (acc_bs,acc_dbs,acc_mbs)+ = (reverse acc_bs,reverse acc_dbs,reverse acc_mbs)+ separateDummyInstanceDecls modname (n:ns) (b:bs) (acc_bs,acc_dbs,acc_mbs)+ = if let x = (elision_targets!!0) in x == take (length x) n+ then separateDummyInstanceDecls modname ns bs (acc_bs,acc_dbs,b:acc_mbs)+ else+ if let x = (elision_targets!!1) in x == take (length x) n+ then separateDummyInstanceDecls modname ns bs (acc_bs,b:acc_dbs,acc_mbs)+ else separateDummyInstanceDecls modname ns bs (b:acc_bs,acc_dbs,acc_mbs)+ where+ modname' = map (\x -> if x == '.' then '_' else x) modname+ elision_targets = [ "$cseqinj_meth_" , modname++".$fSeqinjDummyClass_"++modname'++"()" ]+-- elision_targets = [ "$cseqinj_meth_" , modname++".$fSeqinjDummyClass()" ]+ separateDummyInstanceDecls _ _ _ _ = error "39489387"++-------------------------------------------------------------------------------++ nameOfBind :: DynFlags -> CoreBind -> String+ nameOfBind dflags bndr@(NonRec b _) = showSDoc dflags (ppr b)+ nameOfBind dflags bndr@(Rec ((b,_):_)) = showSDoc dflags (ppr b)+ nameOfBind dflags _ = error "nameOfBind: unexpected"++-------------------------------------------------------------------------------++ typeOfBind :: CoreBind -> Type+ typeOfBind bndr@(NonRec _ e) = exprType e+ typeOfBind bndr@(Rec ((_,e):_)) = exprType e+ typeOfBind _ = error "typeOfBind: unexpected"++-------------------------------------------------------------------------------++ pad :: Int -> String -> String+ pad n s = s ++ (take (n-(length s)) $ repeat ' ')++-------------------------------------------------------------------------------++ fst3 :: (a,b,c) -> a+ fst3 (x,_,_) = x+ snd3 :: (a,b,c) -> b+ snd3 (_,y,_) = y+ thd3 :: (a,b,c) -> c+ thd3 (_,_,z) = z++-------------------------------------------------------------------------------++ -- These two used to be in different spots in this file.+ -- I'm not sure they're both needed/wanted?...++ isSaturatedApp :: Type -> Bool+ isSaturatedApp ty = b+ where+ b = if isFunTy ty+ then {- trace ("isSaturatedApp: FALSE ") $ -} False+ else {- trace ("isSaturatedApp: TRUE " ) $ -} True++ exprIsVarWithFunctionType :: CoreExpr -> Bool+ exprIsVarWithFunctionType e = b+ where+ t = exprType e+ b = case t of+ GHC.FunTy arg res -> True+ _ -> False++-------------------------------------------------------------------------------++ followArrows :: Type -> Type+ followArrows (GHC.FunTy arg res) = followArrows res+ followArrows t = t++-------------------------------------------------------------------------------++ gExpandTypeSynonyms :: CoreExpr -> CoreExpr+ gExpandTypeSynonyms e = e'+ where+ e' = everywhere (mkT fg) e+ fg :: Type -> Type+ fg x = GHC.expandTypeSynonyms x++-------------------------------------------------------------------------------++-- XXX The SYB traversal need not be monadic.+-- Possibly, the CoreM monad is not even needed...++ collectSubexpressionTypes :: ModGuts -> CoreM [Type]+ collectSubexpressionTypes guts = do+ let binds = mg_binds guts+ tyss <- mapM collectSubexpressionTypesBind binds+ let tys = concat tyss+ return tys++ collectSubexpressionTypesBind :: CoreBind -> CoreM [Type]++ collectSubexpressionTypesBind (NonRec _ e) = do+ (_,tys) <- flip runStateT ([]::[Type]) . everywhereM (mkM mfg) $ e++ let tys' = map GHC.expandTypeSynonyms tys+ return tys'+-- return tys+-- return $ nub tys -- no Eq instance!+ where+ mfg :: CoreExpr -> StateT [Type] CoreM CoreExpr+ mfg e = do+ case e of+ Type _ -> return e+ _ -> do+ tys <- get+ let et = exprType e+ put (et:tys)+ return e++ collectSubexpressionTypesBind (Rec bes) = do + tyss <- mapM (\ (b,e) -> collectSubexpressionTypesBind (NonRec b e)) bes+ let tys = concat tyss+ return tys++-------------------------------------------------------------------------------++ generateOmniImports :: DynFlags -> [Type] -> [String]+ generateOmniImports dflags lst = imps'+ where+ imps = generateOmniImports' dflags lst+ -- This is ridiculously costly, but at this point that's+ -- not a concern.+ imps' = nub imps -- have to, even though the lst was pre-nubbed,+ -- because we're extracting subtypes in here++ -- XXX In here we have some very brutal hacks, just to get+ -- proof-of-concept happening. Do something better!...+ generateOmniImports' :: DynFlags -> [Type] -> [String]+ generateOmniImports' dflags [] = []+ generateOmniImports' dflags (t:ts)+ = all_imps ++ generateOmniImports' dflags ts+ where+ tstr = showSDoc dflags $ ppr t+ all_typenames = getAllTextMatches+ $ tstr =~ "[A-Z][.A-Za-z0-9_']*" :: [String]+ all_typenames' = filter (/= "GHC.Prim.Void") all_typenames+ all_typenames'' = filter (/= "GHC.Prim.Addr") all_typenames'+#if 1+ all_typenames''' = filter (/= "Control.DeepSeq.Bounded.Pattern.Pattern") all_typenames''+ all_typenames'''' = filter (/= "Seqaid.Global.SiteID") all_typenames'''+#if 1+ all_splits' = catMaybes $ map splitFQN all_typenames''''+#else+ -- (we don't handle tuples with more than 7 components at this time)+ all_typenames''''' = filter (/= "(Int, Int, Int, Blob Int, [Int], Int, Int, Int, Int)") all_typenames''''+ all_splits' = catMaybes $ map splitFQN all_typenames'''''+#endif+#else+ all_splits' = catMaybes $ map splitFQN all_typenames''+#endif+ all_splits_ = map (\ (x,y) -> if x == "GHC.Prim" then ("GHC.Exts",y) else (x,y)) all_splits'+#if 1+ all_splits = all_splits_+#else+ all_splits = map (\ (x,y) -> if x == "GHC.Integer.Type" then ("GHC.Integer",y) else (x,y)) all_splits_+#endif+ all_imps = map generateOmniImport all_splits++ generateOmniImport :: (String,String) -> String+ generateOmniImport (m,mt) = ( "import " ++ m ++ " ( " ++ mt ++ " )" )++ splitFQN :: String -> Maybe (String,String)+ splitFQN s+ | '.' `elem` s = Just ( reverse $ drop 1 $ dropWhile (/='.') rs+ , reverse $ takeWhile (/='.') rs+ )+ | otherwise = Nothing+ where rs = reverse s++-------------------------------------------------------------------------------++ get_seqaid_instance_strings :: ModGuts -> CoreM [String]+ get_seqaid_instance_strings guts = do+ anns <- getAnnotations deserializeWithData guts+ :: CoreM (UniqFM [SeqaidAnnAvailableInstances]) -- (signature required)+ let annseltss = eltsUFM anns :: [[SeqaidAnnAvailableInstances]]+ let annselts = concat annseltss :: [SeqaidAnnAvailableInstances]+#if TH_TYPE_IN_TYPES_ANN+ let ts = concat $ map (\ (SeqaidAnnAvailableInstances tslst) -> tslst ) annselts :: [Type]+ let tstrs' = map (showSDoc dflags . ppr) ts :: [String]+#else+ let tstrs' = concat $ map (\ (SeqaidAnnAvailableInstances tslst) -> tslst ) annselts :: [String]+#endif+ let tstrs'' = map (map (\x -> if x == '\n' then ' ' else x)) tstrs'+ let compactWhite [] = []+ compactWhite (' ':' ':t) = compactWhite (' ':t)+ compactWhite (h:t) = h:compactWhite t+ let tstrs = map ( id+ . sanitiseAgain+ . remove_class_str+ . compactWhite+ ) tstrs''+ return tstrs++ remove_class_str :: String -> String+ remove_class_str str+ | ss == take lenss str = dropWhile (==' ') $ drop lenss str+ | otherwise = str+ where+#if SEQABLE_ONLY+ ss = "Generics.SOP.Universe.Generic"+#else+#if NFDATAN_ONLY+ ss = "Control.DeepSeq.Bounded.NFDataN.NFDataN"+#else+ ss = "Control.DeepSeq.Bounded.NFDataP.NFDataP"+#endif+#endif+ lenss = length ss++ -- Some types are wrapped in (...).+ -- Others are not.+ -- And even some (but not all!) tuples are double-wrapped [eg. ((a,b))].+ -- Not sure what can do about the latter.+ -- But the former, as done before, can just assure wrap if not wrapped...+ sanitiseAgain :: String -> String+ sanitiseAgain str+ | ( not $ null str ) && '(' /= head str = "(" ++ str ++ ")"+ | otherwise = str+-- I just can't stand this!+--- | ( not $ null str ) && '(' /= head str = '(' : ( str ++ ")" )++-------------------------------------------------------------------------------++ -- This isn't the best name; but it is obviously a predicate, so it's okay.+ -- Also, this is not really internally (logically) consistent,+ -- with respect to parentheses. (But I'm grasping here...)+ instancesAvailable :: [String] -> String -> Bool+ instancesAvailable iss ts+ | elem ts iss = True+ -- ... and yes, this bit us (kinda expected; welcome+ -- to see it actually): 9-tuple in leaky.hs!...+ -- So we will count commas for now, as this DOES at least+ -- form a safe bound; there can only be MORE commas due+ -- to any nesting we're not accounting for!+ | "(" == take 1 ts = if length (filter (==',') ts) > 7 then False else True+ | elem ("("++ts++")") iss = True+ -- XXX this should at least go as far as to recursively call+ -- instancesAvailable on the argument(s) to type constructors.+ | mcnm <- parse ts = if isNothing mcnm then False+ else let cnm = fromJust mcnm in+ cnm `elem` instance_cnms+ | otherwise = False+ where+ parse :: String -> Maybe String+ parse ('(':c:cs) = if isUpper c then Just $ parse' (c:cs)+ else Nothing+ parse s = Just $ parse' s+ parse' s = takeWhile (/=' ') s+ instance_cnms = catMaybes $ map parse iss++-------------------------------------------------------------------------------++ -- O(n*logn + n), versus (nub . sort) or (sort . nub), both of+ -- which are O(n^2) because nub is. Just maybe, nub has lower+ -- average case complexity when fed a sorted list? Here is+ -- the GHC source for nub.+ ---------------------------------------+ -- -- stolen from HBC+ -- nub l = nub' l []+ -- where+ -- nub' [] _ = []+ -- nub' (x:xs) ls+ -- | x `elem` ls = nub' xs ls+ -- | otherwise = x : nub' xs (x:ls)+ ---------------------------------------+ -- elem _ [] = False+ -- elem x (y:ys) = x==y || elem x ys+ ---------------------------------------+ -- So nub will behave pathologically badly for a list with+ -- no two equal elements, due to worst-case linear complexity+ -- of elem.++ nubsort :: Ord a => [a] -> [a]+ nubsort lst = ( map head . group . sort ) lst -- O(nlogn)+--nubsort lst = nub $ sort lst -- O(n^2)!++-------------------------------------------------------------------------------++ assureFQN :: String -> String -> String+ assureFQN thismodname name+ | '.' `elem` name = name+ | otherwise = thismodname ++ ('.':name)++-------------------------------------------------------------------------------+
+ Seqaid/Demo.hs view
@@ -0,0 +1,43 @@++ {-# LANGUAGE CPP #-}++-- |+-- Module : Seqaid.Demo+-- Copyright : (c) 2014, Andrew G. Seniuk+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : Andrew Seniuk <rasfar@gmail.com>+-- Stability : provisional+-- Portability : POSIX, Cabal+--+-- Instrument a sample program (package+-- <http://hackage.haskell.org/package/leaky leaky>)+-- with dynamic forcing functions. Refer to+-- <http://hackage.haskell.org/package/deepseq-bounded deepseq-bounded>+-- for more information about this methodology.++ module Main ( main ) where+--module Seqaid.Demo ( main ) where++ import System.IO.Temp+ import System.Directory+ import System.Process++ main = do+ tdir <- createTempDirectory "." "leaky_"+-- XXX Note that "cabal get" already extracts the tarball for you.+ let seqaid_init_bash = "\+\cabal get leaky-0.1.0.0\n\+\cd leaky-0.1.0.0\n\+\cabal configure\n\+\cabal build\n\+\cabal run 123\n\+\echo\n\+\echo \"(Please see " ++ tdir ++ "/leaky-0.1.0.0/README for the interpretation.)\"\n\+\echo\n"+ setCurrentDirectory tdir+ writeFile "seqaidinit.sh" seqaid_init_bash+ p <- getPermissions "seqaidinit.sh"+ setPermissions "seqaidinit.sh" (p { executable = True })+ system "./seqaidinit.sh"+
+ Seqaid/Global.hs view
@@ -0,0 +1,194 @@++-------------------------------------------------------------------------------++-- XXX I'm not entirely happy with the way Haskell has+-- twisted my arm to arrange the modules, but there you go.++ {- OPTIONS_GHC -O2 #-}++ {-# LANGUAGE CPP #-}++-- This is temporary, so seqaid demo output remains compatible+-- with the documentation already written around it.+#define USE_OLD_SHRINK_PAT 1++-- XXX Should scour the code for "max_depth" etc. -- all those+-- names which are specific to this DEMO_MODE hack!... And get+-- them into CPP guards. And get something sane in the OTHER+-- branches of those guards!!...+-- (Switch now promoted to .cabal flag.)+--- #define DEMO_MODE 1++ {- LANGUAGE BangPatterns #-} -- for debugging only++-------------------------------------------------------------------------------++-- |+-- Module : Seqaid.Global+-- Copyright : (c) 2014, Andrew G. Seniuk+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : Andrew Seniuk <rasfar@gmail.com>+-- Stability : provisional+-- Portability : GHC+--+-- Collects 'IORef's used by the seqaid runtime.+--+-- This will be substantially reorganised and clarified+-- by the next minor version bump (>=0.1.1).++ module Seqaid.Global where++-------------------------------------------------------------------------------++ import Control.DeepSeq.Bounded+ import Data.Typeable ( Typeable )++ -- Stuff for monitoring resource use (i.e. computing objective function):+--import Data.Word ( Word64 )+ import GHC.Int ( Int64 )+ import Data.IORef+ import System.IO.Unsafe ( unsafePerformIO )+ import System.Mem ( performGC )+ import GHC.Stats ( GCStats(..), getGCStats )++--import Debug.Trace ( trace )++--import Data.Array++#if ! DEMO_MODE+ import qualified Data.HashTable.IO as H+#endif++-------------------------------------------------------------------------------++ -- This one's global. (All this stuff is just QUACK stuff...).+ {-# NOINLINE depth_ioref #-}+ depth_ioref :: IORef Int+ depth_ioref = unsafePerformIO $ newIORef 0++#if ! DEMO_MODE+ type HashTable k v = H.CuckooHashTable k v++ {-# NOINLINE patterns_ioref #-}+ patterns_ioref :: IORef (HashTable Int Pattern)+ patterns_ioref = unsafePerformIO $ do+ ht <- H.new+ ioref <- newIORef ht+ return ioref+#else+ {-# NOINLINE pattern_ioref #-}+ pattern_ioref :: IORef Pattern+ pattern_ioref = unsafePerformIO $ newIORef $ compilePat "#"+#endif++ -- This one's global. (All this stuff is just QUACK stuff...).+ {-# NOINLINE snk_ioref #-}+ snk_ioref :: IORef SeqNodeKind+ snk_ioref = unsafePerformIO $ newIORef Insulate++ {-# NOINLINE stats_query_idx_ioref #-}+ stats_query_idx_ioref :: IORef Int+--stats_query_idx_ioref :: IORef Int64+ stats_query_idx_ioref = unsafePerformIO $ newIORef 0++ {-# NOINLINE counter_ioref #-}+ counter_ioref :: IORef Int64+ counter_ioref = unsafePerformIO $ newIORef 0++ {-# NOINLINE next_sample_at_ioref #-}+ next_sample_at_ioref :: IORef Int64+ next_sample_at_ioref = unsafePerformIO $ newIORef sample_period+--next_sample_at_ioref = unsafePerformIO $ newIORef 0++ {-# NOINLINE bytes_allocated_ioref #-}+ bytes_allocated_ioref :: IORef Int64+ bytes_allocated_ioref = unsafePerformIO $ newIORef 0++ {-# NOINLINE bytes_allocated_prev_ioref #-}+ bytes_allocated_prev_ioref :: IORef Int64+ bytes_allocated_prev_ioref = unsafePerformIO $ newIORef 0++ {-# NOINLINE current_bytes_used_ioref #-}+ current_bytes_used_ioref :: IORef Int64+ current_bytes_used_ioref = unsafePerformIO $ newIORef 0++-------------------------------------------------------------------------------++ {-# NOINLINE update_bytes_allocated_ioref #-}+ update_bytes_allocated_ioref :: IO Int64+ update_bytes_allocated_ioref = do+ oldsize <- readIORef bytes_allocated_ioref+ writeIORef bytes_allocated_prev_ioref oldsize+ performGC+ gcstats <- getGCStats+ let newsize = bytesAllocated gcstats+#if 0+ putStrLn $ "\nsize="++show size+ i <- readIORef counter_ioref+ t <- readIORef next_sample_at_ioref+ putStrLn $ "i="++show i++"\nt="++show t+#endif+ writeIORef bytes_allocated_ioref newsize+ return $! newsize - oldsize+-- return newsize++-------------------------------------------------------------------------------++ {-# NOINLINE update_current_bytes_used_ioref #-}+ update_current_bytes_used_ioref :: IO Int64+ update_current_bytes_used_ioref = do+ performGC+ gcstats <- getGCStats+ let cbu = currentBytesUsed gcstats+ writeIORef+ current_bytes_used_ioref+ cbu+ return cbu++-------------------------------------------------------------------------------++ sample_period :: Int64+--sample_period = 1+--sample_period = 10+--sample_period = 400+--sample_period = 1000+ sample_period = 4000 -- the usual for leaky-full+--sample_period = 10000++ -- XXX quack! (6 is minimal; 5 is too small; the leak remains)+ max_depth = 7 :: Int++ fixed_pat_sequence+ = ( map (\i -> compilePat ('*':show i)) [0,1..8] )+#if USE_OLD_SHRINK_PAT+ ++ ( reverse $ condenseEq shrinkPat_old fixed_pat )+#else+ ++ ( reverse $ condenseEq shrinkPat fixed_pat )+#endif++ fixed_pat = compilePat ".{.{..{.}.{.{.{.}#..{.}}}}..{..{.}}}"++-------------------------------------------------------------------------------++ -- From SAI.Data.Generics.Shape.SYB.Filter:+ condenseEq :: Eq a => (a -> a) -> a -> [a] -- beware this can diverge+ condenseEq f z = condenseEq' $ iterate f z+ where+ condenseEq' (x:y:t) | x == y = [x]+ | otherwise = x : condenseEq' (y:t)+ -- no other cases needed -- we know the argument is infinite++-------------------------------------------------------------------------------++ -- XXX Using a triple (esp. the 3rd component) is probably not+ -- the most performant choice... optimisation pending...+ -- XXX Would prefer 1 <-> 2, but to do that would require more+ -- code change to test...+ -- 1 (Int) Contains index of forcing site in the AST of the binding.+ -- 2 (String) Contains site binding variable name.+ -- 3 (Int) Caches the "unique" Int hash of name extended by index.+ type SiteID = (Int,String,Int)++-------------------------------------------------------------------------------+
+ Seqaid/Optim.hs view
@@ -0,0 +1,447 @@++-------------------------------------------------------------------------------++-- Plans+--+-- Try to make the optimiser pure.+--+-- For simplicity, let's assume a steady-state program; this will+-- still be useful with minimal change if need to respond adaptively...+--+-- If you can afford the sum-of-products weighting coefficients,+-- you can get pretty flexible objective functions out of the+-- three main quantities of interest (that I can think of):+--+-- (1) Time.+-- The amount of time elapsed since last checkpoint+-- should preferably not increase.+--+-- (2) Heap size.+-- The size of the live heap since last checkpoint+-- should preferably not increase.+--+-- (3) Bytes allocated (this frame).+-- The amount of GC activity since last checkpoint+-- should preferably not increase.+--+-- Any of these, taken individually (i.e. extremes of the l.c.)+-- would be interesting and useful, but it seems reasonable+-- to expect a non-trivial blend of two, or all, to be+-- most "meta-performant" (best convergence rates). Or who knows!+--+-- Need to experiment.+--+-- I don't yet have code in place measuring (1); only (2) and (3).++-------------------------------------------------------------------------------++-- The specific strategy for this next round at least:+-- Two-phase optimisation:+--+-- (1) N-phase : sweep forcen n=0,1,... until either:+-- - gets too costly in Time [once can measure that...]; or+-- - achieve dramatic improvement in objective function (at n' say)+--+-- (2) P-phase : begin with mkPatN n'+-- - forcep . (mkPatN n) = forcen n+-- Then call erodePat (with weighting of choice).+-- keep doing this, accepting steps only if performance+-- improves (rel. to your objective criterion). Eventually+-- no improvement will be made for a long time -- this is+-- taken as an "approximation to global optimum", and a+-- fresh pass through the P-phase can be used to try+-- additional stochastic trials.+--+-- Also, in principle, you might be better to start mkPatN at+-- an n' higher than the very lowest which plugged leak.+-- This seems a bit unlikely, but I don't know why not...+-- That you might arrive at a better global optimum+-- if you allow some "surplus forcing" at one or more points.+--+-- These are the nagging questions that I'm not sure about,+-- and expect to learn more as begin testing and seqaid on+-- a corpus of programs.++-------------------------------------------------------------------------------++ {- OPTIONS_GHC -O2 #-}++ {-# LANGUAGE CPP #-}++-- XXX Should scour the code for "max_depth" etc. -- all those+-- names which are specific to this DEMO_MODE hack!... And get+-- them into CPP guards. And get something sane in the OTHER+-- branches of those guards!!...+-- (Switch now promoted to .cabal flag.)+--- #define DEMO_MODE 1++ {-# LANGUAGE BangPatterns #-} -- for debugging only? (maybe more...)++-------------------------------------------------------------------------------++-- |+-- Module : Seqaid.Optim+-- Copyright : (c) 2014, Andrew G. Seniuk+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : Andrew Seniuk <rasfar@gmail.com>+-- Stability : provisional+-- Portability : GHC (uses global IORefs)+--+-- Harness morphological code.+--+-- The optimiser is just barely begun, but implementing it is+-- straight-forward Haskell programming, as contrasted with most+-- of the supporting infrastructure.++ module Seqaid.Optim (++ run_IO_SM ,++ optimIO ,++ optim ,++ optim_N_phase ,+ optim_P_phase ,++ ) where++-------------------------------------------------------------------------------++ import Control.DeepSeq.Bounded+ import Data.Typeable ( Typeable )++ -- Stuff for monitoring resource use (i.e. computing objective function):+ import GHC.Int ( Int64 )+ import Data.IORef++#if SEQABLE_ONLY+ -- I've seen this one displayed, so going with the more formal name:+ import Generics.SOP.Universe ( Generic )+--import Generics.SOP ( Generic )+#endif++#if 0+#if ! DEMO_MODE+ import qualified Data.HashTable.IO as H+#endif+#endif++--import Debug.Trace ( trace )++-------------------------------------------------------------------------------++ import Seqaid.Global ( depth_ioref )+#if DEMO_MODE+ import Seqaid.Global ( pattern_ioref )+#else+ import Seqaid.Global ( patterns_ioref )+#endif+ import Seqaid.Global ( snk_ioref )+ import Seqaid.Global ( stats_query_idx_ioref )+ import Seqaid.Global ( counter_ioref )+ import Seqaid.Global ( next_sample_at_ioref )+ import Seqaid.Global ( bytes_allocated_ioref )+ import Seqaid.Global ( bytes_allocated_prev_ioref )+ import Seqaid.Global ( current_bytes_used_ioref )+ import Seqaid.Global ( update_bytes_allocated_ioref )++--depth_ioref :: IORef Int+--pattern_ioref :: IORef Pattern+--patterns_ioref :: IORef (HashTable Int Pattern)+--snk_ioref :: IORef SeqNodeKind+--stats_query_idx_ioref :: IORef Int+--counter_ioref :: IORef Int64+--next_sample_at_ioref :: IORef Int64+--bytes_allocated_ioref :: IORef Int64+--bytes_allocated_prev_ioref :: IORef Int64+--current_bytes_used_ioref :: IORef Int64+--update_bytes_allocated_ioref :: IO Int64++--type HashTable k v = H.CuckooHashTable k v++-------------------------------------------------------------------------------++ import Seqaid.Global ( update_current_bytes_used_ioref )+ import Seqaid.Global ( max_depth )+ import Seqaid.Global ( sample_period )+ import Seqaid.Global ( fixed_pat_sequence )+ import Seqaid.Global ( SiteID )++-------------------------------------------------------------------------------++ -- The plan is to keep this module pure.+ -- So, it must be up the call chain someplace that+ -- the IORef operations occur.+ --+ -- XXX Since that sounds like boilerplate, it might be+ -- a good idea to offer a wrapper to the pure, here,+ -- which also takes care of the IORef stuff...++-------------------------------------------------------------------------------++ -- XXX Why is depth global, but patterns is per-site?...+ -----+ -- This needs to read the (most recently cached) GHC.Stats data.+ -- If N-phase, needs to affect the depth_ioref.+ -- If P-phase, needs to affect the patterns_ioref.+ -- It could actually have type IO (), but might like to+ -- return some pertinent information as well.+ optimIO :: IO ()+--optimIO :: IO (Int,Int,Pattern,SeqNodeKind,Int64,Int64,Int64,Int64,Int64)+ optimIO = do++-- XXX Based on a clone of run_IO_SM.++#if 0++ stats_query_idx <- do+ sqi <- readIORef stats_query_idx_ioref+ return sqi+ depth <- do+ d <- readIORef depth_ioref+ return d+#if 0+-- XXX a code fragment expected to be useful (see seqaidDispatch where clause)+ tmp = stats_query_idx-(2+max_depth)+ pat' | tmp < length fixed_pat_sequence+ = fixed_pat_sequence!!tmp+ | otherwise+ = last fixed_pat_sequence+#endif+#if NFDATAN_ONLY+#error "NFDATAN_ONLY is not valid at this time."+#else+#if 1+ pat <- do+#if 1 || DEMO_MODE+ let tmp = stats_query_idx+-- let tmp = stats_query_idx-(2+max_depth)+ let p | tmp < length fixed_pat_sequence+ = fixed_pat_sequence!!tmp+ | otherwise+ = last fixed_pat_sequence+#if 0+ H.insert ht sid_hash p+#endif+ return p+#else+ ht <- readIORef patterns_ioref+ let sid_hash = thd3 sid+ mp <- H.lookup ht sid_hash+ if isNothing mp+ then do+ let p = compilePat "#"+ H.insert ht sid_hash p+ return p+ else do+ return $ fromJust mp+#endif+#else+-- XXX wrong and never tested, obviously+ pat = patterns_ioref!(fst3 sid)+#endif+#endif++#endif++ i <- do+ ii <- readIORef counter_ioref+ modifyIORef' counter_ioref (1+)+ return ii+ ba <- readIORef bytes_allocated_ioref+ cbu <- readIORef current_bytes_used_ioref++#if 0++#if 0+ if stats_query_idx >= max_depth && i >= t+ then do+ let j = stats_query_idx - max_depth+ writeIORef pattern_ioref (fixed_pat_sequence!!j)+ return ()+ else return ()+#endif+ if depth <= max_depth && i >= t+ then do+#if 1+ modifyIORef' depth_ioref (1+)+#else+-- XXX need Data instances...+-- writeIORef pattern_ioref (mkPatN depth x)+#endif+ return ()+ else return ()++#endif++--- !_ <- return x -- magic! thank you!!++-- return (stats_query_idx,depth,pat,snk,i,t,size,cbu,t')+ return ()++-------------------------------------------------------------------------------++ optim :: ()+ optim = ()++-------------------------------------------------------------------------------++ optim_N_phase :: ()+ optim_N_phase = ()++-------------------------------------------------------------------------------++ optim_P_phase :: ()+ optim_P_phase = ()++-------------------------------------------------------------------------------++ -- Okay!+ -- Now it is time to use the hash values++ -- XXX This is simply the collected unsafePerformIO calls+ -- that were initially scattered throughout seqaidDispatch.+ -- It happened to behave the same as that did, without change;+ -- but a once-over reorganising the logic slightly would be good...++ -- is this pragma necessary? does it even make sense with IO?...+ {-# NOINLINE run_IO_SM #-}+#if SEQABLE_ONLY+ run_IO_SM :: (Generic a,Typeable a)+ => SiteID -> a -> IO (Int,Int,Pattern,SeqNodeKind,Int64,Int64,Int64,Int64,Int64)+#else+#if NFDATAN_ONLY+ run_IO_SM :: (NFDataN a,Typeable a)+ => SiteID -> a -> IO (Int,Int,Pattern,SeqNodeKind,Int64,Int64,Int64,Int64,Int64)+#else+ run_IO_SM :: (NFData a,NFDataN a,Typeable a,NFDataP a)+ => SiteID -> a -> IO (Int,Int,Pattern,SeqNodeKind,Int64,Int64,Int64,Int64,Int64)+#endif+#endif+ run_IO_SM sid x = do++ stats_query_idx <- do+ sqi <- readIORef stats_query_idx_ioref+ return sqi++ depth <- do+ d <- readIORef depth_ioref+ return d++#if 0+-- XXX a code fragment expected to be useful (see seqaidDispatch where clause)+ tmp = stats_query_idx-(2+max_depth)+ pat' | tmp < length fixed_pat_sequence+ = fixed_pat_sequence!!tmp+ | otherwise+ = last fixed_pat_sequence+#endif++#if SEQABLE_ONLY+ let pat = compilePat "#" -- just whatever+#else+#if NFDATAN_ONLY+--- #error "NFDATA_ONLY is not valid at this time."+ let pat = compilePat "#" -- just whatever+#else+ pat <- do+#if 1 || DEMO_MODE+ let tmp = stats_query_idx+-- let tmp = stats_query_idx-(2+max_depth)+ let p | tmp < length fixed_pat_sequence+ = fixed_pat_sequence!!tmp+ | otherwise+ = last fixed_pat_sequence+#if 0+ H.insert ht sid_hash p+#endif+ return p+#else+ ht <- readIORef patterns_ioref+ let sid_hash = thd3 sid+ mp <- H.lookup ht sid_hash+ if isNothing mp+ then do+ let p = compilePat "#"+ H.insert ht sid_hash p+ return p+ else do+ return $ fromJust mp+#endif+#endif+#endif++#if SEQABLE_ONLY+ let snk = Propagate+#else+ let snk = Propagate -- just whatever+#endif++ i <- do+ ii <- readIORef counter_ioref+ modifyIORef' counter_ioref (1+)+ return ii+ t <- do+ tt <- readIORef next_sample_at_ioref+ return tt+ (size,cbu,t') <-+ if i >= t+ then do+ modifyIORef' next_sample_at_ioref (+sample_period)+ -- (the snd component of result is for repairing+ -- a lag in the value for t shown in trace lines)+ tt <- readIORef next_sample_at_ioref+ ba <- update_bytes_allocated_ioref+ cbu <- update_current_bytes_used_ioref+ return (ba,cbu,tt)+ else do+ ba <- readIORef bytes_allocated_ioref+ cbu <- readIORef current_bytes_used_ioref+ return (ba,cbu,t)++ if i >= t+ then do+ modifyIORef' stats_query_idx_ioref (1+)+ return ()+ else return ()++#if 0+ if stats_query_idx >= max_depth && i >= t+ then do+ let j = stats_query_idx - max_depth+ writeIORef pattern_ioref (fixed_pat_sequence!!j)+ return ()+ else return ()+#endif++ if depth <= max_depth && i >= t+ then do+#if 1+ modifyIORef' depth_ioref (1+)+#else+-- XXX need Data instances...+-- writeIORef pattern_ioref (mkPatN depth x)+#endif+ return ()+ else return ()++ optimIO+--- (!_,!_,!_,!_,!_,!_,!_,!_,!_) <- optimIO -- XXX (as if XXX is nec. lol!)++ -- At the moment, this no longer seems necessary at all.+ -- (But maybe it was for when first getting it working,+ -- and sample_period was 1 [or at least small]; and+ -- when the test program did little work...).+ -- XXX Note that if we can avoid this, there is another benefit:+ -- We don't necessarily WANT to force the head of x! (forcen 0,+ -- or forcep "#")...+--- _ <- return $! x -- works as well?...+ !_ <- return x -- magic! thank you!!++ return (stats_query_idx,depth,pat,snk,i,t,size,cbu,t')+-- return ()++-------------------------------------------------------------------------------+
+ Seqaid/Plugin.hs view
@@ -0,0 +1,81 @@++-- |+-- Module : Seqaid.Plugin+-- Copyright : (c) 2014, Andrew G. Seniuk+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : Andrew Seniuk <rasfar@gmail.com>+-- Stability : provisional+-- Portability : GHC >= 7.4 (uses GhcPlugins)+--+-- Standard GHC Core plugin stub.+--+-- Use GHC option -fplugin=Seqaid.Plugin to activate.+-- (Other options, as well as a configuration file, are also required.+-- Refer to the included HTML documentation for more information; or online+-- at the seqaid <http://www.fremissant.net/seqaid#using homepage>.)++ module Seqaid.Plugin ( plugin ) where++ import Seqaid.Core ( seqinjectProgram )++ import GhcPlugins++ plugin :: Plugin+ plugin = defaultPlugin { installCoreToDos = install }++ install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo]+ install clopts todos = do+ reinitializeGlobals+-- putMsgS $ show clopts+-- error "Plugin.hs-DEVEXIT"+ let seqaidpass = CoreDoPluginPass "Seqinject" $ seqinjectProgram clopts+ -- XXX Comment: The alternate insertion points did not help me+ -- with the problems I was having (which were solved via+ -- a text-preprocessor, ultimately). The rules we wanted to apply+ -- will only fire when building the target, if they are IN the+ -- target (not in Seqaid.Runtime.seqaid). [Same applies to inlining+ -- it seems?] Finally solved the problem using GHC -F (text preprocessor).+ -- XXX I forgot I'd left this set to POST-Simplifier plugin insertion!+ -- Can you imagine?? I've been developing for like a solid week+ -- with it set that way, and never managed to notice.... Things+ -- should become a lot more staightforward now, hopefully...+#if 0+#elif 1+ return $ [ seqaidpass ] ++ todos -- pre-simplifier (most stable)+#elif 0+ return $ todos ++ [ seqaidpass ] -- XXX post-simplifier XXX+#elif 0+ -- Tells me: "Rule check results: no rule application sites"+ let rulepass = CoreDoRuleCheck InitialPhase "seqaid_internal/2"+-- let rulepass = CoreDoRuleCheck InitialPhase "seqaid_internal/1"+ return $ rulepass : seqaidpass : todos -- pre-simplifier+-- return $ CoreDoStaticArgs : rulepass : seqaidpass : todos+#elif 0+ let simpmode+ = SimplMode {+ sm_names = []+-- sm_names = ["Simplifier"]+ , sm_phase = InitialPhase+ , sm_rules = False+ , sm_inline = True+ , sm_case_case = False+ , sm_eta_expand = False+ }+ let inlinerpass = CoreDoSimplify 1 simpmode+ return $ inlinerpass : seqaidpass : todos+#endif++#if 0+ data CoreToDo = CoreDoSimplify Int SimplifierMode | ...+ data SimplifierMode+ = SimplMode {+ sm_names :: [String]+ , sm_phase :: CompilerPhase+ , sm_rules :: Bool+ , sm_inline :: Bool+ , sm_case_case :: Bool+ , sm_eta_expand :: Bool+ }+#endif+
+ Seqaid/Prepro.hs view
@@ -0,0 +1,681 @@++-------------------------------------------------------------------------------++ {-# LANGUAGE CPP #-}++ {-# LANGUAGE BangPatterns #-} -- temporary... (debugging/testing)++#define DBG_OMNI 0++-- Sadly it seem there is a bad interaction between SOP.TH and Seqaid.TH,+-- so at least for the time being, data types you need to force will+-- need to be declared in a module which is not itself harnessed.+#define CAN_MIX_SOP_DERIVING_WITH_SEQAID_TH 0++-------------------------------------------------------------------------------++-- |+-- Module : Seqaid.Prepro+-- Copyright : (c) 2014, Andrew G. Seniuk+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : Andrew Seniuk <rasfar@gmail.com>+-- Stability : provisional+-- Portability : GHC+--+-- Seqaid preprocessor, run via GHC -F.++ module Main where+--module Seqaid.Prepro where++ import Seqaid.Config++ import System.Environment++ import Text.Regex.PCRE+ import Text.Regex.Base.RegexLike+ import Data.List ( foldl' )++ import System.Process ( system ) -- debugging only++ import GHC.Exts ( sortWith )+ import Data.List ( groupBy )+ import Data.List ( foldl1' )+ import Data.List ( intercalate )+ import Data.List ( nub )+ import Data.List ( sort )+ import Data.List ( group )+ import Data.Maybe++ import Control.Concurrent ( threadDelay )++--import System.Directory ( removeFile )+ import System.Directory ( createDirectoryIfMissing )+ import System.Directory ( getTemporaryDirectory )+ import System.Directory ( doesFileExist )++ import Distribution.PackageDescription+ import Distribution.PackageDescription.Parse+ import Distribution.Verbosity+ import Distribution.Compiler++ import Data.Char ( toUpper )+ import Data.Char ( isSpace )++ import System.IO ( openFile, IOMode(ReadMode), hFileSize, hClose )++-------------------------------------------------------------------------------++ data SeqaidConfig+ = SeqaidConfig {+ seqaid_cfg_package :: String+ , seqaid_cfg_modules :: [SeqaidConfigModule]+ , seqaid_cfg_instances :: [(String,[String])]+ } deriving ( Show )+ data SeqaidConfigModule+ = SeqaidConfigModule {+ seqaid_cfg_fqname :: String+ , seqaid_cfg_types :: [String]+ , seqaid_cfg_binds :: [String]+ } deriving ( Show )++-------------------------------------------------------------------------------++ breakOn :: Char -> String -> String -> [String] -> [String]+ breakOn c [] sacc acc+ | null sacc = reverse acc+ | otherwise = reverse (reverse sacc:acc)+ breakOn c (h:t) sacc acc+ | h == c = breakOn c t [] (reverse sacc:acc)+ | otherwise = breakOn c t (h:sacc) acc++ trim :: String -> String+ trim s = reverse $ dropWhile (==' ') $ reverse $ dropWhile (==' ') s++ parseTypes :: String -> [String]+ parseTypes s = map trim $ breakOn ',' s [] []++ parseBinds :: String -> [String]+ parseBinds s = map trim $ breakOn ',' s [] []++ parseInstancesStr :: String -> [(String,[String])]+ parseInstancesStr s = parseInstances mts+ where+ mts = parseInstances' s :: [(String,String)]+ parseInstances' :: String -> [(String,String)]+ parseInstances' s = map splitFQN $ map trim $ breakOn ',' s [] []++ parseInstances :: [(String,String)] -> [(String,[String])]+ parseInstances mts = mts'''+ where+ mts' = sortWith snd mts :: [(String,String)]+ mts'' = groupBy (\(x1,y1) (x2,y2) -> x1 == x2) mts' :: [[(String,String)]]+ mts''' = map (foldl' (\ (_,ys) (x,y) -> (x,ys++[y])) ("",[])) mts'' :: [(String,[String])]++ -- XXX I've seen GHC API (or TH?) code for this, no?+ splitFQN :: String -> (String,String)+ splitFQN s = ( reverse $ drop 1 $ dropWhile (/='.') $ reverse s+ , reverse $ takeWhile (/='.') $ reverse s ) -- heh++ parseConfigLines :: SeqaidConfig -> [String] -> SeqaidConfig+ parseConfigLines config [] = config+ parseConfigLines config (l:ls) = config'+ where+ l' = dropWhile (==' ') l+ config'+ | null l' = parseConfigLines config ls+ | head l' == '#' = parseConfigLines config ls+ | head l' == 'p'+ = parseConfigLines (config { seqaid_cfg_package = dropWhile (==' ') $ drop 1 $ dropWhile (/=' ') l' }) ls+ | head l' == 'm'+ = parseConfigLines (config { seqaid_cfg_modules = seqaid_cfg_modules config ++ [ SeqaidConfigModule { seqaid_cfg_fqname = dropWhile (==' ') $ drop 1 $ dropWhile (/=' ') l' , seqaid_cfg_types = [], seqaid_cfg_binds = [] } ] }) ls+ | head l' == 't'+ = let modules = seqaid_cfg_modules config in+ if null modules then error "#1 invalid seqaid.config"+ else let last_module = last modules in+ parseConfigLines (config { seqaid_cfg_modules = init modules ++ [ last_module { seqaid_cfg_types = parseTypes $ dropWhile (==' ') $ drop 1 $ dropWhile (/=' ') l' } ] }) ls+ | head l' == 'b'+ = let modules = seqaid_cfg_modules config in+ if null modules then error "#1 invalid seqaid.config"+ else let last_module = last modules in+ parseConfigLines (config { seqaid_cfg_modules = init modules ++ [ last_module { seqaid_cfg_binds = parseBinds $ dropWhile (==' ') $ drop 1 $ dropWhile (/=' ') l' } ] }) ls+ | head l' == 'i'+ = parseConfigLines (config { seqaid_cfg_instances = parseInstancesStr $ dropWhile (==' ') $ drop 1 $ dropWhile (/=' ') l' }) ls+ | otherwise = error "#2 invalid seqaid.config"++ parseConfig :: IO SeqaidConfig+ parseConfig = do+ config_s <- readFile "seqaid.config"+ let config_dflt = SeqaidConfig { seqaid_cfg_package = "", seqaid_cfg_modules = [], seqaid_cfg_instances = [] }+ let config_dflt' = parseConfigLines config_dflt $ filter (not . isBlankLine) $ lines config_s+ return config_dflt'+ where+ isBlankLine :: String -> Bool+ isBlankLine s = null $ filter (not . isSpace) s++ lookupModule :: String -> SeqaidConfig -> SeqaidConfigModule+ lookupModule modname config = configmod+ where+ configmod = lookupModule' modname $ seqaid_cfg_modules config+ lookupModule' :: String -> [SeqaidConfigModule] -> SeqaidConfigModule+ lookupModule' modname [] = error "#3 invalid seqaid.config"+ lookupModule' modname (h@(SeqaidConfigModule fqname types binds):t)+ | modname == fqname = h+ | otherwise = lookupModule' modname t++-------------------------------------------------------------------------------++ main = do+ args <- getArgs+ if length args < 3+ then error "takes a minimum of 3 arguments (should not be run manually!)"+ else do++ let origname = args!!0+ let infile = args!!1+ let outfile = args!!2++#if 0+ ttt <- doesFileExist outfile+ if ttt+ then do+ putStrLn "exists"+ h <- openFile "outfile" ReadMode+ siz <- hFileSize h+ hClose h+ putStrLn $ "File size is " ++ show siz+ else putStrLn "doesn't exist"+ error "DEVEXIT"+#else+ outfile_already_exists <- doesFileExist outfile+ okay_to_proceed+ <- if outfile_already_exists+ then do+ h <- openFile "outfile" ReadMode+ siz <- hFileSize h+ hClose h+ if 0 == siz then return True else return False+ else return True+ if not okay_to_proceed+ then error "3rd argument exists (should not be run manually!)"+ else return ()+#endif++ let opts = drop 3 args+ let internal = "internal" `elem` opts+ let doomni = "omnitypic" `elem` opts+-- putStrLn $ "origname=" ++ origname ++ "\ninfile=" ++ infile ++ "\noutfile=" ++ outfile ++ "\ninternal=" ++ show internal ++ "\nomnitypic=" ++ show doomni++ config@(SeqaidConfig packagename modules instances') <- parseConfig+-- putStrLn $ show config++ let instances = instances'++ boo@(cppopts_lst,ghcopts_lst) <- parseCabal $ packagename ++ ".cabal"+-- putStrLn $ show ghcopts_lst++#if CAN_MIX_SOP_DERIVING_WITH_SEQAID_TH+ do+#else+ -- Test that no module mentioned in the "instances:" field+ -- is also mentioned in a "module:" field. (Probably a temporary+ -- restriction; due to a bad interaction between Generics.SOP.TH+ -- and Seqaid.TH. Considering Generics.SOP.TH output fails -dcore-lint,+ -- the problem might be a bug in SOP.)+ let sane = testSaneConfig config+ if not sane then error "seqaid.config is not sane"+ else do+#endif++ lexmod_ <- readFile infile++ let allmats = getAllTextMatches $ lexmod_ =~ "^ *module [^\n][^\n]*" :: [String]++ let missing_module_declaration = null allmats++ let indent+ | missing_module_declaration+ = replicate (fromJust $ guessBaseIndentationLevel lexmod_) ' '+--- | missing_module_declaration = ""+ | otherwise+ = let n = length $ takeWhile (==' ') $ head allmats in+ replicate n ' '++ let lexmod_mod+ | missing_module_declaration+ = indent ++ "module Main ( main ) where\n"+--- = error $ "module missing \"module\" declaration: " ++ origname+ | otherwise+ = head allmats++ if missing_module_declaration+ then putStrLn $ "Missing \"module\" declaration: " ++ origname ++ "\n Assuming module Main\n Base indentation level appears to be " ++ show (length indent)+-- then putStrLn $ "Missing \"module\" declaration: " ++ origname ++ "\n Assuming module Main and base indentation level 0"+ else return ()++ let lexmod__+ | missing_module_declaration = lexmod_mod ++ lexmod_+ | otherwise = lexmod_++ -- The takeWhile is an extra precaution, since may encounter+ -- module Foo(bar) where ...+ let modname = takeWhile (/='(') $ ((words lexmod_mod)!!1) -- should be...++-- XXX Getting duplicate output from this (and output in+-- a seemingly-wrong order, too), so gave up on it for now.+-- (The point was only to avoid the TH "Loading pacakge" spam.)+#if 0+ if ( not internal ) && "-v0" `elem` ghcopts_lst+--- [2 of 2] Compiling Main ( Seqaid/Prepro.hs, dist/dist-sandbox-c80c5f2e/build/seqaidpp/seqaidpp-tmp/Main.o )+ then putStrLn $ "Compiling " ++ modname+ else return ()+#endif++ (wasInstanceProcessed,lexmod) <-+ if modname `elem` map fst instances+ then do -- SOP generic deriving of NFDataP and superclasses:++ let (mod,types) = lookupInstance modname instances++ let pragmas = unlines $ map (indent++) $ makePragmas+ let imports = unlines $ map (indent++) $ makeImports++ let seqaidvalidate = make_seqaid_validate types++ let dis = makeDIs types+ let is = makeIs types+ let dgens = makeDGens types++ let lexmod' = pragmas ++ lexmod__ :: String++ let go2 s = s ++ imports ++ indent+ let lexmod'' = replaceAll False+ (makeRegex "^ *module [^\n][^\n]*") go2 lexmod'++ let lexmod''' = lexmod''+ ++ (unlines (map (indent++) seqaidvalidate))+ ++ (unlines (map (indent++) dis))+ ++ (unlines (map (indent++) is))+ ++ (unlines (map (indent++) dgens))++#if CAN_MIX_SOP_DERIVING_WITH_SEQAID_TH+ return (True,lexmod''')+#else+ writeFile outfile lexmod'''+--- _ <- system $ "/bin/cat " ++ outfile+ return (True,lexmod''')+#endif+ else return (False,lexmod__)++#if CAN_MIX_SOP_DERIVING_WITH_SEQAID_TH+ if wasInstanceProcessed+ || ( not $ modname `elem` map seqaid_cfg_fqname modules )+#else+ if not $ modname `elem` map seqaid_cfg_fqname modules+#endif++ then do+ -- The module currently being processed is neither mentioned+ -- in the "instances" nor in a "module" field of seqaid.config.+ -- So do nothing. This is identity, for a GHC -F prepro:+ writeFile outfile lexmod+--- _ <- system $ "/bin/cat " ++ outfile+ return ()++ else do++ -- XXX Some (maybe all) the !'s are probably unneeded.+ momnis <- if ( not doomni ) || internal+ then return Nothing+ else do+ omnis <- omnitypic origname packagename modname boo+ return $ Just omnis++ let (omni_types,omni_imports') = fromJust momnis++ let mod@(SeqaidConfigModule fqname types' binds) = lookupModule modname config++ let types = if isNothing momnis+ then types'+ else nub $ types' ++ omni_types -- should suffice, here++ -- Inject the module currently being compiled:++ -- (1) Substitute all manual instrumentation with+ -- something more convenient to the plugin phase.+--- lexmod <- readFile infile+ let go [] = [] -- shouldn't be possible+ go (c:cs) = c : "seqaidDispatch undefined "+ let lexmod' = replaceAll True+ (makeRegex "[^A-Za-z0-9'_]seqaid ") go lexmod++ let pragmas_ = unlines $ map (indent++) $ makePragmas_++ -- XXX It seems it is necessary to inject a+ -- {-# LANGUAGE TemplateHaskell #-} pragma, even though+ -- it may be given in .cabal with default-extensions: TemplateHaskell+ -- and with ghc-opts: -XTemplateHaskell! And using+ -- {-# LANGUAGE CPP #-} also works, for some unknown reason!++ -- (2) Inject the pragmas:+ let go4 s = pragmas_ ++ s+ let lexmod''_ = replaceAll False+ (makeRegex "^ *module ") go4 lexmod'++ let omni_imports+ = if isNothing momnis+ then []+ else unlines $ map (indent++) omni_imports'++ -- (3) Inject the Seqaid.TH import statement:+ -- Later: And also some type imports (for omnitypic wrapper injection).+ let go2 s = indent ++ "import Seqaid.TH\n" ++ omni_imports ++ s+ let lexmod'' = replaceAll False+ (makeRegex "^ *import ") go2 lexmod''_++ -- (4) Inject the seqaidTH splice call:+ let tqqs = map (\x -> "[t| " ++ x ++ " |]") types+-- Doesn't help, since when GHC reports the error, it re-ppr's onto one line.+-- (Also, the module qualifiers are absent!)+-- let lexmod'''' = lexmod'' ++ indent ++ "seqaidTH [ " ++ intercalate ("\n" ++ indent ++ " , ") tqqs ++ " ]"+ let lexmod'''' = lexmod'' ++ indent ++ "seqaidTH [ " ++ intercalate ", " tqqs ++ " ]" ++ "\n"++ -- (5) Inject the strInstancesTH splice call:+ -- (Or should this be above (4)?...)+ let lexmod''''' = lexmod'''' ++ indent ++ "strInstancesTH" ++ "\n"++ -- (6) Inject the bindsIncludedTH splice call:+ -- (Or should this be above?...)+ let lexmod'''''' = lexmod''''' ++ indent ++ "bindsIncludedTH " ++ show binds ++ "\n"++#if TRY_INJECT_NOINLINE_ON_REQUESTED_BINDS+ let lexmod''''''' = lexmod'''''' ++ indent ++ "noinlineTH " ++ show binds ++ "\n"+#else+ let lexmod''''''' = lexmod''''''+#endif++ writeFile outfile lexmod'''''''+--- _ <- system $ "/bin/cat " ++ outfile+ return ()++-------------------------------------------------------------------------------++ -- Thanks to rampion in http://stackoverflow.com/questions/9071682/replacement-substition-with-haskell-regex-libraries+ replaceAll :: Bool -> Regex -> (String -> String) -> String -> String+ replaceAll all re f s = start end+ where+ allmats = getAllMatches $ match re s+ (_, end, start) = foldl' go (0, s, id) $ (if all || null allmats then id else take 1) allmats+ go (ind,read,write) (off,len) =+ let (skip, start) = splitAt (off - ind) read + (matched, remaining) = splitAt len start + in (off + len, remaining, write . (skip++) . (f matched ++))++-------------------------------------------------------------------------------++ make_seqaid_validate ts = lines $ make_seqaid_validate' ts+ make_seqaid_validate' ts = "\+\seqaidValidate [ " ++ intercalate ", " (map ("''"++) ts) ++ " ]\n"++-------------------------------------------------------------------------------++ makeDIs ts = lines $ makeDIs' ts+ makeDIs' [] = []+ makeDIs' (t:ts) = "\+\deriving instance Show " ++ t ++ "\n\+\deriving instance Generic " ++ t ++ "\n\+\deriving instance Typeable " ++ t ++ "\n\+\deriving instance Data " ++ t ++ "\n" ++ makeDIs' ts++-------------------------------------------------------------------------------++ makeIs ts = lines $ makeIs' ts+ makeIs' [] = []+ makeIs' (t:ts) = "\+\instance NFDataP " ++ t ++ " where rnfp = grnfp\n\+\instance NFDataN " ++ t ++ " where rnfn = grnfn\n\+\instance NFData " ++ t ++ " where rnf = genericRnf\n" ++ makeIs' ts++-------------------------------------------------------------------------------++ makeDGens ts = lines $ makeDGens' ts+ makeDGens' [] = []+ makeDGens' (t:ts) = "\+\deriveGeneric ''" ++ t ++ "\n" ++ makeDGens' ts++-------------------------------------------------------------------------------++ makeITs mod ts = lines $ makeITs' ts+ where+ makeITs' [] = []+ makeITs' (t:ts) = "\+\import " ++ qual ++ " ( " ++ name ++ "(..)" ++ " )" ++ "\n" ++ makeITs' ts+ where+ qual = mod+ name = t++-------------------------------------------------------------------------------++ makePragmas = lines $ "\+\\n\+\-- For NFDataP (which perforce includes NFDataN and NFData):\n\+\{-# LANGUAGE CPP #-}\n\+\{-# LANGUAGE TemplateHaskell #-}\n\+\{- LANGUAGE ScopedTypeVariables #-}\n\+\{-# LANGUAGE DataKinds #-}\n\+\{-# LANGUAGE TypeFamilies #-}\n\+\{- LANGUAGE ConstraintKinds #-}\n\+\{-# LANGUAGE GADTs #-} -- for GHC 7.6.3\n\+\{-# LANGUAGE DeriveGeneric #-}\n\+\{-# LANGUAGE DeriveDataTypeable #-}\n\+\{-# LANGUAGE StandaloneDeriving #-}\n\+\\n\+\{- LANGUAGE TypeSynonymInstances #-}\n\+\\n\+\-- RankNTypes wanted since some injected type signatures,\n\+\-- due to imported types, may require it.\n\+\{-# LANGUAGE RankNTypes #-}\n"++-------------------------------------------------------------------------------++ makePragmas_ = lines $ "\+\\n\+\{- LANGUAGE CPP #-}\n\+\{-# LANGUAGE TemplateHaskell #-}\n"++-------------------------------------------------------------------------------++ makeImports = lines $ "\+\\n\+\import Control.DeepSeq.Bounded\n\+\import Control.DeepSeq.Generics\n\+\\n\+\import Seqaid.TH ( seqaidValidate )\n\+\import Generics.SOP.TH\n\+\import GHC.Generics ( Generic )\n\+\import Data.Typeable ( Typeable )\n\+\import Data.Data ( Data )\n"++-------------------------------------------------------------------------------++ testSaneConfig :: SeqaidConfig -> Bool+ testSaneConfig config@(SeqaidConfig packagename modules instances) = b+ where+ bs = zipWith ($)+ (map (elem . fst) instances)+ (repeat $ map seqaid_cfg_fqname modules)+ b = null bs || not (or bs)++-------------------------------------------------------------------------------++ lookupInstance :: String -> [(String,[String])] -> (String,[String])+ lookupInstance modname [] = error "lookupInstance: unexpected!"+ lookupInstance modname (i@(nm,tys):t)+ | modname == nm = i+ | otherwise = lookupInstance modname t ++-------------------------------------------------------------------------------++ -- Use a trick to obtain the list of all subexpression types in the module.+ -- This has a high compile time cost (as much as doubles build time),+ -- but that may be acceptable for a diagnostic build, and it's+ -- potentially quite a powerful fine-grained blanket harness.+ omnitypic :: String -> String -> String -> ([String],[String]) -> IO ([String],[String])+ omnitypic origname packagename modname (cppopts_lst,ghcopts_lst)= do+ systmp <- getTemporaryDirectory+ let ghctmp = systmp ++ "/ghctmp-seqaidpp"+--- let ghctmp = "/media/ramdisk/ghctmp-seqaidpp"+ createDirectoryIfMissing False ghctmp+ -- XXX this tmpfile is actually not used at all (just as a /dev/null)+ let tmp_filename = "seqaid_tmp_321"+ let tmp_pname = ghctmp ++ "/" ++ tmp_filename+ let omni_types_pname = ghctmp ++ "/omnitypes.txt"+ let omni_imports_pname = ghctmp ++ "/omniimports.txt"+ let cppopts = intercalate " " cppopts_lst+ let ghcopts' = intercalate " " ghcopts_lst++ in_sandbox <- detectSandbox+ let nowneeded = "\+\ -fplugin=Seqaid.Plugin \+\ -F -pgmF " ++ ( if in_sandbox then ".cabal-sandbox/bin/seqaidpp" else "seqaidpp" ) ++ " \+\ -optF omnitypic "++-- The -c option together with --make will prevent linking, while+-- still building all dependencies.+ let ghcopts = ghcopts' ++ " \+\ --make \+\ -c \+\ " ++ nowneeded ++ " \+\ -fplugin-opt=Seqaid.Plugin:prepro=" ++ modname ++ " \+\ -fplugin-opt=Seqaid.Plugin:" ++ omni_types_pname ++ " \+\ -fplugin-opt=Seqaid.Plugin:" ++ omni_imports_pname ++ " \+\ -optF internal \+\ -XTemplateHaskell \+\ -with-rtsopts=-T \+\ -outputdir " ++ ghctmp++-- These are either optional, or already required to be in the .cabal file.+--+-- Probably IS going to be wanted:+--- \ -threaded \+-- Already required to be in the .cabal file:+-- Later: But it's now guarded by a condition (flag), so+-- it doesn't show up for parseCabal! (So added to the above.)+--- \ -fplugin=Seqaid.Plugin \+--- \ -F \+--- \ -pgmF seqaidpp \+-- Optional:+--- \ -optP-Wundef \+--- \ -fno-warn-overlapping-patterns \+-- Seem not to be needed if supply -with-rtsopts (which we do):+--- \ -rtsopts \++#if 0+ putStrLn $ "CPPOPTS:\n" ++ show cppopts+ putStrLn $ "GHCOPTS:\n" ++ show ghcopts+-- error "DEVEXIT"+#endif++ let cmnd = "cabal exec -- ghc "+ ++ ghcopts ++ " "+ ++ cppopts ++ " "+#if 1+ -- /dev/null would do ... if it exists+ ++ origname ++ " >> " ++ tmp_pname ++ " 2>&1"+#else+ ++ origname+#endif+#if DBG_OMNI+ putStrLn cmnd+#endif+ writeFile tmp_pname $ cmnd ++ "\n"+ _ <- system cmnd+--- _ <- system $ "cat " ++ tmp_pname+ omni_types' <- readFile omni_types_pname -- as a String, one type per line+ -- (removing temp files, so stale temp files don't get read by wrong+ -- module pass, in case that's what's happening...)+-- removeFile omni_types_pname+ omni_imports' <- readFile omni_imports_pname+-- removeFile omni_imports_pname+#if DBG_OMNI+ putStrLn omni_types'+ putStrLn omni_imports'+-- error "DEVEXIT"+#endif+ let omni_types = lines omni_types'+ let omni_imports = lines omni_imports'+ return (omni_types,omni_imports)++-------------------------------------------------------------------------------++ mergeInstances :: [(String,[String])] -> [(String,[String])] -> [(String,[String])]+ mergeInstances instances instances' = instances''+ where+ sis = splitInstances instances+ sis' = splitInstances instances'+ sis'' = nub $ sis ++ sis'+ instances'' = parseInstances sis''++ splitInstances :: [(String,[String])] -> [(String,String)]+ splitInstances [] = []+ splitInstances (h@(m,ts):t) = map (\x -> (m,x)) ts ++ splitInstances t++-------------------------------------------------------------------------------++ parseCabal :: String -> IO ([String],[String])+ parseCabal cabal_pname = do+ gpd <- readPackageDescription silent cabal_pname+ let flags = genPackageFlags gpd+ let flags' = map (\ (MkFlag (FlagName a) b c d) -> (map toUpper a, c)) flags+ let cppopts_flags = map (\ (x,y) -> " -D" ++ x ++ "=" ++ if y then "1" else "0") flags'+ let cppopts_flags_string = intercalate " " cppopts_flags+#if 0+MkFlag +flagName :: FlagName+flagDescription :: String+flagDefault :: Bool+flagManual :: Bool+#endif+ let condexes = condExecutables gpd+ let condexe@(_, condexetree) = head condexes+ let Executable _ _ buildinfo = condTreeData condexetree+#if DBG_OMNI+ putStrLn $ "BUILDINFO:\n" ++ show buildinfo+#endif+ let cppopts_cppopts = cppOptions buildinfo+ let cppopts = cppopts_flags ++ cppopts_cppopts+ let ghcopts = process_opts $ options buildinfo+ return (cppopts,ghcopts)+ where+ process_opts :: [(CompilerFlavor, [String])] -> [String]+ process_opts [] = []+ process_opts (h@(cf,ss):t)+ | GHC <- cf = ss ++ process_opts t+ | otherwise = process_opts t++-------------------------------------------------------------------------------++ guessBaseIndentationLevel :: String -> Maybe Int+ guessBaseIndentationLevel str+ | null lst' = Nothing+ | otherwise = Just $ snd $ head lst'+ where+ lst = map (length . takeWhile (==' '))+ $ filter (not . isDashDashCommentLine)+ $ filter (/="")+ $ lines str+-- lst' = sort $ zip lst [0..]+ lst' = map (\x -> (length x,head x)) $ group $ sort lst -- histogram of indentation levels+ isDashDashCommentLine :: String -> Bool+ isDashDashCommentLine (' ':cs) = isDashDashCommentLine cs+ isDashDashCommentLine ('-':'-':_) = True+ isDashDashCommentLine _ = False++-------------------------------------------------------------------------------++ -- (I know of no better way.)+ detectSandbox :: IO Bool+ detectSandbox = doesFileExist "cabal.sandbox.config"++-------------------------------------------------------------------------------+
+ Seqaid/Runtime.hs view
@@ -0,0 +1,265 @@++-------------------------------------------------------------------------------++-- XXX Later: OLD comment! probably not correct+ -- This is a static module injected by Seqaid.+ -- It is not designed to depend dynamically on the target source.++ {- OPTIONS_GHC -O2 #-}++ {-# LANGUAGE CPP #-}++ {-# LANGUAGE BangPatterns #-} -- for debugging only (maybe for more...)++-------------------------------------------------------------------------------++-- |+-- Module : Seqaid.Runtime+-- Copyright : (c) 2014, Andrew G. Seniuk+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : Andrew Seniuk <rasfar@gmail.com>+-- Stability : provisional+-- Portability : GHC (unsafePerformIO)+--+-- This module is for seqaid internal use.++ module Seqaid.Runtime (++ SiteID -- re-export++ , seqaidDispatch++ , seqaidDispatchDyn++-- would be best if could... (less for plugin/lib user to do)+-- , module Control.DeepSeq.Bounded+-- , Typeable++ ) where++-------------------------------------------------------------------------------++ import Control.DeepSeq.Bounded++ import Data.Typeable ( typeOf )+ import Data.Typeable ( Typeable )++ import Seqaid.Global (+ SiteID+--- , run_IO_SM -- moved to Optim [not ideal, but...]+-- , sample_period+ , max_depth+-- , fixed_pat_sequence+ , fixed_pat+ )++ import Seqaid.Optim++ -- (for monitoring resource use, and computing objective function)+ import System.IO.Unsafe ( unsafePerformIO )++ import Debug.Trace ( trace )++#if SEQABLE_ONLY+ import Generics.SOP ( Generic )+#endif++-------------------------------------------------------------------------------++ {-# NOINLINE seqaidDispatch #-}++#if SEQABLE_ONLY++ seqaidDispatch :: (+#if SHOW_TYPE+--- #warning "WARNING-2"+ Typeable a,+#endif+ Generic a) =>+ SiteID ->+ a -> a+ seqaidDispatch+ sid+ x =+#if DBG_SEQAID+ if {- True || -} i >= t+ then+ trace (">>> S "+ ++snd3 sid++"\t"+ ++show stats_query_idx++" "+ ++show (i,t,size)++" "+#if SHOW_TYPE+ ++show (typeOf x)+#endif+ ) $+#endif+ x'+ else x'++#else++#if NFDATAN_ONLY+--- #warning "WARNING-1"++-- It's very tempting to write this with the CPP subconditionals deeper in...+ seqaidDispatch :: (+#if SHOW_TYPE+--- #warning "WARNING-2"+ Typeable a,+#endif+ NFDataN a) =>+ SiteID ->+ a -> a+ seqaidDispatch+ sid+ x =+#if DBG_SEQAID+ if {- True || -} i >= t+ then+ trace (">>> N "+-- trace ("SEQAIDDISPATCH N "+ ++snd3 sid++"\t"+ ++show stats_query_idx++" "+ ++show (i,t,size)++" "+#if SHOW_TYPE+ ++show (typeOf x)+#endif+ ) $+#endif+ x'+ else x'++#else++ seqaidDispatch :: (NFData a,NFDataN a,Typeable a,NFDataP a) =>+ SiteID ->+ a -> a+ seqaidDispatch+ sid+ x =+#if DBG_SEQAID+#if 1+-- 80 cols+ if i >= t+-- if True || i >= t+ then+ trace ((if stats_query_idx == 0 then " live alloc\n" else "")++(if stats_query_idx <= (1+max_depth) then " N " else " P ")+ ++(if stats_query_idx <= (1+max_depth) then (padr 36 (show depth)) else padr 36 (showPat pat'))++" "+-- ++padl 2 (show (fst3 sid))++" "+ ++padr 13 (dropQuals (snd3 sid))+-- ++padl 3 (show stats_query_idx)++" "+ ++padl 8 (show cbu)++" "+ ++padl 9 (show size)++" "+-- ++show (cbu, size)++" "+-- ++show (i, size)++" "+-- ++show (i,t',size)++" "+ ++show (typeOf x)+ ) $+#else+-- 110 cols+ if i >= t+-- if True || i >= t+ then+#if 1+ trace ((if stats_query_idx == 0 then " live heap alloc\n" else "")++(if stats_query_idx <= (1+max_depth) then ">>> N " else ">>> P ")+#else+ trace (">>> P "+#endif+-- trace ("SEQAIDDISPATCH P "+ ++(if stats_query_idx <= (1+max_depth) then (padr 40 (show depth)) else padr 40 (showPat pat'))++" "+ ++padl 2 (show (fst3 sid))++" "+-- ++(if fst3 sid > 9 then "" else " ")++show (fst3 sid)++" "+ ++snd3 sid++"\t"+-- ++show sid++"\t"+ ++padl 3 (show stats_query_idx)++" "+ ++padl 11 (show cbu)++" "+ ++padl 11 (show size)++" "+-- ++show (cbu, size)++" "+-- ++show (i, size)++" "+-- ++show (i,t',size)++" "+ ++show (typeOf x)+ ) $+#endif+#endif+ x'+ else x'++#endif+#endif++ where++ ( stats_query_idx, depth, pat, snk, i, t, size, cbu, t')+-- (!stats_query_idx,!depth,!pat,!snk,!i,!t,!size,!cbu,!t')+ = unsafePerformIO $! run_IO_SM sid x++-- The constants 6 and fixed_pat are specific to the leaky-1.0 package.+-- They are minimal sufficient depth and pattern (respectively) to plug leaky.+#if SEQABLE_ONLY+ x' = force_ snk x+-- x' = force_ Insulate x+#else+#if NFDATAN_ONLY+ x' = forcen depth x+-- x' = forcen 6 x+#else+ pat' = pat+ x' | stats_query_idx <= (1+max_depth)+ = forcep_ pat x -- trying to use *n patterns instead+-- = forcen depth x+ | otherwise+ = forcep_ pat x+#endif+#endif++-------------------------------------------------------------------------------++ -- Note that NFDataP already has Typeable superclass.+ -- (This is not ideal perhaps, as a lot of NFDataP's+ -- functionality doesn't depend on Typeable...).+#if 1+ -- For plugin, we prefer to try without the extra argument first...+ seqaidDispatchDyn :: NFDataP a => a -> a+ seqaidDispatchDyn x = x'+ where+ t = show $ typeOf x+ x' | t == "TA" = forcep_ fixed_pat x+ | otherwise = x+#else+ seqaidDispatchDyn :: NFDataP a => SiteID -> a -> a+--seqaidDispatchDyn :: NFDataP a => a -> a+--seqaidDispatchDyn :: (Typeable a,NFDataP a) => a -> a+ seqaidDispatchDyn _ x = x'+ where+-- !_ = trace t $ ()+ t = show $ typeOf x+ x' | t == "TA" = forcep_ fixed_pat x+-- x' | t == "State" = forcep_ fixed_pat x+ | otherwise = x+#endif++-------------------------------------------------------------------------------++ padr :: Int -> String -> String+ padr n s = s ++ (take (n-(length s)) $ repeat ' ')+ padl :: Int -> String -> String+ padl n s = (take (n-(length s)) $ repeat ' ') ++ s++-------------------------------------------------------------------------------++ -- use it on (String-ified) types!... (See caveat in Core.hs.)+ dropQuals :: String -> String+ dropQuals = reverse . takeWhile (/= '.') . reverse++-------------------------------------------------------------------------------++ fst3 :: (a,b,c) -> a+ fst3 (x,_,_) = x+ snd3 :: (a,b,c) -> b+ snd3 (_,y,_) = y+ thd3 :: (a,b,c) -> c+ thd3 (_,_,z) = z++-------------------------------------------------------------------------------+
+ Seqaid/TH.hs view
@@ -0,0 +1,1244 @@++{-# LANGUAGE CPP #-}++-- See what names from the module being spliced are in scope to TH.+#define DBG_NAMES 0++-- These types come from arguments to the seqaidTH splice.+#define DBG_TYPES 0++-- XXX A bit later yet: This could be handled completely+-- automatically (without needing to depend on seqaid.config+-- "exclude:" field or something), with new seqaidpp-calls-TH+-- idea ... it can see whether "seqaid" is called anywhere+-- in a bind(ing group)'s RHS(s), and decide on exclusion+-- that way...+-------+-- XXX Later: This can now be handled gracefully by seqaidpp+-- but this has not yet been implemented...+-------+-- I'd love to be able to do this, but so far as I can see, we+-- don't get to look at the RHS's of Dec's using reify Name,+-- only get the types... (So user has to add an Exclude ANN+-- as well as their manual seqaidDispatch injection, to any+-- bind which would be excluded by this TH code on other grounds,+-- such as [at present] being polymorphic.)+--- #define EXCLUDE_MANUALLY_INSTRUMENTED 1++-- Now the norm (and the ONLY way I could find to make+-- seqaid blanket harnessing feasible).+#define INJECT_DUMMY_CLASS_AND_INSTANCE_TO_BLOCK_DEAD_CODE_ELIMINATION 1++-- We want this to be 0, but at present the plugin is broken unless it's 1.+#define EXCLUDE_POLYMORPHIC_TYPES 1+--- #define EXCLUDE_MULTIPARAM_TYPES 0++-- You'll need this for some kinds of debugging...+#define SHOW_CONSTRAINT 0++{-# LANGUAGE TemplateHaskell #-}++-- XXX Some sites where I'm using this, should be using TH API to+-- issue errors and warnings...+----+-- Helpful with code tracing.+{-# LANGUAGE BangPatterns #-}++-------------------------------------------------------------------------------++-- |+-- Module : Seqaid.TH+-- Copyright : (c) 2014, Andrew G. Seniuk+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : Andrew Seniuk <rasfar@gmail.com>+-- Stability : provisional+-- Portability : GHC (TH)+--+-- Template Haskell parts of seqaid.+--+-- None of these splices needs to (or should) be called by the user.++ module Seqaid.TH (++ seqaidTH ,++ seqaidValidate ,++-- seqaidSOP ,++-- seqaidManTH ,++-- seqaidInstancesTH ,++ strInstancesTH ,++ bindsIncludedTH ,++#if TRY_INJECT_NOINLINE_ON_REQUESTED_BINDS+ noinlineTH ,+#endif++ module Seqaid.Runtime ,+ module Seqaid.Ann ,++ ) where++ import Language.Haskell.TH+ import Language.Haskell.TH.Syntax ( qLocation )+#if SEQAIDPP_TYPES+ -- actually we use it in both cases, if you want to still+ -- do the top-level RHS wrapping technique; but I'm headed+ -- towards more general type-based subexpression wrapping,+ -- now that the preprocessor has made that possible...+ -- Actually, I suppose TH could be fed a config file, too...+ -- Consider porting all the config-file oriented stuff there?+ -- seqaidpp would only handle injection of static content.+ -- But no, it won't work, we need to know the types in the prepro+ -- at least to create the "deriving instance" declarations.+ import Language.Haskell.TH.Module.Magic ( names )+#else+ import Language.Haskell.TH.Module.Magic ( names )+#endif++ import Data.Generics ( listify, everywhere, mkT )++#if SEQABLE_ONLY+ import Generics.SOP.Universe ( Generic )+#endif++#if NFDATAN_ONLY+ import Control.DeepSeq.Bounded ( NFDataN )+#else+ import Control.DeepSeq.Bounded ( NFDataP )+#endif++ import Seqaid.Runtime ( seqaidDispatch, SiteID )+--import Seqaid.Runtime ( seqaid_internal )+ import Seqaid.Ann++ import Data.Maybe+ import Data.Either+ import Data.List ( intercalate, nub, nubBy )+ import Control.Monad ( liftM, zipWithM, foldM )++#if 0+ import qualified GHC.Environment as GHC ( getFullArgs )+#endif++ -- For global Bool state, to indicate that a warning has already been issued.+ import Data.IORef+ import System.IO.Unsafe ( unsafePerformIO )++ -- Regex only used to beautify warning messages.+ import Text.Regex.PCRE+ import Data.Array ( (!) )+ import Data.Array ( indices )++ import Debug.Trace ( trace )++ import qualified Type as GHC ( Type )++-------------------------------------------------------------------------------++ firstWarningPassed :: IORef Bool+ firstWarningPassed = unsafePerformIO $ newIORef False++-------------------------------------------------------------------------------++ seqaidInstancesTH :: Q [Dec]+ seqaidInstancesTH = do+#if SEQABLE_ONLY+ is <- getInstances ''Generics.SOP.Universe.Generic+#else+#if NFDATAN_ONLY+ is <- getInstances ''NFDataN+#else+ is <- getInstances ''NFDataP+#endif+#endif+ dss <- instancesToSeqinjDecls is+ let ds = concat dss+ return ds++-------------------------------------------------------------------------------++ strInstancesTH :: Q [Dec]+ strInstancesTH = do+#if SEQABLE_ONLY+ is <- getInstances ''Generics.SOP.Universe.Generic+#else+#if NFDATAN_ONLY+ is <- getInstances ''NFDataN+#else+ is <- getInstances ''NFDataP+#endif+#endif+ ss <- instancesToTypeStrings is+#if 1+ exp <- [e| SeqaidAnnAvailableInstances ss |]+-- runIO $ putStrLn $ " :|: exp =\n" ++ pprint exp+ let pragma_decl = PragmaD (AnnP ModuleAnnotation exp)+ return [pragma_decl]+#else+-- > runQ [d| ss = [ "a", "bc" ] |]+-- [ValD (VarP ss_0) (NormalB (ListE [LitE (StringL "a"),LitE (StringL "bc")])) []]+ let lites = map (\x -> LitE (StringL x)) ss+ vp <- newName "seqaid_instance_strings"+ let dec = ValD (VarP vp) (NormalB (ListE lites)) []+ return [dec]+#endif++-------------------------------------------------------------------------------++ bindsIncludedTH :: [String] -> Q [Dec]+ bindsIncludedTH bns = do+ exp <- [e| SeqaidAnnBindsIncluded bns |]+-- runIO $ putStrLn $ " :|: exp =\n" ++ pprint exp+ let pragma_decl = PragmaD (AnnP ModuleAnnotation exp)+ return [pragma_decl]++-------------------------------------------------------------------------------++ -- (And this doesn't even require th-expand-syns.)+ seqaidValidate :: [Name] -> Q [Dec]+ seqaidValidate names = do+ infos' <- mapM reify names+ infos <- mapM seqaidValidate' infos' -- but will it get forced?!?+ -- also, this could be quite expensive in worst case!+-- runIO $! evaluate (force infos) -- I'm doubtful of an instance...+-- No instance.+-- Maybe we'll get lucky and TH is strict in this part??...+ return []+ where+ seqaidValidate' :: Info -> Q Info+ seqaidValidate' t = do+ case t of+ TyConI (TySynD name tyVarBndrs typ) -> error $ "seqaidpp: type synonym in instances list (seqaid.config):\n " ++ pprint name+-- TyConI (TySynD name tyVarBndrs typ) -> error $ "seqaidpp: type synonym in instances list (seqaid.config):\n" ++ pprint t+ _ -> return t++-------------------------------------------------------------------------------++-- Always takes the seqaidpp-provided Type list now, even if+-- it does nothing with them for some reason (eg. leaky FS=4).+#if 1 || SEQAIDPP_TYPES+#if 1+ -- XXX To do this, I'm injecting [q| |] quasis [?] as argument+ -- in the module being spliced. (Injection by seqaidpp.)+ -- ... XXX ... except that doesn't quite work, because+ -- [t| etc. are in the Q monad. So we need to inject a bit+ -- more TH (slippery slope!) -- or is it even possible?...+#if 1+ -- After: And even better haha! Well, this works in the+ -- standalone test, so hang on...+ seqaidTH :: [Q Type] -> Q [Dec]+ seqaidTH types_actions = do+#else+ seqaidTH :: [Type] -> Q [Dec]+ seqaidTH types = do+#endif+#else+ seqaidTH :: [String] -> Q [Dec]+ seqaidTH type_strs = do+#endif+#else+ seqaidTH :: Q [Dec]+ seqaidTH = do+#endif+#if SEQAIDPP_TYPES+ types <- mapM runQ types_actions+#else+ let types = []+#endif+ modname <- fmap loc_module qLocation+ runIO $ putStrLn $ "Included in seqaid harness: " ++ modname+-- runIO $ putStrLn $ "Included in seqaid harness: " ++ dropQuals modname+ do+#if 0+ fullargs <- runIO $ GHC.getFullArgs+-- runIO $ putStrLn $ intercalate "\n" fullargs+-- error "STOP"+{-+-fplugin=Seqaid.Plugin+-fplugin-opt=Seqaid.Plugin:S03+-}+-- runIO $ putStrLn $ show modname+-- error "STOP"+-- modname <- fmap loc_module qLocation >>= \mod -> return (LitE (StringL mod))+-- Module pkgname modname <- reifyModule thisModule+ -- This prevents splicing anything in, unless the plugin is active,+ -- in in particular, is active for the module we're compiling.+ if not $ elem "-fplugin=Seqaid.Plugin" fullargs+ && elem ("-fplugin-opt=Seqaid.Plugin:" ++ modname) fullargs+ then return []+ else do+#endif++#if 1 || SEQAIDPP_TYPES+#if 0+#if 0+ Just types_name <- lookupValueName "seqaid_types"+ types <- reify types_name+-- types <- [d| seqaid_types |]+#endif+ types <- mapM (liftM fromJust . lookupTypeName) type_strs+#else+ let type_strs = map pprint types+#endif+#endif++-- XXX We would like to pass [Type.Type] in the SeqaidAnnTypes ANN.+-- What I can't figure out is how to get Type.Type from TH.Type.+#if 1 || SEQAIDPP_TYPES+#if TH_TYPE_IN_TYPES_ANN+-- I whish this had worked out, but I don't see how to do it...+#if 0+#elif 1+ ghc_types <- $(types)+ sats_exp <- [e| SeqaidAnnTypes ghc_types |]+#elif 0+ sats_exp <- [e| SeqaidAnnTypes $(types) |]+#elif 0+ let ghc_types = map (\x -> $(x)) types+ sats_exp <- [e| SeqaidAnnTypes ghc_types |]+#endif+#else+ sats_exp <- [e| SeqaidAnnTypes type_strs |]+#endif+#if DBG_TYPES+ runIO $ putStrLn $ " :|: sats_exp =\n" ++ pprint sats_exp+#endif+ let sats_pragma_decl = PragmaD (AnnP ModuleAnnotation sats_exp)+#endif++-- XXX Trying to still use the IncludeList, even for blanket+-- by-types wrapping in Core, since want to be able to distinguish+-- synthetic and original binds.+#if INFER_TOP_LEVEL_TYPES+ ns <- names :: Q [Name]+--makeNameType :: Either Name Type -> Q (Either Name (Maybe Name,Type))+ ents_names <- mapM ( makeNameType . (\x->Left x) ) ns :: Q [Either Name (Maybe Name,Type)]+-- ents_names <- mapM makeNameType ns -- :: Q [Either Name (Name,Type)]+#if DBG_NAMES+ runIO $ putStrLn $ "Top-level names in scope:\n" ++ show ns+#endif+#else+ let ents_names = []+#endif++#if SEQAIDPP_TYPES+ -- This is returning Left's, but should be Right (Nothing,ty):+ ents_types <- mapM ( makeNameType_types . (\x->Right x) ) types :: Q [Either Name (Maybe Name,Type)]+#else+ let ents_types = []+#endif++#if DBG_TYPES+ runIO $ putStrLn $ " !! length ents_names=" ++ (show $ length ents_names)+ runIO $ putStrLn $ " !! length ents_types=" ++ (show $ length ents_types)+#endif++ let ents = ents_names ++ ents_types++#if DBG_TYPES || DBG_NAMES+ runIO $ putStrLn $ show ents+#endif+ let nts = rights ents++ if null nts+ then do+#if DBG_NAMES+ runIO $ putStrLn $ "modulespection:names = []"+#endif+ return []+ else do+#if DBG_NAMES+ let ss = map (\ (n,t) -> pprint n ++ " :: " ++ pprint t) nts :: [String]+-- let ss = map pprint ns :: [String]+ let ss' = intercalate "\n " ss+ runIO $ putStrLn $ "modulespection:names = \n " ++ ss'+-- reportWarning ss'+#endif+ sidtyp <- [t| SiteID |]+ ([ann]:dss') <- manifestSeqinjDecls sidtyp nts+-- runIO $ putStrLn $ show $ map length dss'+ let dss = dss'+-- let dss = map reverse dss'+#if INJECT_DUMMY_CLASS_AND_INSTANCE_TO_BLOCK_DEAD_CODE_ELIMINATION+ (clsd:instd:[]) <- manifestDummyClassAndInstance sidtyp dss+#endif++-- error "STOP"++ -- Pattern of decls is: Anns, TypeSig, Binding, TypeSig, Binding, ...+#if SEQAIDPP_TYPES+ let ds = sats_pragma_decl : ann : clsd : instd : reverse (concat $ map reverse dss)+#else+#if INJECT_DUMMY_CLASS_AND_INSTANCE_TO_BLOCK_DEAD_CODE_ELIMINATION+ let ds = ann : clsd : instd : reverse (concat $ map reverse dss)+#else+ let ds = ann : reverse (concat $ map reverse dss)+#endif+#endif++ return ds++-------------------------------------------------------------------------------++ instancesToSeqinjDecls :: [InstanceDec] -> Q [[Dec]]+ instancesToSeqinjDecls ids = zipWithM instancesToSeqinjDecl' [0,1..] ids+ where+ instancesToSeqinjDecl' :: Int -> InstanceDec -> Q [Dec]+ instancesToSeqinjDecl' idx (InstanceD ctx t ds) = do+ let (AppT _ t2) = t -- (AppT (AppT ArrowT t2) t2)+ (seqinj_dec:_) <- [d| seqinj = seqaidDispatch :: () -> () |] -- inefficient+-- (seqinj_dec:_) <- [d| seqinj = forcep "#" :: () -> () |] -- inefficient+ let (ValD (VarP vp1) (NormalB (SigE ae1 (AppT (AppT ArrowT _) _))) [])+ = seqinj_dec+#if 0+ let vp1' = vp1+#else+ let vp1s = show vp1+ let (vp1s1,vp1s2) = break (=='_') vp1s+ let vp1s' = "seqinjinst_" ++ show idx+-- let vp1s' = "seqinjinst" ++ vp1s2+ vp1' <- newName vp1s'+-- let vp1' = mkName vp1s'+#endif+-- > runQ [d| seqinj_blah = forcep "#" |]+-- [ValD (VarP seqinj_blah_0) (NormalB (AppE (VarE Control.DeepSeq.Bounded.NFDataP.forcep) (LitE (StringL "#")))) []]+-- vs.+-- > runQ [d| seqinj_blah = forcep "#" :: Float -> Float |]+-- [ValD (VarP seqinj_blah_1) (NormalB (SigE (AppE (VarE Control.DeepSeq.Bounded.NFDataP.forcep) (LitE (StringL "#"))) (AppT (AppT ArrowT (ConT GHC.Types.Float)) (ConT GHC.Types.Float)))) []]+ let free_tvars_t2 = getFreeTVars t2+ let bind_tvars_t2 = map bindTVars free_tvars_t2+ let ctx2 = make_ctx Nothing free_tvars_t2 ctx+-- ForallT [TyVarBndr] Cxt Type+ let seqinj_tdec+ = SigD vp1' (ForallT bind_tvars_t2 ctx2 (AppT (AppT ArrowT t2) t2))+-- = SigD vp1' (ForallT free_tvars_t2 [] (AppT (AppT ArrowT t2) t2))+-- = SigD vp1' (AppT (AppT ArrowT t2) t2)+-- seqinj_tdec <- [d| $(vp1') :: $(t2) -> $(t2) |]+ let seqinj_fdec+ = (ValD (VarP vp1') (NormalB ae1 ) [])+-- = (ValD (VarP vp1') (NormalB ae1 ) [])+-- = (ValD (VarP vp1') (NormalB (SigE ae1 (AppT (AppT ArrowT t2) t2))) [])+-- return [seqinj_tdec]+ return [seqinj_tdec, seqinj_fdec]+-- return (seqinj_tdec, seqinj_fdec)++-------------------------------------------------------------------------------++ -- (Cloned from [ancient] instancesToSeqinjDecls. Probably doesn't+ -- need the zipping with unique Int's.)+ instancesToTypeStrings :: [InstanceDec] -> Q [String]+ instancesToTypeStrings ids = zipWithM instancesToTypeString' [0,1..] ids+ where+ instancesToTypeString' :: Int -> InstanceDec -> Q String+ instancesToTypeString' idx (InstanceD ctx t ds) = do+ let (AppT _ t2) = t -- (AppT (AppT ArrowT t2) t2)+ return $ pprint t+--- -- (AppT (AppT ArrowT SiteID) (AppT (AppT ArrowT t2) t2))+--- let (AppT _ (AppT _ t2)) = t++-------------------------------------------------------------------------------++ bindTVars :: Type -> TyVarBndr -- specifically, VarT ->+ bindTVars (VarT name) = PlainTV name+ bindTVars _ = error "bindTVars: unexpected!"++-------------------------------------------------------------------------------++ getFreeTVars :: Type -> [Type] -- specifically, -> [VarT]+ getFreeTVars t = listify f t+ where+ f :: Type -> Bool+ f x@(VarT name) = True+ f x = False++-------------------------------------------------------------------------------++ -- Thanks to John L. in http://stackoverflow.com/a/5398910+ -- This was my introduction to TH.++ -- get a list of instances+ getInstances :: Name -> Q [InstanceDec]+--getInstances :: Name -> Q [ClassInstance]+ getInstances typ = do+ ClassI _ instances <- reify typ+ return instances++#if 0+ -- convert the list of instances into an Exp so they can be displayed in GHCi+ showInstances :: Name -> Q Exp+ showInstances typ = do+ ins <- getInstances typ+ return . LitE . stringL $ show ins+#endif++-------------------------------------------------------------------------------++-- XXX Okay, I've run into trouble already here.+-- Between Type and Name (and String).+-- We want the **Type** Types.TA (from the String "Types.TA").+-- But if reify . loopupTypeName, you get (which is cool and nice;+-- and is due to the fact that the types are imported) the full+-- declarations:+-- data Types.TA+-- = Types.A1 GHC.Types.Int | Types.A2 Types.TB GHC.Types.Int Types.TC+-- type Types.State = Types.TA+-- So I guess I could pattern-match on these and other type constructors,+-- and extract the types from it directly. But can we not just avoid it???+-- lookupTypeName :: String -> Maybe Name+-- reify :: Name -> Decl+-- Name -> Q Info with VarI (eg. a function binding), TyConI (what+-- we are getting at present), ...+-- But can't we just say the equivalent of "typeOf Name"?+-------+-- XXX Decided to clone this (and decruft the copy, as usual),+-- since the type case has more than a few differences...++--makeNameType :: Either Name Name -> Q (Either Name (Maybe Name,Type))+ makeNameType :: Either Name Type -> Q (Either Name (Maybe Name,Type))+--makeNameType :: Either Name Type -> Q (Either Name (Name,Type))+--makeNameType :: Either Name Type -> Q (Maybe (Name,Type))++ makeNameType (Right _) = error "makeNameType: Right unexpected!"+ makeNameType enm@(Left nm) = do+ modname <- fmap loc_module qLocation+#if 0+ !_ <- trace ("nm="++pprint nm++" modname="++modname) $ return ()+ if False && takeQuals (pprint nm) /= modname+ then do+ !_ <- trace "HERE-1" $ return ()+ return $ Left nm+-- then return $ Left nm+ else do+#else+ do+#endif+-- Just nm <- lookupValueName nm_string+{-+data TH.Info =+ ClassI Dec [InstanceDec]+ ClassOpI Name Type ParentName Fixity+ TyConI Dec+ FamilyI Dec [InstanceDec]+ PrimTyConI Name Arity Unlifted+ DataConI Name Type ParentName Fixity+ VarI Name Type (Maybe Dec) Fixity+-}+#if 1+--- !_ <- trace "HERE-2" $ return ()+ rnm <- reify nm+--- !_ <- trace ("<><><><> " ++ pprint rnm) $ return ()+ let mnmt+ = case rnm of+-- XXX You might think it would be better to just OMIT all but VarI+-- types (gracefully) -- which I should have tried already, and will+-- certainly try in a moment ... But, probably, you'll NEED to deal+-- with things like DataConI's, since the associated types will+-- have to be in scope ... or ... no?...+ VarI nm_ t_ mdec_ fxty_ ->+ if takeQuals (show nm_) /= modname+ then Nothing+ else Just (nm_,t_)+#if 0+ -- XXX can probably scrounge a Name up in the 3 unimplemented ones+-- ClassI dec_ ideclst_ -> error "makeNameType: ClassI unimplemented"+ ClassOpI nm_ t_ parentnm_ fxty_ ->+ if takeQuals (show nm_) /= modname+ then Nothing else Just (nm_,t_)+-- TyConI dec_ -> error "makeNameType: TyConI unimplemented"+-- FamilyI dec_ ideclst_ -> error "makeNameType: FamilyI unimplemented"+-- PrimTyConI nm_ arty_ unlifted_ -> error "makeNameType: PrimTyConI unimplemented"+ DataConI nm_ t_ parentnm_ fxty_ ->+ if takeQuals (show nm_) /= modname+ then Nothing else Just (nm_,t_)+ _ -> Nothing+#else+ _ -> Nothing+#endif+#else+ rnm@(VarI nm_ t_ mdec_ fxty_) <- reify nm+#endif+ if isNothing mnmt+ then do+ return $ Left nm+-- return $ Nothing+ else do+ let Just (nm_,t_) = mnmt+#if 0+ let snm_ = pprint nm_+ let st_ = pprint t_+ runIO $ putStrLn $ " ********* " ++ snm_ ++ " " ++ st_+#endif+ return $ Right (Just nm_,t_)+-- return $ Just (nm_,t_)++-------------------------------------------------------------------------------++--makeNameType_types :: Either Name Name -> Q (Either Name (Maybe Name,Type))+ makeNameType_types :: Either Name Type -> Q (Either Name (Maybe Name,Type))+--makeNameType_types :: Either Name Type -> Q (Either Name (Name,Type))+--makeNameType_types :: Either Name Type -> Q (Maybe (Name,Type))++ makeNameType_types (Left _) = error "makeNameType_types: Left unexpected!"++#if 1++ makeNameType_types enm@(Right typaboo) = do+ return $ Right (Nothing,typaboo)++#else++ makeNameType_types enm@(Right nm) = do+ modname <- fmap loc_module qLocation+--- !_ <- trace "HERE-2" $ return ()+ rnm <- reify nm+ !_ <- trace ("<><><><> " ++ pprint rnm) $ return ()+ let mnmt+ = case rnm of+ VarI nm_ t_ mdec_ fxty_ -> error "makeNameType_types: VarI unexpected!"+-- ClassI dec_ ideclst_ -> error "makeNameType_types: ClassI unimplemented"+--- TyConI dec_ -> error "makeNameType_types: TyConI unimplemented"+-- FamilyI dec_ ideclst_ -> error "makeNameType_types: FamilyI unimplemented"+-- PrimTyConI nm_ arty_ unlifted_ -> error "makeNameType_types: PrimTyConI unimplemented"+-- DataConI nm_ t_ parentnm_ fxty_ -> error "makeNameType_types: DataConI unimplemented"+-- DataD Cxt Name [TyVarBndr] [Con] [Name]+-- NewtypeD Cxt Name [TyVarBndr] Con [Name]+-- TySynD Name [TyVarBndr] Type++... unfinished ...++ TyConI dec_ -> case dec_ of+ DataD cxt name tyvarbndrs cons name ->+ NewtypeD Cxt Name [TyVarBndr] Con [Name]+ TySynD Name [TyVarBndr] Type+ _ -> Nothing+ if isNothing mnmt+ then do+ return $ Left nm+-- return $ Nothing+ else do+ let Just (nm_,t_) = mnmt+#if 0+ let snm_ = pprint nm_+ let st_ = pprint t_+ runIO $ putStrLn $ " ********* " ++ snm_ ++ " " ++ st_+#endif+ return $ Right (Just nm_,t_)+-- return $ Just (nm_,t_)++#endif++-------------------------------------------------------------------------------++ -- This is identical to produceSeqinjDecls, minus cruft,+ -- since wrote makeNameType instead...+ manifestSeqinjDecls :: Type -> [(Maybe Name,Type)] -> Q [[Dec]]+ manifestSeqinjDecls sidtyp nts = do++ mod <- thisModule+ modname <- fmap loc_module qLocation -- really?? can't get this from mod?!++ reiannbad <- reifyAnnotations (AnnLookupModule mod) :: Q [SeqaidAnnIncludeList]+ if not $ null reiannbad+ then do+ error $ "seqaid: illegal SeqaidAnnIncludeList annotation"+ else do++ reiann <- reifyAnnotations (AnnLookupModule mod) :: Q [SeqaidAnnExclude]+-- runIO $ putStrLn $ "--------------\n" ++ show reiann ++ "---------\n"+--ValueAnnotation+ -- Collect existing ANN 's to initialise the lists of excluded name strings:+ let zlst' = map (\ (SeqaidAnnExclude s) -> s) reiann+ -- Make sure all the name strings fully-qualified:+ let zlst'' = map (\ s -> if elem '.' s then s else modname ++ ('.':s)) zlst'+ let zlst = zlst''++-- XXX I do confess I'm having a hard time following this...++ (injdecls,excorincnms) <- liftM fst $+ ( foldM+ ( \ y@((injdecls_, excorincnms_), yidx) x ->+ do+ eideclst <- manifestSeqinjDecl' zlst yidx x+ case eideclst of+ Left nm -> return ((injdecls_, excorincnms_), yidx)+#if 1+ Right d -> case fst x of+ Nothing -> return ((d:injdecls_, excorincnms_), 1+yidx)+ Just nm -> return ((d:injdecls_, nm:excorincnms_), 1+yidx)+#else+ Right d -> let nm = fst x in+ return ((d:injdecls_, nm:excorincnms_), 1+yidx)+#endif+ )+ (([],[]),0)+ :: [(Maybe Name,Type)] -> Q (([[Dec]],[Name]),Int) ) -- type up to here+--- :: [(Name,Type)] -> Q (([[Dec]],[Name]),Int) ) -- type up to here+ nts++-- runIO $ putStrLn $ " :|: injdecls =\n" ++ pprint injdecls+-- runIO $ putStrLn $ " :|: excorincnms =\n" ++ pprint excorincnms+-- error "STOP"++-- Get all the binds explicitly excluded by ANN pragmas already+-- present in the input source module:++-- Get all the binds excluded based on as-yet unsupported types:+-- let exp = LitE (StringL "Boo!")+ let ss = map pprint excorincnms++ let ss' = ss+-- let ss' = ss ++ zlst+-- runIO $ putStrLn $ " :|: ss' = " ++ intercalate "\n" ss'+-- runIO $ putStrLn $ " :|: zlst = " ++ intercalate "\n" zlst+-- runIO $ putStrLn $ " :|: ss = " ++ intercalate "\n" ss++ exp <- [e| SeqaidAnnIncludeList ss' |]+-- runIO $ putStrLn $ " :|: exp =\n" ++ pprint exp++ let pragma_decl = PragmaD (AnnP ModuleAnnotation exp)++ return ([pragma_decl] : injdecls)+-- manifestSeqinjDecls nts = liftM catMaybes $ zipWithM manifestSeqinjDecl' [0,1..] nts+ where+ manifestSeqinjDecl' :: [String] -> Int -> (Maybe Name,Type) -> Q (Either Name [Dec])+-- manifestSeqinjDecl' :: [String] -> Int -> (Name,Type) -> Q (Either Name [Dec])+ manifestSeqinjDecl' zlst idx (mnm,t) = do+#if 0+data Type = ForallT [TyVarBndr] Cxt Type --- <long comment elided>+ | AppT Type Type --- @T a b@+ | SigT Type Kind --- @t :: k@+ | VarT Name --- @a@+ | ConT Name --- @T@+ | PromotedT Name --- @'T@+ -- See Note [Representing concrete syntax in types]+ | TupleT Int --- @(,), (,,), etc.@+ | UnboxedTupleT Int --- @(#,#), (#,,#), etc.@+ | ArrowT --- @->@+ | ListT --- @[]@+ | PromotedTupleT Int --- @'(), '(,), '(,,), etc.@+ | PromotedNilT --- @'[]@+ | PromotedConsT --- @(':)@+ | StarT --- @*@+ | ConstraintT --- @Constraint@+ | LitT TyLit --- @0,1,2, etc.@+#endif+ let st = pprint t+ let nm = fromJust mnm+ let snm = pprint nm+#if 0+ runIO $ putStrLn $ "mnm = " ++ show mnm ++ "\nst = " ++ st+-- runIO $ putStrLn $ "snm = " ++ snm ++ "\nst = " ++ st+ runIO $ putStrLn $ "zlst = " ++ show zlst+-- error "HERE!"+#endif+ if isJust mnm && elem snm zlst+-- if elem snm zlst+ then do {- runIO (putStrLn "YAY!!!!!") >> -} return (Left nm)+ else do+#if ! EXCLUDE_POLYMORPHIC_TYPES+--- #if ! EXCLUDE_MULTIPARAM_TYPES+ let t2 = t+ do+#else+ mt2 <- case t of+ (ForallT _ _ _) -> do+ if isNothing mnm+ then return $ Just t+ else do+ firstwarnpassed <- runIO $ readIORef firstWarningPassed+ if firstwarnpassed+ then reportWarning $ "seqaid: omitting declaration from auto-harness:\n " ++ snm ++ " :: " ++ beautify st ++ "\n Polymorphic types not yet supported by the plugin."+ else reportWarning $ "seqaid: omitting declaration from auto-harness:\n " ++ snm ++ " :: " ++ beautify st ++ "\n Sorry, polymorphic types not yet supported by the plugin.\n If you need this declaration to be included in the harness,\n please manually instrument with \" seqaid $ \" at the front of the\n RHS of its binding. (For technical reasons, this warning will\n still appear unless you also put\n {-# ANN module (SeqaidAnnExclude \"" ++ dropQuals snm ++ "\") #-}\n someplace in the same module; or just ignore the warning.)"+#if 0+ ++ " Pass seqaidDispatch a distinct, negative Int as\n first argument. (Negative keys are reserved for this eventuality.)"+#endif+ runIO $ modifyIORef' firstWarningPassed (const True)+ return Nothing+ _ -> return $ Just t+ if isNothing mt2 then return $ Left nm+ else do+ -- or is "resultType :: Type -> Type" in TH API?...+ let t2 = followArrows $ fromJust mt2 -- use result type+#endif+ (seqinj_dec:_) <- [d| seqinj = seqaidDispatch :: SiteID -> () -> () |] -- inefficient+#if 0+ let (ValD (VarP vp1) (NormalB (SigE ae1 ( AppT (AppT ArrowT sidtyp) ( AppT (AppT ArrowT _) _))))) [])+ = seqinj_dec+#else+ let (ValD (VarP vp1) (NormalB (SigE ae1 (+ AppT+ (AppT ArrowT sidtyp)+ ( AppT+ (AppT ArrowT _)+ _+ )+ )+ )) [])+ = seqinj_dec+#endif+#if 0+ ( AppT+ (AppT ArrowT sidtyp)+ ( AppT+ (AppT ArrowT typ_)+ typ_+ )+ )+#endif+ let vp1s = show vp1+ let (vp1s1,vp1s2) = break (=='_') vp1s+ let vp1s' = "seqinj_" ++ show idx+ vp1' <- newName vp1s'+#if 1+ t' <- {-trace "Boo-hoo" $-} makeSeqinjType Nothing sidtyp t2+ let seqinj_tdec = SigD vp1' t'+-- let seqinj_tdec = trace ("YES: "++show t') $ SigD vp1' t'+#else+ let seqinj_tdec+ = SigD vp1' (AppT (AppT ArrowT t2) t2)+#endif+-- > runQ [t| forall a. a -> a |]+-- ForallT [PlainTV a_2] [] (AppT (AppT ArrowT (VarT a_2)) (VarT a_2))+-- > runQ [t| forall a b. (a,b) -> (a,b) |]+-- ForallT [PlainTV a_0,PlainTV b_1] [] (AppT (AppT ArrowT (AppT (AppT (TupleT 2) (VarT a_0)) (VarT b_1))) (AppT (AppT (TupleT 2) (VarT a_0)) (VarT b_1)))+ let seqinj_fdec+ = ValD (VarP vp1') (NormalB ae1) []+ return $ Right [seqinj_tdec, seqinj_fdec]++-------------------------------------------------------------------------------++ -- Added this to correctly build a seqinj_[0-9]* type from+ -- a given forall type, also adding the necessary qualifiers:+ -- This is like the 3rd function cloned off of instancesToSeqinjDecl+ -- already, isn't it?? But this is the first to preserve (let alone+ -- focus on) the forall stuff...+ -- XXX This should be called from any places which are creating t -> t...+ -- XXX XXX XXX Forgot! Still need to make newName's -- the only+ -- type var Name that can be reused in here is Maybe Name argument...+ -- XXX Also, we are getting duplicate vars in our synthesised forall binders,+ -- simply need to nub.+-- XXX This is wretched at the moment:+-- When isNothing mn, assume tt is NOT yet in t -> t form, and do it.+-- When isJust mn, tt IS in t -> t form (but we have some other stuff to do).+ makeSeqinjType :: Maybe Name -> Type -> Type -> Q Type+ makeSeqinjType mn sidtyp tt@(ForallT tyvarbndr_lst ctx typ) = do+-- runIO $ putStrLn $ " >FORALL> " ++ pprint tt+ let n = fromJust mn+ let free_tvars_typ' = getFreeTVars typ+-- Next day: I don't like this approach; just send the class typevar+-- if there is one (Just vs. Nothing), but assure the rest of the+-- Type does not start with that var. The type arg should also+-- not yet have the duplication, obviously (i.e. t ==> (t -> t)) -- this+-- is part of the job of THIS function!+#if 1+ let free_tvars_typ = free_tvars_typ'+#else+ let free_tvars_typ+ | isNothing mb = free_tvars_typ'+ | PlainTV n <- b = filter (==(VarT n)) free_tvars_typ'+ | KindedTV n k <- b = filter (==(VarT n)) free_tvars_typ'+#endif+#if 1+ let blah1 = map (\ (VarT n) -> show n) (free_tvars_typ :: [Type]) :: [String]+ let blah2 = nub blah1 :: [String]+ blah3 <- mapM newName (map (take 1) blah2) :: Q [Name]+-- blah3 <- mapM newName (take (length blah2) (repeat "a")) :: Q [Name]+-- blah3 <- mapM newName blah2 :: Q [Name]+ blah4 <- mapM (\ n -> return $ VarT n) blah3 :: Q [Type]+ let bind_tvars_typ = blah4+-- let new_tvars_typ = blah4+ let orig_tyvars = nub free_tvars_typ+ let fresh_tyvars = bind_tvars_typ+#else+ new_tvars_typ+ <- fmap (\ n -> return $ VarT n) $+ (( mapM newName $+ (( nub $+ (( map (\ (VarT n) -> show n) (free_tvars_typ :: [Type])) :: [String] ) ) :: [String] )+ :: Q [Name]))+-- new_tvars_typ <- mapM (\ n -> return $ VarT n) $ mapM newName $ nub $ map (\ (VarT n) -> show n) free_tvars_typ+#endif+ let binding = map bindTVars bind_tvars_typ+-- ForallT [TyVarBndr] Cxt Type+ let (AppT _ typ_) = typ -- you can do this, but it does feel sloppy+ -- to have pattern bindings which you know are inapplicable+ -- except when those patterns arise (i.e. they should+ -- be localised to branches of conditionals, except+ -- conditional branching is such a pain with monads...+-- let (AppT (AppT ArrowT typ_) typ_) = typ+ let typ_' = substTyVars (orig_tyvars,fresh_tyvars) typ_+ let typ' | isNothing mn -- it's not a class method signature+ = let typ_ = substTyVars (orig_tyvars,fresh_tyvars) typ+ in+ ForallT+ binding+ (make_ctx (Just (orig_tyvars,fresh_tyvars)) bind_tvars_typ ctx)+ ( {-trace "BOO-1" $-}+ ( AppT+ (AppT ArrowT sidtyp)+ ( AppT+ (AppT ArrowT typ_)+ typ_+ )+ )+ )+--- (AppT (AppT ArrowT (AppT ArrowT sidtyp) typ_) typ_)+ | otherwise -- then it's a class method signature+ = let (AppT _ typ_) = typ+ typ_' = substTyVars (orig_tyvars,fresh_tyvars) typ_+ in+ ForallT+ binding+ (make_ctx (Just (orig_tyvars,fresh_tyvars)) bind_tvars_typ ctx)+#if 0+ (AppT (AppT ArrowT (VarT n))+ (AppT (AppT ArrowT typ_') typ_')+ )+#else+#if 0+ ( trace "BOO-2" $+ ( AppT+ (AppT ArrowT (VarT n))+ ( AppT+ (AppT ArrowT sidtyp)+ typ_'+ )+ )+ )+#else+ (AppT (AppT ArrowT (VarT n)) typ_')+#endif+#endif+ return typ'+ makeSeqinjType mn sidtyp tt@typ = do+ let n = fromJust mn+ let free_tvars_typ = getFreeTVars typ+ if null free_tvars_typ+ then do+-- runIO $ putStrLn $ " >OTHER:null> " ++ pprint tt+ let typ' | isNothing mn+ = ( AppT+ (AppT ArrowT sidtyp)+ ( AppT+ (AppT ArrowT typ)+ typ+ )+ )+ | otherwise+#if 0+ = AppT+ (AppT ArrowT (VarT n))+ (AppT (AppT ArrowT typ) typ)+#else+#if 0+-- > runQ [t| Int -> Bool -> Float |]+-- AppT (AppT ArrowT (ConT GHC.Types.Int)) (AppT (AppT ArrowT (ConT GHC.Types.Bool)) (ConT GHC.Types.Float))+-- > runQ [t| t1 -> t2 -> t3 |] -- pseudo+-- AppT (AppT ArrowT t1) (AppT (AppT ArrowT t2) t3)+ = trace "BOO-3" $ ( AppT+ (AppT ArrowT (VarT n))+ ( AppT+ (AppT ArrowT sidtyp)+ typ+ )+ )+#else+ = (AppT (AppT ArrowT (VarT n)) typ)+#endif+#endif+ return typ'+ else do+#if 1+ error $ "makeSeqinjType: Nothing and free vars"+#else+ runIO $ putStrLn $ " >OTHER:non-null> " ++ pprint tt+ let bind_tvars_typ = map bindTVars free_tvars_typ+ let typ' = ForallT+ bind_tvars_typ+ (make_ctx (Just ([],[])) free_tvars_typ [])+ (AppT (AppT ArrowT typ) typ)+ let typ' = AppT (AppT ArrowT typ) typ+ return typ'+#endif+--makeSeqinjType (Just n) tt@typ = do+-- error $ "makeSeqinjType: Just " ++ pprint n ++ " and typ not forall"++-------------------------------------------------------------------------------++ -- Humph, looks like I need SYB? I don't see utility functions+ -- for doing subsitutions inside general Type's.+ substTyVars :: ([Type],[Type]) -> Type -> Type+ substTyVars (orig,fresh) t = everywhere (mkT fg) t+ where+ fg :: Type -> Type+ fg (VarT n)+ | isNothing mfn = error "substTyVars: lookup failed!"+ | otherwise = VarT $ fromJust mfn+ where+ mfn = h n orig fresh+ h :: Name -> [Type] -> [Type] -> Maybe Name+ h n [] _ = Nothing+ h n ((VarT o):os) ((VarT f):fs)+-- XXX why am I never seeing this traceline?+ | n == o = trace (show o ++ " ----->> " ++ show f) $ Just f+ | otherwise = h n os fs+ fg x = {-trace (" %%% " ++ show x)-} x++-------------------------------------------------------------------------------++ make_ctx :: Maybe ([Type],[Type]) -> [Type] -> [Pred]-> [Pred]+ make_ctx mof free_tvars_typ ctx = ctx2+ where+ ctx2+ = ctx'+#if SEQABLE_ONLY+ ++ map (\ v -> ClassP name_SOP_Generic [v]) free_tvars_typ+#else+#if NFDATAN_ONLY+ ++ map (\ v -> ClassP name_NFDataN [v]) free_tvars_typ+#else+ ++ map (\ v -> ClassP name_Typeable [v]) free_tvars_typ+ ++ map (\ v -> ClassP name_NFDataN [v]) free_tvars_typ+ ++ map (\ v -> ClassP name_NFData [v]) free_tvars_typ+ ++ map (\ v -> ClassP name_NFDataP [v]) free_tvars_typ+#endif+#endif+#if SHOW_CONSTRAINT+ ++ map (\ v -> ClassP name_Show [v]) free_tvars_typ+#endif+ where+ -- This is to avoid duplication (perhaps ironically...):+ j p | ClassP n ts <- p = ClassP n $ map (substTyVars (orig,fresh)) ts+ | EqualP t1 t2 <- p = EqualP ((substTyVars (orig,fresh)) t1) ((substTyVars (orig,fresh)) t1)+-- | EqualP t1 t2 <- p = error "make_ctx: not ready for EqualP"+ ctx_ | isNothing mof = ctx+ | otherwise = map j ctx+ Just (orig,fresh) = mof -- antipattern...+ !_ = trace (show ctx_) $ ()+ ctx' = (+ id+#if SEQABLE_ONLY+ . filter (\ (ClassP name ts) -> show name /= "Generic")+ . filter (\ (ClassP name ts) -> show name /= "Generics.SOP.Universe.Generic")+#if SHOW_TYPE+ . filter (\ (ClassP name ts) -> show name /= "Typeable")+#endif+#else+#if NFDATAN_ONLY+ . filter (\ (ClassP name ts) -> show name /= "NFDataN")+ . filter (\ (ClassP name ts) -> show name /= "Control.DeepSeq.Bounded.NFDataN.NFDataN")+#if SHOW_TYPE+-- (recently added; and untested; but I think is supposed to be here?)+ . filter (\ (ClassP name ts) -> show name /= "Typeable")+#endif+#else+ . filter (\ (ClassP name ts) -> show name /= "Typeable")+ . filter (\ (ClassP name ts) -> show name /= "NFDataN")+ . filter (\ (ClassP name ts) -> show name /= "NFData")+ . filter (\ (ClassP name ts) -> show name /= "NFDataP")+ . filter (\ (ClassP name ts) -> show name /= "Data.Typeable.Internal.Typeable")+ . filter (\ (ClassP name ts) -> show name /= "Control.DeepSeq.Bounded.NFDataN.NFDataN")+ . filter (\ (ClassP name ts) -> show name /= "Control.DeepSeq.NFData")+ . filter (\ (ClassP name ts) -> show name /= "Control.DeepSeq.Bounded.NFDataP.NFDataP")+#endif+#endif+#if SHOW_CONSTRAINT+ . filter (\ (ClassP name ts) -> show name /= "Show")+ . filter (\ (ClassP name ts) -> show name /= "GHC.Show.Show")+#endif+ )+ ctx_+ name_NFDataP = mkName "NFDataP"+ name_NFDataN = mkName "NFDataN"+ name_NFData = mkName "NFData"+ name_Typeable = mkName "Typeable"+ name_Show = mkName "Show"+ name_SOP_Generic = mkName "Generics.SOP.Universe.Generic"++-------------------------------------------------------------------------------++ showNTs :: [(Name,Type)] -> String+ showNTs nts = ss'+ where+ ss = map (\ (n,t) -> pprint n ++ " :: " ++ pprint t) nts+ ss' = intercalate "\n" ss++-------------------------------------------------------------------------------++ followArrows :: Type -> Type+ followArrows (AppT (AppT ArrowT t1) t2) = followArrows t2+---followArrows (ArrowT t1 t2) = followArrows t2+ followArrows t = t++-------------------------------------------------------------------------------++#if INJECT_DUMMY_CLASS_AND_INSTANCE_TO_BLOCK_DEAD_CODE_ELIMINATION++-- We have already run "dss <- manifestSeqinjDecls nts" so we+-- can assume full benefit of that information here.+--+-- What we need to build:+--+-- - a single class declaration+-- - which contains one method signature declaration per seqinj_[0-9]*+-- signature that was prepared by manifestSeqinjDecls+--+-- class SeqinjDummyClass a where+-- seqinj_class_0 :: a -> Int -> Int+-- ...+--+-- - and a single instance declaration (instancing this class)+-- - which contains one method definition declaration to correspond+-- with each signature in the class declaration+--+-- instance SeqinjDummyClass () where+-- seqinj_class_0 _ x = seqinj_0 x+-- ...+--+-- > runQ [d| class Blah a where blah :: a -> Int -> Int |]+-- [ClassD [] Blah_0 [PlainTV a_2] [] [SigD blah_1 (AppT (AppT ArrowT (VarT a_2)) (AppT (AppT ArrowT (ConT GHC.Types.Int)) (ConT GHC.Types.Int)))]]+--+-- > runQ [d| instance Blah () where blah _ x = seqinj_0 x |]+-- [InstanceD [] (AppT (ConT Ghci1.Blah) (TupleT 0)) [FunD Ghci1.blah [Clause [WildP,VarP x_0] (NormalB (AppE (VarE seqinj_0_1627392795) (VarE x_0))) []]]]+--+-- Notes:+-- - I don't think we want to try to use the (Name,Type) pairs.+-- - rather, use the [[Dec]] -- not all Name's end up producing+-- Decl, remember, so these lists are not parallel! (We could+-- return an elided nts which IS parallel, upstream, but we didn't.)++-- XXX I think I need nested forall in a case like:+-- class SeqinjDummyClass a where+-- seqinj_meth_0 :: a -> Blob b -> Blob b+-- This will become more explicit in TH land; Blob b will actually be+-- (forall b. <ctx> => Blob b). And we do NOT want+-- seqinj_meth_0 :: a -> (forall b. <ctx> => Blob b) -> (forall b. <ctx> => Blob b)+-- we want+-- seqinj_meth_0 :: forall b. <ctx> => a -> Blob b -> Blob b+-- Note that the "a" variable takes its ctx from the class declaration,+-- and in fact it does not get a forall at all [?? right?]+-- So we DON'T need nested forall here (although we would if had+-- multiple variables with different contexts)...++-- XXX Also remember, we probably don't need the top-level seqinj_[0-9]*'s+-- at all now, with the class/instance -- but when build the Map in plugin,+-- will have to make a change to read the signatures in the class rather+-- than as now from the top-level seqinj_[0-9]*'s...+-- LATER: This turned out to be not the case: The top-level seqinj_[0-9]*'s+-- seem to need to be retained in the plugin output.++ manifestDummyClassAndInstance :: Type -> [[Dec]] -> Q [Dec]+ manifestDummyClassAndInstance sidtyp dss = do+--manifestDummyClassAndInstance :: [(Name,Type)] -> [[Dec]] -> Q [Dec]+--manifestDummyClassAndInstance (nt:nts) (ds:dss) = do+ modname <- fmap loc_module qLocation+ let modname' = map (\x -> if x == '.' then '_' else x) modname+ an <- newName "a"+ (sigs,defs) <- liftM fst $+ ( foldM+ ( \ y@((sigs_, defs_), i) dec ->+ do+ -- Prise apart the Dec, tagging values for later reference+ let [tdec, fdec] = dec+ let (SigD vp_s t_s) = tdec+ let (ValD (VarP vp_v) (NormalB ae_v) []) = fdec+ mn <- newName $ "seqinj_meth_" ++ show i+#if 1+#if 1+ t_s' <- makeSeqinjType (Just an) sidtyp t_s+#else+-- XXX no.+ let t_s'' = AppT (AppT ArrowT (VarT an)) t_s+ t_s' <- makeSeqinjType (Just an) t_s''+#endif+#else+ let t_s' = AppT (AppT ArrowT (VarT tv)) t_s+#endif+ let s = SigD mn t_s'+ vv <- newName "x" -- no matter if we [shadow/whatever]+ sid <- newName "sid" -- no matter if we [shadow/whatever]+ let d = FunD+ mn+ [ Clause+ [WildP, VarP sid, VarP vv]+ (NormalB+ (AppE+-- To really never even build them, there's some more changes+-- needed in this modules...+#if NO_TOP_LEVEL_SEQINJ_DUMMIES+ (AppE (VarE $ mkName "Seqaid.Runtime.seqaidDispatch") (VarE sid))+#else+ (AppE (VarE vp_v) (VarE sid))+#endif+ (VarE vv)+ )+ )+ []+ ]+--- sigs = [SigD mn typ]+--- typ = (AppT (AppT ArrowT (VarT tv)) (AppT (AppT ArrowT (ConT GHC.Types.Int)) (ConT GHC.Types.Int)))+-- defs = [FunD mn [Clause [WildP,VarP vv] (NormalB (AppE (VarE seqinj_0_1627392795) (VarE vv))) []]]+ return ((s:sigs_, d:defs_), -1+i)+ )+ (([],[]),-1+length dss)+ :: [[Dec]] -> Q (([Dec],[Dec]),Int) ) -- type up to here+ dss+ cn <- newName $ "SeqinjDummyClass_" ++ modname'+-- cn <- newName "SeqinjDummyClass"+ let cdec = ClassD [] cn [PlainTV an] [] sigs+ let idec = InstanceD [] (AppT (ConT cn) (TupleT 0)) defs+ return [cdec, idec]++#endif++-------------------------------------------------------------------------------++ -- These are only for cosmetic purposes in warning messages.++ -- Cloned from Core.hs.+ -- This will work fine on module names, but don't try to+ -- use it on (String-ified) types!... (See caveat in Core.hs.)+ -- XXX how about nameBase and nameModule? (Oh, but that's Name not String...)+ dropQuals :: String -> String+ dropQuals = reverse . takeWhile (/= '.') . reverse++ takeQuals :: String -> String+ takeQuals = reverse . drop 1 . dropWhile (/= '.') . reverse++ -- XXX VERY BAD INDEED!!!+ beautify :: String -> String+ beautify s = s_+ where+ marr1 = (s =~ "^forall ") :: MatchArray+ (a1,b1) = (marr1!0)+ marr2 = (s =~ "=> ") :: MatchArray+ (a2,b2) = (marr2!0)+ s_ | null $ indices marr1 = s+ | null $ indices marr2 = s+ | otherwise+ = dropWhile (\x -> x==' '||x=='\t'||x=='\n')+ $ drop (a2+b2) s++-------------------------------------------------------------------------------++#if TRY_INJECT_NOINLINE_ON_REQUESTED_BINDS+ noinlineTH :: [String] -> Q [Dec]+--noinlineTH :: [Name] -> Q [Dec]+ noinlineTH nms = do+ mapM+ (\x -> do Just nm <- lookupValueName x+ return $ PragmaD $ InlineP nm NoInline FunLike AllPhases)+ nms+-- mapM (\x -> do { (Just nm) <- lookupValueName x ; return $ PragmaD $ InlineP nm NoInline FunLike AllPhases }) nms+-- mapM (\x -> (liftM fromJust) lookupValueName x >>= \nm -> PragmaD $ InlineP nm NoInline FunLike AllPhases) nms -- oh whatever!!+-- return $ map (\x -> PragmaD $ InlineP x NoInline FunLike AllPhases) nms+#endif++-------------------------------------------------------------------------------+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ seqaid.cabal view
@@ -0,0 +1,300 @@++name: seqaid+version: 0.1.1+synopsis: Dynamic strictness control, including space leak repair+description: Seqaid is a GHC plugin for non-invasive auto-instrumentation of dynamic strictness (and parallelism) control, shortly to include optimisation for automated space leak relief using minimal strictification. [The optimiser is still in development however.]+ .+ Refer to the seqaid <http://www.fremissant.net/seqaid homepage> for more information.+homepage: http://www.fremissant.net/seqaid+license: BSD3+license-file: LICENSE+author: Andrew G. Seniuk+maintainer: Andrew Seniuk <rasfar@gmail.com>+category: Compiler Plugin+--bug-reports: +bug-reports: Andrew Seniuk <rasfar@gmail.com>+build-type: Simple+cabal-version: >= 1.10+tested-with: GHC==7.8.1, GHC==7.8.3+--tested-with: GHC==7.6.3, GHC==7.8.1, GHC==7.8.3++extra-source-files: HTML/*.html+ , HTML/*.css+ , README+-- , tests/*.hs+-- , tests/Makefile++-- source-repository head+-- type: git+-- location: ++-- XXX+-- A few of the latest flags are not used very consistently,+-- and there are probably bugs related:+-- ONLY_TOP_LEVEL_INJECTIONS+-- INFER_TOP_LEVEL_TYPES+-- SEQAIDPP_TYPES+-- (DEMO_MODE)+-- (... the rest, basically! ...)++-- There were about twice as many flags, so I've done what I can,+-- but not ready to throw away the alternative code branches+-- for the remaining yet. In a few minor version bumps, will+-- probably have done away with most of the rest.++Flag TRY_INJECT_NOINLINE_ON_REQUESTED_BINDS+ Description: If we can prevent inling of injected binds (without requiring user edits), that would probably be a good trade off in terms of lost optimiser oppportunities in exchange for assurance that the bind won't be inlined. This didn't work, and is a poor solution anyway.+--Default: True+ Default: False++Flag SEQABLE_ONLY+ Description: Like NFDATAN_ONLY, but for newer Seqable module.+--Default: True+ Default: False++Flag TH_TYPE_IN_TYPES_ANN+ Description: Actually this is just preparatory, haven't gone down this road far yet. (We would like a TH.Type to Type.Type conversion function in the GHC API. Then we'd just send the list of Type.Type for direct use by the Core-plugin downstream).+--Default: True+ Default: False++Flag SEQAIDPP_TYPES+ Description: Rather than choose types to seqinj for based on the types of the top-level binds, use seqaidpp to parse the types from seqaid.config. This stays on perpetually, finally, and could be removed soon.+ Default: True+--Default: False++-- Flag ONLY_TOP_LEVEL_INJECTIONS+-- Description: Like it says; as opposed to descending to (potentially) wrap subexpressions ... the latter which has just become possible due to seqaidpp.+-- --Default: True+-- Default: False++Flag INFER_TOP_LEVEL_TYPES+ Description: If True, then TH/modulespection will be used as it has been, to blanket-inject all top-level functions (at least, those not explicitly or implicitly excluded). Now, if False, only RHS's with result types in the "types" list for the module (in seqaid.config) will be wrapped (again, at least those not explicitly or implicitly excluded).+--Default: True+ Default: False++Flag DEMO_MODE+ Description: This is the only working mode in the first release. (And it only works when tested on the "leaky" package.) The switch exists to exclude hashable/hashtables deps (and subdeps) from the first release, while I can continue to work on this aspect in the development head.+ Default: True+--Default: False++Flag DBG_SEQAID+ Description: When set, every call to seqaidDispatch emits a line of info.+ Default: True+--Default: False++Flag NO_TOP_LEVEL_SEQINJ_DUMMIES+ Description: If have to inject a class and instance anyway to evade DCE, no need for the old top-level seqinj_ declarations (we hope...).+--Default: True+ Default: False++Flag NFDATAN_ONLY+ Description: To simplify debugging.+--Default: True+ Default: False++-- This only applies to NFDATAN_ONLY, since NFDataP has Typeable as+-- a superclass already. (The point is, you can set this False, and+-- get rid of as much class/instance cruft as possible in the Core,+-- for help debugging.)+Flag SHOW_TYPE+ Description: Include Typeable instance for (show . typeOf) in seqaidDispatch+ Default: True+--Default: False++library {++ exposed-modules:+ Seqaid.Plugin+ Seqaid.Config+ Seqaid.Ann+ Seqaid.TH+ Seqaid.Core+ Seqaid.Runtime+ Seqaid.Global+ Seqaid.Optim++--other-modules:++ build-depends:++ base < 5++ -- GHC plugin stuff:+ , ghc >= 7.4+ , syb++ -- Not used in Core.hs plugin part anymore; but there may+ -- be GHC API code coming in Seqaid.TH that uses GHC.Paths.+-- , ghc-paths++ -- used to try to bring types into scope that are needed+ -- for CoreM-level (Simplifier) injections; works except+ -- for polymorphic types such as [a]. Now looking to extend+ -- the TH code to USE the GHC API, which I didn't realise+ -- was possible but see modulespec package...+ , template-haskell+ , modulespection+ , th-expand-syns++ -- low-level forcing libraries+ , deepseq-bounded++ -- at least for IntMap+ , containers+ -- or would regex-posix be better?+ , regex-pcre+ -- to use regex API+ , array+ -- ended up wanting this for State, for a SYB everywhereM traversal+ , mtl++ -- In the end (although it's already a sub-dep), seqaid did end up+ -- depending directly on SOP, since now there's a splice in Seqaid.TH+ -- which calls a generics-sop TH splice itself.+ -- ... But that doesn't save us, because the "deriving instance"+ -- decls are put there by seqaidpp [indeed that was the whole reason+ -- I finally crumbed and reached for a preprocessor!] -- that's+ -- pre-TH, so pre our ability to know whether it's a synonym or not...+-- , generics-sop++ if flag(SEQABLE_ONLY)+ build-depends:+ generics-sop++ if ! flag(DEMO_MODE)+ build-depends:+ -- Unfortunately, hashtables brings in the majority of our deps!+ -- text : 43 modules (hashable and hashtables)+ -- hashable : 3 modules (hashable and hashtables)+ -- hashtables : 12 modules (hashables)+ -- primitive : 10 modules (hashables)+ -- vector : 19 modules (hashables)+ -- Ouch! (this only really matters for sandbox builds)+ hashtables+ -- Need to include this anyway, since this is where "hash" function+ -- comes from (and hashtables doesn't export it).+ -- For building IntMap or HashTable keys from unique strings.+ , hashable++ -- Useful in debugging...+-- , sai-shape-syb+ -- for debugging only (though deepseq-bounded re-exports these anyhow)+-- , deepseq-generics+-- , deepseq++ ghc-options: -optP-Wundef -fno-warn-overlapping-patterns+ ghc-options: -funbox-strict-fields -fwarn-tabs+--ghc-options: -Wall -O2 -funbox-strict-fields -fwarn-tabs++ -- The following extra options are to handle multiline String literals+ -- in the presence of CPP+ -- http://stackoverflow.com/questions/2549167/cpp-extension-and-multiline-literals-in-haskell+ -- I prefer string gaps to unlines [ l1, l2, ... ] b/c then lines+ -- can start at the left margin!+ ghc-options: -pgmP cpphs -optP --cpp+++ if flag(SEQABLE_ONLY)+ cpp-options: -DSEQABLE_ONLY=1+ else+ cpp-options: -DSEQABLE_ONLY=0++ if flag(TH_TYPE_IN_TYPES_ANN)+ cpp-options: -DTH_TYPE_IN_TYPES_ANN=1+ else+ cpp-options: -DTH_TYPE_IN_TYPES_ANN=0++ if flag(SEQAIDPP_TYPES)+ cpp-options: -DSEQAIDPP_TYPES=1+ else+ cpp-options: -DSEQAIDPP_TYPES=0++--if flag(ONLY_TOP_LEVEL_INJECTIONS)+-- cpp-options: -DONLY_TOP_LEVEL_INJECTIONS=1+--else+-- cpp-options: -DONLY_TOP_LEVEL_INJECTIONS=0++ if flag(INFER_TOP_LEVEL_TYPES)+ cpp-options: -DINFER_TOP_LEVEL_TYPES=1+ else+ cpp-options: -DINFER_TOP_LEVEL_TYPES=0++ if flag(DEMO_MODE)+ cpp-options: -DDEMO_MODE=1+ else+ cpp-options: -DDEMO_MODE=0++ if flag(DBG_SEQAID)+ cpp-options: -DDBG_SEQAID=1+ else+ cpp-options: -DDBG_SEQAID=0++ if flag(NO_TOP_LEVEL_SEQINJ_DUMMIES)+ cpp-options: -DNO_TOP_LEVEL_SEQINJ_DUMMIES=1+ else+ cpp-options: -DNO_TOP_LEVEL_SEQINJ_DUMMIES=0++ if flag(NFDATAN_ONLY)+ cpp-options: -DNFDATAN_ONLY=1+ else+ cpp-options: -DNFDATAN_ONLY=0++ if flag(SHOW_TYPE)+ cpp-options: -DSHOW_TYPE=1+ else+ cpp-options: -DSHOW_TYPE=0++ default-extensions: CPP+ default-language: Haskell2010+}++-- XXX Note that the flags in library section are NOT present here.+-- (Which is fine so long as the executable's code doesn't try to use them;+-- and will get a warning anyhow if it does.)+executable seqaid {+-- It seems you cannot put the seqaid Main module in Seqaid.Main namespace?+ hs-source-dirs: .+ main-is: Seqaid/Demo.hs+--other-modules:+--other-extensions:+ build-depends:+ base < 5+-- , seqaid+ , temporary+ , directory+ , process+ ghc-options: -funbox-strict-fields -fwarn-tabs -threaded+--ghc-options: -Wall -O2 -funbox-strict-fields -fwarn-tabs -threaded++ -- The following extra options are to handle multiline String literals+ -- in the presence of CPP+ -- http://stackoverflow.com/questions/2549167/cpp-extension-and-multiline-literals-in-haskell+ -- I prefer string gaps to unlines [ l1, l2, ... ] b/c then lines+ -- can start at the left margin!+ ghc-options: -pgmP cpphs -optP --cpp+ ghc-options: -optP-Wundef -fno-warn-overlapping-patterns++ default-extensions: CPP+ default-language: Haskell2010+}++-- XXX Note that the flags in library section are NOT present here.+-- (Which is fine so long as the executable's code doesn't try to use them;+-- and will get a warning anyhow if it does.)+executable seqaidpp {+ hs-source-dirs: .+ main-is: Seqaid/Prepro.hs+ build-depends:+ base < 5+ , regex-base+ , regex-pcre+-- (process may still be uncommented b/c using to debug...)+ , process+ , directory+ , Cabal+--ghc-options:+ default-language: Haskell2010+ ghc-options: -pgmP cpphs -optP --cpp+ ghc-options: -optP-Wundef -fno-warn-overlapping-patterns+}+