seqaid 0.1.7.0 → 0.2.0.0
raw patch · 26 files changed
+2979/−299 lines, 26 filesdep +cpphsdep +exceptionsdep +filepathdep −modulespectiondep −th-expand-synsdep ~Cabaldep ~arraydep ~deepseq-boundedPVP ok
version bump matches the API change (PVP)
Dependencies added: cpphs, exceptions, filepath, ghc-paths, transformers
Dependencies removed: modulespection, th-expand-syns
Dependency ranges changed: Cabal, array, deepseq-bounded, ghc, mtl, process, template-haskell
API changes (from Hackage documentation)
- Seqaid.Global: condenseEq :: Eq a => (a -> a) -> a -> [a]
- Seqaid.Global: snk_ioref :: IORef SeqNodeKind
+ Seqaid.Global: snk_ioref :: IORef SeqNode
- Seqaid.Optim: run_IO_SM :: (NFData a, NFDataN a, Typeable a, NFDataP a) => SiteID -> a -> IO (Int, Int, Pattern, SeqNodeKind, Int64, Int64, Int64, Int64, Int64)
+ Seqaid.Optim: run_IO_SM :: (NFData a, NFDataN a, Typeable a, NFDataP a) => SiteID -> a -> IO (Int, Int, Pattern, SeqNode, Int64, Int64, Int64, Int64, Int64)
- Seqaid.Runtime: seqaidDispatchDyn :: NFDataP a => a -> a
+ Seqaid.Runtime: seqaidDispatchDyn :: (NFData a, NFDataN a, Typeable a, NFDataP a) => SiteID -> a -> a
Files
- HTML/combout.html +1/−1
- HTML/extra.html +35/−29
- HTML/extra2.html +169/−0
- HTML/index.html +1/−1
- HTML/seqaid.html +26/−24
- HTML/style.css +42/−1
- HTML/style2.css +0/−29
- LICENSE +2/−2
- Seqaid/Ann.hs +1/−1
- Seqaid/Config.hs +1/−1
- Seqaid/Core.hs +1/−1
- Seqaid/Demo.hs +37/−24
- Seqaid/Global.hs +154/−19
- Seqaid/Optim.hs +14/−8
- Seqaid/Plugin.hs +1/−1
- Seqaid/Prepro.hs +96/−72
- Seqaid/Runtime.hs +114/−30
- Seqaid/TH.hs +20/−4
- Seqaid/TH_710.hs +1277/−0
- Seqaid/TH_extra.hs +324/−0
- Seqaid/TH_extra_710.hs +312/−0
- changelog.txt +6/−0
- deepseq-bounded-seqaid-leaky.css +34/−0
- deepseq-bounded-seqaid-leaky.html +89/−0
- release-announcement.txt +50/−0
- seqaid.cabal +172/−51
HTML/combout.html view
@@ -1,4 +1,4 @@-<!DOCTYPE html>+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN" "http://www.w3.org/TR/html4/strict.dtd"> <html> <head> <title>Seqaid : Haskell Leak Eradicator</title>
HTML/extra.html view
@@ -1,4 +1,4 @@-<!DOCTYPE html>+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN" "http://www.w3.org/TR/html4/strict.dtd"> <html> <head> <title>Seqaid : Space leak diagnostic and remedial tool - Contrived?</title>@@ -23,7 +23,7 @@ August I was on hiatus, then finished <tt><span class="nowrap">deepseq-bounded</span></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).+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 earlier). <!-- 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!)@@ -53,7 +53,7 @@ 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.)+(It still leaks in 7.8.4 and <a href="https://downloads.haskell.org/~ghc/7.10.1-rc1/">7.10.1-rc1</a>.) <p> During that battle of wits with the compiler, I wasn't really thinking about <tt><span class="nowrap">deepseq-bounded</span></tt> or <tt>seqaid</tt>, so the leak example was not contrived with these tools in mind (although they already existed, particularly <tt><span class="nowrap">deepseq-bounded</span></tt> which was finished).@@ -76,40 +76,44 @@ <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><em>N</em></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.+But it does illustrate the sorts of effects possible, once <tt>seqaid</tt> has an optimiser. <p> Using <tt>NFDataN.forcen <em>N</em></tt>: <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+ 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 <em>P</em></tt>:-<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 style="margin-bottom: 0px;">+ live alloc type+ P . 227756 1769792 TA+ P <span style="color: #BBB;">(</span>. .. <span style="color: #BBB;">)</span> 296620 3060904 TA+ P <span style="color: #BBB;">(</span>(.. . ).. <span style="color: #BBB;">)</span> 360508 4908612 TA+ P <span style="color: #BBB;">(</span>(.. (. )).. <span style="color: #BBB;">)</span> 421472 5852124 TA+ P <span style="color: #BBB;">(</span>(.. ((. ... ))).(.. )<span style="color: #BBB;">)</span> 521860 9556760 TA+ P <span style="color: #BBB;">(</span>(.(.)(((.)..(.)))).(.(.))<span style="color: #BBB;">)</span> 607100 11270660 TA+ P <span style="color: #BBB;">(</span>(!(!)(((!).!(!))))!(!(!))<span style="color: #BBB;">)</span> 1925776 2392040 TA+ P <span style="color: #BBB;">(</span>(!(!)(((!).!(!))))!(!(!))<span style="color: #BBB;">)</span> 1529652 10297768 TA+ P <span style="color: #BBB;">(</span>(!(!)(((!).!(!))))!(!(!))<span style="color: #BBB;">)</span> 1249900 2393836 TA+ P <span style="color: #BBB;">(</span>(!(!)(((!).!(!))))!(!(!))<span style="color: #BBB;">)</span> 690336 13244056 TA+ P <span style="color: #BBB;">(</span>(!(!)(((!).!(!))))!(!(!))<span style="color: #BBB;">)</span> 212580 13974556 TA+ P <span style="color: #BBB;">(</span>(!(!)(((!).!(!))))!(!(!))<span style="color: #BBB;">)</span> 216936 11284560 TA </pre> <p>-A few remarks:+A sort of <a href="extra2.html">commentary</a> on the change history is on a separate page.++<h3 style="margin-top: 40px;">Remarks</h3> <ul> <li>You can see the space leak as a steady, substantial growth in the heap size, from <tt><em>N</em></tt> equal 0 through 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>).@@ -122,9 +126,11 @@ </ul> <div class="footer">-Andrew Seniuk 2014+Andrew Seniuk <br>-<tt>rasfar@gmail.com</tt>+<span style="margin-left: 4px; font-size: 90%;">Dec. 2014</span>+<br>+<tt style="font-size: 85%;">rasfar@gmail.com</tt> </div> </div>
+ HTML/extra2.html view
@@ -0,0 +1,169 @@+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN" "http://www.w3.org/TR/html4/strict.dtd">+<html>+<head>+<title>Seqaid : Space leak diagnostic and remedial tool - Contrived?</title>+<meta http-equiv="Cache-Control" content="no-cache, no-store, must-revalidate" />+<meta http-equiv="Pragma" content="no-cache" />+<meta http-equiv="Expires" content="0" />+<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;">+Comparison with prior version+</h3>++<p style="margin-top: 16px;">+Previously, using an older version of shrinkPat, it worked out more smoothly, as shown below; so the listing <span class="strikeout">above</span> [at <a href="extra.html">this</a> page] is rather longer [not anymore] and raises some questions I don't yet have answers for, but the net result is the same, and the comments <span class="strikeout">following</span> [at that link] are all still valid.++<p>+(Actually, the numbers have not worked out quite this way for a long time anyway; this portays results from pre-published versions...).++<p>+Seeing these side-by-side (as it were...) is giving me a whistful feeling about the old pattern syntax. Fortunately, whether to use braces or parens, and whether to use !/. or ./#, are still options available through the deepseq-bounded package flags.++<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>+And with the new concrete syntax, but same old shrinkPat used:+<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>+This seems like a usability regression, but the truth is, this is an extreme case, and normally '!' characters will be infrequent, and '.' characters (which do no forcing) will typically predominate amongst leaves of a pattern. Still, if going to prefer parens to braces, might like to reconsider '!' as it is visually too similar to a parenthesis. Some of these issues can be resolved by adding whitespace within the pattern strings (which is permitted). Also, much depends on fonts, and if colour of even greyscale is available this may be a non-issue.+<p>+In fact, to show how beneficial vertical alignment is to the human perception, let's see the new output (more interesting initial sequence) with padding added by hand:+<pre>+ P . 232448 1776868 TA+ P ( ) 302720 1719280 TA+ P (. .. ) 372968 3057960 TA+ P (( ).. ) 442528 3579160 TA+ P ((.. . ).. ) 507104 4907900 TA+ P ((.. () ).. ) 579448 5364696 TA+ P ((.. (.) ).. ) 640096 5853972 TA+ P ((.. (() )).( )) 739964 6867304 TA+ P ((.. ((. ... ))).(.. )) 833820 9551912 TA+ P ((.() ((() ..() ))).(.() )) 918912 9564540 TA+ P ((.(.)(((.)..(.)))).(.(.))) 1006188 11230432 TA+ P ((!(!)(((!).!(!))))!(!(!))) 204624 14250596 TA+</pre>+At which point I notice that shrinkPat is wrong...+Anyway, does that even help much? It seems like a person wants more+than ASCII graphics to cope with this...+<p>+Correct sequence for shrinkPat should be like (for example):+<pre>+ (.(!)) (!(!)) (!(.!))+ (.(.)) (.(.)) (.(..))+ (.!) or (.!) or (.!)+ (..) (..) (..)+ ! ! !+ . . .+</pre>+And certainly, you don't produce ()'s!+<p>+After fixing that:+<pre>+ P . 227756 1769792 TA+ P <span style="color: #BBB;">(</span>. .. <span style="color: #BBB;">)</span> 296620 3060904 TA+ P <span style="color: #BBB;">(</span>(.. . ).. <span style="color: #BBB;">)</span> 360508 4908612 TA+ P <span style="color: #BBB;">(</span>(.. (. )).. <span style="color: #BBB;">)</span> 421472 5852124 TA+ P <span style="color: #BBB;">(</span>(.. ((. ... ))).(.. )<span style="color: #BBB;">)</span> 521860 9556760 TA+ P <span style="color: #BBB;">(</span>(.(.)(((.)..(.)))).(.(.))<span style="color: #BBB;">)</span> 607100 11270660 TA+ P <span style="color: #BBB;">(</span>(!(!)(((!).!(!))))!(!(!))<span style="color: #BBB;">)</span> 1925776 2392040 TA+</pre>+<p>+What the heck, I'll paste that <span class="strikeout">above</span>, although it is hand-padded...+<p>+And here's what had in main document before the shrinkPat fix, as I don't have the heart to delete it yet. :)+<pre style="margin-bottom: 0px;">+ live alloc type+ P . 232448 1776868 TA+ P () 302720 1719280 TA+ P (...) 372968 3057960 TA+ P (()..) 442528 3579160 TA+ P ((...)..) 507104 4907900 TA+ P ((..())..) 579448 5364696 TA+ P ((..(.))..) 640096 5853972 TA+ P ((..(())).()) 739964 6867304 TA+ P ((..((....))).(..)) 833820 9551912 TA+ P ((.()((()..()))).(.())) 918912 9564540 TA<!-- 8 lines cut; exact output depends on seed chosen etc. -->+<span style="color: #F00; font-size: 80%;">*</span>+ P ((.(.)(((.)..(.)))).(.(.))) 1006188 11230432 TA+ P ((!(!)(((!).!(!))))!(!(!))) 204624 14250596 TA+ P ((!(!)(((!).!(!))))!(!(!))) 208800 11236580 TA+ P ((!(!)(((!).!(!))))!(!(!))) 213112 11242000 TA+ P ((!(!)(((!).!(!))))!(!(!))) 217436 11353868 TA+ P ((!(!)(((!).!(!))))!(!(!))) 221852 11250772 TA+ P ((!(!)(((!).!(!))))!(!(!))) 126192 11275044 TA+ P ((!(!)(((!).!(!))))!(!(!))) 130876 11131820 TA+</pre>+<!--+ P ((!(!)(((!).!(!))))!(!(!))) 1649020 2357840 TA+ P ((!(!)(((!).!(!))))!(!(!))) 2326012 2416660 TA+ P ((!(!)(((!).!(!))))!(!(!))) 3003004 2412660 TA+ P ((!(!)(((!).!(!))))!(!(!))) 3647228 2379892 TA+ P ((!(!)(((!).!(!))))!(!(!))) 3207456 10209292 TA+ P ((!(!)(((!).!(!))))!(!(!))) 2382464 13247360 TA+ P ((!(!)(((!).!(!))))!(!(!))) 1590240 13251400 TA+ P ((!(!)(((!).!(!))))!(!(!))) 594664 14446332 TA+-->+<span style="margin-left: 32px; margin-top: 0px; font-size: 70%;">+<span style="color: #F41;">*</span>+<span style="color: black; font-size: 80%;">+8 lines cut; exact output depends on seed chosen etc.+</span>+</span>++<div class="footer">+Andrew Seniuk+<br>+<span style="margin-left: 4px; font-size: 90%;">January 2015</span>+<br>+<tt style="font-size: 85%;">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
@@ -1,4 +1,4 @@-<!DOCTYPE html>+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN" "http://www.w3.org/TR/html4/strict.dtd"> <html> <head> <title>Seqaid : Haskell Leak Eradicator</title>
HTML/seqaid.html view
@@ -1,4 +1,4 @@-<!DOCTYPE html>+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN" "http://www.w3.org/TR/html4/strict.dtd"> <html> <head> <title>Seqaid : Space leak diagnostic and remedial tool</title>@@ -15,24 +15,24 @@ <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.+If you're reading this, you probably don't need to be told that <span class="nowrap">space leak is</span> 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>:+Quoting <span class="nowrap">briefly from</span> <span class="nowrap">Neil Mitchell's 2013</span> <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.+“[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."+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."+“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.+Seqaid (package <a href="http://hackage.haskell.org/package/seqaid">seqaid</a> on hackage) is a tool to help debug <span class="nowrap">space leak</span> <span class="nowrap">in Haskell</span> projects. <p> @@ -44,7 +44,7 @@ <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)+<li>a small library (used by the plugin; or for manual instrumentation) </ul> <p>@@ -52,7 +52,7 @@ 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.+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>@@ -77,7 +77,7 @@ 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>+Happily, 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.--> @@ -146,7 +146,7 @@ <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.+Besides the <tt>seqaid.config</tt> file, all that is needed to use seqaid on your own project are 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>@@ -159,7 +159,7 @@ <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.+Although <tt>seqaid</tt> is not an actual function, from the user's perspective it must be treated as if it was, in the fixity/associativity context of each call site. 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#t: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--> @@ -171,7 +171,7 @@ <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>+<a id="dig01h" style="margin-bottom: -15px;" class="dig-toggle-hide" href='javascript:toggle("dig01");'>Hide</a><p style="margin-bottom: 0px;"> 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...@@ -181,8 +181,6 @@ </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"><span class="nowrap">deepseq-bounded</span></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... @@ -195,7 +193,7 @@ <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>+<a style="display: block; margin-bottom: -15px;" id="dig02h" class="dig-toggle-hide" href='javascript:toggle("dig02");'>Hide</a><p style="margin-bottom: 0px;"> 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>@@ -240,14 +238,14 @@ <!--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>+<a id="dig03h" style="margin-bottom: -15px;" class="dig-toggle-hide" href='javascript:toggle("dig03");'>Hide</a><p style="margin-bottom: 0px;"> There is nothing intrinsically non-H98 about <tt><span class="nowrap">deepseq-bounded</span></tt>, but for generic deriving support GHC is needed.-You could write your own NFDataP and superclass instances, and be H98 all the way.-<tt><span class="nowrap">deepseq-bounded</span></tt> can be built in H98 mode with the flag HASKELL98_FRAGMENT...+You could write your own <tt>NFDataP</tt> and superclass instances, and be H98 all the way.+<tt><span class="nowrap">deepseq-bounded</span></tt> can be built in H98 mode with the flag <tt>HASKELL98_FRAGMENT</tt>... </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><span class="nowrap">deepseq-bounded</span></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...).+There is rich mathemetical structure underlying strictness manipulation (see for instance+<a href="http://www.fremissant.net/deepseq-bounded/deepseq-bounded.html#fusion">fusion rules</a> in <tt><span class="nowrap">deepseq-bounded</span></tt>, and the <a href="http://hackage.haskell.org/package/deepseq-bounded/docs/Control-DeepSeq-Bounded-PatUtil.html">PatUtil</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> @@ -265,7 +263,7 @@ The new <tt>Seqable</tt> module of <tt><span class="nowrap">deepseq-bounded</span></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.+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> antics, and not even function applications. <h3 style="margin-top: 50px; margin-bottom: 8px;">Notes</h3> @@ -294,7 +292,7 @@ <!-- <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>+<a id="dig05h" style="margin-bottom: -15px;" class="dig-toggle-hide" href='javascript:toggle("dig05");' style="margin-bottom: 6px;">Hide</a><p style="margin-bottom: 0px;"> 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.@@ -367,7 +365,11 @@ </table> -<div class="footer" style="margin-top: 20px;">+<div class="comments" style="margin-top: 30px; margin-left: 20px;" onclick="javascript:document.location.href = 'http://www.reddit.com/r/haskell/comments/2pscxh/ann_deepseqbounded_seqaid_leaky/';">+<a href="http://www.reddit.com/r/haskell/comments/2pscxh/ann_deepseqbounded_seqaid_leaky/"><b>Discussion</b></a><br /><span style="font-size: 60%;"><a style="display: inline-block; color: black; position: relative; top: -8px; href="http://www.reddit.com/r/haskell/comments/2pscxh/ann_deepseqbounded_seqaid_leaky/">(reddit) </a></span>+</div>++<div class="footer" style="margin-top: 40px;"> Andrew Seniuk 2014 <br> <tt>rasfar@gmail.com</tt>
HTML/style.css view
@@ -1,6 +1,10 @@-pre { font-size: 12pt; margin-left: 20px; padding-left: 10px; padding-right: 10px; padding-top: 10px; padding-bottom: 10px; background-color: #DDD; }++pre { font-size: 12pt; margin-left: 20px; padding-left: 10px; padding-right: 10px; padding-top: 10px; padding-bottom: 10px; background-color: rgba(230,230,230,1.0); }+pre.virgin { padding-left: 0px; padding-right: 0px; font-size: 85%; background-color: transparent; margin-top: 0px; margin-bottom: 0px; } 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; }+div.digression > tt { padding-left: 0px; padding-right: 0px; font-size: 85%; background-color: transparent; }+div.digression > p > tt { padding-left: 0px; padding-right: 0px; font-size: 85%; background-color: transparent; } /* Works, but not nicely: red { color: #f00; } */@@ -15,6 +19,11 @@ h2 { margin-top: 30px; color: #777; } h3 { margin-top: 30px; color: #444; } h4 { margin-top: 40px; color: #222; }+a:visited { color: #7700BB; } /* visited link */+a:hover { color: #BB00BB; } /* mouse over link */+a:active { color: #7700BB; } /* selected link */+a.comments:link { color: #0000BB; } /* unvisited link */+div.comments { cursor: hand; text-align: center; display: inline-block; padding-left: 12px; padding-right: 12px; padding-top: 8px; padding-bottom: 0px; background-color: #CDE; cursor: pointer; font-family: sans; font-size: 90%; margin-top: 30px; margin-left: 10px; } div.footer { font-family: sans; font-size: 70%; margin-top: 40px; } div.footer > tt { font-size: 90%; } /*@@ -27,3 +36,35 @@ td { text-align: top; vertical-align: top; padding-left: 8px; padding-top: 16px; } li { margin-top: 4px; } .nowrap { white-space: nowrap; }+.cmnt { color: #888; }+.dcmnt { color: #555; }+hr.hrule {+/* Thanks to http://css-tricks.com/examples/hrs/ */+ border: 0;+ height: 1px;+ background: #333;+ background-image: -webkit-linear-gradient(left, #ccc, #333, #ccc); + background-image: -moz-linear-gradient(left, #ccc, #333, #ccc); + background-image: -ms-linear-gradient(left, #ccc, #333, #ccc); + background-image: -o-linear-gradient(left, #ccc, #333, #ccc); + margin: 50px 0 5px 0;+}+/* Thanks to SO answer of daGUY in http://stackoverflow.com/questions/2539207/ho+w-to-change-the-strike-out-line-through-thickness-in-css */+.strikeout {+ position: relative;+ padding-left: 3pt;+ padding-right: 3pt;+}+.strikeout::after {+ border-bottom: 2px solid #C33;+ content: "";+ left: 0;+ position: absolute;+ right: 0;+ top: 50%;+}+.grey { color: #BBB; letter-spacing: -4px; }++tt { background: transparent; }+
− HTML/style2.css
@@ -1,29 +0,0 @@-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-family: sans; font-size: 80%; margin-top: 40px; }-div.footer > tt { font-size: 90%; }-/*-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; }-.nowrap { white-space: nowrap; }
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2014, Andrew Seniuk+Copyright (c) 2014-2015, Andrew G. Seniuk All rights reserved. @@ -13,7 +13,7 @@ disclaimer in the documentation and/or other materials provided with the distribution. - * Neither the name of Andrew Seniuk nor the names of other+ * Neither the name of Andrew G. Seniuk nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission.
Seqaid/Ann.hs view
@@ -8,7 +8,7 @@ -- | -- Module : Seqaid.Ann--- Copyright : (c) 2014, Andrew G. Seniuk+-- Copyright : Andrew G. Seniuk 2014-2015 -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Andrew Seniuk <rasfar@gmail.com>
Seqaid/Config.hs view
@@ -5,7 +5,7 @@ -- | -- Module : Seqaid.Config--- Copyright : (c) 2014, Andrew G. Seniuk+-- Copyright : Andrew G. Seniuk 2014-2015 -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Andrew Seniuk <rasfar@gmail.com>
Seqaid/Core.hs view
@@ -126,7 +126,7 @@ -- | -- Module : Seqaid.Core--- Copyright : (c) 2014, Andrew G. Seniuk+-- Copyright : Andrew G. Seniuk 2014-2015 -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Andrew Seniuk <rasfar@gmail.com>
Seqaid/Demo.hs view
@@ -3,7 +3,7 @@ -- | -- Module : Seqaid.Demo--- Copyright : (c) 2014, Andrew G. Seniuk+-- Copyright : Andrew G. Seniuk 2014-2015 -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Andrew Seniuk <rasfar@gmail.com>@@ -20,8 +20,8 @@ --module Seqaid.Demo ( main ) where import System.Environment ( getArgs )- import System.IO.Temp- import System.Directory+ import qualified System.IO.Temp as T+ import qualified System.Directory as D import System.Process import System.Exit @@ -42,34 +42,47 @@ putStrLn "seqaid: \"seqaid demo\" is the only supported invocation at this time." return $ ExitFailure 1 else do- tdir <- createTempDirectory "." "leaky_"+ tdir <- T.createTempDirectory "." "leaky_" -- XXX Note that "cabal get" already extracts the tarball for you.-#if IS_WINDOWS- let shebang_line = "@echo off\n"+-- XXX Note mingw32 still uses bash.+ let dos_str = concat+ [ "@echo off\n"+ , "cabal get leaky-" ++ leaky_version ++ "\n"+ , "cd leaky-" ++ leaky_version ++ "\n"+ , "cabal configure\n"+ , "cabal build\n"+ , "cabal run 234\n"+ , "echo.\n"+ , "echo \"(Please see " ++ tdir ++ "/leaky-" ++ leaky_version ++ "/README for the interpretation.)\"\n"+ , "echo.\n"+ ]++ let nix_str = concat+ [ "#!/bin/bash\nset -e\n" ++ ""+ , "cabal get leaky-" ++ leaky_version ++ "\n"+ , "cd leaky-" ++ leaky_version ++ "\n"+ , "cabal configure\n"+ , "cabal build\n"+ , "cabal run 234\n"+ , "echo\n"+ , "echo \"(Please see " ++ tdir ++ "/leaky-" ++ leaky_version ++ "/README for the interpretation.)\"\n"+ , "echo\n"+ ]++#ifdef mingw32_HOST_OS+ let seqaid_init_bash = nix_str #else- let shebang_line = "#!/bin/bash\nset -e\n"-#endif- let seqaid_init_bash = shebang_line ++ "\-\cabal get leaky-" ++ leaky_version ++ "\n\-\cd leaky-" ++ leaky_version ++ "\n\-\cabal configure\n\-\cabal build\n\-\cabal run 123\n\ #if IS_WINDOWS-\echo.\n\+ let seqaid_init_bash = dos_str #else-\echo\n\+ let seqaid_init_bash = nix_str #endif-\echo \"(Please see " ++ tdir ++ "/leaky-" ++ leaky_version ++ "/README for the interpretation.)\"\n\-#if IS_WINDOWS-\echo.\n"-#else-\echo\n" #endif- setCurrentDirectory tdir++ D.setCurrentDirectory tdir writeFile "seqaidinit.sh" seqaid_init_bash- p <- getPermissions "seqaidinit.sh"- setPermissions "seqaidinit.sh" (p { executable = True })+ p <- D.getPermissions "seqaidinit.sh"+ D.setPermissions "seqaidinit.sh" (p { D.executable = True }) st <- system "./seqaidinit.sh" case st of ExitSuccess -> return ExitSuccess
Seqaid/Global.hs view
@@ -8,9 +8,20 @@ {-# LANGUAGE CPP #-} +-- Later: This (now) has no effect when new grammar is in effect. -- This is temporary, so seqaid demo output remains compatible--- with the documentation already written around it.-#define USE_OLD_SHRINK_PAT 1+-- with the documentation already written around it. (The new+-- shrinkPat has more finesse, but you have to run the demo+-- longer to see the heap stabilise -- the demonstration is+-- not nearly as effective. Also, the patterns have a lot+-- of #'s in them which looks noisy and confusing, although+-- it's natural enough.) We could attempt vertical alignment+-- since flanking whitespace is now supported, and that would+-- do more than anything to improve the presentation...+-- However, with DEMO_MODE off, one would definitely prefer+-- the new shrinkPat. This comment will probably be+-- as writ on water...+#define USE_OLD_SHRINK_PAT 0 -- XXX Should scour the code for "max_depth" etc. -- all those -- names which are specific to this DEMO_MODE hack!... And get@@ -25,7 +36,7 @@ -- | -- Module : Seqaid.Global--- Copyright : (c) 2014, Andrew G. Seniuk+-- Copyright : Andrew G. Seniuk 2014-2015 -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Andrew Seniuk <rasfar@gmail.com>@@ -34,11 +45,37 @@ -- -- Collects 'IORef's used by the seqaid runtime. ----- This will be substantially reorganised and clarified--- by the next minor version bump (>=0.1.1).+-- This will be substantially reorganised and clarified soon. - module Seqaid.Global where+ module Seqaid.Global ( +#if DEMO_MODE+ depth_ioref ,+ pattern_ioref ,+ snk_ioref ,+#endif++#if ! DEMO_MODE+ patterns_ioref ,+#endif++ stats_query_idx_ioref ,+ counter_ioref ,+ next_sample_at_ioref ,+ bytes_allocated_ioref ,+ bytes_allocated_prev_ioref ,+ current_bytes_used_ioref ,+ update_bytes_allocated_ioref ,+ update_current_bytes_used_ioref ,++ SiteID ,+ sample_period ,+ max_depth ,+ fixed_pat ,+ fixed_pat_sequence ,++ ) where+ ------------------------------------------------------------------------------- import Control.DeepSeq.Bounded@@ -62,11 +99,6 @@ ------------------------------------------------------------------------------- - -- 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 @@ -76,17 +108,29 @@ ht <- H.new ioref <- newIORef ht return ioref-#else+#endif++-------------------------------------------------------------------------------++ -- This group is very temporary!)++ -- definitely temporary hack (uniform forcing depth regardless of SiteID)+ {-# NOINLINE depth_ioref #-}+ depth_ioref :: IORef Int+ depth_ioref = unsafePerformIO $ newIORef 0++ -- definitely temporary hack (uniform Pattern regardless of SiteID) {-# NOINLINE pattern_ioref #-} pattern_ioref :: IORef Pattern- pattern_ioref = unsafePerformIO $ newIORef $ compilePat "#"-#endif+ pattern_ioref = unsafePerformIO $ newIORef $ emptyPat - -- This one's global. (All this stuff is just QUACK stuff...).+ -- definitely temporary hack (uniform SeqNode regardless of SiteID) {-# NOINLINE snk_ioref #-}- snk_ioref :: IORef SeqNodeKind+ snk_ioref :: IORef SeqNode snk_ioref = unsafePerformIO $ newIORef Insulate +-------------------------------------------------------------------------------+ {-# NOINLINE stats_query_idx_ioref #-} stats_query_idx_ioref :: IORef Int --stats_query_idx_ioref :: IORef Int64@@ -160,14 +204,104 @@ max_depth = 7 :: Int fixed_pat_sequence- = ( map (\i -> compilePat ('*':show i)) [0,1..8] )+ = let shrink_pat+ | deepseq_bounded_flag__new_improved_pattern_grammar = shrinkPat #if USE_OLD_SHRINK_PAT- ++ ( reverse $ condenseEq shrinkPat_old fixed_pat )+ | otherwise = shrinkPat_old #else- ++ ( reverse $ condenseEq shrinkPat fixed_pat )+ | otherwise = shrinkPat #endif+ in ( map (\i -> compilePat ('*':show i)) [0,1..8] )+ ++ ( reverse $ condenseEq shrink_pat fixed_pat ) +-- [Debugging notes for recent changes to deepseq-bounded.]+-- leaky: DeepSeqBounded_PingException "NFDataP: PING: 0 Int\n()\n"+-- leaky: DeepSeqBounded_PingException "NFDataP: PING: 1 Int\n()\n"+-- leaky: DeepSeqBounded_PingException "NFDataP: PING: 3 Int\n()\n"+-- leaky: DeepSeqBounded_PingException "NFDataP: PING: 7 Int\n()\n"+-- leaky: DeepSeqBounded_PingException "NFDataP: PING: 12 Int\n()\n"+-- leaky: DeepSeqBounded_PingException "NFDataP: PING: 13 Int\n()\n"+-- leaky: DeepSeqBounded_PingException "NFDataP: PING: 14 Int\n()\n"+-- This is what we see. If wait (only see 0 repeating for a while).+-- (And the system grinds to a crawl, although it appears to be+-- a stable crawl.)+-----+-- See cotemp (20150111130916) 000-readme for the labelling of the tree...+-- This mystery is largely solved. As for "slowdown" well, it's no+-- wonder if we're trying to print something for every one of the+-- gizillion exceptions, but if it was a quick stats update or something,+-- might actually be fine at full speed...+-- Speaking of "speed", a threadDelay-type attribute would be useful...+-- Too useful not to do it! (Except that threadDelay is known to be+-- a bit flakey...). (But you gotta try...)+#if 1+ fixed_pat+ | deepseq_bounded_flag__new_improved_pattern_grammar+ = setPatternPatNodeUniqueIDs 0 $+-- compilePat "=>cab((!(!)(((^!).!(!))))!(^!(!)))"+-- compilePat "=>cab((!(!)(((+!).!(!))))!(+!(!)))"+-- compilePat "((!(!)(((+^/!).!(!))))!(!(!)))"+-- compilePat "((!(!)(((+^!).!(!))))!(!(!)))"+-- compilePat "+^(+^(+^!+^(+^/!)+^/(+^/(+^/(+^/!)+^/.+^/!+^/(+^/!))))+^/!+^/(+^/!+^/(+^/!)))"+-- compilePat "+^/(+^/(+^/!+^/(+^/!)+^/(+^/(+^/(+^/!)+^/.+^/!+^/(+^/!))))+^/!+^/(+^/!+^/(+^/!)))"+-- compilePat "+^(+^(+^!+^(+^!)+^(+^(+^(+^!)+^.+^!+^(+^!))))+^!+^(+^!+^(+^!)))"+-- compilePat "((!(!)+(+(+(+!).!(!))))!(!(!)))" -- yes, it works (if you wait a wee bit) -- trying the full-blanket-+'d one again!!!+-- compilePat "((!(!)(((+!).!(!))))!+(!(!)))" -- +-- compilePat "((!(!)((+(+!).!(!))))!(!(!)))" -- ACTUALLY WORKS -- at FIRST you see only TC, then after the next stats line you see "4 TC / 3 Int" (or maybe the other way around, but I think this is the order...)+-- compilePat "((!(!)(((+!).!(!))))!(!(!)))" -- still works+-- XXX Oh, I see what happened: I made !(!) -> . at some point,+-- as part of testing, and this got propagated and forgotten,+-- and changed back . -> ! (instead of !(!)) -- but this is+-- harmless actually?!!!+-- compilePat "((!(!)(((+^!)+^/.!(!))))!(!(!)))"+-- compilePat "((!+^/.(((!)+^/.!(!))))!(!(!)))" -- nothing.+-- compilePat "+(+(+!+(+!)+(+(+(+!).!(!))))!(!(!)))" -- XXX XXX+-- compilePat "(+(!+.(+((!)+.!(!))))!(!(!)))"+---- compilePat "((!(!)((+.(!)+.+!(!))))!(!(!)))"+----- compilePat "+(+(+!+!+(+(+(+!).!(!))))!(!(!)))" -- XXX XXX+-- compilePat "+(+(+!+(+!)+(+(+(+!).!(!))))!(!(!)))" -- XXX XXX+-- compilePat "((+!^(!)(+((!).+^!/^(+^!))))!(!(!)))" -- yep+-- compilePat "((+!^(!)(+((!).+^!^(+^!))))!(!(!)))" -- all working+ -- compilePat "((!(+^/.)(((!)+^/.!+^/.)))!(!(!)))" -- nothing+-- compilePat "((!(/.)(((!)/.!/.)))!(!(!)))" -- nothing+--- compilePat "((!/.(((!)/.!(!))))!(!(!)))" -- nope, neither calls handleAttrs (incididentally, this leaks noticeably and monotonically, while the one with just . on the Blob, if not technically leak-free [? it seems to accumulate heap and then periodically discharge it, notwithstanding our frequent performGC calls...], at least not exhibiting net growth over longrunning...) This is a better test at the moment as the first . is of simple base nullary type Int.+-- compilePat "((!(!)(((!)/.!(!))))!(!(!)))" -- the problem with this test is that the .'d node is of unusual type Blob, which has hack NFData instances etc...+--- compilePat "((!+.(((!)+.+!(!))))+!(!(+!)))"+--- compilePat "((+!+.((+(+!)+.!(!))))+!(!(+!)))"+--- compilePat "((!+.(((!)+.!(!))))!(!(!)))"+--- compilePat "((!.(((!)+.!(!))))!(!(!)))"+--- compilePat "((!.(((!)+.!(!))))!(!(!)))"+-- compilePat "((!(!)(((!)+.!(!))))!(!(!)))"+-- compilePat "+(+(+!+(+!)+(+(+(+!)+.+!+(+!))))+!+(+!+(+!)))" -- this is working now for generic nodes, but NOT for any of the others; so we see it for exactly the OTHER 9 nodes not among the 8 listed below! ch!... [later: fixed GNFDataP]+-- compilePat "^(^(^!^(^!)^(^(^(^!)^.^!^(^!))))^!^(^!^(^!)))" -- AMAZINGLY WORKS!!! See IDs 0 1 3 7 12 13 14+-- compilePat "((!(!)(((^!).!(!))))!(!(!)))" -- works+-- compilePat "((!(!)(((!).^!(!))))!(!(!)))" -- NO WORKY: FREEZES (same)+#if 0+-- (Reproducible serious bug!)+-- compilePat "((!(!)(((!).+!(!))))!(!(!)))" -- NO WORKY: FREEZES+ -- AFTER "trc msg.":+--- P (( ()((() + ()))) ( ())) duty 918272 8720160 TA+--- P ((!(!)(((!) +!(!))))!(!(!))) duty 1660356 2185992 TA+--- P ((!(!)(((!) +!(!))))!(!(!))) duty 2348988 2244528 TA+--- P ((!(!)(((!) +!(!))))!(!(!))) duty 3037620 2240528 TA+--- P ((!(!)(((!) +!(!))))!(!(!))) duty 3693484 2207760 TA+--- trc msg.+--- ^C+#endif+-- compilePat "((!(!)(((!)+.!(!))))!(!(!)))" -- NO WORKY+-- compilePat "((!(!)(((+!).!(+!))))!(!(!)))" -- works! "(TRACE: 3 Int) (TRACE: 7 Int)" repeating+-- compilePat "((!(!)(((!).!(+!))))!(!(!)))" -- works! "(TRACE: 7 Int)"+-- compilePat "((!(!)(((!)+^/.!(!))))!(!(!)))" -- no worky!+-- compilePat "(+^/(!(!)(((!).!(!))))!(!(!)))" -- no worky+-- compilePat "(+(!(!)(((!).!(!))))!(!(!)))" -- no worky+-- compilePat "(+(!(!)(((+!).!(!))))!(!(!)))"+-- compilePat "((!(!)(((+!).!(!))))!(!(!)))" -- works! "(TRACE: 3 Int)"+ compilePat "((!(!)(((!).!(!))))!(!(!)))"+ | otherwise+ = compilePat ".{.{..{.}.{.{.{.}#..{.}}}}..{..{.}}}"+#else fixed_pat = compilePat ".{.{..{.}.{.{.{.}#..{.}}}}..{..{.}}}"+#endif ------------------------------------------------------------------------------- @@ -185,6 +319,7 @@ -- the most performant choice... optimisation pending... -- XXX Would prefer 1 <-> 2, but to do that would require more -- code change to test...+ -- XXX This is no doubt located here to avoid a cyclical import! -- 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.
Seqaid/Optim.hs view
@@ -81,7 +81,7 @@ -- | -- Module : Seqaid.Optim--- Copyright : (c) 2014, Andrew G. Seniuk+-- Copyright : Andrew G. Seniuk 2014-2015 -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Andrew Seniuk <rasfar@gmail.com>@@ -128,6 +128,8 @@ #endif #endif + import Control.Concurrent ( myThreadId )+ --import Debug.Trace ( trace ) -------------------------------------------------------------------------------@@ -150,7 +152,7 @@ --depth_ioref :: IORef Int --pattern_ioref :: IORef Pattern --patterns_ioref :: IORef (HashTable Int Pattern)---snk_ioref :: IORef SeqNodeKind+--snk_ioref :: IORef SeqNode --stats_query_idx_ioref :: IORef Int --counter_ioref :: IORef Int64 --next_sample_at_ioref :: IORef Int64@@ -189,7 +191,7 @@ -- 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 :: IO (Int,Int,Pattern,SeqNode,Int64,Int64,Int64,Int64,Int64) optimIO = do -- XXX Based on a clone of run_IO_SM.@@ -310,18 +312,20 @@ {-# 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)+ => SiteID -> a -> IO (Int,Int,Pattern,SeqNode,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)+ => SiteID -> a -> IO (Int,Int,Pattern,SeqNode,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)+ => SiteID -> a -> IO (Int,Int,Pattern,SeqNode,Int64,Int64,Int64,Int64,Int64) #endif #endif run_IO_SM sid x = do +--- myThreadId >>= writeIORef deepseq_bounded_ioref__main_thread_id+ stats_query_idx <- do sqi <- readIORef stats_query_idx_ioref return sqi@@ -354,10 +358,12 @@ = fixed_pat_sequence!!tmp | otherwise = last fixed_pat_sequence+ tid <- myThreadId+ let p' = fmap (setPatNodePingParentTID tid) p #if 0- H.insert ht sid_hash p+ H.insert ht sid_hash p' #endif- return p+ return p' #else ht <- readIORef patterns_ioref let sid_hash = thd3 sid
Seqaid/Plugin.hs view
@@ -1,7 +1,7 @@ -- | -- Module : Seqaid.Plugin--- Copyright : (c) 2014, Andrew G. Seniuk+-- Copyright : Andrew G. Seniuk 2014-2015 -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Andrew Seniuk <rasfar@gmail.com>
Seqaid/Prepro.hs view
@@ -9,7 +9,7 @@ #define DBG_OMNI 0 --- Sadly it seem there is a bad interaction between SOP.TH and Seqaid.TH,+-- Sadly it seems 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@@ -18,7 +18,7 @@ -- | -- Module : Seqaid.Prepro--- Copyright : (c) 2014, Andrew G. Seniuk+-- Copyright : Andrew G. Seniuk 2014-2015 -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Andrew Seniuk <rasfar@gmail.com>@@ -124,6 +124,7 @@ parseConfigLines config [] = config parseConfigLines config (l:ls) = config' where+ -- XXX looks like I'm discarding all layout info right here, so far: l' = dropWhile (==' ') l config' | null l' = parseConfigLines config ls@@ -377,7 +378,15 @@ -- (3) Inject the Seqaid.TH import statement: -- Later: And also some type imports (for omnitypic wrapper injection).+#if 1 let go2 s = indent ++ "import Seqaid.TH\n" ++ omni_imports ++ s+#else+#if __GLASGOW_HASKELL__ >= 710+ let go2 s = indent ++ "import Seqaid.TH_710\n" ++ omni_imports ++ s+#else+ let go2 s = indent ++ "import Seqaid.TH\n" ++ omni_imports ++ s+#endif+#endif let lexmod'' = replaceAll False (makeRegex "^ *import ") go2 lexmod''_ @@ -422,87 +431,97 @@ ------------------------------------------------------------------------------- make_seqaid_validate ts = lines $ make_seqaid_validate' ts- make_seqaid_validate' ts = "\-\seqaidValidate [ " ++ intercalate ", " (map ("''"++) ts) ++ " ]\n"+ 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+ makeDIs' (t:ts) = concat+ [ "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+ makeIs' (t:ts) = concat+ [ "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+ 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+ 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+ = [ "\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"+ makePragmas_+ = [ "\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"+ makeImports+ = [ "\n"+ , "import Control.DeepSeq.Bounded\n"+ , "import Control.DeepSeq.Generics\n"+ , "\n"+#if 1+ , "import Seqaid.TH ( seqaidValidate )\n"+#else+#if __GLASGOW_HASKELL__ >= 710+ , "import Seqaid.TH_710 ( seqaidValidate )\n"+#else+ , "import Seqaid.TH ( seqaidValidate )\n"+#endif+#endif+ , "import Generics.SOP.TH\n"+ , "import GHC.Generics ( Generic )\n"+ , "import Data.Typeable ( Typeable )\n"+ , "import Data.Data ( Data )\n"+ ] ------------------------------------------------------------------------------- @@ -543,40 +562,45 @@ 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 " + let nowneeded = intercalate " "+ [ "-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+ let ghcopts = intercalate " "+ [ ghcopts'+ , "--make "+ , "-c "+ , "-pgmPcpphs -optP--cpp"+ , "" ++ 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 \+--- , " -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 \+--- , " -fplugin=Seqaid.Plugin "+--- , " -F "+--- , " -pgmF seqaidpp " -- Optional:---- \ -optP-Wundef \---- \ -fno-warn-overlapping-patterns \+--- , " -optP-Wundef "+--- , " -fno-warn-overlapping-patterns " -- Seem not to be needed if supply -with-rtsopts (which we do):---- \ -rtsopts \+--- , " -rtsopts " #if 0 putStrLn $ "CPPOPTS:\n" ++ show cppopts
Seqaid/Runtime.hs view
@@ -1,21 +1,19 @@ ------------------------------------------------------------------------------- --- 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...) + {-# LANGUAGE ScopedTypeVariables #-}+ ------------------------------------------------------------------------------- -- | -- Module : Seqaid.Runtime--- Copyright : (c) 2014, Andrew G. Seniuk+-- Copyright : Andrew G. Seniuk 2014-2015 -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Andrew Seniuk <rasfar@gmail.com>@@ -65,6 +63,10 @@ import Generics.SOP ( Generic ) #endif + import Control.Exception+ import System.IO+ import System.IO.Error+ ------------------------------------------------------------------------------- {-# NOINLINE seqaidDispatch #-}@@ -132,7 +134,11 @@ #else - seqaidDispatch :: (NFData a,NFDataN a,Typeable a,NFDataP a) =>+ -- XXX Question: Are all the superclass constraints still needed?+ -- There was a time when they were. (Although they're implicit+ -- for normal Haskell compilation, for whatever I was doing either+ -- in TH or in Core, they were needed to get them in scope.+ seqaidDispatch :: forall a. (NFData a,NFDataN a,Typeable a,NFDataP a) => SiteID -> a -> a seqaidDispatch@@ -144,10 +150,10 @@ 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'))++" "+ 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 30 (show depth)) else padr 30 (showPat pat'))++" " -- ++padl 2 (show (fst3 sid))++" "- ++padr 13 (dropQuals (snd3 sid))+ ++padr 8 (dropQuals (snd3 sid)) -- ++padl 3 (show stats_query_idx)++" " ++padl 8 (show cbu)++" " ++padl 9 (show size)++" "@@ -156,6 +162,8 @@ -- ++show (i,t',size)++" " ++show (typeOf x) ) $+ x'+ else x' #else -- 110 cols if i >= t@@ -180,10 +188,10 @@ -- ++show (i,t',size)++" " ++show (typeOf x) ) $-#endif-#endif x' else x'+#endif+#endif #endif #endif@@ -194,49 +202,125 @@ -- (!stats_query_idx,!depth,!pat,!snk,!i,!t,!size,!cbu,!t') = unsafePerformIO $! run_IO_SM sid x +-- Later: Now "EXCEPTION ACTION" message /is/ printed -- twice.+-- And then we see "leaky: DeepSeqBounded_PingException",+-- on which leaky seems to die.+-----+-- Doesn't appear to work -- exception still kills whole program,+-- and no "EXCEPTION ACTION" message is printed.+#if 0+#elif 1+ x' = unsafePerformIO $ handle f $ do+ evaluate x''+ return x''+ f = (\ (DeepSeqBounded_PingException msg)+ -> do+#if 1+ putStr (msg::String) -- b/c showRose ends '\n'+-- putStrLn (msg::String)+#else+ hPutStrLn stderr msg+ hFlush stderr+#endif+#if 0+ hPutStrLn stderr "EXCEPTION ACTION"+ hFlush stderr+#endif+-- evaluate x''+ return x'')+#elif 0+ x' = unsafePerformIO $ evaluate x'' `catch` f+-- catchJust :: Exception e => (e -> Maybe b) -> IO a -> (b -> IO a) -> IO a + f = (\ () -> do+#if 0+ hPutStrLn stderr "EXCEPTION ACTION"+ hFlush stderr+#endif+-- evaluate x''+ return x'')+#elif 0+ x' = unsafePerformIO $ evaluate x'' `catchJust'` f+ catchJust' = catchJust ep+--- x' = unsafePerformIO $! evaluate x'' `catchJust'` ep f+--- catchJust' = flip catchJust+--- ep :: forall e. Exception e => e -> Maybe a+ ep = (\e -> if isDeepSeqBounded_PingException e then Just () else error "BOO!" {-Nothing-})+--- ep = (\ (e::DeepSeqBounded_PingException) -> if isDeepSeqBounded_PingException $ fromException e then Just x'' else Nothing)+--- f :: DeepSeqBounded_PingException -> IO a+ f = (\ () -> do+#if 0+ hPutStrLn stderr "EXCEPTION ACTION"+ hFlush stderr+#endif+ evaluate x''+ return x'')+#endif+ isDeepSeqBounded_PingException DeepSeqBounded_PingException{} = True+ isDeepSeqBounded_PingException _ = False+ -- 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+ x'' = force_ snk x+-- x'' = force_ Insulate x #else #if NFDATAN_ONLY- x' = forcen depth x--- x' = forcen 6 x+ 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+ 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'+#if SEQABLE_ONLY+ seqaidDispatchDyn :: Generic a => SiteID -> a -> a+ seqaidDispatchDyn _ x = x' where+--- !_ = trace t () t = show $ typeOf x- x' | t == "TA" = forcep_ fixed_pat x+ x' | False = undefined+--- | t == "State" = force_ Propagate x -- never, right? (type synonym)+ | t == "TA" = force_ Propagate x+ | t == "TB" = force_ Propagate x+ | t == "TC" = force_ Propagate x+ | otherwise = x+--- | otherwise = force_ Insulate x+#else+#if NFDATAN_ONLY+ seqaidDispatchDyn :: (Typeable a,NFDataN a) => SiteID -> a -> a+ seqaidDispatchDyn _ x = x'+ where+--- !_ = trace t ()+ t = show $ typeOf x+ x' | t == "TA" = forcen max_depth x+-- x' | t == "State" = forcen max_depth x | otherwise = x #else- seqaidDispatchDyn :: NFDataP a => SiteID -> a -> a+ -- [Very old function, never really used.]+ -- Note that NFDataP already has Typeable superclass.+ -- (This is not ideal perhaps, as a lot of NFDataP's+ -- functionality doesn't depend on Typeable...).+ -- See note to seqaidDispatch,+ seqaidDispatchDyn :: (NFData a,NFDataN a,Typeable a,NFDataP a) =>+ SiteID -> a -> a+--seqaidDispatchDyn :: NFDataP a => SiteID -> a -> a --seqaidDispatchDyn :: NFDataP a => a -> a --seqaidDispatchDyn :: (Typeable a,NFDataP a) => a -> a seqaidDispatchDyn _ x = x' where--- !_ = trace t $ ()+--- !_ = trace t () t = show $ typeOf x x' | t == "TA" = forcep_ fixed_pat x -- x' | t == "State" = forcep_ fixed_pat x | otherwise = x+#endif #endif -------------------------------------------------------------------------------
Seqaid/TH.hs view
@@ -48,7 +48,7 @@ -- | -- Module : Seqaid.TH--- Copyright : (c) 2014, Andrew G. Seniuk+-- Copyright : Andrew G. Seniuk 2014-2015 -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Andrew Seniuk <rasfar@gmail.com>@@ -61,6 +61,12 @@ module Seqaid.TH ( +#if __GLASGOW_HASKELL__ >= 710++ module Seqaid.TH_710 ,++#else+ seqaidTH , seqaidValidate ,@@ -82,8 +88,16 @@ module Seqaid.Runtime , module Seqaid.Ann , +#endif+ ) where +#if __GLASGOW_HASKELL__ >= 710++ import Seqaid.TH_710++#else+ import Language.Haskell.TH import Language.Haskell.TH.Syntax ( qLocation ) #if SEQAIDPP_TYPES@@ -96,9 +110,9 @@ -- 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 )+ import Seqaid.TH_extra ( names ) #else- import Language.Haskell.TH.Module.Magic ( names )+ import Seqaid.TH_extra ( names ) #endif import Data.Generics ( listify, everywhere, mkT )@@ -992,7 +1006,7 @@ ------------------------------------------------------------------------------- - make_ctx :: Maybe ([Type],[Type]) -> [Type] -> [Pred]-> [Pred]+ make_ctx :: Maybe ([Type],[Type]) -> [Type] -> [Pred] -> [Pred] make_ctx mof free_tvars_typ ctx = ctx2 where ctx2@@ -1241,4 +1255,6 @@ #endif -------------------------------------------------------------------------------++#endif
+ Seqaid/TH_710.hs view
@@ -0,0 +1,1277 @@++{-# LANGUAGE CPP #-}++#if __GLASGOW_HASKELL__ >= 710+--- #warning With GHC 7.10, Seqaid.TH is still broken.+#endif++-- 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_710+-- Copyright : Andrew G. Seniuk 2014-2015+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : Andrew Seniuk <rasfar@gmail.com>+-- Stability : provisional+-- Portability : GHC (TH)+--+-- /NOTE: This is a development branch (probably broken) of "Seqaid.TH" for GHC 7.10./+--+-- Template Haskell parts of seqaid.+--+-- None of these splices needs to (or should) be called by the user.++ module Seqaid.TH_710 (++#if __GLASGOW_HASKELL__ >= 710++ seqaidTH ,++ seqaidValidate ,++-- seqaidSOP ,++-- seqaidManTH ,++-- seqaidInstancesTH ,++ strInstancesTH ,++ bindsIncludedTH ,++#if TRY_INJECT_NOINLINE_ON_REQUESTED_BINDS+ noinlineTH ,+#endif++ module Seqaid.Runtime ,+ module Seqaid.Ann ,++#endif++ ) where++#if __GLASGOW_HASKELL__ >= 710++ 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 Seqaid.TH_extra ( names )+#else+ import Seqaid.TH_extra ( 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+ 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_+ ctx2 <- make_ctx (Just (orig_tyvars,fresh_tyvars)) bind_tvars_typ ctx+ let typ' | isNothing mn -- it's not a class method signature+ = let typ_ = substTyVars (orig_tyvars,fresh_tyvars) typ+ in+ ForallT+ binding+ ctx2+ ( {-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+ ctx2+#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+ ctx <- make_ctx (Just ([],[])) free_tvars_typ []+ let typ' = ForallT+ bind_tvars_typ+ ctx+ (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] -> Q [Pred]+ make_ctx mof free_tvars_typ ctx = do+ let class_name_lst+ = []+#if SEQABLE_ONLY+ ++ [name_SOP_Generic]+#else+#if NFDATAN_ONLY+ ++ [name_NFDataN]+#else+ ++ [name_Typeable]+ ++ [name_NFDataN]+ ++ [name_NFData]+ ++ [name_NFDataP]+#endif+#endif+#if SHOW_CONSTRAINT+ ++ [name_Show]+#endif++ ctx2 <- mapM varT class_name_lst+ return ctx2+ where+ -- This is to avoid duplication (perhaps ironically...):+#if 1+#warning At 2429376459103765 in TH_710.hs, this is a kludge!+ ctx_ | isNothing mof = ctx+ | otherwise = ctx+-- | otherwise = map j ctx+#else+#if __GLASGOW_HASKELL__ < 710+#if 0+ 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"+#endif+#else+ j p | ForallT ts ((VarT n):_) _ <- p = forallT (map (substTyVars (orig,fresh)) ts) (varT n)+ -- | EqualP t1 t2 <- p = EqualP ((substTyVars (orig,fresh)) t1) ((substTyVars (orig,fresh)) t1)+-- | EqualP t1 t2 <- p = error "make_ctx: not ready for EqualP"+#endif+ ctx_ | isNothing mof = ctx+ | otherwise = map j ctx+#endif+ Just (orig,fresh) = mof -- antipattern...+ !_ = trace (show ctx_) $ ()+ ctx' = (+ id+#if SEQABLE_ONLY+ . filter (\ (ForallT _ ((VarT name):_) _) -> show name /= "Generic")+ . filter (\ (ForallT _ ((VarT name):_) _) -> show name /= "Generics.SOP.Universe.Generic")+#if SHOW_TYPE+ . filter (\ (ForallT _ ((VarT name):_) _) -> show name /= "Typeable")+#endif+#else+#if NFDATAN_ONLY+ . filter (\ (ForallT _ ((VarT name):_) _) -> show name /= "NFDataN")+ . filter (\ (ForallT _ ((VarT name):_) _) -> show name /= "Control.DeepSeq.Bounded.NFDataN.NFDataN")+#if SHOW_TYPE+-- (recently added; and untested; but I think is supposed to be here?)+ . filter (\ (ForallT _ ((VarT name):_) _) -> show name /= "Typeable")+#endif+#else+ . filter (\ (ForallT _ ((VarT name):_) _) -> show name /= "Typeable")+ . filter (\ (ForallT _ ((VarT name):_) _) -> show name /= "NFDataN")+ . filter (\ (ForallT _ ((VarT name):_) _) -> show name /= "NFData")+ . filter (\ (ForallT _ ((VarT name):_) _) -> show name /= "NFDataP")+ . filter (\ (ForallT _ ((VarT name):_) _) -> show name /= "Data.Typeable.Internal.Typeable")+ . filter (\ (ForallT _ ((VarT name):_) _) -> show name /= "Control.DeepSeq.Bounded.NFDataN.NFDataN")+ . filter (\ (ForallT _ ((VarT name):_) _) -> show name /= "Control.DeepSeq.NFData")+ . filter (\ (ForallT _ ((VarT name):_) _) -> show name /= "Control.DeepSeq.Bounded.NFDataP.NFDataP")+#endif+#endif+#if SHOW_CONSTRAINT+ . filter (\ (ForallT _ ((VarT name):_) _) -> show name /= "Show")+ . filter (\ (ForallT _ ((VarT name):_) _) -> 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++-------------------------------------------------------------------------------++#endif+
+ Seqaid/TH_extra.hs view
@@ -0,0 +1,324 @@++{-+Copyright (c) 2013, Jonathan Fischoff++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 Jonathan Fischoff 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.+-}++-- This is based on Language.Haskell.TH.Module.Magic from+-- the modulespection package (Jonathan Fischoff, BSD3).+-- Maintainer is not responding to 7.10 patches so, decided+-- to plop it in and start eliding/modifying. This is+-- still pretty much verbatim from modulespection.++{- LANGUAGE CPP #-}++{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE NamedFieldPuns #-}++ module Seqaid.TH_extra+ (++ -- * Name Introspection+ names+ , moduleNames++#if 0+ -- * Declaration Introspection+ , declarations+ , moduleDeclarations+#endif++ )+ where++#include "ghcplatform.h"+ + import Language.Haskell.TH as TH+ import Data.Maybe+ import GHC+ import Module+ import GHC.Paths ( libdir )+ import DynFlags + import Name as Name+ import RdrName + import MonadUtils+ import HsDecls as HsDecls+ import SrcLoc+ import Bag+ import Control.Monad+ import Data.Monoid+ import System.IO.Temp+ import HeaderInfo+ import DriverPipeline+ import SysTools+ import Packages+ import Config+ import qualified Control.Monad.IO.Class as MTL+ import Control.Monad.Catch+ import Exception (throwIO)+ import GhcMonad+ import GHC.IO.Handle+ import System.FilePath.Posix (takeBaseName)++ -- | Get all the top level declarations of the current file.+ -- All names are returned whether they are exported or not.+ names :: Q [TH.Name]+ names = moduleNames . loc_filename =<< location++ -- | Get all the top level names of a given module. + -- If a file path is used, all names, exported and internal+ -- are returned. If a module name is used, only the exported+ -- names are returned.+ moduleNames :: String -> Q [TH.Name]+#if 0+ moduleNames target+ = runIO $ runGhc (Just libdir) $ do+ dflags <- getSessionDynFlags+ setSessionDynFlags dflags+ lookupModuleNames target+#else+ moduleNames target = runIO $ + defaultErrorHandler + defaultFatalMessager + defaultFlushOut + $ do+ runGhc (Just libdir) $ do+ dflags <- getSessionDynFlags+ setSessionDynFlags dflags+ lookupModuleNames target+#endif++#if 0++ -- | Look up a name, and get out the declaration + -- or return nothing+ nameToMaybeDec :: TH.Name -> Q (Maybe Dec)+ nameToMaybeDec name = do+ info <- reify name+ return $ case info of+ TyConI dec -> Just dec+ _ -> Nothing+ + -- | Get all the type declarations of the current file. + -- Function and pattern declarations are ignored ... for now.+ declarations :: Q [Dec]+ declarations = mapMaybeM nameToMaybeDec =<< names++ -- | Get all the top level names of a given module. + -- If a file path is used, all names, exported and internal+ -- are returned. If a module name is used, only the exported+ -- names are returned.+ -- Function and pattern declarations are ignored ... for now.+ moduleDeclarations :: String -> Q [Dec]+ moduleDeclarations = mapMaybeM nameToMaybeDec <=< moduleNames ++#endif++#if 1++#if __GLASGOW_HASKELL__ < 707+ instance MTL.MonadIO Ghc where+ liftIO = MonadUtils.liftIO+#endif++ instance MonadThrow Ghc where+ throwM = liftIO . throwIO++ instance MonadCatch Ghc where+ catch = gcatch+ mask f =+ Ghc $ \s -> mask $ \io_restore ->+ let+ g_restore (Ghc m) = Ghc $ \s -> io_restore (m s)+ in+ unGhc (f g_restore) s+ uninterruptibleMask = error "uninterruptibleMask"++#endif++ -- | Either try to parse a source file or if the module is+ -- part of library, look it up and browse the contents+ lookupModuleNames :: (MTL.MonadIO m, MonadCatch m, GhcMonad m) + => String -> m [TH.Name]+ lookupModuleNames mName = do + target <- targetId <$> guessTarget mName Nothing+ case target of+ TargetModule moduleName -> getExistingModuleNames + =<< lookupModule moduleName Nothing+ TargetFile filePath _ -> do + dflags <- getSessionDynFlags+ opts <- liftIO $ getOptionsFromFile dflags filePath+ (newDFlags, unhandledFlags, _) <- + liftIO $ parseDynamicFilePragma dflags opts+ liftIO $ checkProcessArgsResult newDFlags unhandledFlags+ if (xopt Opt_Cpp newDFlags) then do+ withSystemTempFile (takeBaseName filePath <> ".cpp") $ \cppFilePath handle -> do+ liftIO $ hClose handle+ liftIO $ doCpp newDFlags True False filePath cppFilePath+ srcOpts <- liftIO $ getOptionsFromFile newDFlags cppFilePath+ (newestDFlags, unhandled_flags, warns)+ <- liftIO $ parseDynamicFilePragma newDFlags srcOpts+ liftIO $ checkProcessArgsResult newestDFlags unhandled_flags+ parseFile newestDFlags cppFilePath+ else + parseFile newDFlags filePath++ -- | Turn ErrorMessages into a String+ errString :: Show a => Bag a -> String + errString = unlines + . map show + . foldBag (<>) (:[]) []++ -- | Parse a file and collect all of the declarations names+ parseFile :: GhcMonad m => DynFlags -> FilePath -> m [TH.Name]+ parseFile dflags filePath = do+ src <- liftIO $ readFile filePath + let (warns, L _ hsModule) = + either (error . errString) id+ $ parser src dflags filePath+ + names = mapMaybe getNameMaybe $ hsmodDecls hsModule+ + return $ map rdrNameToName names++ showModuleName :: Module -> String+ showModuleName = moduleNameString . moduleName++ getExistingModuleNames :: GhcMonad m => Module -> m [TH.Name]+ getExistingModuleNames modl = do+ moduleInfo <- getModuleInfo modl+ case moduleInfo of+ Nothing -> error $ "modulespection: Failed to find module info for "+ <> showModuleName modl+ <> " in getExistingModuleNames"+ Just mod_info -> fmap (map (occNameToName . nameOccName . getName))+ . mapMaybeM lookupName + $ modInfoExports mod_info++ -- | Simple Class for getting the name of things+ class GetNameMaybe a where+ getNameMaybe :: a -> Maybe RdrName++ instance GetNameMaybe (HsDecl RdrName) where+ getNameMaybe = \case + TyClD x -> getNameMaybe x+ HsDecls.ValD x -> getNameMaybe x+ _ -> Nothing++ instance GetNameMaybe (TyClDecl RdrName) where+ getNameMaybe = \case+ ForeignType x _ -> getNameMaybe x+#if __GLASGOW_HASKELL__ >= 707+ FamDecl x -> getNameMaybe $ fdLName x + SynDecl { tcdLName } -> getNameMaybe tcdLName+ DataDecl { tcdLName } -> getNameMaybe tcdLName+#else+ x@(TyFamily {}) -> getNameMaybe $ tcdLName x+ TyDecl x _ _ _ -> getNameMaybe x+#endif+ + x@(ClassDecl {}) -> getNameMaybe $ tcdLName x++ instance GetNameMaybe (HsBindLR RdrName RdrName) where+ getNameMaybe = \case + x@(FunBind {}) -> getNameMaybe $ fun_id x + _ -> Nothing++ instance GetNameMaybe a => GetNameMaybe (GenLocated SrcSpan a) where+ getNameMaybe (L _ x) = getNameMaybe x ++ instance GetNameMaybe RdrName where+ getNameMaybe = Just++ -- Name Utils+ occNameToName :: OccName -> TH.Name+ occNameToName = mkName . occNameString ++ rdrNameToName :: RdrName -> TH.Name+ rdrNameToName = \case + RdrName.Unqual x -> occNameToName x+ RdrName.Qual _ x -> occNameToName x+ RdrName.Orig _ x -> occNameToName x+ RdrName.Exact x -> occNameToName $ nameOccName x++ doCpp :: DynFlags -> Bool -> Bool -> FilePath -> FilePath -> IO ()+ doCpp dflags raw include_cc_opts input_fn output_fn = do+ let hscpp_opts = getOpts dflags opt_P+ let cmdline_include_paths = includePaths dflags++ pkg_include_dirs <- getPackageIncludePath dflags []+ let include_paths = foldr (\ x xs -> "-I" : x : xs) []+ (cmdline_include_paths ++ pkg_include_dirs)++ let verbFlags = getVerbFlags dflags++ let cc_opts+ | include_cc_opts = getOpts dflags opt_c+ | otherwise = []++ let cpp_prog args | raw = SysTools.runCpp dflags args+ | otherwise = SysTools.runCc dflags (SysTools.Option "-E" : args)++ let target_defs =+ [ "-D" ++ HOST_OS ++ "_BUILD_OS=1",+ "-D" ++ HOST_ARCH ++ "_BUILD_ARCH=1",+ "-D" ++ TARGET_OS ++ "_HOST_OS=1",+ "-D" ++ TARGET_ARCH ++ "_HOST_ARCH=1" ]+ -- remember, in code we *compile*, the HOST is the same our TARGET,+ -- and BUILD is the same as our HOST.++ cpp_prog ( map SysTools.Option verbFlags+ ++ map SysTools.Option include_paths+ ++ map SysTools.Option hsSourceCppOpts+ ++ map SysTools.Option target_defs+ ++ map SysTools.Option hscpp_opts+ ++ map SysTools.Option cc_opts+ ++ [ SysTools.Option "-x"+ , SysTools.Option "c"+ , SysTools.Option input_fn+ -- We hackily use Option instead of FileOption here, so that the file+ -- name is not back-slashed on Windows. cpp is capable of+ -- dealing with / in filenames, so it works fine. Furthermore+ -- if we put in backslashes, cpp outputs #line directives+ -- with *double* backslashes. And that in turn means that+ -- our error messages get double backslashes in them.+ -- In due course we should arrange that the lexer deals+ -- with these \\ escapes properly.+ , SysTools.Option "-o"+ , SysTools.FileOption "" output_fn+ ])++ hsSourceCppOpts :: [String]+ -- Default CPP defines in Haskell source+ hsSourceCppOpts =+ [ "-D__GLASGOW_HASKELL__="++cProjectVersionInt ]+
+ Seqaid/TH_extra_710.hs view
@@ -0,0 +1,312 @@++{-+Copyright (c) 2013, Jonathan Fischoff; 2015, Andrew G. 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 Jonathan Fischoff 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.+-}++-- This is based on Language.Haskell.TH.Module.Magic from+-- the modulespection package (Jonathan Fischoff, BSD3).+-- Maintainer is not responding to 7.10 patches so, decided+-- to plop it in and start eliding/modifying. This is+-- still pretty much verbatim from modulespection, except+-- that I've patched it for GHC 7.10.++{- LANGUAGE CPP #-}++{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE NamedFieldPuns #-}++module Seqaid.TH_extra_710+#if __GLASGOW_HASKELL__ >= 710+ ( -- * Name Introspection+ names+ , moduleNames+ -- * Declaration Introspection+ , declarations+ , moduleDeclarations+ )+#endif+where++#if __GLASGOW_HASKELL__ >= 710++#include "ghcplatform.h"+ +import Language.Haskell.TH as TH+import Data.Maybe+import GHC+import Module+import GHC.Paths ( libdir )+import DynFlags +import Name as Name+import RdrName +import MonadUtils+import HsDecls as HsDecls+import SrcLoc+import Bag+import Control.Monad+import Data.Monoid+import System.IO.Temp+import HeaderInfo+import DriverPipeline+import SysTools+import Packages+import Config+import qualified Control.Monad.IO.Class as MTL+import Control.Monad.Catch+import Exception (throwIO)+import GhcMonad+import GHC.IO.Handle+import System.FilePath.Posix (takeBaseName)++-- | Get all the top level declarations of the current file.+-- All names are returned whether they are exported or not.+names :: Q [TH.Name]+names = moduleNames . loc_filename =<< location++-- | Get all the top level names of a given module. +-- If a file path is used, all names, exported and internal+-- are returned. If a module name is used, only the exported+-- names are returned.+moduleNames :: String -> Q [TH.Name]+moduleNames target = runIO $ + defaultErrorHandler + defaultFatalMessager + defaultFlushOut + $ do+ runGhc (Just libdir) $ do+ dflags <- getSessionDynFlags+ setSessionDynFlags dflags+ lookupModuleNames target++-- | Look up a name, and get out the declaration +-- or return nothing+nameToMaybeDec :: TH.Name -> Q (Maybe Dec)+nameToMaybeDec name = do+ info <- reify name+ return $ case info of+ TyConI dec -> Just dec+ _ -> Nothing+ +-- | Get all the type declarations of the current file. +-- Function and pattern declarations are ignored ... for now.+declarations :: Q [Dec]+declarations = mapMaybeM nameToMaybeDec =<< names++-- | Get all the top level names of a given module. +-- If a file path is used, all names, exported and internal+-- are returned. If a module name is used, only the exported+-- names are returned.+-- Function and pattern declarations are ignored ... for now.+moduleDeclarations :: String -> Q [Dec]+moduleDeclarations = mapMaybeM nameToMaybeDec <=< moduleNames ++#if __GLASGOW_HASKELL__ < 707+instance MTL.MonadIO Ghc where+ liftIO = MonadUtils.liftIO+#endif++instance MonadThrow Ghc where+ throwM = liftIO . throwIO++instance MonadCatch Ghc where+ catch = gcatch++instance MonadMask Ghc where+ mask f =+ Ghc $ \s -> mask $ \io_restore ->+ let+ g_restore (Ghc m) = Ghc $ \s -> io_restore (m s)+ in+ unGhc (f g_restore) s+ uninterruptibleMask = error "uninterruptibleMask"+-- | Either try to parse a source file or if the module is+-- part of library, look it up and browse the contents+lookupModuleNames :: (MTL.MonadIO m, MonadMask m, GhcMonad m) + => String -> m [TH.Name]+lookupModuleNames mName = do + target <- targetId <$> guessTarget mName Nothing+ case target of+ TargetModule moduleName -> getExistingModuleNames + =<< lookupModule moduleName Nothing+ TargetFile filePath _ -> do + dflags <- getSessionDynFlags+ opts <- liftIO $ getOptionsFromFile dflags filePath+ (newDFlags, unhandledFlags, _) <- + liftIO $ parseDynamicFilePragma dflags opts+ liftIO $ checkProcessArgsResult newDFlags unhandledFlags+ if (xopt Opt_Cpp newDFlags) then do+ withSystemTempFile (takeBaseName filePath <> ".cpp") $ \cppFilePath handle -> do+ liftIO $ hClose handle+ liftIO $ doCpp newDFlags True False filePath cppFilePath+ srcOpts <- liftIO $ getOptionsFromFile newDFlags cppFilePath+ (newestDFlags, unhandled_flags, warns)+ <- liftIO $ parseDynamicFilePragma newDFlags srcOpts+ liftIO $ checkProcessArgsResult newestDFlags unhandled_flags+ parseFile newestDFlags cppFilePath+ else + parseFile newDFlags filePath++-- | Turn ErrorMessages into a String+errString :: Show a => Bag a -> String +errString = unlines + . map show + . foldBag (<>) (:[]) []++-- | Parse a file and collect all of the declarations names+parseFile :: GhcMonad m => DynFlags -> FilePath -> m [TH.Name]+parseFile dflags filePath = do+ src <- liftIO $ readFile filePath + let (warns, L _ hsModule) = + either (error . errString) id+ $ parser src dflags filePath+ + names = mapMaybe getNameMaybe $ hsmodDecls hsModule+ + return $ map rdrNameToName names++showModuleName :: Module -> String+showModuleName = moduleNameString . moduleName++getExistingModuleNames :: GhcMonad m => Module -> m [TH.Name]+getExistingModuleNames modl = do+ moduleInfo <- getModuleInfo modl+ case moduleInfo of+ Nothing -> error $ "modulespection: Failed to find module info for "+ <> showModuleName modl+ <> " in getExistingModuleNames"+ Just mod_info -> fmap (map (occNameToName . nameOccName . getName))+ . mapMaybeM lookupName + $ modInfoExports mod_info++-- | Simple Class for getting the name of things+class GetNameMaybe a where+ getNameMaybe :: a -> Maybe RdrName++instance GetNameMaybe (HsDecl RdrName) where+ getNameMaybe = \case + TyClD x -> getNameMaybe x+ HsDecls.ValD x -> getNameMaybe x+ _ -> Nothing++instance GetNameMaybe (TyClDecl RdrName) where+ getNameMaybe = \case+#if __GLASGOW_HASKELL__ < 710+ ForeignType x _ -> getNameMaybe x+#endif+#if __GLASGOW_HASKELL__ >= 707+ FamDecl x -> getNameMaybe $ fdLName x + SynDecl { tcdLName } -> getNameMaybe tcdLName+ DataDecl { tcdLName } -> getNameMaybe tcdLName+#else+ x@(TyFamily {}) -> getNameMaybe $ tcdLName x+ TyDecl x _ _ _ -> getNameMaybe x+#endif+ + x@(ClassDecl {}) -> getNameMaybe $ tcdLName x++instance GetNameMaybe (HsBindLR RdrName RdrName) where+ getNameMaybe = \case + x@(FunBind {}) -> getNameMaybe $ fun_id x + _ -> Nothing++instance GetNameMaybe a => GetNameMaybe (GenLocated SrcSpan a) where+ getNameMaybe (L _ x) = getNameMaybe x ++instance GetNameMaybe RdrName where+ getNameMaybe = Just++-- Name Utils+occNameToName :: OccName -> TH.Name+occNameToName = mkName . occNameString ++rdrNameToName :: RdrName -> TH.Name+rdrNameToName = \case + RdrName.Unqual x -> occNameToName x+ RdrName.Qual _ x -> occNameToName x+ RdrName.Orig _ x -> occNameToName x+ RdrName.Exact x -> occNameToName $ nameOccName x++doCpp :: DynFlags -> Bool -> Bool -> FilePath -> FilePath -> IO ()+doCpp dflags raw include_cc_opts input_fn output_fn = do+ let hscpp_opts = getOpts dflags opt_P+ let cmdline_include_paths = includePaths dflags++ pkg_include_dirs <- getPackageIncludePath dflags []+ let include_paths = foldr (\ x xs -> "-I" : x : xs) []+ (cmdline_include_paths ++ pkg_include_dirs)++ let verbFlags = getVerbFlags dflags++ let cc_opts+ | include_cc_opts = getOpts dflags opt_c+ | otherwise = []++ let cpp_prog args | raw = SysTools.runCpp dflags args+ | otherwise = SysTools.runCc dflags (SysTools.Option "-E" : args)++ let target_defs =+ [ "-D" ++ HOST_OS ++ "_BUILD_OS=1",+ "-D" ++ HOST_ARCH ++ "_BUILD_ARCH=1",+ "-D" ++ TARGET_OS ++ "_HOST_OS=1",+ "-D" ++ TARGET_ARCH ++ "_HOST_ARCH=1" ]+ -- remember, in code we *compile*, the HOST is the same our TARGET,+ -- and BUILD is the same as our HOST.++ cpp_prog ( map SysTools.Option verbFlags+ ++ map SysTools.Option include_paths+ ++ map SysTools.Option hsSourceCppOpts+ ++ map SysTools.Option target_defs+ ++ map SysTools.Option hscpp_opts+ ++ map SysTools.Option cc_opts+ ++ [ SysTools.Option "-x"+ , SysTools.Option "c"+ , SysTools.Option input_fn+ -- We hackily use Option instead of FileOption here, so that the file+ -- name is not back-slashed on Windows. cpp is capable of+ -- dealing with / in filenames, so it works fine. Furthermore+ -- if we put in backslashes, cpp outputs #line directives+ -- with *double* backslashes. And that in turn means that+ -- our error messages get double backslashes in them.+ -- In due course we should arrange that the lexer deals+ -- with these \\ escapes properly.+ , SysTools.Option "-o"+ , SysTools.FileOption "" output_fn+ ])++hsSourceCppOpts :: [String]+-- Default CPP defines in Haskell source+hsSourceCppOpts =+ [ "-D__GLASGOW_HASKELL__="++cProjectVersionInt ]++#endif+
+ changelog.txt view
@@ -0,0 +1,6 @@++0.1.7.0 -> 0.2.0.0+ - deepseq-bounded had a major version bump+ - fixed cpphs missing dependency (Seqaid lib, and seqaid and seqaidpp exe's)+ - more...+
+ deepseq-bounded-seqaid-leaky.css view
@@ -0,0 +1,34 @@++pre { font-size: 14pt; margin-left: 20px; padding-left: 10px; padding-right: 10px; padding-top: 10px; padding-bottom: 10px; background-color: rgba(230,230,230,1.0); }+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.comments { font-family: sans; font-size: 80%; margin-top: 40px; }+div.footer { font-family: sans; font-size: 80%; margin-top: 40px; }+div.footer > tt { font-size: 90%; }+/*+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; }+.nowrap { white-space: nowrap; }++tt { background: transparent; }+
+ deepseq-bounded-seqaid-leaky.html view
@@ -0,0 +1,89 @@+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN" "http://www.w3.org/TR/html4/strict.dtd">+<html>+<head>+<title>Seqaid : Space leak diagnostic and remedial tool</title>+<meta http-equiv="Cache-Control" content="no-cache, no-store, must-revalidate" />+<meta http-equiv="Pragma" content="no-cache" />+<meta http-equiv="Expires" content="0" />+<link rel="stylesheet" href="deepseq-bounded-seqaid-leaky.css" />+</head>+<body>+<!--body style="width: 800px;"-->++<div class="main">++<h2 style="margin-top: 50px; color: #555;">deepseq-bounded, seqaid, leaky</h2>++This trio of related packages explores strictness control in a variety of ways.++<p>+<a href="http://www.fremissant.net/deepseq-bounded">deepseq-bounded</a> provides classes and generic functions to artificially force evaluation, to extents controlled by static or dynamic configuration.++<p>+<a href="http://www.fremissant.net/seqaid">seqaid</a> puts that into practise, providing a GHC plugin to auto-instrument your package with a strictness harness, which is dynamically optimisable during runtime.+This is supported directly in the GHC compilation pipeline, without requiring (or performing!) any edits to your sources.++<p>+<a href="http://www.fremissant.net/leaky">leaky</a> is a minimal, prototypic executable that leaks space under current <span class="nowrap">state-of-the-art</span> compilation (even with <span class="nowrap">-O2 GHC <a href="https://downloads.haskell.org/~ghc/7.10.1-rc1/">7.10.1-rc1</a></span>; but certainly <span class="nowrap">with -O2 GHC 7.8.*</span>).++<p>+On hackage.haskell.org:+<ul>+<li> <a href="https://hackage.haskell.org/package/deepseq-bounded">deepseq-bounded</a>+<li> <a href="https://hackage.haskell.org/package/seqaid">seqaid</a>+<li> <a href="https://hackage.haskell.org/package/leaky">leaky</a>+</ul>++<p>+I've started a <a href="http://www.reddit.com/r/haskell/comments/2pscxh/ann_deepseqbounded_seqaid_leaky/">reddit discussion</a> page for the three together.++<p>+Easiest way to try them all, is to install seqaid and run the demo:++<pre>+ cabal install seqaid+ seqaid demo+</pre>++<p>+This tests seqaid on a local copy of the leaky source package.++<p>+It turned out to be routine to extend deepseq-bounded and seqaid to dynamically configurable parallelisation (paraid?).+Many other wrappers could be explored, too!+Maybe seqaid should be renamed to koolaid or something...++<p>+It's a pretty complicated system, and just first release, so there's bound to be lots of problems.+For now, any issues or comments can be directed to the reddit page (or private email).+There's also the list announcement threads on <tt>haskell-cafe</tt> and <tt>glasgow-haskell-users</tt> for general discussion, and on <tt>ghc-devs</tt> for technical.+I'll maintain a <a href="http://www.fremissant.net/seqaid/trac">casual list</a> of bugs and feature requests, and will set up a proper tracker if there's interest.++<div class="footer" style="margin-top: 40px;">+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>+
+ release-announcement.txt view
@@ -0,0 +1,50 @@++Subject:++ANN: deepseq-bounded, seqaid, leaky++Body:++This trio of related packages explores strictness control in a variety of ways.++deepseq-bounded provides classes and generic functions to artificially force evaluation, to extents controlled by static or dynamic configuration.++seqaid puts that into practise, providing a GHC plugin to auto-instrument your package with a strictness harness, which is dynamically optimisable during runtime. This is supported directly in the GHC compilation pipeline, without requiring (or performing!) any edits to your sources.++leaky is a minimal, prototypic executable that leaks space under current state-of-the-art compilation (GHC 7.8.3 -O2, at the present time).++deepseq-bounded+ hackage: https://hackage.haskell.org/package/deepseq-bounded+ homepage: http://www.fremissant.net/deepseq-bounded++seqaid+ hackage: https://hackage.haskell.org/package/seqaid+ homepage: http://www.fremissant.net/seqaid++leaky+ hackage: https://hackage.haskell.org/package/leaky+ homepage: http://www.fremissant.net/leaky++Reddit discussion for the three together:+ http://www.reddit.com/r/haskell/comments/2pscxh/ann_deepseqbounded_seqaid_leaky/++Easiest way to try them all, is to install seqaid and run the demo:++ cabal install seqaid+ seqaid demo++This tests seqaid on a local copy of the leaky source package.++It turned out to be routine to extend deepseq-bounded and seqaid to dynamically configurable parallelisation (paraid?). Many other wrappers could be explored, too! Maybe seqaid should be renamed to koolaid or something...++It's a pretty complicated system, and just first release, so there's bound to be lots of problems. I've not set up a bug tracker, but will maintain a casual list of bugs and feature requests at++ http://www.fremissant.net/seqaid/todo.html++and will set up a proper tracker if there's interest.++Any issues (or comments), I'm here, or on the reddit discussion (or email).++Andrew Seniuk+rasfar on #haskell+
seqaid.cabal view
@@ -1,42 +1,66 @@ +-------------------------------------------------------------------------------+ name: seqaid-version: 0.1.7.0+version: 0.2.0.0 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.- .- Please share your comments on this <http://www.reddit.com/r/haskell/comments/2pscxh/ann_deepseqbounded_seqaid_leaky/ reddit> discussion.-homepage: http://www.fremissant.net/seqaid license: BSD3 license-file: LICENSE author: Andrew G. Seniuk maintainer: Andrew Seniuk <rasfar@gmail.com>-category: Compiler Plugin+homepage: http://fremissant.net/seqaid bug-reports: http://fremissant.net/seqaid/trac ---bug-reports: Andrew Seniuk <rasfar@gmail.com>+category: Compiler Plugin build-type: Simple+stability: provisional, nascent 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+-- NOTE: Version of GHC /must/ be >= 7.8, due to need to use TH >= 2.9.+-- Could possibly relax to TH >= 2.8 (which would include GHC 7.6.*),+-- but would need to stop using AnnP and related features of TH 2.9.+--tested-with: GHC==7.8.1, GHC==7.8.3, GHC==7.8.4, GHC==7.10.1+tested-with: GHC==7.8.1, GHC==7.8.3, GHC==7.8.4+--tested-with: GHC==7.8.*, GHC==7.10.1 -- illegal syntax (Cabal 1.20)+--tested-with: GHC==7.6.3, GHC==7.8.1, GHC==7.8.3, GHC==7.8.4 +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.+ .+ Please share your comments on this <http://www.reddit.com/r/haskell/comments/2pscxh/ann_deepseqbounded_seqaid_leaky/ reddit> discussion.++extra-source-files:+ README+ , changelog.txt+ , HTML/*.html+ , HTML/*.css+ , release-announcement.txt+ , deepseq-bounded-seqaid-leaky.html+ , deepseq-bounded-seqaid-leaky.css+ -- source-repository head -- type: git -- location: +-------------------------------------------------------------------------------+ -- 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 HELLO_HACKAGE_VISITOR+ Description: [Note to those reading on Hackage:] Please ignore these flags, which would be better presented in a collapsed state. The flags are mostly for development purposes.+ Default: False++Flag GHC_710+ Description: (Still broken for GHC 7.10.) Until I learn how to test GHC version in the .cabal file, we need a flag, since some build-depends must be excluded completely. (CPP testing __GLASGOW_HASKELL__ is then used the rest of the way, in the source files.)+--Default: True+ Default: False+ 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.+ 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 @@ -61,7 +85,7 @@ -- 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).+ Description: If True, then TH 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 @@ -85,6 +109,8 @@ --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,@@ -106,40 +132,86 @@ Seqaid.Global Seqaid.Optim ---other-modules:+ -- It's not possible for Cabal flags to conditionally+ -- include other-modules. So, there needs to be additional+ -- CPP guards in the source modules...+ other-modules:+ Seqaid.TH_extra+ , Seqaid.TH_710+ , Seqaid.TH_extra_710 - build-depends:+ -- These are the dependencies of modulespection which, at this+ -- time (20150106), are not (otherwise) also dependencies of seqaid.+ -- Later: Really? I thought temporary was... (Oh! only of seqaid exe.)+ if flag(GHC_710)+ build-depends:+ ghc-paths == 0.1.*+ , temporary == 1.2.*+ , transformers == 0.4.*+ , exceptions == 0.6.*+ , filepath == 1.3.*+ else+ build-depends:+ ghc-paths == 0.1.*+ , temporary == 1.2.*+ , transformers == 0.3.*+ , exceptions == 0.5.*+ , filepath == 1.3.* + build-depends: base == 4.*+ , cpphs >= 1.14 - -- GHC plugin stuff:- , ghc >= 7.4 && < 7.9+ if flag(GHC_710)+ build-depends:+ ghc == 7.10.*+ , template-haskell == 2.10.*+-- Later: Minimally excerpted, and patched for GHC 7.10.+-- , modulespection > 0.1.2.1+-- Later: Where do I use it though??...+-- Still working on patching th-expand-syns for GHC 7.10.+-- For now, we do without this feature if 7.10.+-- , th-expand-syns == 0.3.*+ else+ build-depends:+ -- GHC plugins require >= 7.4+ -- SOP requires >= 7.6+ ghc >= 7.6 && < 7.10+-- Finally needed to drop to 2.8.* for testing GHC 7.6.3!+-- *** template-haskell-2.8 is too low -- we need AnnP and ModuleAnnotation!+-- Probably best to try to find a different transport than annotations+-- for communicating TH -> Core plugin...+-- , template-haskell >= 2.8 && < 2.10+ , template-haskell == 2.9.*+-- Later: Minimally excerpted, and patched for GHC 7.10.+-- , modulespection >= 0.1.2+-- Later: Where do I use it though??...+-- , th-expand-syns == 0.3.*++ build-depends:++ -- low-level forcing library+ deepseq-bounded == 0.6.* || == 0.7.*++ -- ad hoc generics , syb <= 0.4.2 -- 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 == 0.1.* - -- 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 == 2.9.*- , modulespection >= 0.1.2- , th-expand-syns == 0.3.*-- -- low-level forcing libraries- , deepseq-bounded == 0.5.*- -- at least for IntMap , containers == 0.5.* -- or would regex-posix be better? , regex-pcre <= 0.94.4 -- to use regex API- , array == 0.5.*+-- Finally needed to drop to 0.4.* for testing GHC 7.6.3!+ , array == 0.4.* || == 0.5.*+-- , array == 0.5.* -- ended up wanting this for State, for a SYB everywhereM traversal- , mtl == 2.1.*+-- Finally needed to drop to 2.* for testing GHC 7.6.3!+ , mtl == 2.*+-- , mtl == 2.1.* -- , mtl == 2.1.3.* -- , mtl == 2.1.3.1 @@ -172,21 +244,36 @@ -- , deepseq == 1.3.0.2 ghc-options: -optP-Wundef -fno-warn-overlapping-patterns+ ghc-options: -pgmPcpphs -optP--cpp ghc-options: -funbox-strict-fields -fwarn-tabs --ghc-options: -Wall -O2 -funbox-strict-fields -fwarn-tabs +-- XXX Later yet: Nevertheless, cpphs is the best way to go,+-- since at least we always know we can install it! Does it+-- work to add it to the build-depends? Finding out...+-- (Only needs to work for Cabal-with-GHC-7.8 anyhow, as+-- seqaid is broken for GHC < 7.8 for some time to come anyway.)+-- XXX LATER: Dependence on cpphs has resulted in broken builds+-- (see hackage build reports for leaky, at least). So going to+-- factor out the string gaps... -- 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: -pgmP cpphs -optP--cpp+--ghc-options: -cpp if flag(SEQABLE_ONLY) cpp-options: -DSEQABLE_ONLY=1 else cpp-options: -DSEQABLE_ONLY=0 + if flag(TRY_INJECT_NOINLINE_ON_REQUESTED_BINDS)+ cpp-options: -DTRY_INJECT_NOINLINE_ON_REQUESTED_BINDS=1+ else+ cpp-options: -DTRY_INJECT_NOINLINE_ON_REQUESTED_BINDS=0+ if flag(TH_TYPE_IN_TYPES_ANN) cpp-options: -DTH_TYPE_IN_TYPES_ANN=1 else@@ -236,6 +323,8 @@ 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.)@@ -245,31 +334,41 @@ main-is: Seqaid/Demo.hs --other-modules: --other-extensions:+ build-depends: base == 4.*+ , cpphs >= 1.14 , temporary == 1.2.* , directory == 1.2.*- , process == 1.2.*+-- Finally needed to drop to 1.* for testing GHC 7.6.3!+ , process == 1.*+-- , process == 1.2.* 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+ -- [See comments in the library part above.]+ ghc-options: -pgmP cpphs -optP--cpp+--ghc-options: -cpp - if os(windows)- cpp-options: -DIS_WINDOWS=1- else- cpp-options: -DIS_WINDOWS=0+-- Test #ifdef mingw32_HOST_OS instead! (it's built-in to GHC)+------+-- XXX LATER: We can do both... If (supposing it's possible?) there's+-- Windows and Cabal/GHC, but no MinGW (a.k.a. mingw32), we can respond+-- to that by executing a Cmnd batch script.+--+-- And, if it /is/ MinGW, then it's the same bash script as run on *nix...+if os(windows)+ cpp-options: -DIS_WINDOWS=1+else+ cpp-options: -DIS_WINDOWS=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.)@@ -278,14 +377,36 @@ main-is: Seqaid/Prepro.hs build-depends: base == 4.*+ , cpphs >= 1.14 , regex-base <= 0.93.2 , regex-pcre <= 0.94.4 -- (process may still be uncommented b/c using to debug...)- , process == 1.2.*+-- Finally needed to drop to 1.* for testing GHC 7.6.3!+ , process == 1.*+-- , process == 1.2.* , directory == 1.2.*- , Cabal >= 1.18- default-language: Haskell2010- ghc-options: -pgmP cpphs -optP --cpp+-- , Cabal >= 1.20+-- , Cabal+ , Cabal >= 1.10+-- , Cabal >= 1.18+ ghc-options: -optP-Wundef -fno-warn-overlapping-patterns+ -- [See comments in the library part above.]+ ghc-options: -pgmP cpphs -optP--cpp+--ghc-options: -cpp++ if flag(TRY_INJECT_NOINLINE_ON_REQUESTED_BINDS)+ cpp-options: -DTRY_INJECT_NOINLINE_ON_REQUESTED_BINDS=1+ else+ cpp-options: -DTRY_INJECT_NOINLINE_ON_REQUESTED_BINDS=0++ default-extensions: CPP+ default-language: Haskell2010++--ghc-options: -O0+--ghc-options: -O2+ }++-------------------------------------------------------------------------------