packages feed

stgi (empty) → 1

raw patch · 69 files changed

+9472/−0 lines, 69 filesdep +QuickCheckdep +ansi-terminaldep +ansi-wl-pprintsetup-changedbinary-added

Dependencies added: QuickCheck, ansi-terminal, ansi-wl-pprint, base, containers, deepseq, doctest, parsers, semigroups, smallcheck, stgi, tasty, tasty-html, tasty-hunit, tasty-quickcheck, tasty-rerun, tasty-smallcheck, template-haskell, text, th-lift, transformers, trifecta

Files

+ .stylish-haskell.yaml view
@@ -0,0 +1,154 @@+# stylish-haskell configuration file+# ==================================++# The stylish-haskell tool is mainly configured by specifying steps. These steps+# are a list, so they have an order, and one specific step may appear more than+# once (if needed). Each file is processed by these steps in the given order.+steps:+  # Convert some ASCII sequences to their Unicode equivalents. This is disabled+  # by default.+  # - unicode_syntax:+  #     # In order to make this work, we also need to insert the UnicodeSyntax+  #     # language pragma. If this flag is set to true, we insert it when it's+  #     # not already present. You may want to disable it if you configure+  #     # language extensions using some other method than pragmas. Default:+  #     # true.+  #     add_language_pragma: true++  # Import cleanup+  - imports:+      # There are different ways we can align names and lists.+      #+      # - global: Align the import names and import list throughout the entire+      #   file.+      #+      # - file: Like global, but don't add padding when there are no qualified+      #   imports in the file.+      #+      # - group: Only align the imports per group (a group is formed by adjacent+      #   import lines).+      #+      # - none: Do not perform any alignment.+      #+      # Default: global.+      align: group++      # Folowing options affect only import list alignment.+      #+      # List align has following options:+      #+      # - after_alias: Import list is aligned with end of import including+      #   'as' and 'hiding' keywords.+      #+      #   > import qualified Data.List      as List (concat, foldl, foldr, head,+      #   >                                          init, last, length)+      #+      # - with_alias: Import list is aligned with start of alias or hiding.+      #+      #   > import qualified Data.List      as List (concat, foldl, foldr, head,+      #   >                                 init, last, length)+      #+      # - new_line: Import list starts always on new line.+      #+      #   > import qualified Data.List      as List+      #   >     (concat, foldl, foldr, head, init, last, length)+      #+      # Default: after alias+      list_align: after_alias++      # Long list align style takes effect when import is too long. This is+      # determined by 'columns' setting.+      #+      # - inline: This option will put as much specs on same line as possible.+      #+      # - new_line: Import list will start on new line.+      #+      # - new_line_multiline: Import list will start on new line when it's+      #   short enough to fit to single line. Otherwise it'll be multiline.+      #+      # - multiline: One line per import list entry.+      #   Type with contructor list acts like single import.+      #+      #   > import qualified Data.Map as M+      #   >     ( empty+      #   >     , singleton+      #   >     , ...+      #   >     , delete+      #   >     )+      #+      # Default: inline+      long_list_align: new_line_multiline++      # List padding determines indentation of import list on lines after import.+      # This option affects 'list_align' and 'long_list_align'.+      list_padding: 4++      # Separate lists option affects formating of import list for type+      # or class. The only difference is single space between type and list+      # of constructors, selectors and class functions.+      #+      # - true: There is single space between Foldable type and list of it's+      #   functions.+      #+      #   > import Data.Foldable (Foldable (fold, foldl, foldMap))+      #+      # - false: There is no space between Foldable type and list of it's+      #   functions.+      #+      #   > import Data.Foldable (Foldable(fold, foldl, foldMap))+      #+      # Default: true+      separate_lists: true++  # Language pragmas+  - language_pragmas:+      # We can generate different styles of language pragma lists.+      #+      # - vertical: Vertical-spaced language pragmas, one per line.+      #+      # - compact: A more compact style.+      #+      # - compact_line: Similar to compact, but wrap each line with+      #   `{-#LANGUAGE #-}'.+      #+      # Default: vertical.+      style: vertical++      # Align affects alignment of closing pragma brackets.+      #+      # - true: Brackets are aligned in same collumn.+      #+      # - false: Brackets are not aligned together. There is only one space+      #   between actual import and closing bracket.+      #+      # Default: true+      align: true++      # stylish-haskell can detect redundancy of some language pragmas. If this+      # is set to true, it will remove those redundant pragmas. Default: true.+      remove_redundant: true++  # Align the types in record declarations+  # - records: {}++  # Replace tabs by spaces. This is disabled by default.+  # - tabs:+  #     # Number of spaces to use for each tab. Default: 8, as specified by the+  #     # Haskell report.+  #     spaces: 8++  # Remove trailing whitespace+  - trailing_whitespace: {}++# A common setting is the number of columns (parts of) code will be wrapped+# to. Different steps take this into account. Default: 80.+columns: 80++# Sometimes, language extensions are specified in a cabal file or from the+# command line instead of using language pragmas in the file. stylish-haskell+# needs to be aware of these, so it can parse the file correctly.+#+# No language extensions are enabled by default.+# language_extensions:+  # - TemplateHaskell+  # - QuasiQuotes
+ HLint.hs view
@@ -0,0 +1,23 @@+import "hint" HLint.Default+import "hint" HLint.Builtin.All++-- Naming can be useful+ignore "Avoid lambda"+ignore "Redundant lambda"+ignore "Eta reduce"+ignore "Use camelCase"+ignore "Use fromMaybe"+ignore "Use if"+ignore "Use const"+ignore "Use uncurry"++-- AMP fallout+error "generalize mapM"  = mapM  ==> traverse+error "generalize mapM_" = mapM_ ==> traverse_+error "generalize forM"  = forM  ==> for+error "generalize forM_" = forM_ ==> for_+error "Avoid return" =+    return ==> pure+    where note = "return is obsolete as of GHC 7.10"++error "Use parentheses instead of ($)" = f $ x ==> ()
+ LICENSE.md view
@@ -0,0 +1,31 @@+BSD-3 license+=============++Written by David Luposchainsky in 2016. 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 David Luposchainsky nor the names of other+    contributors may be used to endorse or promote products derived+    from this software without specific prior written permission.++This software is provided by the copyright holders and contributors+"as is" and any express or implied warranties, including, but not+limited to, the implied warranties of merchantability and fitness for+a particular purpose are disclaimed. In no event shall the copyright+owner or contributors be liable for any direct, indirect, incidental,+special, exemplary, or consequential damages (including, but not+limited to, procurement of substitute goods or services; loss of use,+data, or profits; or business interruption) however caused and on any+theory of liability, whether in contract, strict liability, or tort+(including negligence or otherwise) arising in any way out of the use+of this software, even if advised of the possibility of such damage.
+ README.md view
@@ -0,0 +1,595 @@+STGi - STG interpreter+======================++STGi is a visual STG implementation to help understand Haskell's execution+model.++It does this by guiding through the runnning of a program, showing stack and+heap, and giving explanations of the applied transition rules. Here what an+intermediate state looks like:++![](screenshot.png)++[![](https://travis-ci.org/quchen/stgi.svg?branch=master)](https://travis-ci.org/quchen/stgi)++Table of contents+-----------------++- [Quickstart guide](#quickstart-guide)+- [About the machine](#about-the-machine)+- [Useful applications](#useful-applications)+- [Language introduction](#language-introduction)+	- [Top-level](#top-level)+    - [The `main` value, termination](#the-main-value-termination)+	- [Expressions](#expressions)+	- [Updates](#updates)+	- [Pitfalls](#pitfalls)+	- [Code example](#code-example)+	- [Marshalling values](#marshalling-values)+- [Runtime behaviour](#runtime-behaviour)+	- [Code segment](#code-segment)+	- [Stack](#stack)+	- [Heap](#heap)+    - [Black holes](#black-holes)+    - [Garbage collection](#garbage-collection)+	- [Unhelpful error message?](#unhelpful-error-message)+- [Differences from the 1992 paper](#differences-from-the-1992-paper)+	- [Grammar](#grammar)+	- [Evaluation](#evaluation)+- [GHC's current STG](#ghcs-current-stg)+++Quickstart guide+----------------++If you want to have a quick look at the STG, here is what you need to get going.+The program should build with both [`stack`][stack] and [`cabal`][cabal].++The `app/Main.hs` file is written so you can easily switch out the `prog` value+for other `Program`s that contain a `main` definition. The `Stg.ExamplePrograms`+module provides a number of examples that might be worth having a look, and are+a good starting point for modifications or adding your own programs. It's+probably easier to read in Haddock format, so go ahead and run++```bash+stack haddock --open stgi+```++and have a look at the example programs.++When you're happy with your `app/Main.hs`, run++```bash+stack build --exec "stgi-exe --colour=true" | less -R+```++to get coloured output in `less`. Type `/====` to search for `====`, which+finds the top of every new step; use `n` (next step) or `N` (previous step) to+navigate through the execution.+++About the machine+-----------------++The spineless tagless graph reduction machine, STG for short, is an automaton+used to map non-strict functional languages onto stock hardware. It was+developed for, and is heavily used in, [the Haskell compiler GHC][ghc].++This project implements an interpreter for the STG as it is [described in the+1992 paper on the subject][stg1992], with the main focus on being nice to a+human user. Things that might be important for an actual compiler backend, such+as performance or static analysis, are not considered in general, only if it+helps the understanding of the STG.++The idea behind the machine is to represent the program in its abstract syntax+tree form. However, due to references to other parts of the syntax tree, a+program is a graph, not a tree. By evaluating this graph using a small set of+rules, it can be systematically reduced to a final value, which will be the+result of the program.++The STG is+  - **spineless** because the graph is not represented as a single data+    structure in memory, but as a set of small, individual parts of the graph+    that reference each other. An important part of the evaluation mechanism is+    how to follow these references.+  - **tagless** because all heap values - unevaluated values, functions, already+    evaluated values - are represented alike on the heap, in form of closures.+    Tag*ful* would mean these closures have to be annotated with things like+    type information, or whether they were previously evaluated already.+  - **graph reducing** because heap objects can be overwritten by simpler values+    the machine has found out to be equivalent. For example, the computation+    `1+1` on the heap might be overwritten by a constant `2` once that result+    has been obtained somewhere.+++Useful applications+-------------------++STGi was started to teach myself about the STG. Not long into the project, I+decided to extend it to save others the many detours I had to take to implement+it. In that sense, it can be a useful tool if you're interested in the+lower-level properties of a Haskell implementation. I did my best to keep the+code readable, and added some decent Haddock/comment coverage. Speaking of+Haddock: it's an excellent tool to start looking around the project before+digging into the source!++The other benefit is for teaching others: instead (or in addition to!) of+explaining certain common Haskell issues on a whiteboard with boxes and arrows,+you can share an interactive view of common programs with others. The example+programs feature some interesting cases.++1. Does this leak memory? On the stack or the heap?+2. I heard GHC doesn't have a call stack?!+3. Why is this value not garbage collected?+4. Why are lists sometimes not very performant?+5. How many steps does this small, innocent function take to produce a result?+++Language introduction+---------------------++The STG language can be seen as a mostly simplified version of Haskell with a+couple of lower level additions. The largest difference is probably that STG is+an untyped language.++The syntax will be discussed below. For now, as an appetizer, the familiar+Haskell code++```haskell+foldl' _ acc [] = acc+foldl' f acc (y:ys) = case f acc y of+	!acc' -> foldl' f acc' ys++sum = foldl' add 0+```++could be translated to++```haskell+foldl' = \f acc xs -> case xs of+    Nil -> acc;+    Cons y ys -> case f acc y of+        acc' -> foldl' f acc' ys;+    badList -> Error_foldl' badList;++sum = \ -> foldl' add zero;++zero = \ -> Int# 0#+```+++### Top-level++An STG program consists of a set of bindings, each of the form++```haskell+name = \(<free vars>) <bound vars> -> <expression body>+```++The right-hand side is called a *lambda form*, and is closely related to the+usual lambda from Haskell.++  - Bound variables are the lambda paramaters just like in Haskell.+  - Free variables are the variables used in the `body` that are not bound or+    global. This means that variables from the parent scope are not+    automatically in scope, but you can get them into scope by adding them to+    the free variables list.++### The `main` value, termination++In the default configuration, program execution starts by moving the definitions+given in the source code onto the heap, and then evaluating the `main` value. It+will continue to run until there is no rule applicable to the current state. Due+to the lazy IO implementation, you can load indefinitely running programs in+your pager application and step as long forward as you want.++### Expressions++Expressions can, in general, be one of a couple of alternatives.++  - **Letrec**++    ```haskell+    letrec <...bindings...> in <expression>+    ```++    Introduce local definitions, just like Haskell's `let`.++  - **Let**++    ```haskell+    let <...bindings...> in <expression>+    ```++    Like `letrec`, but the bindings cannot refer to each other (or themselves).+    In other words, `let` is non-recursive.++  - **Case**++    ```haskell+    case <expression> of <alts>+    ```++    Evaluate the `<expression>` (called scrutinee) to WHNF and continue+    evaluating the matching alternative. Note that the WHNF part makes case+    strict, and indeed it is the *only* construct that does evaluation.++    The `<alts>` are semicolon-separated list of alternatives of the form++    ```haskell+    Constructor <args> -> <expression> -- algebraic+    1# -> <expression>                 -- primitive+    ```++    and can be either all algebraic or all primitive. In case of algebraic+    alternatives, the constructor's arguments are in scope in the following+    expression, just like in Haskell's pattern matching.++    Each list of alts must include a default alternative at the end, which can+    optinally bind a variable.++    ```haskell+    v -> <expression>       -- bound default; v is in scope in the expression+    default -> <expression> -- unbound default+    ```++  - **Function application**++    ```haskell+    function <args>+    ```++    Like Haskell's function application. The `<args>` are primitive values or+    variables.++  - **Primitive application**++    ```haskell+    primop# <arg1> <arg2>+    ```++    Primitive operation on unboxed integers.++    The following operations are supported:++      - Arithmetic+        - `+#`: addition+        - `-#`: subtraction+        - `*#`: multiplication+        - `/#`: integer division (truncated towards -∞)+        - `%#`: modulo (truncated towards -∞)+      - Boolean, returning `1#` for truth and `0#` for falsehood:+        `<#`, `<=#`, `==#`, `/=#`, `>=#`, `>#`++  - **Constructor application**++    ```haskell+    Constructor <args>+    ```++    An algebraic data constructor applied to a number of arguments, just like+    function application. Note that constructors always have to be saturated+    (not partially applied); to get a partially applied constructor, wrap it in+    a lambda form that fills in the missing arguments with parameters.++  - **Primitive literal**++    An integer postfixed with `#`, like `123#`.++For example, Haskell's `maybe` function could be implemented in STG like this:++```haskell+maybe = \nothing just x -> case x of+    Just j   -> just j;+    Nothing  -> nothing;+    badMaybe -> Error_badMaybe badMaybe+```++Some lambda expressions can only contain certain sub-elements; these special+cases are detailed in the sections below. To foreshadow these issues:++- Lambda forms always have lifted (not primitive) type+- Lambda forms with non-empty argument lists and standard constructors are never+  updatable+++### Updates++A lambda form can optionally use a double arrow `=>`, instead of a normal arrow `->`.+This tells the machine to update the lambda form's value in memory once it has+been calculated, so the computation does not have to be repeated should the+value be required again. This is the mechanism that is key to the lazy+evaluation model the STG implements. For example, evaluating `main` in++```haskell+add = <add two boxed ints>+one = \ -> Int# 1#;+two = \ -> Int# 2#;+main = \ => add2 one two+```++would, once the computation returns, overwrite `main` (modulo technical+details) with++```haskell+main = \ -> Int# 3#+```++A couple of things to keep in mind:++- Closures with non-empty argument lists and constructors are already in WHNF,+  so they are never updatable.+- When a value is only entered once, updating it is unnessecary work. Deciding+  whether a potentially updatable closure should actually be updatable is what+  the *update analysis* would do in a compiler when translating into the STG.++++### Pitfalls++- Semicolons are an annoyance that allows the grammar to be simpler. This+  tradeoff was chosen to keep the project's code simpler, but this may change+  in the future.++  For now, the semicolon rule is that **bindings and alternatives are+  semicolon-separated**.++- Lambda forms stand for deferred computations, and as such cannot have+  primitive type, which are always in normal form. To handle primitive types,+  you'll have to box them like in++  ```haskell+  three = \ -> Int# 3#+  ```++  Writing++  ```haskell+  three' = \ -> 3#+  ```++  is invalid, and the machine would halt in an error state. You'll notice that+  the unboxing-boxing business is quite laborious, and this is precisely the+  reason unboxed values alone are so fast in GHC.++- Function application cannot be nested, since function arguments are primitives+  or variables. Haskell's `map f (map g xs)` would be written++  ```haskell+  let map_g_xs = \ -> map g xs+  in map f map_g_xs+  ```++  assuming all variables are in global scope. This means that nesting functions+  in Haskell results in a heap allocation via `let`.++- Free variable values have to be explicitly given to closures. Function+  composition could be implemented like++  ```haskell+  compose = \f g x -> let gx = \(g x) -> g x+                      in f gx+  ```++  Forgetting to hand `g` and `x` to the `gx` lambda form would mean that in the+  `g x` call neither of them was in scope, and the machine would halt with+  a "variable not in scope" error.++  This applies even for recursive functions, which have to be given to+  their own list of free variables, like in `rep` in the following example:++  ```haskell+  replicate = \x -> let rep = \(rep x) -> Cons x rep+  				    in rep+  ```+++### Code example++The 1992 paper gives two implementations of the `map` function in section 4.1.+The first one is the STG version of++```haskell+map f [] = []+map f (y:ys) = f y : map f ys+```++which, in this STG implementation, would be written++```haskell+map = \f xs -> case xs of+    Nil -> Nil;+    Cons y ys -> let fy = \(f y) => f y;+                     mfy = \(f ys) => map f ys+                 in Cons fy mfy;+    badList -> Error_map badList+```++For comparison, the paper's version is++```haskell+map = {} \n {f,xs} -> case xs of+    Nil {} -> Nil {}+    Cons {y,ys} -> let fy = {f,y} \u {} -> f {y}+                       mfy = {f,ys} \u {} -> map {f,ys}+                   in Cons {fy,mfy}+    badList -> Error_map {badList}+```++You can find lots of further examples of standard Haskell functions implemented+by hand in STG in the `Prelude` modules. Combined with the above explanations,+this is all you should need to get started.++++### Marshalling values++The `Stg.Marshal` module provides functions to inject Haskell values into the+STG (`toStg`), and extract them from a machine state again (`toStg`). These+functions are tremendously useful in practice, make use of them! After chasing a+list value on the heap manually you'll know the value of `fromStg`, and in order+to get data structures into the STG you have to write a lot of code, and be+careful doing it at that. Keep in mind that `fromStg` requires the value to  be+in normal form, or extraction will fail.++++Runtime behaviour+-----------------++The following steps are an overview of the evaluation rules. Running the STG in+verbose mode (`-v2`) will provide a more detailed description of what happened+each particular step.++### Code segment++The code segment is the current instruction the machine evaluates.++- **Eval** evaluates expressions.+    - **Function application** pushes the function's arguments on the stack+      and **Enter**s the address of the function.+	- **Constructor applications** simply transition into the+	  **ReturnCon** state when evaluated.+	- Similarly, **primitive ints** transition into the **ReturnInt** state.+	- **Case** pushes a return frame, and proceeds evaluating the scrutinee.+	- **Let(rec)** allocates heap closures, and extends the local environment+	  with the new bindings.+- **Enter** evaluates memory addresses by looking up the value at a memory+  address on the heap, and evaluating its body.+  	- If the closure entered is updatable, push an update frame so it can later+	  be overwritten with the value it evaluates to.+	- If the closure takes any arguments, supply it with values taken from+	  argument frames.+- **ReturnCon** instructs the machine to branch depending on which constructor+  is present, by popping a return frame.+- **ReturnInt** does the same, but for primitive values.++### Stack++The stack has three different kinds of frames.++- **Argument** frames store pending function arguments. They are pushed when+  evaluating a function applied to arguments, and popped when entering a closure+  that has a non-empty argument list.+- **Return** frames are pushed when evaluating a `case` expression, in order to+  know where to continue once the scrutinee has been evaluated. They are popped+  when evaluating constructors or primitive values.+- **Update** frames block access to argument and return frames. If an evaluation+  step needs to pop one of them but there is an update frame in the way, it can+  get rid the update frame by overriding the memory address pointed to by it+  with the current value being evaluated, and retrying the evaluation now that+  the update frame is gone. This mechanism is what enables lazy evaluation in+  the STG.++### Heap++The heap is a mapping from memory addresses to heap objects, which can be+closures or black holes (see below). Heap entries are allocated by `let(rec)`,+and deallocated by garbage collection.++As a visual guide to the user, closures are annotated with `Fun` (takes+arguments), `Con` (data constructors), and `Thunk` (suspended computations).+++### Black holes++The heap does not only contain closures, but also black holes. Black holes are+annotated with the step in which they were created; this annotation is purely+for display purposes, and not used by the machine.++At runtime, when an updatable closure is entered (evaluated), it is overwritten+by a black hole. Black holes do not only provide better overview over what+thunk is currently evaluated, but have two useful technical benefits:++1. Memory mentioned only in the closure is now ready to be collected,+   avoiding certain space leaks. [The 1992 paper][stg1992] gives the following+   example in section 9.3.3:++   ```haskell+   list = \(x) => <long list>+   l = \(list) => last list+   ```++   When entering `l` without black holes, the entire `list` is kept in memory+   until `last` is done. On the other hand, overwriting `l` with a black hole+   upon entering deletes the `last` pointer from it, and `last` can run, and be+   garbage collected, incrementally.++2. Entering a black hole means a thunk depends on itself, allowing the+ interpreter to catch some non-terminating computations with a useful error+++### Garbage collection++Currently, two garbage collection algorithms are implemented:++- **Tri-state tracing**: free all unused memory addresses, and does not touch+  the others. This makes following specific closures on the heap easy.+- **Two-space copying**: move all used memory addresses to the beginning of the+  heap, and discard all those that weren't moved. This has the advantage of+  reordering the heap roughly in the order the closures will be accessed by the+  program again, but the disadvantage of making things harder to track, since+  for example the `main` value might appear in several different locations+  throughout the run of a program.+++### Unhelpful error message?++The goal of this project is being useful to human readers. If you find an error+message that is unhelpful or even misleading, please open an issue with a+minimal example on how to reproduce it!++++Differences from the 1992 paper+-------------------------------++### Grammar++- Function application uses no parentheses or commas like in Haskell `f x y z`,+  not with curly parentheses and commas like in the paper `f {x,y,z}`.+- Comment syntax like in Haskell+- Constructors can end with a `#` to allow labelling primitive boxes+  e.g. with `Int#`.+- A lambda's head is written `\(free) bound -> body`, where `free` and+  `bound` are space-separated variable lists, instead of the paper's+  `{free} \n {bound} -> body`, which uses comma-separated lists. The+  update flag `\u` is signified using a double arrow `=>` instead of the+  normal arrow `->`.++### Evaluation++- The three stacks from the operational semantics given in the paper - argument,+  return, and update - are unified into a single one, since they run+  synchronously anyway. This makes the current location in the evaluation much+  clearer, since the stack is always popped from the top. For example, having a+  return frame at the top means the program is close to a `case` expression.+- Although heap closures are all represented alike, they are classified for the+  user in the visual output:+    - Constructors are closures with a constructor application body, and+      only free variables.+    - Other closures with only free variables are thunks.+    - Closures with non-empty argument lists are functions.++++GHC's current STG+-----------------++The implementation here uses the *push/enter* evaluation model of the STG, which+is fairly elegant, and was initially thought to also be top in terms of+performance. As it turned out, the latter is not the case, and another+evaluation model called *eval/apply*, which treats (only) function application a+bit different, is faster in practice.++This notable revision is documented in [the 2004 paper *How to make a fast+curry*][fastcurry]. I don't have plans to support this evaluation model right+now, but it's on my list of long-term goals (alongside the current push/enter).++++[cabal]: https://www.haskell.org/cabal/+[fastcurry]: http://research.microsoft.com/en-us/um/people/simonpj/papers/eval-apply/+[ghc]: https://www.haskell.org/ghc/+[stack]: http://haskellstack.org/+[stg1992]: http://research.microsoft.com/apps/pubs/default.aspx?id=67083
+ Setup.hs view
@@ -0,0 +1,2 @@+import           Distribution.Simple+main = defaultMain
+ app/CmdLineArgs.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE LambdaCase        #-}+{-# LANGUAGE OverloadedStrings #-}++module CmdLineArgs (+    parseCmdArgs,+    Options(..),+) where++++import System.Console.GetOpt+import Text.Read++++data Options = Options+    { optAnsi      :: Maybe Bool+    , optNumStates :: Maybe Int+    , optVerbosity :: Int }++defOptions :: Options+defOptions = Options { optAnsi      = Nothing+                     , optNumStates = Nothing+                     , optVerbosity = defaultVerbosity }++defaultVerbosity :: Int+defaultVerbosity = 2++options :: [OptDescr (Options -> Options)]+options =+    [ Option ['c'] ["colour"]+        (OptArg+            (\x ->+                let parsed = case x of+                        Nothing      -> Just True+                        Just "auto"  -> Nothing+                        Just "false" -> Just False+                        Just "true"  -> Just True+                        Just _       -> Just False+                in \opts -> opts { optAnsi = parsed } )+            "auto|false|true" )+        "Colourize output"+    , Option ['n'] ["showStates"]+        (OptArg+            (\x ->+                let parsed = case x >>= readMaybe of+                        Just n | n == 0    -> Nothing+                               | otherwise -> Just n+                        Nothing            -> Nothing+                in \opts -> opts { optNumStates = parsed } )+            "int" )+        "Colourize output"+    , Option ['v'] ["verbosity"]+        (OptArg+            (\x ->+                let parsed = case x >>= readMaybe of+                        Just n | 0 <= n && n <= 2 -> n+                        _otherwise                -> defaultVerbosity+                in \opts -> opts { optVerbosity = parsed } )+            "0,1,2" )+        "Verbosity" ]++parseCmdArgs :: [String] -> IO Options+parseCmdArgs argv = case getOpt Permute options argv of+    (o,_,[]) -> pure (foldr id defOptions o)+    (_,_,errs) -> ioError (userError (concat errs ++ usageInfo header options))+  where+    header = "Usage: $0 [OPTION...]"
+ app/Main.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE LambdaCase        #-}+{-# LANGUAGE OverloadedStrings #-}++module Main (main) where++++import System.Console.ANSI (hSupportsANSI)+import System.Environment+import System.IO           (stdout)++import           CmdLineArgs+import qualified Stg.ExamplePrograms      as Example+import           Stg.Language.Prettyprint+import           Stg.RunForPager++++main :: IO ()+main = do+    opts <- parseCmdArgs =<< getArgs++    ansi <- case optAnsi opts of+        Just x -> pure x+        Nothing -> hSupportsANSI stdout+    let numStates = optNumStates opts+        verbosity = optVerbosity opts++    let prog = Example.addTwoNumbers 1 2++    runForPager (if ansi then prettyprint else prettyprintPlain)+                numStates+                verbosity+                prog
+ app/Stg/RunForPager.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE MultiWayIf        #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes        #-}++-- | Run a STG program with output suitable for use in a pager, such as @less@.+module Stg.RunForPager (runForPager) where++++import           Control.Monad+import           Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NE+import           Data.Monoid+import           Data.Text          (Text)+import qualified Data.Text          as T+import qualified Data.Text.IO       as T++import Stg.Language+import Stg.Machine+import Stg.Machine.Types+import Stg.Util++++runForPager+    :: (forall a. Pretty a => a -> Text)+    -> Maybe Int -- ^ Steps to show. Negative numbers count from the end.+    -> Int       -- ^ Verbosity level+    -> Program+    -> IO ()+runForPager ppr showSteps verbosity prog =+    let allStates = evalsUntil RunIndefinitely+                               (HaltIf (const False))+                               (PerformGc (const (Just triStateTracing)))+                               (initialState "main" prog)+        states = case showSteps of+            Just n | n > 0 -> NE.fromList (NE.take n allStates)+                   | n < 0 -> unsafeTakeLast (abs n) allStates+            _else -> allStates+        line = T.replicate 80 "-"+        fatLine = T.replicate 80 "="+    in do+        T.putStrLn fatLine+        T.putStrLn "Program:"+        T.putStrLn line+        T.putStrLn (ppr prog)+        let loop (state :| rest) = do+                T.putStrLn fatLine+                printInfo ppr verbosity state line+                T.putStrLn (ppr state)+                case rest of+                    [] -> pure state+                    (s:ss) -> loop (s:|ss)+        _finalState <- loop states+        T.putStrLn fatLine++printInfo+    :: (forall a. Pretty a => a -> Text)+    -> Int+    -> StgState+    -> Text -- ^ Line+    -> IO ()+printInfo ppr verbosity state line =+    when (verbosity > 0)+        (do T.putStr (show' (stgSteps state) <> ". ")+            T.putStrLn+                (if | verbosity == 2 -> ppr (stgInfo state)+                    | verbosity == 1 -> ppr (let Info shortInfo _ = stgInfo state+                                             in shortInfo ))+            T.putStrLn line )++-- | Take the last N elements of a list (in original order).+--+-- Number of takes must be at least 1!+unsafeTakeLast :: Int -> NonEmpty a -> NonEmpty a+unsafeTakeLast n _ | n <= 0 = error "unsafeTakeLast: argument must be >= 1"+unsafeTakeLast n list+  = let list' = NE.toList list+    in NE.fromList (zipOverflow (drop n list') list')+  where+    zipOverflow (_:xs) (_:ys) = zipOverflow xs ys+    zipOverflow xs [] = xs+    zipOverflow [] ys = ys
+ screenshot.png view

binary file changed (absent → 44572 bytes)

+ src/Data/Stack.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies      #-}++-- | A simple stack type. Very similar to an ordinary list, but with a more+-- specialized API.+module Data.Stack (+    Stack(..),+    forEachPop,+    (<>>),+    span,+) where++++import           Control.DeepSeq+import           Data.Foldable                as F+import           Data.Monoid+import qualified GHC.Exts                     as OL+import           Prelude                      hiding (span)+import qualified Prelude                      as P+import           Text.PrettyPrint.ANSI.Leijen hiding (list, (<>))++++-- | The usual stack data structure.+data Stack a = Empty | a :< Stack a+    deriving (Eq, Ord)++instance Show a => Show (Stack a) where+    show = show . toList++instance Pretty a => Pretty (Stack a) where+    pretty = prettyList . toList++instance Functor Stack where+    fmap _ Empty = Empty+    fmap f (x :< xs) = f x :< fmap f xs++instance Foldable Stack where+    foldMap _ Empty = mempty+    foldMap f (x :< xs) = f x <> foldMap f xs++instance Monoid (Stack a) where+    mempty = Empty+    Empty `mappend` s = s+    (x :< xs) `mappend` ys = x :< (xs <> ys)++instance OL.IsList (Stack a) where+    type Item (Stack a) = a+    fromList = foldr (:<) Empty+    toList = F.toList++instance NFData a => NFData (Stack a) where+    rnf Empty = ()+    rnf (x :< xs) = rnf x `seq` rnf xs++-- | Push a list of items onto the stack. The first item will be at the+-- top of the stack.+(<>>) :: [a] -> Stack a -> Stack a+list <>> stack = foldr (:<) stack list++-- | For each list element, pop one element off the stack. Fail if not enough+-- elements are on the stack.+forEachPop :: [x] -> Stack a -> Maybe ([a], Stack a)+forEachPop (_:_) Empty = Nothing+forEachPop [] stack = Just ([], stack)+forEachPop (_:xs) (s :< stack) = case forEachPop xs stack of+    Nothing -> Nothing+    Just (pops, rest) -> Just (s:pops, rest)++-- | Like 'Prelude.span' for lists.+span :: (a -> Bool) -> Stack a -> (Stack a, Stack a)+span p stack = let (a,b) = P.span p (toList stack)+                in (OL.fromList a, OL.fromList b)
+ src/Stg/ExamplePrograms.hs view
@@ -0,0 +1,412 @@+{-# LANGUAGE LambdaCase        #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes       #-}++-- | A collection of  example programs that might be interesting to look  at+-- during execution.+module Stg.ExamplePrograms (++    -- * Simple introductory programs++        addTwoNumbers,+        calculateLength,++    -- * Sum of list++        -- ** via 'Data.Foldable.foldl''+        sum_foldl',++        -- ** via 'Data.Foldable.foldl'' implemented with 'foldr'+        sum_foldl'ViaFoldr,++        -- ** via 'foldl'+        sum_foldl,++        -- ** via 'foldr'+        sum_foldr,+++    -- * Fibonacci++        -- ** Naive implementation (exponential time)+        fibonacciNaive,++        -- ** Improved implementation (linear time)+        fibonacciImproved,++        -- ** Infinite list with zipWith (+)+        fibonacciZipWith,+++    -- * List concatenation++        -- | It is well-known that Haskell's (++) operator is linear if+        -- associated to the right, but quadratic when associated to the left.+        -- These two examples showcase the issue.++        -- ** Right-associated+        listConcatRightAssociated,++        -- ** Left-associated+        listConcatLeftAssociated,++    -- * Sorting+    naiveSort,+    librarySort,++    -- * Sharing++        -- ** Repeat+        repeatNaive,+        repeatSharing,+) where++++import           Data.Monoid+import           Stg.Language+import           Stg.Marshal+import           Stg.Parser.QuasiQuoter+import qualified Stg.Prelude            as Stg++++++-- | A program that adds two numbers.+addTwoNumbers :: Integer -> Integer -> Program+addTwoNumbers x y = mconcat+    [ Stg.add+    , toStg "x" x+    , toStg "y" y+    , [program|+    main = \ => add x y+    |]]++-- | A program that measures the length of a list.+calculateLength :: [Integer] -> Program+calculateLength xs = mconcat+    [ Stg.length+    , toStg "xs" xs+    , [program|+    main = \ => case length xs of r -> r+    |]]++++-- | Program to sum up a list, but with the @sum@ function left undefined.+sumTemplate :: [Integer] -> Program+sumTemplate list = mconcat+    [ Stg.add+    , toStg "zero" (0 :: Integer)+    , toStg "list" list+    , [program| main = \ => sum list |]]++-- | Sum up a list of 'Integer's using+--+-- @+-- sum = 'Data.Foldable.foldl'' ('+') 0+-- @+--+-- This is a good way to sum up a list in Haskell, as it runs in constant space.+sum_foldl' :: [Integer] -> Program+sum_foldl' list = mconcat+    [ sumTemplate list+    , Stg.foldl'+    , [program| sum = \ -> foldl' add zero |]]++-- | Sum up a list of 'Integer's using+--+-- @+-- sum = 'Data.Foldable.foldl'' ('+') 0+-- @+--+-- where 'Data.Foldable.foldl'' is implemented via 'foldr' as+--+-- @+-- foldl' f z ys = 'foldr' (\x xs acc -> xs '$!' f acc x) id ys z+-- @+--+-- which is a standard "'Data.Foldable.foldl'' in terms of 'foldr'" definition.+-- This definition is denotationally equivalent to the standard+-- 'Data.Foldable.foldl'', but has a bit more computational overhead.+sum_foldl'ViaFoldr :: [Integer] -> Program+sum_foldl'ViaFoldr list = mconcat+    [ sumTemplate list+    , Stg.id+    , Stg.foldr+    , [program|+    sum = \ -> foldl' add zero;+    foldl' = \f z xs ->+        let go = \(f) x xs acc -> case f acc x of+                forced -> xs forced+        in foldr go id xs z+    |]]++-- | Sum up a list of 'Integer's using+--+-- @+-- sum = 'foldl' ('+') 0+-- @+--+-- This is the canonical space leak in Haskell: note how the accumulator is+-- lazy, resulting in a large thunk buildup of suspended additions, that is only+-- collapsed to a final value after 'foldl' has terminated. The thunks are+-- stored on the heap, so it grows linearly with the length of the list. When+-- that thunk is forced, it will push lots of additions on the stack; in+-- summary, this produces a heap overflow, and if the heap is not exhausted, it+-- will try to overflow the stack.+sum_foldl :: [Integer] -> Program+sum_foldl list = mconcat+    [ sumTemplate list+    , Stg.foldl+    , [program| sum = \ -> foldl add zero |]]++-- | Sum up a list of 'Integer's using+--+-- @+-- sum = 'foldr' ('+') 0+-- @+--+-- Like the 'foldl' version demonstrated in 'sum_foldl', this is a space-leaking+-- implementation of the sum of a list. In this case however, the leak spills to+-- the stack and the heap alike: the stack contains the continuations for the+-- additions, while the heap contains thunks for the recursive call to @foldr@.+sum_foldr :: [Integer] -> Program+sum_foldr list = mconcat+    [ sumTemplate list+    , Stg.foldr+    , [program| sum = \ -> foldr add zero |]]++++-- | Compute the list of Fibonacci numbers eagerly in the contents, but lazy in+-- the spine.+--+-- This means that the program will successively generate all the Fibonacci+-- numbers, allocating new cells of the infinite list and calculating their new+-- values, and garbage collecting previous values.+--+-- You can picture this as what happens to `fibo` in the Haskell program+--+-- @+-- main = let fibo = 'zipWith' ('+') fibo ('tail' fibo)+--        in 'Data.Foldable.traverse_' 'print' fibo+-- @+fibonacciZipWith :: Program+fibonacciZipWith = mconcat+    [ Stg.add+    , toStg "zero" (0 :: Integer)+    , Stg.foldl'+    , Stg.zipWith+    , [program|++    flipConst = \x y -> y;+    main = \ =>+        letrec+            fibo = \ =>+                letrec+                    fib0 = \(fib1) -> Cons zero fib1;+                    fib1 = \(fib2) =>+                        let one = \ -> Int# 1#+                        in Cons one fib2;+                    fib2 = \(fib0 fib1) => zipWith add fib0 fib1+                in fib0+        in foldl' flipConst zero fibo+    |]]++-- | Calculate the n-th Fibonacci number using the computationally (horribly)+-- inefficient formula+--+-- @+-- fib n | n <= 1 = n+-- fib n = fib (n-1) + fib (n-2)+-- @+--+-- This implementation is stack-only, so enjoy watching it explode. At the time+-- of writing this, the machine takes:+--+-- * fib  0  =>    27 steps+-- * fib  1  =>    27 steps+-- * fib  2  =>   122 steps+-- * fib  3  =>   218 steps+-- * fib  4  =>   410 steps+-- * fib  5  =>   698 steps+-- * fib  6  =>  1178 steps+-- * fib  7  =>  1946 steps+-- * fib  8  =>  3194 steps+-- * fib  9  =>  5210 steps+-- * fib 10  =>  8474 steps+fibonacciNaive :: Integer -> Program+fibonacciNaive n = mconcat+    [ Stg.add+    , Stg.leq_Int+    , Stg.sub+    , toStg "one" (1 :: Integer)+    , toStg "n" n+    , [program|+    main = \ =>+        letrec+            fib = \(fib) n -> case leq_Int n one of+            True -> n;+            _False -> case sub n one of+                nMinusOne -> case fib nMinusOne of+                    fibNMinusOne -> case sub nMinusOne one of+                        nMinusTwo -> case fib nMinusTwo of+                            fibNMinusTwo -> case add fibNMinusOne fibNMinusTwo of+                                result -> result+        in fib n+    |]]++-- | Calculate the n-th Fibonacci number using the more effective formula+--+-- @+-- fib = fib' 0 1+--   where+--     fib' x _ | n <= 0 = x+--     fib' x !y n = fib' y (x+y) (n-1)+-- @+--+-- This implementation is a lot faster than the naive exponential+-- implementation. For examle, calculating the 10th Fibonacci number (55) takes+-- only 490 steps, compared to the many thousand of the exponential version.+fibonacciImproved :: Integer -> Program+fibonacciImproved n = mconcat+    [ Stg.add+    , Stg.leq_Int+    , Stg.sub+    , toStg "zero" (0 :: Integer)+    , toStg "one" (1 :: Integer)+    , toStg "n" n+    , [program|+    main = \ =>+        letrec+            fib = \(fib') -> fib' zero one;+            fib' = \(fib') x y n -> case leq_Int n zero of+                True -> x;+                _False -> case add x y of+                    xy -> case sub n one of+                        nMinusOne -> fib' y xy nMinusOne+        in fib n+    |]]++-- | List concatenation example with the 'concat' definition left out.+listConcatTemplate :: [[Integer]] -> Program+listConcatTemplate xss = mconcat+    [ toStg "xss" xss+    , Stg.concat2+    , [program|++    forceList = \xs -> case xs of+        Nil -> Done;+        Cons _ xs' -> forceList xs';+        _ -> BadListError;++    concatenated = \ => concat xss;+    main = \ => case forceList concatenated of+        _ -> concatenated++    |]]++-- | Force a right-associated concatenation+--+-- @+-- [0] '++' ([1] '++' ([2] '++' ([3])))+-- @+--+-- and store it in the @main@ closure.+--+-- This computation is __linear__ in the number of elements of the sublists.+listConcatRightAssociated :: [[Integer]] -> Program+listConcatRightAssociated xss = mconcat+    [ listConcatTemplate xss+    , Stg.foldr+    , [program| concat = \ -> foldr concat2 nil |]]++-- | Force a left-associated concatenation+--+-- @+-- (([0] '++' [1]) '++' [2]) '++' [3]+-- @+--+-- and store it in the @main@ closure.+--+-- This computation is __quadratic__ in the number of elements of the sublists.+listConcatLeftAssociated :: [[Integer]] -> Program+listConcatLeftAssociated xss = mconcat+    [ listConcatTemplate xss+    , Stg.foldl'+    , [program| concat = \ -> foldl' concat2 nil |]]++-- | Sort a list with the canonical Quicksort-inspired algorithm often found+-- in introductory texts about Haskell.+--+-- Note that this is not Quicksort itself, as one key feature of it is sorting+-- in-place. In particular, this algorithm is not all that quick, as it takes+-- almost a thousand steps to reach the final state when sorting @[5,4,3,2,1]@.+naiveSort :: [Integer] -> Program+naiveSort xs =+    toStg "xs" xs+    <> Stg.forceSpine+    <> Stg.naiveSort+    <> [program|+        sorted = \ => naiveSort xs;+        main = \ => forceSpine sorted |]++-- | Sort a list with a translation of Haskell's 'Data.List.sort', which is+-- an implementation of mergesort with ordered sublist detection.+librarySort :: [Integer] -> Program+librarySort xs =+    toStg "xs" xs+    <> Stg.forceSpine+    <> Stg.sort+    <> [program|+        sorted = \ => sort xs;+        main = \ => forceSpine sorted |]++++-- | This is a naive implementation of the 'repeat' function,+--+-- @+-- 'repeat' x = x : 'repeat' x+-- @+--+-- and it is used to compute the infinite repetition of a number. Run this+-- program for a couple hundred steps and observe the heap and the garbage+-- collector. Count the GC invocations, and compare it to the behaviour of+-- 'repeatSharing'! Also note how long it takes to generate two successive+-- list elements.+--+-- The reason for this behaviour is that the call to @'repeat' x@ is not shared,+-- but done again for each cons cell, requiring one heap allocation every time.+-- Cleaning up after this keeps the GC quite busy.+repeatNaive :: Program+repeatNaive = repeatSharing <> [program|+    repeat = \x ->+        let repeatX = \(x) -> repeat x+        in Cons x repeatX+    |]++-- | This uses a much better definition of 'repeat',+--+-- @+-- 'repeat' x = let repeatX = x : repeatX+--            in repeatX+-- @+--+-- This program does only a total of three heap allocations before continously+-- running without interruption: one for the @repeated@ value, one for the+-- self-referencing cons cell, and one beacuse of how 'Stg.forceSpine' works.+--+-- Note how much smaller the cycles between the traversal of two neighbouring+-- list cells is!+repeatSharing :: Program+repeatSharing = mconcat+    [ Stg.forceSpine+    , Stg.repeat+    , [program|+    main = \ =>+        let repeated = \ -> repeat 1#+        in case forceSpine repeated of v -> v+    |]]
+ src/Stg/Language.hs view
@@ -0,0 +1,404 @@+{-# LANGUAGE DeriveGeneric     #-}+{-# LANGUAGE LambdaCase        #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell   #-}++-- | The STG language syntax tree, modeled after the description in the+-- 1992 paper+-- <http://research.microsoft.com/apps/pubs/default.aspx?id=67083 (link)>.+--+-- A 'Program' is typically created using functionality provided by the+-- "Stg.Parser" module, as opposed to manually combining the data types given+-- in this module.+--+-- For plenty of comparisons of STG language source and generated parse trees,+-- have a look at the "Stg.Parser.QuasiQuoter" module.+module Stg.Language (+    Program        (..),+    Binds          (..),+    LambdaForm     (..),+    prettyLambda,+    UpdateFlag     (..),+    Rec            (..),+    Expr           (..),+    Alts           (..),+    NonDefaultAlts (..),+    AlgebraicAlt   (..),+    PrimitiveAlt   (..),+    DefaultAlt     (..),+    Literal        (..),+    PrimOp         (..),+    Var            (..),+    Atom           (..),+    Constr         (..),+    Pretty         (..),++    -- * Meta information+    classify,+    LambdaType(..),+) where++++import           Control.DeepSeq+import           Data.List.NonEmpty           (NonEmpty (..))+import qualified Data.List.NonEmpty           as NonEmpty+import           Data.Map                     (Map)+import qualified Data.Map                     as M+import           Data.Monoid                  hiding (Alt)+import           Data.Text                    (Text)+import qualified Data.Text                    as T+import           GHC.Exts+import           GHC.Generics+import           Language.Haskell.TH.Lift+import           Text.PrettyPrint.ANSI.Leijen hiding ((<>))++-- $setup+-- >>> :set -XQuasiQuotes+-- >>> import Stg.Parser.QuasiQuoter++++-- | Package of style definitions used for prettyprinting the STG AST.+data StgAstStyle = StgAstStyle+    { keyword :: Doc -> Doc+        -- ^ Keyword style+    , prim :: Doc -> Doc+        -- ^ Primitive style, for literals and functions+    , variable :: Doc -> Doc+        -- ^ Variable style+    , constructor :: Doc -> Doc+        -- ^ Constructor style+    , semicolon :: Doc -> Doc+        -- ^ Semicolons separating lists of bindings and alternatives+    }++-- | Colour definitions used by the STG AST.+style :: StgAstStyle+style = StgAstStyle+    { keyword     = id+    , prim        = dullgreen+    , variable    = dullyellow+    , constructor = dullmagenta+    , semicolon   = dullwhite+    }++++-- | An STG program consists of bindings.+newtype Program = Program Binds+    deriving (Eq, Ord, Show, Generic)++-- | Left-biased union of the contained bindings.+instance Monoid Program where+    mempty = Program mempty+    Program x `mappend` Program y = Program (x <> y)++-- | Bindings are collections of lambda forms, indexed over variables.+--+-- They exist at the top level, or as part of a let(rec) binding.+newtype Binds = Binds (Map Var LambdaForm)+    deriving (Eq, Ord, Generic)++-- | __Right-biased__ union of binds. This makes it easier to overwrite modify+-- definitions from other programs. For example, if you have one program that+-- has a certain definition of 'map', you can write+--+-- @+-- program' = program <> [stg| map = ... |]+-- @+--+-- to make it use your own version.+instance Monoid Binds where+    mempty = Binds mempty+    Binds x `mappend` Binds y = Binds (y <> x)++instance Show Binds where+    show (Binds binds) = "(Binds " <> show (M.assocs binds) <> ")"++-- | A lambda form unifies free and bound variables associated with a function+-- body. The lambda body must not be of primitive type, as this would imply+-- the value is both boxed and unboxed.+--+-- >>> [stg| \(x) y z -> expr x z |]+-- LambdaForm [Var "x"] NoUpdate [Var "y",Var "z"] (AppF (Var "expr") [AtomVar (Var "x"),AtomVar (Var "z")])+data LambdaForm = LambdaForm ![Var] !UpdateFlag ![Var] !Expr+    deriving (Eq, Ord, Show, Generic)++-- | Possible classification of lambda forms.+data LambdaType =+      LambdaCon   -- ^ Data constructor ('AppC' as body)+    | LambdaFun   -- ^ Function (lambda with non-empty argument list)+    | LambdaThunk -- ^ Thunk (everything else)+    deriving (Eq, Ord, Show)++instance Pretty LambdaType where+    pretty = \case+        LambdaCon -> "Con"+        LambdaFun -> "Fun"+        LambdaThunk -> "Thunk"++-- | Classify the type of a lambda form based on its shape.+classify :: LambdaForm -> LambdaType+classify = \case+    LambdaForm _ _ [] AppC{} -> LambdaCon+    LambdaForm _ _ (_:_) _   -> LambdaFun+    LambdaForm _ _ []    _   -> LambdaThunk++-- | The update flag distinguishes updateable from non-updateable lambda forms.+--+-- The former will be overwritten in-place when it is evaluated, allowing+-- the calculation of a thunk to be shared among multiple uses of the+-- same value.+data UpdateFlag = Update | NoUpdate+    deriving (Eq, Ord, Show, Generic, Enum, Bounded)++-- | Distinguishes @let@ from @letrec@.+data Rec = NonRecursive | Recursive+    deriving (Eq, Ord, Show, Generic, Enum, Bounded)++-- | An expression in the STG language.+data Expr =+      Let !Rec !Binds !Expr    -- ^ Let expression @let(rec) ... in ...@+    | Case !Expr !Alts         -- ^ Case expression @case ... of ... x -> y@+    | AppF !Var ![Atom]        -- ^ Function application @f x y z@+    | AppC !Constr ![Atom]     -- ^ Saturated constructor application @Just a@+    | AppP !PrimOp !Atom !Atom -- ^ Primitive function application @+# 1# 2#@+    | Lit !Literal             -- ^ Literal expression @1#@+    deriving (Eq, Ord, Show, Generic)++-- | List of possible alternatives in a 'Case' expression.+--+-- The list of alts has to be homogeneous. This is not ensured by the type+-- system, and should be handled by the parser instead.+data Alts = Alts !NonDefaultAlts !DefaultAlt+    deriving (Eq, Ord, Show, Generic)++-- | The part of a 'Case' alternative that's not the default.+data NonDefaultAlts =+      NoNonDefaultAlts+        -- ^ Used in 'case' statements that consist only of a default+        -- alternative. These can be useful to force or unpack values.++    | AlgebraicAlts !(NonEmpty AlgebraicAlt)+        -- ^ Algebraic alternative, like @Cons x xs@.++    | PrimitiveAlts !(NonEmpty PrimitiveAlt)+        -- ^ Primitive alternative, like @1#@.+    deriving (Eq, Ord, Show, Generic)++-- | As in @True | False@+data AlgebraicAlt = AlgebraicAlt !Constr ![Var] !Expr+    deriving (Eq, Ord, Show, Generic)++-- | As in @1#@, @2#@, @3#@+data PrimitiveAlt = PrimitiveAlt !Literal !Expr+    deriving (Eq, Ord, Show, Generic)++-- | If no viable alternative is found in a pattern match, use a 'DefaultAlt'+-- as fallback.+data DefaultAlt =+       DefaultNotBound !Expr+     | DefaultBound !Var !Expr+    deriving (Eq, Ord, Show, Generic)++-- | Literals are the basis of primitive operations.+newtype Literal = Literal Integer+    deriving (Eq, Ord, Show, Generic)++-- | Primitive operations.+data PrimOp =+      Add -- ^ @+@+    | Sub -- ^ @-@+    | Mul -- ^ @*@+    | Div -- ^ @/@+    | Mod -- ^ @%@+    | Eq  -- ^ @==@+    | Lt  -- ^ @<@+    | Leq -- ^ @<=@+    | Gt  -- ^ @>@+    | Geq -- ^ @>=@+    | Neq -- ^ @/=@+    deriving (Eq, Ord, Show, Generic, Bounded, Enum)++-- | Variable.+newtype Var = Var Text+    deriving (Eq, Ord, Show, Generic)++instance IsString Var where fromString = coerce . T.pack++-- | Smallest unit of data. Atoms unify variables and literals, and are what+-- functions take as arguments.+data Atom =+      AtomVar !Var+    | AtomLit !Literal+    deriving (Eq, Ord, Show, Generic)++-- | Constructors of algebraic data types.+newtype Constr = Constr Text+    deriving (Eq, Ord, Show, Generic)++instance IsString Constr where fromString = coerce . T.pack++++--------------------------------------------------------------------------------+-- Lift instances+deriveLiftMany [ ''Program, ''Literal, ''LambdaForm, ''UpdateFlag, ''Rec+               , ''Expr, ''Alts, ''AlgebraicAlt, ''PrimitiveAlt, ''DefaultAlt+               , ''PrimOp, ''Atom ]++instance Lift NonDefaultAlts where+    lift NoNonDefaultAlts = [| NoNonDefaultAlts |]+    lift (AlgebraicAlts alts) =+        [| AlgebraicAlts (NonEmpty.fromList $(lift (toList alts))) |]+    lift (PrimitiveAlts alts) =+        [| PrimitiveAlts (NonEmpty.fromList $(lift (toList alts))) |]++instance Lift Binds where+    lift (Binds binds) = [| Binds (M.fromList $(lift (M.assocs binds))) |]++instance Lift Constr where+    lift (Constr con) = [| Constr (T.pack $(lift (T.unpack con))) |]++instance Lift Var where+    lift (Var var) = [| Var (T.pack $(lift (T.unpack var))) |]++++--------------------------------------------------------------------------------+-- Pretty instances++semicolonTerminated :: [Doc] -> Doc+semicolonTerminated = align . vsep . punctuate (semicolon style ";")++instance Pretty Program where+    pretty (Program binds) = pretty binds++instance Pretty Binds where+    pretty (Binds bs) =+        (semicolonTerminated . map prettyBinding . M.assocs) bs+      where+        prettyBinding (var, lambda) =+            pretty var <+> "=" <+> pretty lambda++-- | Prettyprint a 'LambdaForm', given prettyprinters for the free variable+-- list.+--+-- Introduced so 'Stg.Machine.Types.Closure' can hijack it to display+-- the free value list differently.+prettyLambda+    :: ([Var] -> Doc) -- ^ Free variable list printer+    -> LambdaForm+    -> Doc+prettyLambda pprFree (LambdaForm free upd bound expr) =+    (prettyExp . prettyUpd . prettyBound . prettyFree) "\\"+  where+    prettyFree | null free = id+               | otherwise = (<> lparen <> pprFree free <> rparen)+    prettyUpd = (<+> case upd of Update   -> "=>"+                                 NoUpdate -> "->" )+    prettyBound | null bound = id+                | null free = (<> prettyList bound)+                | otherwise = (<+> prettyList bound)+    prettyExp = (<+> pretty expr)++instance Pretty LambdaForm where+    pretty = prettyLambda prettyList++instance Pretty Rec where+    pretty = \case+        NonRecursive -> ""+        Recursive    -> "rec"++instance Pretty Expr where+    pretty = \case+        Let rec binds expr ->+            let inBlock = indent 4 (keyword style "in" <+> pretty expr)+                bindingBlock = line <> indent 4 (+                    keyword style ("let" <> pretty rec) <+> pretty binds )+            in vsep [bindingBlock, inBlock]++        Case expr alts -> vsep [ hsep [ keyword style "case"+                                      , pretty expr+                                      , keyword style "of" ]+                               , indent 4 (align (pretty alts)) ]++        AppF var []   -> pretty var+        AppF var args -> pretty var <+> prettyList args++        AppC con []   -> pretty con+        AppC con args -> pretty con <+> prettyList args++        AppP op arg1 arg2 -> pretty op <+> pretty arg1 <+> pretty arg2++        Lit lit -> pretty lit++instance Pretty Alts where+    pretty (Alts NoNonDefaultAlts def) = pretty def+    pretty (Alts (AlgebraicAlts alts) def) =+        semicolonTerminated (map pretty (toList alts) <> [pretty def])+    pretty (Alts (PrimitiveAlts alts) def) =+        semicolonTerminated (map pretty (toList alts) <> [pretty def])++instance Pretty AlgebraicAlt where+    pretty (AlgebraicAlt con [] expr)+        = pretty con <+> "->" <+> pretty expr+    pretty (AlgebraicAlt con args expr)+        = pretty con <+> prettyList args <+> "->" <+> pretty expr++instance Pretty PrimitiveAlt where+    pretty (PrimitiveAlt lit expr) =+        pretty lit <+> "->" <+> pretty expr++instance Pretty DefaultAlt where+    pretty = \case+        DefaultNotBound expr  -> "default" <+> "->" <+> pretty expr+        DefaultBound var expr -> pretty var <+> "->" <+> pretty expr++instance Pretty Literal where+    pretty (Literal i) = prim style (integer i <> "#")++instance Pretty PrimOp where+    pretty op = prim style (case op of+        Add -> "+#"+        Sub -> "-#"+        Mul -> "*#"+        Div -> "/#"+        Mod -> "%#"+        Eq  -> "==#"+        Lt  -> "<#"+        Leq -> "<=#"+        Gt  -> ">#"+        Geq -> ">=#"+        Neq -> "/=#" )++instance Pretty Var where+    pretty (Var name) = variable style (string (T.unpack name))+    prettyList = hsep . map pretty++instance Pretty Atom where+    pretty = \case+        AtomVar var -> pretty var+        AtomLit lit -> pretty lit+    prettyList = hsep . map pretty++instance Pretty Constr where+    pretty (Constr name) = constructor style (string (T.unpack name))++instance NFData Program+instance NFData Binds+instance NFData LambdaForm+instance NFData UpdateFlag+instance NFData Rec+instance NFData Expr+instance NFData Alts+instance NFData NonDefaultAlts+instance NFData AlgebraicAlt+instance NFData PrimitiveAlt+instance NFData DefaultAlt+instance NFData Literal+instance NFData PrimOp+instance NFData Var+instance NFData Atom+instance NFData Constr
+ src/Stg/Language/Prettyprint.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE LambdaCase        #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Prettyprinting STG elements in various formats.+module Stg.Language.Prettyprint (+    Pretty(..),+    prettyprint,+    prettyprintPlain,+) where++++import           Data.Text                    (Text)+import qualified Data.Text                    as T+import           Prelude                      hiding ((<$>))+import           Text.PrettyPrint.ANSI.Leijen++++-- | Prettyprint a value as 'Text', including styles such as colours.+prettyprint :: Pretty a => a -> Text+prettyprint = prettyprintModified id++-- | Prettyprint a value as 'Text', stripped off all style information such as+-- colours.+prettyprintPlain :: Pretty a => a -> Text+prettyprintPlain = prettyprintModified plain++prettyprintModified :: Pretty a => (Doc -> Doc) -> a -> Text+prettyprintModified modifier input =+    T.pack (displayS (renderPretty 0.4 1000 (modifier (pretty input))) "")
+ src/Stg/Machine.hs view
@@ -0,0 +1,160 @@+{-# LANGUAGE LambdaCase        #-}+{-# LANGUAGE OverloadedLists   #-}+{-# LANGUAGE OverloadedStrings #-}++-- | User-facing API to work with STG programs.+module Stg.Machine (+    initialState,++    -- * Evaluation+    evalStep,+    evalUntil,+    evalsUntil,+    terminated,+    HaltIf(..),+    RunForSteps(..),++    -- * Garbage collection+    garbageCollect,+    PerformGc(..),+    GarbageCollectionAlgorithm,+    triStateTracing,+    twoSpaceCopying,+) where+++import           Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NE++import Stg.Language+import Stg.Machine.Evaluate+import Stg.Machine.GarbageCollection+import Stg.Machine.Types++++-- | Create a suitable initial state for an STG.+initialState+    :: Var -- ^ Main+    -> Program+    -> StgState+initialState mainVar (Program binds) = initializedState+  where+    -- In order to avoid code duplication, we create the initial state by+    -- packing the entire program in a "letrec <topLevelDefs> in <main>".+    -- Evaluating this step once allocates everything as desired; the resulting+    -- state is precisely the initial state we want, except that the definitions+    -- are stored in the local environment, and not in the global. We therefore+    -- copy that over, and we're done.+    --+    -- Avoiding the copying altogether would have its advantages: no manual+    -- fiddling, and once main is done, everything could be garbage collected.+    -- Unfortunately, GC and rules rely on the existence of a global+    -- environment, so we *have* to fill it.+    dummyLetInitial = StgState+        { stgCode    = Eval (Let Recursive binds (AppF mainVar [])) mempty+        , stgStack   = mempty+        , stgHeap    = mempty+        , stgGlobals = mempty+        , stgSteps   = 0+        , stgInfo    = Info StateInitial [] }+    initializedState = case evalStep dummyLetInitial of+        state | terminated state -> state+        state@StgState+            { stgCode = Eval (AppF _mainVar []) (Locals locals) }+          -> state+            { stgCode    = Eval (AppF mainVar []) mempty+            , stgSteps   = 0+            , stgGlobals = Globals locals+            , stgInfo    = Info StateInitial [] }+        badState -> badState+            { stgInfo = Info (StateError InitialStateCreationFailed) [] }+++-- | Predicate to decide whether the machine should halt.+data RunForSteps =+      RunIndefinitely -- ^ Do not terminate based on the number of steps+    | RunForMaxSteps Integer++-- | Predicate to decide whether the machine should halt.+newtype HaltIf = HaltIf (StgState -> Bool)++-- | Decide whether garbage collection should be attempted, and with which+-- algorithm.+newtype PerformGc = PerformGc (StgState -> Maybe GarbageCollectionAlgorithm)++-- | Evaluate the STG until a predicate holds, aborting if the maximum number of+-- steps are exceeded.+--+-- @+-- 'last' ('evalsUntil' ...) ≡ 'evalUntil'+-- @+evalUntil+    :: RunForSteps -- ^ Maximum number of steps allowed+    -> HaltIf      -- ^ Halting decision function+    -> PerformGc   -- ^ Condition under which to perform GC+    -> StgState    -- ^ Initial state+    -> StgState    -- ^ Final state+evalUntil runForSteps halt performGc state+    = NE.last (evalsUntil runForSteps halt performGc state)++-- | Evaluate the STG, and record all intermediate states.+--+-- * Stop when a predicate holds.+-- * Stop if the maximum number of steps are exceeded.+-- * Perform GC on every step.+--+-- @+-- 'evalsUntil' ≈ 'unfoldr' 'evalUntil'+-- @+evalsUntil+    :: RunForSteps       -- ^ Maximum number of steps allowed+    -> HaltIf            -- ^ Halting decision function+    -> PerformGc         -- ^ Condition under which to perform GC+    -> StgState          -- ^ Initial state+    -> NonEmpty StgState -- ^ Initial state plus intermediate states+evalsUntil runForSteps (HaltIf haltIf) (PerformGc performGc)+  = NE.fromList . go False+  where+    terminate = (:[])+    go attemptGc = \case++        state@StgState{ stgSteps = steps }+            | RunForMaxSteps maxSteps <- runForSteps+            , steps >= maxSteps+            -> terminate (state { stgInfo = Info MaxStepsExceeded [] })++        state | haltIf state+            -> terminate (state { stgInfo = Info HaltedByPredicate [] })++        state@StgState{ stgInfo = Info StateTransition{} _ }+            | attemptGc+            , Just algorithm <- performGc state+            -> case garbageCollect algorithm state of+                stateGc@StgState{stgInfo = Info GarbageCollection _} ->+                    state : stateGc : go False (evalStep stateGc)+                _otherwise -> state : go True (evalStep state)+            | otherwise -> state : go True (evalStep state)++        state@StgState{ stgInfo = Info StateInitial _ }+            | attemptGc+            , Just algorithm <- performGc state+            -> case garbageCollect algorithm state of+                stateGc@StgState{stgInfo = Info GarbageCollection _} ->+                    state : stateGc : go False (evalStep stateGc)+                _otherwise -> state : go True (evalStep state)+            | otherwise -> state : go True (evalStep state)++        state@StgState{ stgInfo = Info GarbageCollection _ }+            -> state : go False (evalStep state)++        state+            -> terminate state++-- | Check whether a state is terminal.+terminated :: StgState -> Bool+terminated StgState{stgInfo = Info info _} = case info of+    StateTransition{}    -> False+    StateInitial{}      -> False+    GarbageCollection{} -> False+    _otherwise          -> True
+ src/Stg/Machine/Env.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Defines operations on local and global variable environments.+module Stg.Machine.Env (++    -- * Locals+    addLocals,+    makeLocals,+    val,+    vals,+    localVal,+    NotInScope(..),++    -- * Globals+    globalVal,+) where++++import           Control.Applicative+import qualified Data.Map            as M+import           Data.Monoid++import Stg.Language+import Stg.Machine.Types+import Stg.Util++++-- | Add a list of bindings to the local environment.+--+-- Already existing variables will be shadowed (i.e. overwritten).+addLocals :: [Mapping Var Value] -> Locals -> Locals+addLocals defs locals = makeLocals defs <> locals++-- | Create a local environment from a list of bindings.+makeLocals :: [Mapping Var Value] -> Locals+makeLocals = Locals . M.fromList . map (\(Mapping k v) -> (k,v))++-- | Look up the value of an 'Atom' first in the local, then in the global+-- environment.+val :: Locals -> Globals -> Atom -> Validate NotInScope Value+val _lcl _gbl (AtomLit (Literal k)) = Success (PrimInt k)+val (Locals locals) (Globals globals) (AtomVar var) =+    case M.lookup var locals <|> M.lookup var globals of+        Just v -> Success v+        Nothing -> Failure (NotInScope [var])++-- | Look up the values of many 'Atom's, and return their values in the+-- input's order, or a list of variables not in scope.+vals :: Locals -> Globals -> [Atom] -> Validate NotInScope [Value]+vals locals globals = traverse (val locals globals)++-- | Look up the value of a variable in the local environment.+localVal :: Locals -> Atom -> Validate NotInScope Value+localVal locals = val locals mempty++-- | Look up the value of a variable in the global environment.+globalVal :: Globals -> Atom -> Validate NotInScope Value+globalVal globals = val mempty globals
+ src/Stg/Machine/Evaluate.hs view
@@ -0,0 +1,609 @@+{-# LANGUAGE LambdaCase        #-}+{-# LANGUAGE OverloadedLists   #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Evaluate STG 'Program's.+module Stg.Machine.Evaluate (+    evalStep,+) where++++import           Data.Bifunctor+import qualified Data.Foldable  as F+import qualified Data.List      as L+import qualified Data.Map       as M+import           Data.Monoid    hiding (Alt)++import           Data.Stack        (Stack (..), (<>>))+import qualified Data.Stack        as S+import           Stg.Language+import           Stg.Machine.Env+import qualified Stg.Machine.Heap  as H+import           Stg.Machine.Types+import           Stg.Util++++-- | Smart constructor to avoid generating info if nothing was discarded+mkDetail_UnusedLocalVariables :: [Var] -> Locals -> [InfoDetail]+mkDetail_UnusedLocalVariables usedVars locals =+    [ Detail_UnusedLocalVariables usedVars locals+    | let Locals localsMap = locals+          used = M.fromList [ (var, ()) | var <- usedVars ]+          unused = localsMap `M.difference` used+    , not (M.null unused) && not (M.null localsMap) ]++-- | Look up an algebraic constructor among the given alternatives, and return+-- the first match. If nothing matches, return the default alternative.+lookupAlgebraicAlt+    :: Alts+    -> Constr+    -> Maybe (Either DefaultAlt AlgebraicAlt)+lookupAlgebraicAlt (Alts (AlgebraicAlts alts) def) constr+  = Just (case L.find matchingAlt alts of+        Just alt   -> Right alt+        _otherwise -> Left def )+  where+    matchingAlt (AlgebraicAlt c _ _) = c == constr+lookupAlgebraicAlt (Alts PrimitiveAlts{} _) _ = Nothing+lookupAlgebraicAlt (Alts NoNonDefaultAlts{} def) _ = Just (Left def)++-- | 'lookupAlgebraicAlt' for primitive literals.+lookupPrimitiveAlt+    :: Alts+    -> Literal+    -> Maybe (Either DefaultAlt PrimitiveAlt)+lookupPrimitiveAlt (Alts (PrimitiveAlts alts) def) lit+  = Just (case L.find matchingAlt alts of+        Just alt   -> Right alt+        _otherwise -> Left def )+  where+    matchingAlt (PrimitiveAlt lit' _) = lit' == lit+lookupPrimitiveAlt (Alts AlgebraicAlts{} _) _ = Nothing+lookupPrimitiveAlt (Alts NoNonDefaultAlts{} def) _ = Just (Left def)++liftLambdaToClosure :: Locals -> LambdaForm -> Validate NotInScope Closure+liftLambdaToClosure localsLift lf@(LambdaForm free _ _ _) =+    case traverse (first (:[]) . localVal localsLift . AtomVar) free of+        Success freeVals   -> Success (Closure lf freeVals)+        Failure notInScope -> Failure (mconcat notInScope)++data PrimError = Div0++applyPrimOp :: PrimOp -> Integer -> Integer -> Validate PrimError Integer+applyPrimOp Div _ 0 = Failure Div0+applyPrimOp Mod _ 0 = Failure Div0+applyPrimOp op x y = Success (opToFunc op x y)+  where+    boolToPrim p a b = if p a b then 1 else 0+    opToFunc = \case+        Add -> (+)+        Sub -> (-)+        Mul -> (*)+        Div -> div+        Mod -> mod+        Eq  -> boolToPrim (==)+        Lt  -> boolToPrim (<)+        Leq -> boolToPrim (<=)+        Gt  -> boolToPrim (>)+        Geq -> boolToPrim (>=)+        Neq -> boolToPrim (/=)++isArgFrame :: StackFrame -> Bool+isArgFrame ArgumentFrame{} = True+isArgFrame _else           = False++++-- | Perform a single STG machine evaluation step.+evalStep :: StgState -> StgState+evalStep state = let state' = stgRule state+                 in state' { stgSteps = stgSteps state' + 1 }++++-- | Apply a single STG evaluation rule, as specified in the 1992 paper.+stgRule :: StgState -> StgState++++-- (1) Function application+stgRule s@StgState+    { stgCode    = Eval (AppF f xs) locals+    , stgStack   = stack+    , stgGlobals = globals }+    | Success (Addr addr) <- val locals globals (AtomVar f)+    , Success xsVals <- vals locals globals xs++  = let stack' = map ArgumentFrame xsVals <>> stack++    in s { stgCode  = Enter addr+         , stgStack = stack'+         , stgInfo  = Info+             (StateTransition Eval_FunctionApplication)+             ( Detail_FunctionApplication f xs+             : mkDetail_UnusedLocalVariables (f : [ var | AtomVar var <- xs ]) locals )}++++-- (2) Enter non-updatable closure+stgRule s@StgState+    { stgCode  = Enter addr+    , stgStack = stack+    , stgHeap  = heap }+    | Just (HClosure (Closure (LambdaForm free NoUpdate bound body) freeVals))+        <- H.lookup addr heap+    , Just (frames, stack') <- bound `S.forEachPop` stack+    , all isArgFrame frames+    , args <- [ arg | ArgumentFrame arg <- frames ]++  = let locals = makeLocals (freeLocals <> boundLocals)+        freeLocals = zipWith Mapping free freeVals+        boundLocals = zipWith Mapping bound args++    in s { stgCode  = Eval body locals+         , stgStack = stack'+         , stgInfo  = Info (StateTransition Enter_NonUpdatableClosure)+                           [Detail_EnterNonUpdatable addr boundLocals] }++++-- (3) let(rec)+stgRule s@StgState+    { stgCode = Eval (Let rec (Binds letBinds) expr) locals+    , stgHeap = heap }++  = let (letVars, letLambdaForms) = unzip (M.assocs letBinds)++        -- We'll need the memory addresses to be created on the heap at this+        -- point already, so we pre-allocate enough already. If everything goes+        -- fine (i.e. all variables referenced in the 'let' are in scope), these+        -- dummy objects can later be overwritten by the actual closures formed+        -- in the 'let' block.+        (newAddrs, heapWithPreallocations) =+            let preallocatedObjs = map (const (Blackhole 0)) letVars+            in H.allocMany preallocatedObjs heap++        -- The local environment enriched by the definitions in the 'let'.+        locals' = let newMappings = zipWith Mapping letVars (map Addr newAddrs)+                  in makeLocals newMappings <> locals++        -- The local environment applicable in the lambda forms defined in the+        -- 'let' binding.+        localsRhs = case rec of+            NonRecursive -> locals  -- New bindings are invisible+            Recursive    -> locals' -- New bindings are in scope++    in case traverse (liftLambdaToClosure localsRhs) letLambdaForms of+        Success closures ->+                -- As promised above, the preallocated dummy closures are now+                -- discarded, and replaced with the newly formed closures.+            let heap' = H.updateMany+                    newAddrs+                    (map HClosure closures)+                    heapWithPreallocations+            in s { stgCode = Eval expr locals'+                 , stgHeap = heap'+                 , stgInfo = Info (StateTransition (Eval_Let rec))+                                  [Detail_EvalLet letVars newAddrs] }+        Failure notInScope ->+            s { stgInfo = Info (StateError (VariablesNotInScope notInScope)) [] }++++-- (18, 19) Shortcut for matching primops, given before the general case rule+-- (4) so it takes precedence.+--+-- This rule allows evaluating primops without the overhead of allocating an+-- intermediate return stack frame.+--+-- When reading the source here for educational purposes, you should skip this+-- rule until you've seen the normal case rule (4) and the normal+-- primop rule (14).+--+-- This rule has the slight modification compared to the paper in that it works+-- for both bound and unbound default cases.+stgRule s@StgState+    { stgCode = Eval (Case (AppP op x y) alts) locals }+    | Success (PrimInt xVal) <- localVal locals x+    , Success (PrimInt yVal) <- localVal locals y+    , Success opXY <- applyPrimOp op xVal yVal+    , Just altLookup <- lookupPrimitiveAlt alts (Literal opXY)++  = let (locals', expr) = case altLookup of+            Left (DefaultBound pat e)+                -> (addLocals [Mapping pat (PrimInt opXY)] locals, e)+            Left (DefaultNotBound e)+                -> (locals, e)+            Right (PrimitiveAlt _opXY e)+                -> (locals, e)++    in s { stgCode = Eval expr locals'+         , stgInfo = Info (StateTransition Eval_Case_Primop_DefaultBound) [] }++++-- (4) Case evaluation+stgRule s@StgState+    { stgCode  = Eval (Case expr alts) locals+    , stgStack = stack }++  = let stack' = ReturnFrame alts locals :< stack++    in s { stgCode  = Eval expr locals+         , stgStack = stack'+         , stgInfo  = Info (StateTransition Eval_Case)+                           [Detail_EvalCase] }++++-- (5) Constructor application+stgRule s@StgState+    { stgCode    = Eval (AppC con xs) locals+    , stgGlobals = globals }+    | Success valsXs <- vals locals globals xs++  = s { stgCode = ReturnCon con valsXs+      , stgInfo = Info+          (StateTransition Eval_AppC)+          (mkDetail_UnusedLocalVariables [ var | AtomVar var <- xs ] locals) }++++-- (6) Algebraic constructor return, standard match+stgRule s@StgState+    { stgCode  = ReturnCon con ws+    , stgStack = ReturnFrame alts locals :< stack' }+    | Just (Right (AlgebraicAlt _con vars expr)) <- lookupAlgebraicAlt alts con+    , length ws == length vars++  = let locals' = addLocals (zipWith Mapping vars ws) locals++    in s { stgCode  = Eval expr locals'+         , stgStack = stack'+         , stgInfo  = Info (StateTransition ReturnCon_Match)+                           [Detail_ReturnCon_Match con vars] }+++++-- (7) Algebraic constructor return, unbound default match+stgRule s@StgState+    { stgCode  = ReturnCon con _ws+    , stgStack = ReturnFrame alts locals :< stack' }+    | Just (Left (DefaultNotBound expr)) <- lookupAlgebraicAlt alts con++  = s { stgCode  = Eval expr locals+      , stgStack = stack'+      , stgInfo  = Info (StateTransition ReturnCon_DefUnbound) [] }++++-- (8) Algebraic constructor return, bound default match+stgRule s@StgState+    { stgCode  = ReturnCon con ws+    , stgStack = ReturnFrame alts locals :< stack'+    , stgHeap  = heap+    , stgSteps = steps }+    | Just (Left (DefaultBound v expr)) <- lookupAlgebraicAlt alts con++  = let locals' = addLocals [Mapping v (Addr addr)] locals+        (addr, heap') = H.alloc (HClosure closure) heap+        closure = Closure (LambdaForm vs NoUpdate [] (AppC con (map AtomVar vs))) ws+        vs = let newVar _old i = Var ("alg8_" <> show' steps <> "-" <> show' i)+             in zipWith newVar ws [0::Integer ..]+    in s { stgCode  = Eval expr locals'+         , stgStack = stack'+         , stgHeap  = heap'+         , stgInfo  = Info (StateTransition ReturnCon_DefBound)+                           [Detail_ReturnConDefBound v addr] }++++-- (9) Literal evaluation+stgRule s@StgState { stgCode = Eval (Lit (Literal k)) _locals}+  = s { stgCode = ReturnInt k+      , stgInfo = Info (StateTransition Eval_Lit) [] }++++-- (10) Literal application+stgRule s@StgState { stgCode = Eval (AppF f []) locals }+    | Success (PrimInt k) <- val locals mempty (AtomVar f)++  = s { stgCode = ReturnInt k+      , stgInfo = Info (StateTransition Eval_LitApp)+                       (mkDetail_UnusedLocalVariables [f] locals) }++++-- (11) Primitive return, standard match found+stgRule s@StgState+    { stgCode  = ReturnInt k+    , stgStack = ReturnFrame alts locals :< stack' }+    | Just (Right (PrimitiveAlt _k expr)) <- lookupPrimitiveAlt alts (Literal k)++  = s { stgCode  = Eval expr locals+      , stgStack = stack'+      , stgInfo  = Info (StateTransition ReturnInt_Match) [] }++++-- (12) Primitive return, bound default match+stgRule s@StgState+    { stgCode  = ReturnInt k+    , stgStack = ReturnFrame alts locals :< stack' }+    | Just (Left (DefaultBound v expr)) <- lookupPrimitiveAlt alts (Literal k)++  = let locals' = addLocals [Mapping v (PrimInt k)] locals++    in s { stgCode  = Eval expr locals'+         , stgStack = stack'+         , stgInfo  = Info (StateTransition ReturnInt_DefBound)+                           [Detail_ReturnIntDefBound v k] }++++-- (13) Primitive return, unbound default match+stgRule s@StgState+    { stgCode  = ReturnInt k+    , stgStack = ReturnFrame alts locals :< stack' }+    | Just (Left (DefaultNotBound expr)) <- lookupPrimitiveAlt alts (Literal k)++  = s { stgCode  = Eval expr locals+      , stgStack = stack'+      , stgInfo  = Info (StateTransition ReturnInt_DefUnbound) [] }++++-- (14) Primitive function application+--+-- This rule has been modified to take not only primitive-valued variables, but+-- also primitive values directly as arguments.+--+-- Without this modification, you cannot evaluate @+# 1# 2#@, you have to+-- write+--+-- @+-- case 1# of one -> case 2# of two -> case +# one two of ...+-- @+--+-- which is a bit silly. I think this might be an oversight in the 1992 paper.+-- The fast curry paper does not seem to impose this restriction.+--+--+-- TODO: This rule is probably obsolete because of rules (18) and (19).+-- Remove it after confirming this is true. I (quchen) was not able to produce+-- a case in which (14) is still needed.+stgRule s@StgState+    { stgCode = Eval (AppP op x y) locals }+    | Success (PrimInt xVal) <- localVal locals x+    , Success (PrimInt yVal) <- localVal locals y+    , Success result <- applyPrimOp op xVal yVal++  = s { stgCode = ReturnInt result+      , stgInfo = Info (StateTransition Eval_AppP)+                       (mkDetail_UnusedLocalVariables [var | AtomVar var <- [x,y]]+                                                      locals )}++++-- (15) Enter updatable closure+stgRule s@StgState+    { stgCode  = Enter addr+    , stgStack = stack+    , stgHeap  = heap+    , stgSteps = tick }+    | Just (HClosure (Closure (LambdaForm free Update [] body) freeVals))+        <- H.lookup addr heap++  = let stack' = UpdateFrame addr :< stack+        locals = makeLocals (zipWith Mapping free freeVals)+        heap' = H.update addr (Blackhole tick) heap++    in s { stgCode  = Eval body locals+         , stgStack = stack'+         , stgHeap  = heap'+         , stgInfo  = Info (StateTransition Enter_UpdatableClosure)+                           [Detail_EnterUpdatable addr] }++++-- (16) Algebraic constructor return, argument/return stacks empty -> update+stgRule s@StgState+    { stgCode  = ReturnCon con ws+    , stgStack = UpdateFrame addr :< stack'+    , stgHeap  = heap+    , stgSteps = steps }++  = let vs = let newVar _old i = Var ("upd16_" <> show' steps <> "-" <> show' i)+             in zipWith newVar ws [0::Integer ..]+        lf = LambdaForm vs NoUpdate [] (AppC con (map AtomVar vs))+        heap' = H.update addr (HClosure (Closure lf ws)) heap++    in s { stgCode  = ReturnCon con ws+         , stgStack = stack'+         , stgHeap  = heap'+         , stgInfo  = Info (StateTransition ReturnCon_Update)+                           [Detail_ConUpdate con addr] }++++-- (17a) Enter partially applied closure+stgRule s@StgState+    { stgCode  = Enter addrEnter+    , stgStack = stack+    , stgHeap  = heap+    , stgSteps = steps }+    | Just (HClosure (Closure (LambdaForm _vs NoUpdate xs _body) _wsf))+        <- H.lookup addrEnter heap+    , Just (argFrames, UpdateFrame addrUpdate :< stack')+        <- popArgsUntilUpdate stack++  = let xs1 = zipWith const xs (F.toList argFrames)+        f = Var ("upd17a_" <> show' steps)+        fxs1 = AppF f (map AtomVar xs1)+        freeVars = f : xs1+        freeVals = zipWith const+            (Addr addrEnter : F.foldMap (\(ArgumentFrame v) -> [v]) argFrames)+            freeVars+        updatedClosure = Closure (LambdaForm freeVars NoUpdate [] fxs1) freeVals++        heap' = H.update addrUpdate (HClosure updatedClosure) heap++    in s { stgCode  = Enter addrEnter+         , stgStack = argFrames <>> stack'+         , stgHeap  = heap'+         , stgInfo  = Info (StateTransition Enter_PartiallyAppliedUpdate)+                           [Detail_PapUpdate addrUpdate] }++  where++    -- | Are there enough 'ArgumentFrame's on the stack to fill the args+    -- parameter? If so, return those frames, along with the rest of the stack.+    popArgsUntilUpdate withArgsStack+        = let (argFrames, argsPoppedStack) = S.span isArgFrame withArgsStack+          in Just ( filter isArgFrame (F.toList argFrames)+                  , argsPoppedStack)++++stgRule s = noRuleApplies s++++-- | When there are no rules, the machine halts. But there are many different+-- ways this state can be reached, so it's helpful to the user to distinguish+-- them from each other.+noRuleApplies :: StgState -> StgState++-- Page 39, 2nd paragraph: "[...] closures with non-empty argument lists are+-- never updatable [...]"+noRuleApplies s@StgState+    { stgCode = Enter addr+    , stgHeap = heap }+    | Just (HClosure (Closure (LambdaForm _ Update (_:_) _) _))+        <- H.lookup addr heap+  = s { stgInfo = Info (StateError UpdatableClosureWithArgs) [] }++++-- Page 39, 4th paragraph: "It is not possible for the ReturnInt state to see an+-- empty return stack, because that would imply that a closure should be updated+-- with a primitive value; but no closure has a primitive type."+noRuleApplies s@StgState+    { stgCode  = ReturnInt{}+    , stgStack = Empty }++  = s { stgInfo = Info (StateError ReturnIntWithEmptyReturnStack)+                       [Detail_ReturnIntCannotUpdate] }++++-- Function argument not in scope+noRuleApplies s@StgState+    { stgCode    = Eval (AppF f xs) locals+    , stgGlobals = globals }+    | Failure notInScope <- vals locals globals (AtomVar f : xs)++  = s { stgInfo = Info (StateError (VariablesNotInScope notInScope)) [] }++++-- Constructor argument not in scope+noRuleApplies s@StgState+    { stgCode    = Eval (AppC _con xs) locals+    , stgGlobals = globals }+    | Failure notInScope <- vals locals globals xs++  = s { stgInfo = Info (StateError (VariablesNotInScope notInScope)) [] }++++-- Algebraic constructor return, but primitive alternative on return frame+noRuleApplies s@StgState+    { stgCode  = ReturnCon{}+    , stgStack = ReturnFrame (Alts PrimitiveAlts{} _) _ :< _ }++  = s { stgInfo = Info (StateError AlgReturnToPrimAlts) [] }++++-- Primitive return, but algebraic alternative on return frame+noRuleApplies s@StgState+    { stgCode  = ReturnInt _+    , stgStack = ReturnFrame (Alts AlgebraicAlts{} _) _ :< _ }++  = s { stgInfo = Info (StateError PrimReturnToAlgAlts) [] }++++noRuleApplies s@StgState+    { stgCode = Eval (AppP _op x y) locals }+    | Failure notInScope <- traverse (localVal locals) ([x,y] :: [Atom])++  = s { stgInfo = Info (StateError (VariablesNotInScope notInScope)) [] }++++-- Entering a black hole+noRuleApplies s@StgState+    { stgCode  = Enter addr+    , stgHeap  = heap }+    | Just (Blackhole bhTick) <- H.lookup addr heap++  = s { stgInfo = Info (StateError EnterBlackhole)+                       [Detail_EnterBlackHole addr bhTick] }++++-- Update closure with primitive value+noRuleApplies s@StgState+    { stgCode  = ReturnInt _+    , stgStack = UpdateFrame _ :< _}++  = s { stgInfo  = Info (StateError UpdateClosureWithPrimitive)+                        [Detail_UpdateClosureWithPrimitive] }++++-- Non-algebraic scrutinee+--+-- For more information on this, see 'Stg.Prelude.seq'.+noRuleApplies s@StgState -- TODO: Make sure this catches the right states+    { stgCode  = Enter _+    , stgStack = ReturnFrame{} :< _}++  = s { stgInfo  = Info (StateError NonAlgPrimScrutinee) [] }+++noRuleApplies s@StgState+    { stgCode = Eval (AppP op x y) locals }+    | Success (PrimInt xVal) <- localVal locals x+    , Success (PrimInt yVal) <- localVal locals y+    , Failure Div0 <- applyPrimOp op xVal yVal++  = s { stgInfo  = Info (StateError DivisionByZero) [] }++-- (6) Algebraic constructor return, standard match+noRuleApplies s@StgState+    { stgCode  = ReturnCon con ws+    , stgStack = ReturnFrame alts _ :< _ }+    | Just (Right (AlgebraicAlt _con vars _)) <- lookupAlgebraicAlt alts con+    , length ws /= length vars++  = s { stgInfo  = Info (StateError (BadConArity (length ws) (length vars)))+                                    [Detail_BadConArity] }++++++-- Successful, ordinary termination+noRuleApplies s@StgState { stgStack = S.Empty }+  = s { stgInfo = Info NoRulesApply [] }++++noRuleApplies s = s { stgInfo = Info NoRulesApply [Detail_StackNotEmpty] }
+ src/Stg/Machine/GarbageCollection.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase        #-}++-- | Remove unused heap objects.+module Stg.Machine.GarbageCollection (+    garbageCollect,++    -- * Algorithms+    GarbageCollectionAlgorithm,+    triStateTracing,+    twoSpaceCopying,+) where++++import qualified Data.Set as S++import Stg.Machine.GarbageCollection.Common+import Stg.Machine.GarbageCollection.TriStateTracing+import Stg.Machine.GarbageCollection.TwoSpaceCopying+import Stg.Machine.Types++++garbageCollect :: GarbageCollectionAlgorithm -> StgState -> StgState+garbageCollect algorithm@(GarbageCollectionAlgorithm name _) state+  = let (deadAddrs, forwards, state') = splitHeapWith algorithm state+    in if S.size deadAddrs > 0+        then state' { stgSteps = stgSteps state + 1+                    , stgInfo  = Info GarbageCollection+                                      [Detail_GarbageCollected name deadAddrs forwards] }+        else state
+ src/Stg/Machine/GarbageCollection/Common.hs view
@@ -0,0 +1,134 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase        #-}++-- | Definitions used by various garbage collection algorithms.+module Stg.Machine.GarbageCollection.Common (+    splitHeapWith,+    GarbageCollectionAlgorithm(..),+    Addresses(addrs),+    UpdateAddrs(..),+) where++++import           Data.Map      (Map)+import           Data.Sequence (Seq, ViewL (..), (<|))+import qualified Data.Sequence as Seq+import           Data.Set      (Set)+import qualified Data.Set      as S+import           Data.Text++import Stg.Machine.Types++++-- | Split the heap contained in a machine state in two parts: the dead objects+-- that can safely be discarded, and the alive ones that are still needed by+-- the program.+splitHeapWith+    :: GarbageCollectionAlgorithm+    -> StgState+    -> (Set MemAddr, Map MemAddr MemAddr, StgState)+splitHeapWith (GarbageCollectionAlgorithm _name gc) = gc++data GarbageCollectionAlgorithm = GarbageCollectionAlgorithm+    Text+    (StgState -> (Set MemAddr, Map MemAddr MemAddr, StgState))+        -- ^ Dead addresses, moved addresses, new state++-- | Collect all mentioned addresses in a machine element.+--+-- Note that none of the types in "Stg.Language" contain addresses, since an+-- address is not something present in the STG _language_, only in the execution+-- contest the language is put in in the "Stg.Machine" modules.+class Addresses a where+    -- | All contained addresses in the order they appear, but without+    -- duplicates.+    addrs :: a -> Seq MemAddr+    addrs = nubSeq . addrs'++    -- | All contained addresses in the order they appear, with duplicates.+    addrs' :: a -> Seq MemAddr++nubSeq :: Ord a => Seq a -> Seq a+nubSeq = go mempty+  where+    go cache entries = case Seq.viewl entries of+        EmptyL -> mempty+        x :< xs+            | S.member x cache -> go cache xs+            | otherwise -> x <| go (S.insert x cache) xs++instance (Foldable f, Addresses a) => Addresses (f a) where+    addrs' = foldMap addrs'++instance Addresses Code where+    addrs' = \case+        Eval _expr locals   -> addrs' locals+        Enter addr          -> addrs' addr+        ReturnCon _con args -> addrs' args+        ReturnInt _int      -> mempty++instance Addresses StackFrame where+    addrs' = \case+        ArgumentFrame vals       -> addrs' vals+        ReturnFrame _alts locals -> addrs' locals+        UpdateFrame addr         -> addrs' addr++instance Addresses MemAddr where+    addrs' addr = Seq.singleton addr++instance Addresses Globals where+    addrs' (Globals globals) = addrs' globals++instance Addresses Locals where+    addrs' (Locals locals) = addrs' locals++instance Addresses Closure where+    addrs' (Closure _lf free) = addrs' free++instance Addresses HeapObject where+    addrs' = \case+        HClosure closure  -> addrs' closure+        Blackhole _bhTick -> mempty++instance Addresses Value where+    addrs' = \case+        Addr addr  -> addrs' addr+        PrimInt _i -> mempty+++-- | Update all contained addresses in a certain value. Useful for moving+-- garbage collectors.+class UpdateAddrs a where+    updateAddrs :: (MemAddr -> MemAddr) -> a -> a++instance UpdateAddrs Code where+    updateAddrs upd = \case+        Eval expr locals      -> Eval expr (updateAddrs upd locals)+        Enter addr            -> Enter (updateAddrs upd addr)+        ReturnCon constr args -> ReturnCon constr (updateAddrs upd args)+        r@ReturnInt{}         -> r++instance UpdateAddrs Locals where+    updateAddrs upd (Locals locals) = Locals (updateAddrs upd locals)++instance UpdateAddrs Globals where+    updateAddrs upd (Globals locals) = Globals (updateAddrs upd locals)++instance UpdateAddrs Value where+    updateAddrs upd = \case+        Addr addr   -> Addr (updateAddrs upd addr)+        p@PrimInt{} -> p++instance UpdateAddrs MemAddr where+    updateAddrs = id++instance (Functor f, UpdateAddrs a) => UpdateAddrs (f a) where+    updateAddrs upd = fmap (updateAddrs upd)++instance UpdateAddrs StackFrame where+    updateAddrs upd = \case+        ArgumentFrame arg       -> ArgumentFrame (updateAddrs upd arg)+        ReturnFrame alts locals -> ReturnFrame alts (updateAddrs upd locals)+        UpdateFrame addr        -> UpdateFrame (updateAddrs upd addr)
+ src/Stg/Machine/GarbageCollection/TriStateTracing.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase        #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Tri-state ("tri-colour") garbage collector.+--+-- * Not compacting: alive memory is not altered+-- * Tracing+module Stg.Machine.GarbageCollection.TriStateTracing (+    triStateTracing,+) where++++import           Data.Map      (Map)+import qualified Data.Map      as M+import           Data.Monoid   hiding (Alt)+import           Data.Sequence (Seq)+import           Data.Set      (Set)+import qualified Data.Set      as S++import Stg.Machine.GarbageCollection.Common+import Stg.Machine.Types++++-- | Remove all unused addresses, without moving the others.+triStateTracing :: GarbageCollectionAlgorithm+triStateTracing = GarbageCollectionAlgorithm+    "Tri-state tracing"+    (insert2nd mempty . garbageCollect)++insert2nd :: a -> (x, y) -> (x, a, y)+insert2nd a (x,y) = (x,a,y)++garbageCollect :: StgState -> (Set MemAddr, StgState)+garbageCollect stgState@StgState+    { stgCode    = code+    , stgHeap    = heap+    , stgGlobals = globals+    , stgStack   = stack }+  = let GcState {aliveHeap = alive, oldHeap = Heap dead}+            = until everythingCollected gcStep start+        start = GcState+            { aliveHeap = mempty+            , oldHeap = heap+            , staged = (seqToSet . mconcat)+                [addrs code, addrs globals, addrs stack] }+        stgState' = stgState { stgHeap = alive }+    in (M.keysSet dead, stgState')++seqToSet :: Ord a => Seq a -> Set a+seqToSet = foldMap S.singleton++everythingCollected :: GcState -> Bool+everythingCollected = noAlives+  where+    noAlives GcState {staged = alive} = S.null alive++-- | Each closure is in one of three states: in the alive heap, staged for+-- later rescue, or not even staged yet.+data GcState = GcState+    { aliveHeap :: Heap+        -- ^ Heap of closures known to be alive.+        --   Has no overlap with the old heap.++    , staged :: Set MemAddr+        -- ^ Memory addresses known to be alive,+        --   but not yet rescued from the old heap.++    , oldHeap :: Heap+        -- ^ The old heap, containing both dead+        --   and not-yet-found alive closures.+    } deriving (Eq, Ord, Show)++gcStep :: GcState -> GcState+gcStep GcState+    { aliveHeap = oldAlive@(Heap alive)+    , staged    = stagedAddrs+    , oldHeap   = Heap oldRest }+  = GcState+    { aliveHeap = oldAlive <> Heap rescued+    , staged    = seqToSet (addrs rescued)+    , oldHeap   = Heap newRest }+  where+    rescued, newRest :: Map MemAddr HeapObject+    (rescued, newRest) = M.partitionWithKey isAlive oldRest+      where+        isAlive addr _closure = M.member addr alive+                             || S.member addr stagedAddrs
+ src/Stg/Machine/GarbageCollection/TwoSpaceCopying.hs view
@@ -0,0 +1,210 @@+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase                 #-}+{-# LANGUAGE MultiWayIf                 #-}+{-# LANGUAGE OverloadedStrings          #-}++-- | Two space stop-and-copy garbage collector.+--+-- * Compacting: memory is moved to a new location+-- * Tracing+module Stg.Machine.GarbageCollection.TwoSpaceCopying (+    twoSpaceCopying,+) where++++import           Control.Monad.Trans.Class+import           Control.Monad.Trans.Reader+import           Control.Monad.Trans.State+import           Data.Foldable+import           Data.Map                   (Map)+import qualified Data.Map                   as M+import           Data.Monoid+import           Data.Sequence              (Seq, ViewL (..), (|>))+import qualified Data.Sequence              as Seq+import           Data.Set                   (Set)+import qualified Data.Set                   as S++import           Stg.Machine.GarbageCollection.Common+import qualified Stg.Machine.Heap                     as H+import           Stg.Machine.Types++++-- | Remove all unused addresses by moving them to a safe location.+twoSpaceCopying :: GarbageCollectionAlgorithm+twoSpaceCopying = GarbageCollectionAlgorithm+    "Two-space copying"+    garbageCollect++newtype Gc a = Gc (ReaderT Heap (State GcState) a)+    deriving (Functor, Applicative, Monad)++askHeap :: Gc Heap+askHeap = Gc ask++getGcState :: Gc GcState+getGcState = Gc (lift get)++putGcState :: GcState -> Gc ()+putGcState s = Gc (lift (put s))++execGc :: Gc a -> Heap -> GcState -> GcState+execGc (Gc rsa) oldHeap gcState =+    let sa = runReaderT rsa oldHeap+        finalState = execState sa gcState+    in finalState++data GcState = GcState+    { toHeap :: Heap+        -- ^ Heap of closures known to be alive.++    , forwards :: Map MemAddr MemAddr+        -- ^ Forward pointers to the new locations of already collected heap+        -- objects++    , toScavenge :: Seq MemAddr+        -- ^ Heap objects already evacuated, but not yet scavenged. Contains+        -- only objects that are also in the 'toHeap'.++    , toEvacuate :: Seq MemAddr+        -- ^ Heap objects known to be alive, but not yet evacuated.+    } deriving (Eq, Ord, Show)++garbageCollect :: StgState -> (Set MemAddr, Map MemAddr MemAddr, StgState)+garbageCollect stgState@StgState+    { stgCode    = code+    , stgHeap    = heap+    , stgGlobals = globals+    , stgStack   = stack }+  = let rootAddrs = mconcat [addrs code, addrs stack, addrs globals]+        initialState = GcState+            { toHeap     = mempty+            , forwards   = mempty+            , toScavenge = mempty+            , toEvacuate = rootAddrs }+        finalState = execGc evacuateScavengeLoop heap initialState+    in case finalState of+        GcState {toHeap = heap', forwards = forwards'} ->+            let deadFormerAddrs+                  = let Heap old = heap+                    in M.keysSet old `S.difference` M.keysSet forwards'++                forward addr = M.findWithDefault forwardErr addr forwards'+                forwardErr = error "Invalid forward in GC; please report this as a bug"++                removeIdentities = M.filterWithKey (/=)++                stgState' = stgState+                    { stgCode    = updateAddrs forward code+                    , stgStack   = updateAddrs forward stack+                    , stgGlobals = updateAddrs forward globals+                    , stgHeap    = heap' }+            in (deadFormerAddrs, removeIdentities forwards', stgState')++evacuateScavengeLoop :: Gc ()+evacuateScavengeLoop = initialEvacuation >> scavengeLoop++initialEvacuation :: Gc ()+initialEvacuation = getAndClearToEvacuate >>= evacuateAll+  where+    getAndClearToEvacuate = do+        gcState <- getGcState+        putGcState (gcState{toEvacuate = mempty})+        pure (toEvacuate gcState)+    evacuateAll = traverse_ evacuate++scavengeLoop :: Gc ()+scavengeLoop = do+    scavengeNext <- getAndClearToScavenge+    if | Seq.null scavengeNext -> pure ()+       | otherwise -> do+           scavengeAddrs S.empty scavengeNext+           scavengeLoop+  where+    getAndClearToScavenge = do+        gcState <- getGcState+        putGcState (gcState{toScavenge = mempty})+        pure (toScavenge gcState)+    scavengeAddrs alreadyScavenged toAddrs = case Seq.viewl toAddrs of+        EmptyL -> pure ()+        addr :< rest+            | S.member addr alreadyScavenged -> scavengeAddrs alreadyScavenged rest+            | otherwise -> do+                scavenge addr+                scavengeAddrs (S.insert addr alreadyScavenged) rest++data EvacuationStatus = NotEvacuatedYet | AlreadyEvacuatedTo MemAddr++-- | Copy a closure from from-space to to-space, if it has not been evacuated+-- previously. Copying to to-space involves a new allocation in to-space,+-- registering the copied address to be scavenged, and creating a forwarding+-- entry so that further evacuations can short-circuit.+evacuate :: MemAddr -> Gc MemAddr+evacuate = \fromAddr -> forwardingStatus fromAddr >>= \case+    AlreadyEvacuatedTo newAddr -> pure newAddr+    NotEvacuatedYet -> fmap (H.lookup fromAddr) askHeap >>= \case+        Nothing -> error "Tried collecting a non-existent memory address!\+                         \ Please report this as a bug."+        Just heapObject -> do+            newAddr <- copyIntoToSpace heapObject+            registerToBeScavenged newAddr+            createForward fromAddr newAddr+            pure newAddr+  where+    forwardingStatus :: MemAddr -> Gc EvacuationStatus+    forwardingStatus addr = do+        GcState { forwards = forw } <- getGcState+        pure (case M.lookup addr forw of+            Nothing -> NotEvacuatedYet+            Just newAddr -> AlreadyEvacuatedTo newAddr )++    copyIntoToSpace :: HeapObject -> Gc MemAddr+    copyIntoToSpace heapObject = do+        gcState <- getGcState+        let (addr', to') = H.alloc heapObject (toHeap gcState)+        putGcState gcState { toHeap = to' }+        pure addr'++    registerToBeScavenged :: MemAddr -> Gc ()+    registerToBeScavenged addr = do+        gcState@GcState { toScavenge = sc } <- getGcState+        putGcState gcState { toScavenge = sc |> addr }++    createForward :: MemAddr -> MemAddr -> Gc ()+    createForward from to = do+        gcState@GcState{forwards = forw} <- getGcState+        putGcState gcState { forwards = M.insert from to forw }++-- | Find referenced addresses in a heap object, and overwrite them with their+-- evacuated new addresses.+scavenge :: MemAddr -> Gc ()+scavenge = \scavengeAddr -> do+    scavengeHeapObject <- do+        GcState { toHeap = heap } <- getGcState+        pure (H.lookup scavengeAddr heap)+    case scavengeHeapObject of+        Nothing -> error "Scavenge error: address not found on to-heap\+                         \ Please report this as a bug."+        Just Blackhole{} -> pure mempty+        Just (HClosure (Closure lf frees)) -> do+            frees' <- evacuateContainedValues frees+            updateClosure scavengeAddr (Closure lf frees')+            registerForEvacuation [ addr | Addr addr <- frees' ]+  where+    evacuateContainedValues :: [Value] -> Gc [Value]+    evacuateContainedValues = traverse (\case+        Addr addr -> fmap (\x -> Addr x) (evacuate addr)+        i@PrimInt{} -> pure i )++    updateClosure :: MemAddr -> Closure -> Gc ()+    updateClosure addr closure = do+        gcState@GcState { toHeap = heap } <- getGcState+        let heap' = H.update addr (HClosure closure) heap+        putGcState gcState { toHeap = heap' }++    registerForEvacuation :: [MemAddr] -> Gc ()+    registerForEvacuation addresses = do+        gcState@GcState { toEvacuate = evac } <- getGcState+        putGcState gcState { toEvacuate = evac <> Seq.fromList addresses }
+ src/Stg/Machine/Heap.hs view
@@ -0,0 +1,59 @@+-- | The STG heap maps memory addresses to closures.+module Stg.Machine.Heap (+    -- * Info+    size,++    -- * Management+    lookup,+    update,+    updateMany,+    alloc,+    allocMany,+) where++++import qualified Data.List   as L+import qualified Data.Map    as M+import           Data.Monoid+import           Prelude     hiding (lookup)++import Stg.Machine.Types++++-- | Current number of elements in a heap.+size :: Heap -> Int+size (Heap heap) = M.size heap++-- | Look up a value on the heap.+lookup :: MemAddr -> Heap -> Maybe HeapObject+lookup addr (Heap heap) = M.lookup addr heap++-- | Update a value on the heap.+update :: MemAddr -> HeapObject -> Heap -> Heap+update addr obj (Heap h) = Heap (M.adjust (const obj) addr h)++-- | Update many values on the heap.+updateMany :: [MemAddr] -> [HeapObject] -> Heap -> Heap+updateMany addrs objs heap =+    L.foldl' (\h (addr, obj) -> update addr obj h) heap (zip addrs objs)++-- | Store a value in the heap at an unused address.+alloc :: HeapObject -> Heap -> (MemAddr, Heap)+alloc lambdaForm heap = (addr, heap')+  where+    ([addr], heap') = allocMany [lambdaForm] heap++-- | Store many values in the heap at unused addresses, and return them+-- in input order.+allocMany :: [HeapObject] -> Heap -> ([MemAddr], Heap)+allocMany heapObjects (Heap heap) = (addrs, heap')+  where+    smallestUnusedAddr = case M.maxViewWithKey heap of+        Nothing -> 0+        Just ((MemAddr maxAddr, _), _) -> maxAddr+1+    addrs = zipWith (\addr _obj -> MemAddr addr)+                    [smallestUnusedAddr ..]+                    heapObjects+    heap' = Heap (heap <> M.fromList (zip addrs heapObjects))
+ src/Stg/Machine/Types.hs view
@@ -0,0 +1,545 @@+{-# LANGUAGE DeriveGeneric              #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase                 #-}+{-# LANGUAGE MultiWayIf                 #-}+{-# LANGUAGE OverloadedLists            #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE TypeFamilies               #-}++-- | Types used in the execution of the STG machine.+module Stg.Machine.Types (+    StgState(..),+    StgStateStyle(..),+    StackFrame(..),+    MemAddr(..),+    Value(..),+    Code(..),+    Mapping(..),+    Globals(..),+    Locals(..),+    Closure(..),+    Heap(..),+    HeapObject(..),++    -- * State information+    Info(..),+    InfoShort(..),+    InfoDetail(..),+    StateTransition(..),+    StateError(..),+    NotInScope(..),+) where++++import           Control.DeepSeq+import           Data.Foldable+import           Data.Map                     (Map)+import qualified Data.Map                     as M+import           Data.Monoid+import           Data.Set                     (Set)+import           Data.Text                    (Text)+import qualified Data.Text                    as T+import           GHC.Generics+import           Text.PrettyPrint.ANSI.Leijen hiding ((<>))+import           Text.Printf++import Data.Stack+import Stg.Language+import Stg.Util++++-- | The internal state of an STG.+data StgState = StgState+    { stgCode :: Code+        -- ^ Operation the STG should perform next++    , stgStack :: Stack StackFrame+        -- ^ The stack stores not-yet-used arguments (argument stack part),+        -- computations to return to once case evaluation has finished+        -- (return stack part), and instructions to update heap entries+        -- once computation of a certain value is done.++    , stgHeap :: Heap+        -- ^ The heap stores values allocated at the top level or in @let(rec)@+        --   expressions.++    , stgGlobals :: Globals+        -- ^ The environment consisting of the top-level definitions.++    , stgSteps :: !Integer+        -- ^ A counter, used to generte fresh variable names from.++    , stgInfo :: Info+        -- ^ Information about the current state+    }+    deriving (Eq, Ord, Show, Generic)++-- | Package of style definitions used in this module.+data StgStateStyle = StgStateStyle+    { headline :: Doc -> Doc+        -- ^ Style of headlines in the state overview, such as \"Heap" and+        --   "Frame i".+    , address :: Doc -> Doc+        -- ^ Style of memory addresses, including @0x@ prefix.+    , addressCore :: Doc -> Doc+        -- ^ Style of memory addresses; applied only to the actual address+        --   number, such as @ff@ in @0xff@.++    , closureType :: Doc -> Doc+        -- ^ Style of the type of a closure, such as BLACKHOLE or FUN.++    , stackFrameType :: Doc -> Doc+        -- ^ Style of the stack frame annotation, such as UPD or ARG.+    }++-- | Colour definitions used in this module.+style :: StgStateStyle+style = StgStateStyle+    { headline       = dullblue+    , address        = dullcyan+    , addressCore    = underline+    , closureType    = bold+    , stackFrameType = bold+    }++-- Local re-definition to avoid cyclic import with the Heap module+heapSize :: Heap -> Int+heapSize (Heap h) = length h++instance Pretty StgState where+    pretty state = align (vsep+        [ headline style "Code:" <+> pretty (stgCode state)+        , nest 4 (vsep [headline style "Stack", prettyStack (stgStack state) ])+        , nest 4 (vsep [headline style "Heap" <> " (" <> pretty (heapSize (stgHeap state)) <+> "entries)"+                       , pretty (stgHeap state) ])+        , nest 4 (vsep [headline style "Globals", pretty (stgGlobals state)])+        , nest 4 (headline style "Step:" <+> pretty (stgSteps state)) ])++-- | Prettyprint a 'Stack'.+prettyStack :: Pretty a => Stack a -> Doc+prettyStack Empty = "(empty)"+prettyStack stack = (align . vsep) prettyFrames+  where+    prettyFrame frame i = hsep+        [ headline style (int i <> ".")+        , align (pretty frame) ]+    prettyFrames = zipWith prettyFrame (toList stack) (reverse [1..length stack])++-- ^ A stack frame of the unified stack that includes arguments, returns, and+-- updates.+data StackFrame =+      ArgumentFrame Value+        -- ^ Argument frames store values on the argument stack, so that they+        -- can later be retrieved when the calling function can be applied to+        -- them.++    | ReturnFrame Alts Locals+        -- ^ Return frames are used when the scrutinee of a case expression is+        -- done being evaluated, and the branch to continue on has to be+        -- decided.++    | UpdateFrame MemAddr+        -- ^ When an updatable closure is entered, an update frame with its heap+        -- address is created. Once its computation finishes, its heap entry is+        -- updated with the computed value.++    deriving (Eq, Ord, Show, Generic)++instance Pretty StackFrame where+    pretty = \case+        ArgumentFrame val -> stackFrameType style "Arg" <+> pretty val+        ReturnFrame alts locals -> stackFrameType style "Ret" <+>+            (align . vsep) [ fill 7 (headline style "Alts:")   <+> align (pretty alts)+                           , fill 7 (headline style "Locals:") <+> align (pretty locals) ]+        UpdateFrame addr -> stackFrameType style "Upd" <+> pretty addr++-- | A memory address.+newtype MemAddr = MemAddr Int+    deriving (Eq, Ord, Show, Enum, Bounded, Generic)++instance Pretty MemAddr where+    pretty (MemAddr addr) = address style ("0x" <> addressCore style (hexAddr addr))+      where+        hexAddr = text . printf "%02x"++-- | A value of the STG machine.+data Value = Addr MemAddr | PrimInt Integer+    deriving (Eq, Ord, Show, Generic)++instance Pretty Value where+    pretty = \case+        Addr addr -> pretty addr+        PrimInt i -> pretty (Literal i)+    prettyList = tupled . map pretty++-- | The different code states the STG can be in.+data Code =+          -- | Evaluate an expression within a local environment+          Eval Expr Locals++          -- | Load the closure at a certain heap address+        | Enter MemAddr++          -- | Sub-computation terminated with algebraic constructor+        | ReturnCon Constr [Value]++          -- | Sub-computation terminated with a primitive integer+        | ReturnInt Integer+    deriving (Eq, Ord, Show, Generic)++instance Pretty Code where+    pretty = \case+        Eval expr locals -> (align . vsep)+            [ "Eval" <+> pretty expr+            , headline style "Locals:" <+> pretty locals ]+        Enter addr -> "Enter" <+> pretty addr+        ReturnCon constr args -> "ReturnCon" <+> pretty constr <+> prettyList args+        ReturnInt i -> "ReturnInt" <+> pretty (Literal i)++-- | A single key -> value association.+data Mapping k v = Mapping k v+    deriving (Eq, Ord, Show, Generic)++instance (Pretty k, Pretty v) => Pretty (Mapping k v) where+    pretty (Mapping k v) = pretty k <+> "->" <+> pretty v++-- | Prettyprint a 'Map', @key -> value@.+prettyMap :: (Pretty k, Pretty v) => Map k v -> Doc+prettyMap m | M.null m = "(empty)"+prettyMap m = (align . vsep) [ pretty (Mapping k v) | (k,v) <- M.assocs m ]++-- | The global environment consists of the mapping from top-level definitions+-- to their respective values.+newtype Globals = Globals (Map Var Value)+    deriving (Eq, Ord, Show, Monoid, Generic)++instance Pretty Globals where+    pretty (Globals globals) = prettyMap globals++-- | The global environment consists if the mapping from local definitions+-- to their respective values.+newtype Locals = Locals (Map Var Value)+    deriving (Eq, Ord, Show, Monoid, Generic)++instance Pretty Locals where+    pretty (Locals locals) = prettyMap locals++-- | User-facing information about the current state of the STG.+data Info = Info InfoShort [InfoDetail]+    deriving (Eq, Ord, Show, Generic)++instance Pretty Info where+    pretty = \case+        Info short []      -> pretty short+        Info short details -> vsep [pretty short, prettyList details]++-- | Short machine status info. This field may be used programmatically, in+-- particular it tells the stepper whether the machine has halted.+data InfoShort =+      NoRulesApply+      -- ^ There is no valid state transition to continue with.++    | MaxStepsExceeded+      -- ^ The machine did not halt within a number of steps. Used by+      -- 'Stg.Machine.evalUntil'.++    | HaltedByPredicate+      -- ^ The machine halted because a user-specified halting predicate+      -- held.++    | StateError StateError+      -- ^ The machine halted in a state that is known to be invalid, there is+      -- no valid state transition to continue with.+      --+      -- An example of this would be a 'ReturnCon' state with an empty+      -- return stack.++    | StateTransition StateTransition+      -- ^ Description of the state transition that lead to the current state.++    | StateInitial+      -- ^ Used to mark the initial state of the machine.++    | GarbageCollection+      -- ^ A garbage collection step, in which no ordinary evaluation is done.+    deriving (Eq, Ord, Show, Generic)++instance Pretty InfoShort where+    pretty = \case+        HaltedByPredicate -> "Halting predicate held"+        NoRulesApply      -> "No further rules apply"+        MaxStepsExceeded  -> "Maximum number of steps exceeded"+        StateError err    -> "Errorenous state:" <+> pretty err+        StateTransition t -> pretty t+        StateInitial      -> "Initial state"+        GarbageCollection -> "Garbage collection"++data StateTransition =+      Enter_NonUpdatableClosure+    | Enter_PartiallyAppliedUpdate+    | Enter_UpdatableClosure+    | Eval_AppC+    | Eval_AppP+    | Eval_Case+    | Eval_Case_Primop_Normal+    | Eval_Case_Primop_DefaultBound+    | Eval_FunctionApplication+    | Eval_Let Rec+    | Eval_Lit+    | Eval_LitApp+    | ReturnCon_DefBound+    | ReturnCon_DefUnbound+    | ReturnCon_Match+    | ReturnCon_Update+    | ReturnInt_DefBound+    | ReturnInt_DefUnbound+    | ReturnInt_Match+    deriving (Eq, Ord, Show, Generic)++instance Pretty StateTransition where+    pretty = \case+        Enter_NonUpdatableClosure     -> "Enter non-updatable closure"+        Enter_PartiallyAppliedUpdate  -> "Enter partially applied closure"+        Enter_UpdatableClosure        -> "Enter updatable closure"+        Eval_AppC                     -> "Constructor application"+        Eval_AppP                     -> "Primitive function application"+        Eval_Case                     -> "Case evaluation"+        Eval_Case_Primop_Normal       -> "Case evaluation of primop: taking a shortcut, standard match"+        Eval_Case_Primop_DefaultBound -> "Case evaluation of primop: taking a shortcut, bound default match"+        Eval_FunctionApplication      -> "Function application"+        Eval_Let NonRecursive         -> "Let evaluation"+        Eval_Let Recursive            -> "Letrec evaluation"+        Eval_Lit                      -> "Literal evaluation"+        Eval_LitApp                   -> "Literal application"+        ReturnCon_DefBound            -> "Algebraic constructor return, bound default match"+        ReturnCon_DefUnbound          -> "Algebraic constructor return, unbound default match"+        ReturnCon_Match               -> "Algebraic constructor return, standard match"+        ReturnCon_Update              -> "Update by constructor return"+        ReturnInt_DefBound            -> "Primitive constructor return, bound default match"+        ReturnInt_DefUnbound          -> "Primitive constructor return, unbound default match"+        ReturnInt_Match               -> "Primitive constructor return, standard match found"++-- | Type safety wrapper.+newtype NotInScope = NotInScope [Var]+    deriving (Eq, Ord, Show, Generic, Monoid)++instance Pretty NotInScope where+    pretty (NotInScope vars) = commaSep (map pretty vars)++data StateError =+      VariablesNotInScope NotInScope+    | UpdatableClosureWithArgs+    | ReturnIntWithEmptyReturnStack+    | AlgReturnToPrimAlts+    | PrimReturnToAlgAlts+    | InitialStateCreationFailed+    | EnterBlackhole+    | UpdateClosureWithPrimitive+    | NonAlgPrimScrutinee+    | DivisionByZero+    | BadConArity Int Int+    deriving (Eq, Ord, Show, Generic)++instance Pretty StateError where+    pretty = \case+        VariablesNotInScope notInScope -> pretty notInScope <+> "not in scope"+        UpdatableClosureWithArgs -> "Closures with non-empty argument lists are never updatable"+        ReturnIntWithEmptyReturnStack -> "ReturnInt state with empty return stack"+        AlgReturnToPrimAlts -> "Algebraic constructor return to primitive alternatives"+        PrimReturnToAlgAlts -> "Primitive return to algebraic alternatives"+        InitialStateCreationFailed -> "Initial state creation failed"+        EnterBlackhole -> "Entering black hole"+        UpdateClosureWithPrimitive -> "Update closure with primitive value"+        NonAlgPrimScrutinee -> "Non-algebraic/primitive case scrutinee"+        DivisionByZero -> "Division by zero"+        BadConArity retArity altArity -> "Return" <+> pprArity retArity+                                     <+> "constructor to" <+> pprArity altArity+                                     <+> "alternative"++pprArity :: Int -> Doc+pprArity = \case+    0 -> "nullary"+    1 -> "unary"+    2 -> "binary"+    3 -> "ternary"+    n -> int n <> "-ary"++data InfoDetail =+      Detail_FunctionApplication Var [Atom]+    | Detail_UnusedLocalVariables [Var] Locals+    | Detail_EnterNonUpdatable MemAddr [Mapping Var Value]+    | Detail_EvalLet [Var] [MemAddr]+    | Detail_EvalCase+    | Detail_ReturnCon_Match Constr [Var]+    | Detail_ReturnConDefBound Var MemAddr+    | Detail_ReturnIntDefBound Var Integer+    | Detail_EnterUpdatable MemAddr+    | Detail_ConUpdate Constr MemAddr+    | Detail_PapUpdate MemAddr+    | Detail_ReturnIntCannotUpdate+    | Detail_StackNotEmpty+    | Detail_GarbageCollected Text (Set MemAddr) (Map MemAddr MemAddr)+    | Detail_EnterBlackHole MemAddr Integer+    | Detail_UpdateClosureWithPrimitive+    | Detail_BadConArity+    deriving (Eq, Ord, Show, Generic)++instance Pretty InfoDetail where+    prettyList = vsep . map pretty+    pretty items = bulletList (case items of+        Detail_FunctionApplication val [] ->+            ["Inspect value" <+> pretty val]+        Detail_FunctionApplication function args ->+            [ "Apply function"+              <+> pretty function+              <+> "to argument" <> pluralS args+              <+> commaSep (map pretty args) ]++        Detail_UnusedLocalVariables usedVars (Locals locals) ->+            let used = M.fromList [ (var, ()) | var <- usedVars ]+                unused = locals `M.difference` used+                pprDiscardedBind var val = [pretty var <+> "(" <> pretty val <> ")"]+            in ["Unused local variable" <> pluralS (M.toList unused) <+> "discarded:"+                <+> case unused of+                    [] -> "(none)"+                    _  -> commaSep (M.foldMapWithKey pprDiscardedBind unused) ]++        Detail_EnterNonUpdatable addr args ->+            [ "Enter closure at" <+> pretty addr+            , if null args+                then pretty addr <+> "does not take any arguments, so no frames are popped"+                else hang 4 (vsep+                        [ "Extend local environment with mappings from bound values to argument frame addresses:"+                        , commaSep (foldMap (\arg -> [pretty arg]) args) ])]++        Detail_EvalLet vars addrs ->+            [ hsep+                [ "Local environment extended by"+                , commaSep (foldMap (\var -> [pretty var]) vars) ]+            , hsep+                [ "Allocate new closure" <> pluralS vars <+> "at"+                , commaSep (zipWith (\var addr -> pretty addr <+> "(" <> pretty var <> ")") vars addrs)+                , "on the heap" ]]++        Detail_EvalCase ->+            ["Save alternatives and local environment as a stack frame"]++        Detail_ReturnCon_Match con args ->+            ["Pattern" <+> pretty (AppC con (map AtomVar args)) <+> "matches, follow its branch"]++        Detail_ReturnConDefBound var addr ->+            [ "Allocate closure at" <+> pretty addr <+> "for the bound value"+            , "Extend local environment with" <+> pretty (Mapping var addr) ]++        Detail_ReturnIntDefBound var i ->+            [ "Extend local environment with" <+> pretty (Mapping var (PrimInt i)) ]++        Detail_EnterUpdatable addr ->+            [ "Push a new update frame with the entered address" <+> pretty addr+            , "Overwrite the heap object at" <+> pretty addr <+> "with a black hole" ]++        Detail_ConUpdate con addrU ->+            [ "Trying to return" <+> pretty con <> ", but there is no return frame on the top of the stack"+            , "Update closure at" <+> pretty addrU <+> "given by the update frame with returned constructor"  ]++        Detail_PapUpdate updAddr ->+            [ "Not enough arguments on the stack"+            , "Try to reveal more arguments by performing the update for" <+> pretty updAddr ]++        Detail_ReturnIntCannotUpdate ->+            ["No closure has primitive type, so we cannot update one with a primitive int"]++        Detail_StackNotEmpty ->+            [ "The stack is not empty; the program terminated unexpectedly."+            , "The lack of a better description is a bug in the STG evaluator."+            , "Please report this to the project maintainers!" ]++        Detail_GarbageCollected algorithm deadAddrs movedAddrs -> mconcat+            [ [ "Algorithm: " <> string (T.unpack algorithm) ]+            , [ "Removed old address" <> pluralES deadAddrs <> ":" <+> pprAddrs deadAddrs ]+            , [ "Moved alive address" <> pluralES movedAddrs <> ":" <+> pprMoved movedAddrs+                | not (M.null movedAddrs) ]]+          where+            pprAddrs = pretty . commaSep . foldMap (\addr -> [pretty addr])+            pluralES [_] = ""+            pluralES _ = "es"++            pprMoved = commaSep . map (\(x, y) -> pretty (Mapping x y)) . M.assocs++        Detail_EnterBlackHole addr tick ->+            [ "Heap address" <+> pretty addr <+> "is a black hole, created in step" <+> pretty tick+            , "Entering a black hole means a thunk depends on its own evaluation"+            , "This is the functional equivalent of an infinite loop"+            , "GHC reports this condition as \"<<loop>>\"" ]++        Detail_UpdateClosureWithPrimitive ->+            [ "A closure never has primitive type, so it cannot be updated with a primitive value" ]++        Detail_BadConArity ->+            [ "Constructors always have to be fully applied." ] )++-- | A closure is a lambda form, together with the values of its free variables.+data Closure = Closure LambdaForm [Value]+    deriving (Eq, Ord, Show, Generic)++instance Pretty Closure where+    pretty (Closure lambdaForm []) = pretty lambdaForm+    pretty (Closure lambda freeVals) =+        prettyLambda prettyFree lambda+      where+        prettyFree vars = commaSep (zipWith (\k v -> pretty (Mapping k v)) vars freeVals)++-- | The heap stores closures addressed by memory location.+newtype Heap = Heap (Map MemAddr HeapObject)+    deriving (Eq, Ord, Show, Generic, Monoid)++instance Pretty Heap where+    pretty (Heap heap) = prettyMap heap++data HeapObject =+      HClosure Closure+    | Blackhole Integer+        -- ^ When an updatable closure is entered, it is overwritten by a+        -- black hole. This has two main benefits:+        --+        -- 1. Memory mentioned only in the closure is now ready to be collected,+        --    avoiding certain space leaks.+        -- 2. Entering a black hole means a thunk depends on itself, allowing+        --    the interpreter to catch some non-terminating computations with+        --    a useful error+        --+        -- To make the black hole a bit more transparent, it is tagged with+        -- the STG tick in which it was introduced. This tag is used only for+        -- display purposes.+    deriving (Eq, Ord, Show, Generic)++instance Pretty HeapObject where+    pretty ho = typeOf ho <+> pprHo ho+      where+        pprHo = \case+            HClosure closure -> align (pretty closure)+            Blackhole tick   -> "(from step" <+> integer tick <> ")"+        typeOf = closureType style . \case+            HClosure (Closure lf _free) -> pretty (classify lf)+            Blackhole _ -> "Blackhole"++instance NFData StgState+instance NFData StackFrame+instance NFData MemAddr+instance NFData Value+instance NFData Code+instance (NFData k, NFData v) => NFData (Mapping k v) where+    rnf (Mapping k v) = rnf k `seq` rnf v `seq` ()+instance NFData Globals+instance NFData Locals+instance NFData Info+instance NFData InfoShort+instance NFData StateTransition+instance NFData NotInScope+instance NFData StateError+instance NFData InfoDetail+instance NFData Closure+instance NFData Heap+instance NFData HeapObject
+ src/Stg/Marshal.hs view
@@ -0,0 +1,12 @@+-- | Convert Haskell values to STG values and back.+--+-- This module is what users should be using - it reexports only the safe+-- classes.+module Stg.Marshal (+    ToStg(toStg),+    FromStg(fromStg),+    FromStgError(..),+) where++import Stg.Marshal.FromStg+import Stg.Marshal.ToStg
+ src/Stg/Marshal/FromStg.hs view
@@ -0,0 +1,270 @@+{-# LANGUAGE LambdaCase        #-}+{-# LANGUAGE OverloadedLists   #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Extract Haskell values from running STG programs.+module Stg.Marshal.FromStg (+    FromStg(..),+    FromStgError(..),+) where++++import Data.Bifunctor++import           Stg.Language+import qualified Stg.Machine.Env   as Env+import qualified Stg.Machine.Heap  as H+import           Stg.Machine.Types+import           Stg.Util++++-- | Look up the value of a global variable.+--+-- Instances of this class should have a corresponding 'ToStg' instance to+-- inject a value into the program, with the two being inverse to each other (up+-- to forcing the generated thunks).+class FromStg value where++    -- | Retrieve the value of a global variable.+    fromStg+        :: StgState+        -> Var -- ^ Name of the global, e.g. @main@+        -> Either FromStgError value+    fromStg stgState = globalVal stgState (\case+        PrimInt{} -> Left TypeMismatch+        Addr addr -> fromStgAddr stgState addr )++    -- | Retrieve the value of a heap address.+    fromStgAddr+        :: StgState+        -> MemAddr+        -> Either FromStgError value++    -- | Used only for looking up primitive integers.+    fromStgPrim+        :: Integer+        -> Either FromStgError value+    fromStgPrim _ = Left TypeMismatch++    {-# MINIMAL fromStgAddr #-}++data FromStgError =+      TypeMismatch        -- ^ e.g. asking for an @Int#@ at an address+                          --   that contains a @Cons@+    | IsWrongLambdaType LambdaType -- ^ Tried retrieving a non-constructor+    | IsBlackhole         -- ^ Tried retrieving a black hole+    | BadArity         -- ^ e.g. @Cons x y z@+    | NotFound NotInScope -- ^ An unsuccessful variable lookup+    | AddrNotOnHeap+    | NoConstructorMatch  -- ^ None of the given alternatives matched the given+                          -- constructor, e.g. when trying to receive a 'Left'+                          -- as a 'Just'+    deriving (Eq, Ord, Show)++-- | Look up the global of a variable and handle the result.+--+-- Slighly bent version of 'Env.globalVal' to fit the types in this module+-- better.+globalVal+    :: FromStg value+    => StgState+    -> (Value -> Either FromStgError value) -- ^ What to do with the value if found+    -> Var                                  -- ^ Name of the global value to inspect+    -> Either FromStgError value+globalVal stgState f var = case Env.globalVal (stgGlobals stgState) (AtomVar var) of+    Failure _ -> Left (NotFound (NotInScope [var]))+    Success v -> f v++-- | Create a local environment.+--+-- Slighly bent version of 'Env.makeLocals' to fit the types in this module+-- better.+makeLocals :: [Var] -> [Value] -> Locals+makeLocals freeVars freeVals = Env.makeLocals (zipWith Mapping freeVars freeVals)++-- | Look up the value of an 'Atom' in a state, given a local environment.+atomVal+    :: FromStg value+    => StgState+    -> Locals+    -> Atom+    -> Either FromStgError value+atomVal stgState locals var = case Env.val locals (stgGlobals stgState) var of+    Failure notInScope -> Left (NotFound notInScope)+    Success (Addr addr) -> fromStgAddr stgState addr+    Success (PrimInt i)  -> fromStgPrim i++-- | Inspect whether a closure at a certain memory address matches the desired+-- criteria.+inspect+    :: FromStg value+    => StgState+    -> (Closure -> [Either (Maybe FromStgError) value])+        -- ^ List of possible matches, e.g. Nil and Cons in the list case.+        -- See e.g. 'matchCon2' in order to implement these matchers.+    -> MemAddr+    -> Either FromStgError value+inspect stgState inspectClosure addr = case H.lookup addr (stgHeap stgState) of+    Nothing -> Left AddrNotOnHeap+    Just heapObject -> case heapObject of+        Blackhole{} -> Left IsBlackhole+        HClosure closure -> firstMatch (inspectClosure closure)++  where+    firstMatch :: [Either (Maybe FromStgError) b] -> Either FromStgError b+    firstMatch (Right r : _)         = Right r+    firstMatch (Left Nothing : rest) = firstMatch rest+    firstMatch (Left (Just err) : _) = Left err+    firstMatch []                    = Left NoConstructorMatch+    firstMatch _ghc7_10_3 = error "Default to silence GHC's broken exhaustiveness checker"++instance FromStg () where+    fromStgAddr stgState = inspect stgState (\closure ->+        [matchCon0 "Unit" closure])++instance FromStg Bool where+    fromStgAddr stgState = inspect stgState (\closure ->+        [ True  <$ matchCon0 "True"  closure+        , False <$ matchCon0 "False" closure ])++-- | Boxed (@Int\# 1\#@) or unboxed (@1#@)+instance FromStg Integer where+    fromStg stgState var = case Env.globalVal (stgGlobals stgState) (AtomVar var) of+        Failure _ -> Left (NotFound (NotInScope [var]))+        Success val -> case val of+            PrimInt i -> Right i+            Addr addr -> fromStgAddr stgState addr+    fromStgAddr stgState = inspect stgState (\closure ->+        [ matchCon1 "Int#" closure >>= \(x, locals) ->+            liftToMatcher (atomVal stgState locals x) ])+    fromStgPrim i = Right i++instance (FromStg a, FromStg b) => FromStg (a,b) where+    fromStgAddr stgState = inspect stgState (\closure ->+        [ matchCon2 "Pair" closure >>= \((x,y), locals) ->+            (,) <$> liftToMatcher (atomVal stgState locals x)+                <*> liftToMatcher (atomVal stgState locals y) ])++instance (FromStg a, FromStg b, FromStg c) => FromStg (a,b,c) where+    fromStgAddr stgState = inspect stgState (\closure ->+        [ matchCon3 "Triple" closure >>= \((x,y,z), locals) ->+            (,,) <$> liftToMatcher (atomVal stgState locals x)+                 <*> liftToMatcher (atomVal stgState locals y)+                 <*> liftToMatcher (atomVal stgState locals z) ])++instance (FromStg a, FromStg b, FromStg c, FromStg d) => FromStg (a,b,c,d) where+    fromStgAddr stgState = inspect stgState (\closure ->+        [ matchCon4 "Quadruple" closure >>= \((x,y,z,w), locals) ->+            (,,,) <$> liftToMatcher (atomVal stgState locals x)+                  <*> liftToMatcher (atomVal stgState locals y)+                  <*> liftToMatcher (atomVal stgState locals z)+                  <*> liftToMatcher (atomVal stgState locals w) ])++instance (FromStg a, FromStg b, FromStg c, FromStg d, FromStg e) => FromStg (a,b,c,d,e) where+    fromStgAddr stgState = inspect stgState (\closure ->+        [ matchCon5 "Quintuple" closure >>= \((x,y,z,w,v), locals) ->+            (,,,,) <$> liftToMatcher (atomVal stgState locals x)+                   <*> liftToMatcher (atomVal stgState locals y)+                   <*> liftToMatcher (atomVal stgState locals z)+                   <*> liftToMatcher (atomVal stgState locals w)+                   <*> liftToMatcher (atomVal stgState locals v) ])++instance FromStg a => FromStg (Maybe a) where+    fromStgAddr stgState = inspect stgState (\closure ->+        [ Nothing <$ matchCon0 "Nothing" closure+        , matchCon1 "Just" closure >>= \(arg, locals) ->+            Just <$> liftToMatcher (atomVal stgState locals arg) ])++instance (FromStg a, FromStg b) => FromStg (Either a b) where+    fromStgAddr stgState = inspect stgState (\closure ->+        [ matchCon1 "Left" closure >>= \(arg, locals) ->+            Left  <$> liftToMatcher (atomVal stgState locals arg)+        , matchCon1 "Right" closure >>= \(arg, locals) ->+            Right <$> liftToMatcher (atomVal stgState locals arg) ])++instance FromStg a => FromStg [a] where+    fromStgAddr stgState = inspect stgState (\closure ->+        [ [] <$ matchCon0 "Nil" closure+        , matchCon2 "Cons" closure >>= \((x,xs), locals) ->+             (:) <$> liftToMatcher (atomVal stgState locals x)+                 <*> liftToMatcher (atomVal stgState locals xs) ])++-- | Lift an errable value into a context where the specific error is not+-- necessarily present.+liftToMatcher :: Either e a -> Either (Maybe e) a+liftToMatcher = first Just++-- | Like 'matchCon2', but for nullary 'Constr'uctors.+matchCon0 :: Constr -> Closure -> Either (Maybe FromStgError) ()+matchCon0 _ (Closure lambdaForm _)+    | classify lambdaForm == LambdaThunk = Left (Just (IsWrongLambdaType LambdaThunk))+    | classify lambdaForm == LambdaFun   = Left (Just (IsWrongLambdaType LambdaFun))+matchCon0 wantedCon (Closure (LambdaForm _ _ _ (AppC actualCon args)) _)+    | wantedCon == actualCon = case args of+        []  -> Right ()+        _xs -> Left (Just BadArity)+matchCon0 _ _ = Left Nothing++-- | Like 'matchCon2', but for unary 'Constr'uctors.+matchCon1 :: Constr -> Closure -> Either (Maybe FromStgError) (Atom, Locals)+matchCon1 _ (Closure lambdaForm _)+    | classify lambdaForm == LambdaThunk = Left (Just (IsWrongLambdaType LambdaThunk))+    | classify lambdaForm == LambdaFun   = Left (Just (IsWrongLambdaType LambdaFun))+matchCon1 wantedCon (Closure (LambdaForm freeVars _ _ (AppC actualCon args)) freeVals)+    | wantedCon == actualCon = case args of+        [x] -> Right (x, makeLocals freeVars freeVals)+        _xs -> Left (Just BadArity)+matchCon1 _ _ = Left Nothing++-- | Match a 'Closure' for a binary 'Constr'uctor.+--+-- * If the constructor matches, return its arguments, and the local environment+--   stored in the closure.+-- * If the constructor does not match, return 'Nothing' as error, indicating+--   to the caller that the next matcher should be tried.+-- * If the constructor fails due to a non-recoverable error, such as wrong+--   arity, abort with the corresponding error.+matchCon2 :: Constr -> Closure -> Either (Maybe FromStgError) ((Atom, Atom), Locals)+matchCon2 _ (Closure lambdaForm _)+    | classify lambdaForm == LambdaThunk = Left (Just (IsWrongLambdaType LambdaThunk))+    | classify lambdaForm == LambdaFun   = Left (Just (IsWrongLambdaType LambdaFun))+matchCon2 wantedCon (Closure (LambdaForm freeVars _ _ (AppC actualCon args)) freeVals)+    | wantedCon == actualCon = case args of+        [x,y] -> Right ((x,y), makeLocals freeVars freeVals)+        _xs   -> Left (Just BadArity)+matchCon2 _ _ = Left Nothing++-- | Like 'matchCon2', but for ternary 'Constr'uctors.+matchCon3 :: Constr -> Closure -> Either (Maybe FromStgError) ((Atom, Atom, Atom), Locals)+matchCon3 _ (Closure lambdaForm _)+    | classify lambdaForm == LambdaThunk = Left (Just (IsWrongLambdaType LambdaThunk))+    | classify lambdaForm == LambdaFun   = Left (Just (IsWrongLambdaType LambdaFun))+matchCon3 wantedCon (Closure (LambdaForm freeVars _ _ (AppC actualCon args)) freeVals)+    | wantedCon == actualCon = case args of+        [x,y,z] -> Right ((x,y,z), makeLocals freeVars freeVals)+        _xs     -> Left (Just BadArity)+matchCon3 _ _ = Left Nothing++-- | Like 'matchCon2', but for 4-ary 'Constr'uctors.+matchCon4 :: Constr -> Closure -> Either (Maybe FromStgError) ((Atom, Atom, Atom, Atom), Locals)+matchCon4 _ (Closure lambdaForm _)+    | classify lambdaForm == LambdaThunk = Left (Just (IsWrongLambdaType LambdaThunk))+    | classify lambdaForm == LambdaFun   = Left (Just (IsWrongLambdaType LambdaFun))+matchCon4 wantedCon (Closure (LambdaForm freeVars _ _ (AppC actualCon args)) freeVals)+    | wantedCon == actualCon = case args of+        [x,y,z,w] -> Right ((x,y,z,w), makeLocals freeVars freeVals)+        _xs       -> Left (Just BadArity)+matchCon4 _ _ = Left Nothing++-- | Like 'matchCon2', but for 5-ary 'Constr'uctors.+matchCon5 :: Constr -> Closure -> Either (Maybe FromStgError) ((Atom, Atom, Atom, Atom, Atom), Locals)+matchCon5 _ (Closure lambdaForm _)+    | classify lambdaForm == LambdaThunk = Left (Just (IsWrongLambdaType LambdaThunk))+    | classify lambdaForm == LambdaFun   = Left (Just (IsWrongLambdaType LambdaFun))+matchCon5 wantedCon (Closure (LambdaForm freeVars _ _ (AppC actualCon args)) freeVals)+    | wantedCon == actualCon = case args of+        [x,y,z,w,v] -> Right ((x,y,z,w,v), makeLocals freeVars freeVals)+        _xs         -> Left (Just BadArity)+matchCon5 _ _ = Left Nothing
+ src/Stg/Marshal/ToStg.hs view
@@ -0,0 +1,288 @@+{-# LANGUAGE LambdaCase        #-}+{-# LANGUAGE OverloadedLists   #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes       #-}++-- | Convert Haskell values to STG values.+module Stg.Marshal.ToStg (+    ToStg(..),+) where++++import           Control.Applicative+import           Control.Monad.Trans.Class+import           Control.Monad.Trans.Writer+import           Data.List.NonEmpty         (NonEmpty (..))+import qualified Data.List.NonEmpty         as NonEmpty+import qualified Data.Map                   as M+import           Data.Monoid+import           Data.Text                  (Text)++import           Stg.Language+import qualified Stg.Parser.QuasiQuoter as QQ+import qualified Stg.Prelude.List       as Stg+import qualified Stg.Prelude.Maybe      as Stg+import           Stg.Util++-- $setup+-- >>> :set -XOverloadedStrings+-- >>> let ppr = Data.Text.IO.putStrLn . Stg.Language.Prettyprint.prettyprintPlain++++-- | Prefix for all generated variables+genPrefix :: Text+genPrefix = "__"++-- | Convert a Haskell value to an STG binding.+--+-- Instances of this class should have a corresponding 'FromStg' instance to+-- retrieve a value fom the program, with the two being inverse to each other+-- (up to forcing the generated thunks).+--+-- This class contains a helper function, 'toStgWithGlobals', this is hidden+-- from the outside. If you want to write your own instance, have a look at the+-- source for documentation.+class ToStg value where+    toStg+        :: Var -- ^ Name of the binding+        -> value+        -> Program+    toStg var val =+        let (globals, actualDef) = runWriter (toStgWithGlobals var val)+        in globals <> actualDef++    -- | Some definitions, such as the one for lists, require certain global+    -- values to be present (such as nil). In order to avoid duplicate+    -- definitions, this function allows defining top-level elements using+    -- 'Writer's 'tell' function.+    toStgWithGlobals+        :: Var -- ^ Name of the binding+        -> value+        -> Writer Program Program -- ^ Log: globals; value: value definition itself+    toStgWithGlobals var val = pure (toStg var val)++    {-# MINIMAL toStg | toStgWithGlobals #-}++-- | >>> ppr (toStg "unit" ())+-- unit = \ -> Unit+instance ToStg () where+    toStg name _ = Program (Binds [(name, LambdaForm [] NoUpdate []+        (AppC (Constr "Unit") []) )])++-- | >>> ppr (toStg "int" (1 :: Integer))+-- int = \ -> Int# 1#+instance ToStg Integer where+    toStg name i = Program (Binds [(name, LambdaForm [] NoUpdate []+        (AppC (Constr "Int#") [AtomLit (Literal i)]) )])++-- | Same as the 'Integer' instance, but makes for shorter type annotations+instance ToStg Int where+    toStg name i = toStg name (fromIntegral i :: Integer)++-- | >>> ppr (toStg "bool" True)+-- bool = \ -> True+instance ToStg Bool where+    toStg name b = Program (Binds [(name, LambdaForm [] NoUpdate []+        (AppC (Constr (show' b)) []) )])++-- | >>> ppr (toStg "maybe" (Nothing :: Maybe Int))+-- maybe = \ => nothing;+-- nothing = \ -> Nothing+--+-- >>> ppr (toStg "maybe" (Just 1 :: Maybe Int))+-- maybe = \ =>+--     let __justVal = \ -> Int# 1#+--     in Just __justVal+instance ToStg a => ToStg (Maybe a) where+    toStgWithGlobals name Nothing = do+        tell Stg.nothing+        pure (Program (Binds [(name, [QQ.stg| \ => nothing |])]))+    toStgWithGlobals name (Just x) = do+        Program xBinding <- toStgWithGlobals justBindName x+        pure (Program (Binds [+            ( name+            , LambdaForm [] Update []+                (Let NonRecursive+                    xBinding+                    (AppC "Just" [AtomVar justBindName]) ))]))+      where+        justBindName :: Var+        justBindName = Var (genPrefix <> "justVal")++-- | >>> ppr (toStg "either" (Left 1 :: Either Int [Int]))+-- either = \ =>+--     let __leftval = \ -> Int# 1#+--     in Left __leftval+--+-- >>> ppr (toStg "either" (Right 2 :: Either [Int] Int))+-- either = \ =>+--     let __rightval = \ -> Int# 2#+--     in Right __rightval+instance (ToStg a, ToStg b) => ToStg (Either a b) where+    toStgWithGlobals name x = do+        let bindName = Var (genPrefix <> chooseEither "left" "right" x <> "val")+        Program xBinding <- case x of+            Left l  -> toStgWithGlobals bindName l+            Right r -> toStgWithGlobals bindName r+        pure (Program (Binds [+            ( name+            , LambdaForm [] Update []+                (Let NonRecursive+                    xBinding+                    (AppC (chooseEither "Left" "Right" x) [AtomVar bindName]) ))]))+          where+            chooseEither l _ (Left  _) = l+            chooseEither _ r (Right _) = r++-- | >>> ppr (toStg "list" ([] :: [Int]))+-- list = \ => nil;+-- nil = \ -> Nil+--+-- >>> ppr (toStg "list" [1, 2, 3 :: Int])+-- list = \ =>+--     letrec __0_value = \ -> Int# 1#;+--            __1_cons = \(__1_value __2_cons) -> Cons __1_value __2_cons;+--            __1_value = \ -> Int# 2#;+--            __2_cons = \(__2_value) -> Cons __2_value nil;+--            __2_value = \ -> Int# 3#+--     in Cons __0_value __1_cons;+-- nil = \ -> Nil+instance ToStg a => ToStg [a] where+    toStgWithGlobals name dataValues = do+        tell Stg.nil+        case dataValues of+            (x:xs) -> do+                (Just inExpression, letBindings)+                    <- mkListBinds Nothing (NonEmpty.zip [0..] (x :| xs))+                let rec = if null xs then NonRecursive else Recursive+                pure (Program (Binds [(name, LambdaForm [] Update []+                    (Let rec letBindings inExpression) )]))+            _nil -> pure (Program (Binds [(name, [QQ.stg| \ => nil |])]))+      where++        mkConsVar :: Int -> Var+        mkConsVar i = Var (genPrefix <> show' i <> "_cons")++        mkListBinds+            :: ToStg value+            => Maybe Expr -- ^ Has the 'in' part of the @let@ already been+                          -- set, and if yes to what? Used to avoid allocating+                          -- the first cons cell, avoiding an immediate GC.+            -> NonEmpty (Int, value) -- ^ Index and value of the cells+            -> Writer Program (Maybe Expr, Binds)+        mkListBinds inExpression ((i, value) :| rest) = do++            let valueVar = Var (genPrefix <> show' i <> "_value")+            Program valueBind <- toStgWithGlobals valueVar value++            (inExpression', restBinds) <- do+                let consVar = mkConsVar i+                    nextConsVar = if null rest then Var "nil"+                                               else mkConsVar (i+1)+                    consBind = case inExpression of+                        Nothing -> mempty+                        Just _ -> (Binds . M.singleton consVar) (LambdaForm+                            (valueVar : [nextConsVar | not (null rest)])+                            NoUpdate -- Standard constructors are not updatable+                            []+                            consExpr )+                    consExpr = AppC (Constr "Cons") (map AtomVar [valueVar, nextConsVar])++                    inExpression' = inExpression <|> Just consExpr++                recursiveBinds <- case rest of+                    (i',v') : isvs -> fmap snd (mkListBinds inExpression' ((i',v') :| isvs))+                    _nil           -> pure mempty++                pure (inExpression', consBind <> recursiveBinds)++            pure (inExpression', valueBind <> restBinds)++tupleEntry+    :: ToStg value+    => Text+    -> value+    -> WriterT Binds (Writer Program) ()+tupleEntry name val = do+    let bindName = Var (genPrefix <> name)+    Program bind <- lift (toStgWithGlobals bindName val)+    tell bind++-- | This definition unifies the creation of tuple bindings to reduce code+-- duplication between the tuple instances.+tupleBinds+    :: Var    -- ^ Name of the tuple binding+    -> Constr -- ^ Name of the tuple constructor, e.g. \"Pair"+    -> Binds  -- ^ Bindings of the entries+    -> Binds+tupleBinds name tupleCon binds  =+    let bindVars =+            let Binds b = binds+            in M.keys b+    in Binds [(name,+        LambdaForm [] Update []+            (Let NonRecursive+                binds+                (AppC tupleCon (map AtomVar bindVars)) ))]++-- | >>> ppr (toStg "pair" ((1,2) :: (Int,Int)))+-- pair = \ =>+--     let __fst = \ -> Int# 1#;+--         __snd = \ -> Int# 2#+--     in Pair __fst __snd+instance (ToStg a, ToStg b) => ToStg (a,b) where+    toStgWithGlobals name (x,y) = do+        binds <- execWriterT (do+            tupleEntry "fst" x+            tupleEntry "snd" y )+        pure (Program (tupleBinds name (Constr "Pair") binds))++-- | >>> ppr (toStg "triple" ((1,2,3) :: (Int,Int,Int)))+-- triple = \ =>+--     let __x = \ -> Int# 1#;+--         __y = \ -> Int# 2#;+--         __z = \ -> Int# 3#+--     in Triple __x __y __z+instance (ToStg a, ToStg b, ToStg c) => ToStg (a,b,c) where+    toStgWithGlobals name (x,y,z) = do+        binds <- execWriterT (do+            tupleEntry "x" x+            tupleEntry "y" y+            tupleEntry "z" z )+        pure (Program (tupleBinds name (Constr "Triple") binds))++-- | >>> ppr (toStg "quadruple" ((1,2,3,4) :: (Int,Int,Int,Int)))+-- quadruple = \ =>+--     let __w = \ -> Int# 1#;+--         __x = \ -> Int# 2#;+--         __y = \ -> Int# 3#;+--         __z = \ -> Int# 4#+--     in Quadruple __w __x __y __z+instance (ToStg a, ToStg b, ToStg c, ToStg d) => ToStg (a,b,c,d) where+    toStgWithGlobals name (w4,x4,y4,z4) = do+        binds <- execWriterT (do+            tupleEntry "w" w4+            tupleEntry "x" x4+            tupleEntry "y" y4+            tupleEntry "z" z4 )+        pure (Program (tupleBinds name (Constr "Quadruple") binds))++-- | >>> ppr (toStg "quintuple" ((1,2,3,4,5) :: (Int,Int,Int,Int,Int)))+-- quintuple = \ =>+--     let __v = \ -> Int# 1#;+--         __w = \ -> Int# 2#;+--         __x = \ -> Int# 3#;+--         __y = \ -> Int# 4#;+--         __z = \ -> Int# 5#+--     in Quintuple __v __w __x __y __z+instance (ToStg a, ToStg b, ToStg c, ToStg d, ToStg e) => ToStg (a,b,c,d,e) where+    toStgWithGlobals name (v5,w5,x5,y5,z5) = do+        binds <- execWriterT (do+            tupleEntry "v" v5+            tupleEntry "w" w5+            tupleEntry "x" x5+            tupleEntry "y" y5+            tupleEntry "z" z5 )+        pure (Program (tupleBinds name (Constr "Quintuple") binds))
+ src/Stg/Parser/Parser.hs view
@@ -0,0 +1,309 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase                 #-}+{-# LANGUAGE OverloadedLists            #-}+{-# LANGUAGE OverloadedStrings          #-}++-- | A parser for the STG language, modeled after the grammar given in the+-- description in the 1992 paper+-- <http://research.microsoft.com/apps/pubs/default.aspx?id=67083 (link)>+-- with a couple of differences to enhance usability:+--+--   * Function application uses no parentheses or commas like in Haskell+--     (@f x y z@), not with curly parentheses and commas like in the paper+--     (@f {x,y,z}@).+--   * Comment syntax like in Haskell: @-- inline@, @{- multiline -}@.+--   * Constructors may end with a @#@ to allow labelling primitive boxes+--     e.g. with @Int#@.+--   * A lambda's head is written @\\(free) bound -> body@, where @free@ and+--     @bound@ are space-separated variable lists, instead of the paper's+--     @(free) \\n (bound) -> body@, which uses comma-separated lists. The+--     update flag @\\u@ is signified using a double arrow @=>@ instead of the+--     normal arrow @->@.+module Stg.Parser.Parser (++    -- * General parsing+    parse,+    StgParser,++    -- * Parser rules+    program,+    binds,+    lambdaForm,+    expr,+    alts,+    nonDefaultAlts,+    algebraicAlt,+    primitiveAlt,+    defaultAlt,+    literal,+    primOp,+    atom,+    var,+    con,+) where++++import           Control.Applicative+import           Control.Monad+import           Data.Char                    (isSpace)+import           Data.List                    as L+import qualified Data.List.NonEmpty           as NonEmpty+import qualified Data.Map.Strict              as M+import           Data.Maybe+import           Data.Monoid+import           Data.Text                    (Text)+import qualified Data.Text                    as T+import           Text.Parser.Token.Highlight+import           Text.PrettyPrint.ANSI.Leijen (Doc)+import           Text.Trifecta                as Trifecta++import Stg.Language++++-- | Parse STG source using a user-specified parser. To parse a full program,+-- use @'parse' 'program'@.+--+-- >>> parse program "id = \\x -> x"+-- Right (Program (Binds [(Var "id",LambdaForm [] NoUpdate [Var "x"] (AppF (Var "x") []))]))+parse :: StgParser ast -> Text -> Either Doc ast+parse (StgParser p) input = case parseString (whiteSpace *> p <* eof) mempty (T.unpack input) of+    Success a -> Right a+    Failure e -> Left e++-- | Skip a certain token. Useful to consume, but not otherwise use, certain+-- tokens.+skipToken :: TokenParsing parser => parser a -> parser ()+skipToken = void . token++-- | A parser for an STG syntax element.+newtype StgParser ast = StgParser (Trifecta.Parser ast)+    deriving (CharParsing, Parsing, Alternative, Applicative, Functor, Monad)++instance TokenParsing StgParser where+    someSpace = skipMany (void (satisfy isSpace) <|> comment)++-- | Syntax rules for parsing variable-looking like identifiers.+varId :: TokenParsing parser => IdentifierStyle parser+varId = IdentifierStyle+    { _styleName = "variable"+    , _styleStart = lower <|> char '_'+    , _styleLetter = alphaNum <|> oneOf "_'"+    , _styleReserved = ["let", "letrec", "in", "case", "of", "default"]+    , _styleHighlight = Identifier+    , _styleReservedHighlight = ReservedIdentifier }++-- | Parse a variable identifier. Variables start with a lower-case letter or+-- @_@, followed by a string consisting of alphanumeric characters or @'@, @_@.+var :: (Monad parser, TokenParsing parser) => parser Var+var = ident varId++-- | Skip a reserved variable identifier.+reserved :: (Monad parser, TokenParsing parser) => Text -> parser ()+reserved = reserveText varId++-- | Parse a constructor identifier. Constructors follow the same naming+-- conventions as variables, but start with an upper-case character instead, and+-- may end with a @#@ symbol.+con :: (Monad parser, TokenParsing parser) => parser Constr+con = highlight Constructor constructor <?> "constructor"+  where+    constructor = token (do+        start <- upper+        body  <- many (alphaNum <|> oneOf "_'")+        end   <- string "#" <|> pure ""+        (pure . Constr . T.pack) (start : body <> end) )++-- | Parse an STG program.+program :: (Monad parser, TokenParsing parser) => parser Program+program = someSpace *> fmap Program binds <* eof <?> "STG program"++-- | Parse a collection of bindings, used by @let(rec)@ expressions and at the+-- top level of a program.+binds :: (Monad parser, TokenParsing parser) => parser Binds+binds = bindings <?> "non-empty list of bindings"+  where+    bindings = fmap (Binds . M.fromList) (sepBy1 binding semi)+    binding = (,) <$> var <* symbol "=" <*> lambdaForm++comment :: TokenParsing parser => parser ()+comment = skipToken (highlight Comment (lineComment <|> blockComment)) <?> ""+  where+    lineComment  = try (symbol "--") *> manyTill anyChar (char '\n')+    blockComment = try (symbol "{-") *> manyTill anyChar (try (symbol "-}"))++-- | Parse a lambda form, consisting of a list of free variables, and update+-- flag, a list of bound variables, and the function body.+lambdaForm :: (Monad parser, TokenParsing parser) => parser LambdaForm+lambdaForm = lf >>= validateLambda <?> "lambda form"+  where+    lf :: (Monad parser, TokenParsing parser) => parser LambdaForm+    lf = (\free bound upd body -> LambdaForm free upd bound body)+         <$  token (char '\\')+         <*> (parens (some var) <|> pure [])+         <*> many var+         <*> updateArrow+         <*> expr++    validateLambda = \case+        LambdaForm _ Update [] AppC{} ->+           fail "Standard constructors are never updatable"+        LambdaForm _ Update (_:_) _ ->+           fail "Lambda forms with non-empty argument lists are never updatable"+        LambdaForm _ _ _ Lit{} ->+           fail "No lambda form has primitive type like 1#;\+                \ primitives must be boxed, e.g. Int# (1#)"+        LambdaForm _ _ _ AppP{} ->+           fail "No lambda form has primitive type like \"+# a b\";\+                \ only \"case\" can evaluate them"+        x -> pure x++    -- Parse an update flag arrow. @->@ means no update, @=>@ update.+    updateArrow :: (Monad parser, TokenParsing parser) => parser UpdateFlag+    updateArrow = token (symbol "->" *> pure NoUpdate+                     <|> symbol "=>" *> pure Update+                     <?> "update arrow" )++-- | Parse an arrow token, @->@.+arrow :: TokenParsing parser => parser ()+arrow = skipToken (symbol "->")++-- | Parse an expression, which can be+--+--   * let, @let(rec) ... in ...@+--   * case, @case ... of ...@+--   * function application, @f (...)@+--   * constructor application, @C (...)@+--   * primitive application, @p# (...)@+--   * literal, @1#@+expr :: (Monad parser, TokenParsing parser) => parser Expr+expr = choice [let', case', appF, appC, appP, lit] <?> "expression"+  where+    letHead+        :: (Monad parser, TokenParsing parser)+        => parser (Binds -> Expr -> Expr)+    let', case', appF, appC, appP, lit+        :: (Monad parser, TokenParsing parser)+        => parser Expr++    letHead = reserved "letrec" *> pure (Let Recursive)+          <|> reserved "let"    *> pure (Let NonRecursive)+    let' = letHead+        <*> binds+        <*  reserved "in"+        <*> expr+        <?> "let(rec)"+    case' = Case+        <$  reserved "case"+        <*> (expr <?> "expression (as case scrutinee)")+        <*  reserved "of"+        <*> alts+        <?> "case expression"+    appF = AppF <$> var <*> many atom <?> "function application"+    appC = AppC <$> con <*> many atom <?> "constructor application"+    appP = AppP <$> primOp <*> atom <*> atom <?> "primitive function application"+    lit = Lit <$> literal <?> "literal expression"++-- | Parse the alternatives given in a @case@ expression.+alts :: (Monad parser, TokenParsing parser) => parser Alts+alts = Alts+       <$> nonDefaultAlts+       <*> defaultAlt+       <?> "case alternatives"++atom :: (Monad parser, TokenParsing parser) => parser Atom+atom = AtomVar <$> var+   <|> AtomLit <$> literal+   <?> "atom (variable or literal)"+++-- | Parse a primitive operation.+--+-- @+-- +#+-- @+primOp :: TokenParsing parser => parser PrimOp+primOp = choice ops <?> "primitive function"+  where+    ops = [ "+"  ~> Add+          , "-"  ~> Sub+          , "*"  ~> Mul+          , "/"  ~> Div+          , "%"  ~> Mod+          , "<"  ~> Lt+          , "<=" ~> Leq+          , "==" ~> Eq+          , "/=" ~> Neq+          , ">=" ~> Geq+          , ">"  ~> Gt ]+    op ~> val = token (try (string op <* char '#')) *> pure val++literal :: TokenParsing parser => parser Literal+literal = token (Literal <$> integer' <* char '#') <?> "integer literal"+++-- | Parse non-default alternatives. The list of alternatives can be either+-- empty, all algebraic, or all primitive.+--+-- @+-- Nil -> ...+-- Cons x xs -> ...+-- @+--+-- @+-- 1# -> ...+-- 2# -> ...+-- @+nonDefaultAlts :: (Monad parser, TokenParsing parser) => parser NonDefaultAlts+nonDefaultAlts = AlgebraicAlts . NonEmpty.fromList <$> some algebraicAlt+             <|> PrimitiveAlts . NonEmpty.fromList <$> some primitiveAlt+             <|> pure NoNonDefaultAlts+             <?> "non-default case alternatives"++-- | Parse a single algebraic alternative.+--+-- @+-- Cons x xs -> ...+-- @+algebraicAlt :: (Monad parser, TokenParsing parser) => parser AlgebraicAlt+algebraicAlt = try (AlgebraicAlt <$> con)+           <*> (many var >>= disallowDuplicates)+           <*  arrow+           <*> expr+           <*  semi+           <?> "algebraic case alternative"+  where+    disallowDuplicates vars = case duplicates vars of+        [] -> pure vars+        dups ->+            let plural = case dups of [_] -> ""; _ -> "s"+                errMsg = "Duplicate variable" <> plural <> " in binding: "+                         <> L.intercalate ", " varNames+                varNames = map (\(Var v) -> T.unpack v) dups+            in fail errMsg+    duplicates = mapMaybe (\case (x:_:_) -> Just x; _ -> Nothing) . group . sort++-- | Parse a single primitive alternative, such as @1#@.+--+-- @+-- 1# -> ...+-- @+primitiveAlt :: (Monad parser, TokenParsing parser) => parser PrimitiveAlt+primitiveAlt = try (PrimitiveAlt <$> literal) <* arrow <*> expr <* semi+    <?> "primitive case alternative"++-- | Parse the default alternative, taken if none of the other alternatives+-- in a @case@ expression match.+--+-- @+-- default -> ...+-- @+--+-- @+-- v -> ...+-- @+defaultAlt :: (Monad parser, TokenParsing parser) => parser DefaultAlt+defaultAlt = DefaultNotBound <$ reserved "default" <* arrow <*> expr+         <|> DefaultBound <$> var <* arrow <*> expr+         <?> "default alternative"
+ src/Stg/Parser/QuasiQuoter.hs view
@@ -0,0 +1,204 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell   #-}++-- | Quasiquoters for easier generation of STG syntax trees.+-- The 'stg' quoter is most convenient, I suggest you use it unless you have a+-- reason not to.+module Stg.Parser.QuasiQuoter (++    -- * Heuristic quasiquoter+    stg,++    -- * Specific syntax element quasiquoters+    program,+    binds,+    lambdaForm,+    expr,+    alts,+    nonDefaultAlts,+    algebraicAlt,+    primitiveAlt,+    defaultAlt,+    literal,+    primOp,+    atom,+) where++++import           Data.Either+import           Data.Monoid+import           Data.Text                    (Text)+import qualified Data.Text                    as T+import           Language.Haskell.TH+import           Language.Haskell.TH.Lift+import           Language.Haskell.TH.Quote+import           Text.PrettyPrint.ANSI.Leijen hiding ((<>))++import           Stg.Language.Prettyprint+import           Stg.Parser.Parser        (StgParser, parse)+import qualified Stg.Parser.Parser        as Parser++-- $setup+-- >>> :set -XTemplateHaskell+-- >>> :set -XQuasiQuotes++++defaultQuoter :: QuasiQuoter+defaultQuoter = QuasiQuoter+    { quoteExp  = \_ -> fail "No STG expression quoter implemented"+    , quotePat  = \_ -> fail "No STG pattern quoter implemented"+    , quoteType = \_ -> fail "No STG type quoter implemented"+    , quoteDec  = \_ -> fail "No STG declaration quoter implemented" }++-- | Heuristic quasiquoter for STG language elements.+-- Tries a number of parsers, and will use the first successful one.+--+-- To gain more fine-grained control over what the input should be parsed to,+-- use one of the non-heuristic quoters, such as 'stgProgram' or+-- 'stgLambdaForm'. These will also give you much better error messages than+-- merely "doesn't work".+--+-- >>> [stg| id = \x -> x |]+-- Program (Binds [(Var "id",LambdaForm [] NoUpdate [Var "x"] (AppF (Var "x") []))])+--+-- >>> [stg| \x -> x |]+-- LambdaForm [] NoUpdate [Var "x"] (AppF (Var "x") [])+--+-- >>> [stg| x |]+-- AppF (Var "x") []+stg :: QuasiQuoter+stg = defaultQuoter { quoteExp = expQuoter }+  where+    expQuoter inputString =+        let input = T.pack inputString+            parses =+                [ quoteAs "program"        Parser.program        input+                , quoteAs "lambdaForm"     Parser.lambdaForm     input+                , quoteAs "expr"           Parser.expr           input+                , quoteAs "alts"           Parser.alts           input+                , quoteAs "algebraicAlt"   Parser.algebraicAlt   input+                , quoteAs "primitiveAlt"   Parser.primitiveAlt   input+                , quoteAs "defaultAlt"     Parser.defaultAlt     input+                , quoteAs "literal"        Parser.literal        input+                , quoteAs "primOp"         Parser.primOp         input+                , quoteAs "atom"           Parser.atom           input+                , quoteAs "variable"       Parser.var            input+                , quoteAs "constructor"    Parser.con            input ]+        in case partitionEithers parses of+            (_, ast:_) -> ast+            (errs, _) -> (fail . T.unpack . T.unlines)+                ("No parse succeeded. Individual errors:" : errs)++    -- | Attempt to parse an input using a certain parser, and return the+    -- generated expression on success.+    quoteAs :: Lift ast => Text -> Parser.StgParser ast -> Text -> Either Text (Q Exp)+    quoteAs parserName parser input = fmap lift (case Parser.parse parser input of+        Left err -> Left (prettyprint ("  -" <+> text (T.unpack parserName) <> ":" <+> plain (align err)))+        Right r -> Right r )++-- | Build a quasiquoter from a 'Parser'.+stgQQ+    :: Lift ast+    => StgParser ast+    -> Text -- ^ Name of the parsed syntax element (for error reporting)+    -> QuasiQuoter+stgQQ parser elementName = defaultQuoter { quoteExp  = expQuoter }+    where+    expQuoter input = case parse parser (T.pack input) of+        Left err  -> fail (T.unpack ("Invalid STG " <> elementName <> ":\n" <> prettyprint (plain err)))+        Right ast -> [| ast |]++-- | Quasiquoter for 'Stg.Language.Program's.+--+-- >>> [program| id = \x -> x |]+-- Program (Binds [(Var "id",LambdaForm [] NoUpdate [Var "x"] (AppF (Var "x") []))])+program :: QuasiQuoter+program = stgQQ Parser.program "program"++-- | Quasiquoter for 'Stg.Language.Binds'.+--+-- >>> [binds| id = \x -> x |]+-- (Binds [(Var "id",LambdaForm [] NoUpdate [Var "x"] (AppF (Var "x") []))])+binds :: QuasiQuoter+binds = stgQQ Parser.binds "binds"++-- | Quasiquoter for 'Stg.Language.LambdaForm's.+--+-- >>> [lambdaForm| \x -> x |]+-- LambdaForm [] NoUpdate [Var "x"] (AppF (Var "x") [])+lambdaForm :: QuasiQuoter+lambdaForm = stgQQ Parser.lambdaForm "lambda form"++-- | Quasiquoter for 'Stg.Language.Expr'essions.+--+-- >>> [expr| f x y z |]+-- AppF (Var "f") [AtomVar (Var "x"),AtomVar (Var "y"),AtomVar (Var "z")]+expr :: QuasiQuoter+expr = stgQQ Parser.expr "expression"++-- | Quasiquoter for 'Stg.Language.Alts'.+--+-- >>> [alts| Just x -> True; default -> False |]+-- Alts (AlgebraicAlts (AlgebraicAlt (Constr "Just") [Var "x"] (AppC (Constr "True") []) :| [])) (DefaultNotBound (AppC (Constr "False") []))+--+-- >>> [alts| 0# -> True; default -> False |]+-- Alts (PrimitiveAlts (PrimitiveAlt (Literal 0) (AppC (Constr "True") []) :| [])) (DefaultNotBound (AppC (Constr "False") []))+alts :: QuasiQuoter+alts = stgQQ Parser.alts "alternatives"++-- | Quasiquoter for 'Stg.Language.Alt'.+--+-- >>> [nonDefaultAlts| Just x -> True; Nothing -> False; |]+-- AlgebraicAlts (AlgebraicAlt (Constr "Just") [Var "x"] (AppC (Constr "True") []) :| [AlgebraicAlt (Constr "Nothing") [] (AppC (Constr "False") [])])+--+-- >>> [nonDefaultAlts| 0# -> False; 1# -> True; |]+-- PrimitiveAlts (PrimitiveAlt (Literal 0) (AppC (Constr "False") []) :| [PrimitiveAlt (Literal 1) (AppC (Constr "True") [])])+nonDefaultAlts :: QuasiQuoter+nonDefaultAlts = stgQQ Parser.nonDefaultAlts "algebraic alternatives"++-- | Quasiquoter for 'Stg.Language.AlgebraicAlt's.+--+-- >>> [algebraicAlt| Just x -> x; |]+-- AlgebraicAlt (Constr "Just") [Var "x"] (AppF (Var "x") [])+algebraicAlt :: QuasiQuoter+algebraicAlt = stgQQ Parser.algebraicAlt "algebraic alternative"++-- | Quasiquoter for 'Stg.Language.PrimitiveAlt's.+--+-- >>> [primitiveAlt| 1# -> x; |]+-- PrimitiveAlt (Literal 1) (AppF (Var "x") [])+primitiveAlt :: QuasiQuoter+primitiveAlt = stgQQ Parser.primitiveAlt "primitive alternative"++-- | Quasiquoter for 'Stg.Language.DefaultAlt's.+--+-- >>> [defaultAlt| default -> x |]+-- DefaultNotBound (AppF (Var "x") [])+--+-- >>> [defaultAlt| x -> x |]+-- DefaultBound (Var "x") (AppF (Var "x") [])+defaultAlt :: QuasiQuoter+defaultAlt = stgQQ Parser.defaultAlt "default alternative"++-- | Quasiquoter for 'Stg.Language.Literal's.+--+-- >>> [literal| 1# |]+-- Literal 1+literal :: QuasiQuoter+literal = stgQQ Parser.literal "literal"++-- | Quasiquoter for 'Stg.Language.PrimOp's.+--+-- >>> [primOp| +# |]+-- Add+primOp :: QuasiQuoter+primOp = stgQQ Parser.primOp "primop"++-- | Quasiquoter for 'Stg.Language.Atom's.+--+-- >>> [atom| x |]+-- AtomVar (Var "x")+atom :: QuasiQuoter+atom = stgQQ Parser.atom "atom"
+ src/Stg/Prelude.hs view
@@ -0,0 +1,140 @@+{-# LANGUAGE QuasiQuotes #-}++-- | Common Haskell functions, translated to STG. Use the 'Monoid' instance+-- for 'Program' to mix them.+--+-- This module should be imported qualified, since it heavily conflicts with the+-- standard Haskell "Prelude".+module Stg.Prelude (+    -- * Maybe+    maybe,+    nothing,++    -- * Lists+    nil,+    concat2,+    reverse,+    foldl,+    foldl',+    foldr,+    iterate,+    cycle,+    take,+    filter,+    repeat,+    replicate,+    sort,+    naiveSort,+    map,+    length,+    zip,+    zipWith,+    forceSpine,+    equals_List_Int,++    -- * Tuples+    fst,+    snd,+    curry,+    uncurry,+    swap,+    equals_Pair_Int,++    -- * Boolean+    and2,+    or2,+    not,+    bool,+    eq_Bool,++    -- * Numbers+    -- ** Arithmetic+    add,+    sub,+    mul,+    div,+    mod,+    -- ** Comparisons+    eq_Int,+    lt_Int,+    leq_Int,+    gt_Int,+    geq_Int,+    neq_Int,++    -- ** Other+    min,+    max,++    -- * Functions+    seq,+    id,+    const,+    compose,+    fix,++    -- * Helpers+    force,+) where++++import Prelude ()++import Stg.Language+import Stg.Parser.QuasiQuoter+import Stg.Prelude.Bool+import Stg.Prelude.Function+import Stg.Prelude.List+import Stg.Prelude.Maybe+import Stg.Prelude.Number+import Stg.Prelude.Tuple++-- | Force a value to normal form and return it.+--+-- This function makes heavy use of the fact that the STG is untyped. It+-- currently supports the following types:+--+--  * Unit (Unit)+--  * Maybe (Just, Nothing)+--  * Bool (True, False)+--  * Int (Int#)+--  * Either (Left, Right)+--  * Tuples (Pair, Triple)+--  * List (Nil, Cons)+--+-- Everything else will run into an error.+force :: Program+force = [stg|+    force = \ =>+        letrec+            go0 = \ -> Done;+            go1 = \(go go0) x     -> case go x of default -> go0;+            go2 = \(go go1) x y   -> case go x of default -> go1 y;+            go3 = \(go go2) x y z -> case go x of default -> go2 y z;++            go = \(go0 go1 go2 go3) x -> case x of++                Unit -> go0;++                Nothing -> go0;+                Just x  -> go1 x;++                True  -> go0;+                False -> go0;++                Int# _ -> go0;++                Left l  -> go1 l;+                Right r -> go1 r;++                Pair   x y   -> go2 x y;+                Triple x y z -> go3 x y z;++                Nil       -> go0;+                Cons x xs -> go2 x xs;++                x -> Error_ForceNotImplementedFor x;++            forceAndReturnValue = \(go) x -> case go x of default -> x+        in forceAndReturnValue |]
+ src/Stg/Prelude/Bool.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE QuasiQuotes     #-}++-- | Boolean functions, like in "Data.Bool".+module Stg.Prelude.Bool (+    and2,+    or2,+    not,+    bool,+    eq_Bool,+) where++++import Prelude ()++import Stg.Language+import Stg.Parser.QuasiQuoter++++eq_Bool, and2, or2, not, bool :: Program++-- | Boolean equality.+eq_Bool = [program|+    eq_Bool = \x y -> case x of+        True -> case y of+            True    -> True;+            False   -> False;+            badBool -> Error_eq_Bool badBool;+        False -> case y of+            True    -> False;+            False   -> True;+            badBool -> Error_eq_Bool badBool;+        badBool -> Error_eq_Bool badBool+    |]++-- | Binary and. Haskell's @(&&)@.+--+-- @+-- && : Bool -> Bool -> Bool+-- @+and2 = [program|+    and2 = \x y -> case x of+        True  -> y;+        False -> False;+        badBool  -> Error_and2 badBool+    |]++-- | Binary or. Haskell's @(||)@.+--+-- @+-- || : Bool -> Bool -> Bool+-- @+or2 = [program|+    or2 = \x y -> case x of+        True     -> True;+        False    -> y;+        badBool  -> Error_or2 badBool+    |]++-- | Binary negation.+--+-- @+-- not : Bool -> Bool+-- @+not = [program|+    not = \x -> case x of+        True -> False;+        False -> True;+        badBool  -> Error_not badBool+    |]+++-- | Boolean deconstructor.+--+-- @+-- bool f _ False = f+-- bool _ t True  = t+-- @+--+-- @+-- bool : a -> a -> Bool -> a+-- @+bool = [program|+    bool = \f t p -> case p of+        True    -> t;+        False   -> f;+        badBool -> Error_bool badBool+    |]
+ src/Stg/Prelude/Function.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE QuasiQuotes #-}++module Stg.Prelude.Function (+    seq,+    id,+    const,+    compose,+    fix,+) where++++import Prelude ()++import Stg.Language           (Program)+import Stg.Parser.QuasiQuoter++++seq, id, const, compose, fix :: Program++++-- | Finally I can define 'Prelude.seq' directly! :-)+--+-- Note that this function is less powerful than GHC's 'Prelude.seq', since  STG+-- does not have a rule to force functions, only expressions that reduce to an+-- algebraic or primitive value. This leads to the fact that STG's @seq@ is less+-- powerful than Haskell's, since in Haskell+--+-- @+-- seq (const ()) () = ()+-- @+--+-- whereas in the STG+--+-- @+-- constUnit = \(x) -> Unit ();+-- seq (constUnit, Unit) = ERROR+-- @+seq = [program| seq = \x y -> case x of default -> y |]++-- | Identity function.+--+-- @+-- id : a -> a+-- @+id = [program| id = \x -> x |]++-- | Constant function.+--+-- @+-- Const : a -> b -> a+-- @+const = [program| const = \x y -> x |]++-- | Function composition.+--+-- @+-- compose : (b -> c) -> (a -> b) -> a -> c+-- @+compose = [program|+    compose = \f g x ->+        let gx = \(g x) -> g x+        in f gx+    |]++-- | The fixed point combinator.+--+-- @+-- fix : (a -> a) -> a+-- @+fix = [program| fix = \f -> letrec x = \(f x) => f x in x |]
+ src/Stg/Prelude/List.hs view
@@ -0,0 +1,493 @@+{-# LANGUAGE OverloadedLists   #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes       #-}++module Stg.Prelude.List (+    nil,+    concat2,+    reverse,+    foldl,+    foldl',+    foldr,+    iterate,+    cycle,+    take,+    filter,+    repeat,+    replicate,+    sort,+    naiveSort,+    map,+    equals_List_Int,+    length,+    zip,+    zipWith,+    forceSpine,+) where++++import Prelude ()++import Data.Monoid++import Stg.Language+import Stg.Parser.QuasiQuoter+import Stg.Prelude.Function   as Func+import Stg.Prelude.Number     as Num++-- $setup+-- >>> :set -XOverloadedStrings+-- >>> import Stg.Language.Prettyprint+-- >>> import qualified Data.Text.IO   as T++++nil, concat2, foldl, foldl', foldr, iterate, cycle, take, filter,+    repeat, replicate, sort, map, equals_List_Int, length, zip, zipWith,+    reverse, forceSpine, naiveSort :: Program+++-- | The empty list as a top-level closure.+--+-- @+-- nil : [a]+-- @+nil = [program| nil = \ -> Nil |]++-- | Concatenate two lists. Haskell's @(++)@.+--+-- @+-- concat2 : [a] -> [a] -> [a]+-- @+concat2 = [program|+    concat2 = \xs ys -> case xs of+        Nil -> ys;+        Cons x xs' ->+            let rest = \(xs' ys) => concat2 xs' ys+            in Cons x rest;+        badList -> Error_concat2 badList+    |]++-- | Lazy left list fold. Provided mostly for seeing how it causes stack+-- overflows.+--+-- @+-- foldl : (b -> a -> b) -> b -> [a] -> b+-- @+foldl = [program|+    foldl = \f acc xs -> case xs of+        Nil -> acc;+        Cons y ys ->+            let acc' = \(f acc y) => case f acc y of v -> v+            in foldl f acc' ys;+        badList -> Error_foldl badList+    |]++-- | Strict left list fold.+--+-- Careful: the STG only supports primitive and algebraic case scrutinees.+-- As a result, you can only hand primitive or algebraic @b@ values to this+-- function or it will fail!+--+-- @+-- foldl' : (b -> a -> b) -> b -> [a] -> b+-- @+foldl' = [program|+    foldl' = \f acc xs -> case xs of+        Nil -> acc;+        Cons y ys -> case f acc y of+            acc' -> foldl' f acc' ys;+        badList -> Error_foldl' badList+    |]++-- | Right list fold.+--+-- @+-- foldr : (a -> b -> b) -> b -> [a] -> b+-- @+foldr = [program|+    foldr = \f z xs -> case xs of+        Nil -> z;+        Cons y ys ->+            -- rest only used once, no need for update+            let rest = \(f z ys) -> foldr f z ys+            in f y rest;+        badList -> Error_foldr badList+    |]++-- | Build a list by repeatedly applying a function to an initial value.+--+-- @+-- iterate f x = [x, f x, f (f x), ...]+-- @+--+-- @+-- iterate : (a -> a) -> a -> [a]+-- @+iterate = [program|+    iterate = \f x ->+        letrec+            fx = \(f x) => f x;+            rest = \(f fx) => iterate f fx+        in Cons x rest+    |]++-- | Infinite list created by repeating an initial (non-empty) list.+--+-- @+-- cycle [x,y,z] = [x,y,z, x,y,z, x,y,z, ...]+-- @+--+-- @+-- cycle : [a] -> [a]+-- @+cycle = concat2 <> [program|+    cycle = \xs ->+        letrec xs' = \(xs xs') => concat2 xs xs'+        in xs'+    |]++-- | Take n elements form the beginning of a list.+--+-- @+-- take 3 [1..] = [1,2,3]+-- @+--+-- @+-- take : Int -> [a] -> [a]+-- @+take = [program|+    take = \n ->+        letrec+            takePrim = \(takePrim) nPrim xs ->+                case nPrim of+                    0# -> Nil;+                    default -> case xs of+                        Nil -> Nil;+                        Cons x xs ->+                            let rest = \(takePrim xs nPrim) => case -# nPrim 1# of+                                    nPrimPred -> takePrim nPrimPred xs+                            in Cons x rest;+                        badList -> Error_take_badList badList+        in case n of+            Int# nPrim -> takePrim nPrim;+            badInt -> Error_take_badInt badInt+    |]++-- | Keep only the elements for which a predicate holds.+--+-- @+-- filter even [1..] = [2, 4, 6, ...]+-- @+--+-- @+-- filter : (a -> Bool) -> [a] -> [a]+-- @+filter = [program|+    filter = \p xs -> case xs of+        Nil -> Nil;+        Cons x xs' -> case p x of+            False -> filter p xs';+            True ->+                let rest = \(p xs') => filter p xs'+                in Cons x rest;+            badBool -> Error_filter_1 badBool;+        badList -> Error_filter_2 badList+    |]++-- | reverse a list.+--+-- @+-- reverse [1,2,3] = [3,2,1]+-- @+--+-- @+-- reverse : [a] -> [a]+-- @+reverse = nil <> [program|+    reverse = \xs ->+        letrec+            reverse' = \(reverse') xs ys ->+                case xs of+                    Nil -> ys;+                    Cons x xs ->+                        let yxs = \(x ys) -> Cons x ys+                        in reverse' xs yxs;+                    badList -> Error_reverse badList+        in reverse' xs nil+    |]++-- | Repeat a single element infinitely.+--+-- @+-- repeat 1 = [1, 1, 1, ...]+-- @+--+-- @+-- repeat : a -> [a]+-- @+repeat = [program|+    repeat = \x ->+        letrec xs = \(x xs) -> Cons x xs+        in xs+    |]++-- | Repeat a single element a number of times.+--+-- @+-- replicate 3 1 = [1, 1, 1]+-- @+--+-- @+-- replicate : Int -> a -> [a]+-- @+replicate = [program|+    replicate = \n x ->+        letrec+            replicateXPrim = \(replicateXPrim x) nPrim ->+                case ># nPrim 0# of+                    0# -> Nil;+                    default ->+                        let rest = \(replicateXPrim nPrim) =>+                                case -# nPrim 1# of+                                    nPrimPred -> replicateXPrim nPrimPred+                        in Cons x rest+        in case n of+            Int# nPrim -> replicateXPrim nPrim;+            badInt -> Error_replicate badInt+    |]++-- | Haskell's Prelude sort function at the time of implementing this.+-- Not quite as pretty as the Haskell version, but functionally equivalent. :-)+--+-- This implementation is particularly efficient when the input contains runs of+-- already sorted elements. For comparison, sorting [1..100] takes 6496 steps,+-- whereas 'naiveSort' requires 268082.+--+-- @+-- sort : [Int] -> [Int]+-- @+sort = mconcat [gt_Int, Func.compose, nil] <> [program|+    sort = \ =>+        letrec+            sequences = \(descending ascending) xs2 -> case xs2 of+                Cons a xs1 -> case xs1 of+                    Cons b xs -> case gt_Int a b of+                        True -> let aList = \(a) -> Cons a nil+                                in descending b aList xs;+                        False -> let aCons = \(a) as -> Cons a as+                                 in ascending b aCons xs;+                        badBool -> Error_sort_sequences1 badBool;+                    Nil -> Cons xs2 nil;+                    badList -> Error_sort_sequences2 badList;+                Nil -> Cons xs2 nil;+                badList -> Error_sort_sequences3 badList;++            descending = \(descending sequences) a as bbs ->+                letrec+                    aas = \(a as) -> Cons a as;+                    fallthrough = \(sequences aas bbs) ->+                        let sequencesBs = \(sequences bbs) -> sequences bbs+                        in Cons aas sequencesBs+                in case bbs of+                    Cons b bs -> case gt_Int a b of+                        True -> descending b aas bs;+                        False -> fallthrough;+                        badBool -> Error_sort_descending1 badBool;+                    Nil -> fallthrough;+                    badList -> Error_sort_descending2 badList;++            ascending = \(ascending sequences) a as bbs ->+                letrec+                    asa = \(a as) ys ->+                        let aConsYs = \(a ys) -> Cons a ys+                        in as aConsYs;+                    fallthrough = \(sequences asa bbs) ->+                        let sequencesBs = \(sequences bbs) -> sequences bbs;+                            asaNil = \(asa) -> asa nil+                        in Cons asaNil sequencesBs+                in case bbs of+                    Cons b bs -> case gt_Int a b of+                        False -> ascending b asa bs;+                        True -> fallthrough;+                        badBool -> Error_sort_ascescending1 badBool;+                    Nil -> fallthrough;+                    badList -> Error_sort_ascescending2 badList;++            mergeAll = \(mergeAll mergePairs) xs -> case xs of+                Cons y ys -> case ys of+                    Nil -> y;+                    Cons _1 _2 -> compose mergeAll mergePairs xs;+                    badList -> Error_sort_mergeAll1 badList;+                Nil -> Error_sort_mergeAll_emptyListAsArgument;+                badList -> Error_sort_mergeAll2 badList;++            mergePairs = \(merge mergePairs) zs -> case zs of+                Cons a ys -> case ys of+                    Cons b xs ->+                        let mergeAB = \(merge a b) -> merge a b;+                            mergePairsXs = \(mergePairs xs) -> mergePairs xs+                        in Cons mergeAB mergePairsXs;+                    Nil -> zs;+                    badList -> Error_sort_mergePairs1 badList;+                Nil -> zs;+                badList -> Error_sort_mergePairs2 badList;++            merge = \(merge) as bs -> case as of+                Cons a as' -> case bs of+                    Cons b bs' -> case gt_Int a b of+                        True ->+                            let mergeAsBs' = \(merge as bs') => merge as bs'+                            in Cons b mergeAsBs';+                        False ->+                            let mergeAs'Bs = \(merge as' bs) => merge as' bs+                            in Cons a mergeAs'Bs;+                        badBool -> Error_sort_merge3 badBool;+                    Nil -> as;+                    badList -> Error_sort_merge2 badList;+                Nil -> bs;+                badList -> Error_sort_merge1 badList++        in compose mergeAll sequences |]++-- | That Haskell sort function often misleadingly referred to as "quicksort".+--+-- @+-- naiveSort : [Int] -> [Int]+-- @+naiveSort = mconcat [leq_Int, gt_Int, filter, concat2] <> [program|+    naiveSort = \xs -> case xs of+        Nil -> Nil;+        Cons pivot xs' ->+            let beforePivotSorted = \(pivot xs') =>+                    letrec+                        atMostPivot = \(pivot) y -> leq_Int  y pivot;+                        beforePivot = \(xs' atMostPivot) => filter atMostPivot xs'+                    in naiveSort beforePivot;++                afterPivotSorted = \(pivot xs') =>+                    letrec+                        moreThanPivot = \(pivot) y -> gt_Int y pivot;+                        afterPivot    = \(xs' moreThanPivot) => filter moreThanPivot  xs'+                    in naiveSort afterPivot+            in  let fromPivotOn = \(pivot afterPivotSorted) -> Cons pivot afterPivotSorted+                in concat2 beforePivotSorted fromPivotOn;+        badList -> Error_sort badList |]++-- | Apply a function to each element of a list.+--+-- @+-- map : (a -> b) -> [a] -> [b]+-- @+map = [program|+    map = \f list -> case list of+        Nil       -> Nil;+        Cons x xs -> let fx  = \(f x)  => f x;+                         fxs = \(f xs) => map f xs+                     in Cons fx fxs;+        badList -> Error_map badList+    |]++-- | Equality of lists of integers.+--+-- @+-- equals_List_Int : [Int] -> [Int] -> Bool+-- @+equals_List_Int = Num.eq_Int <> [program|+    equals_List_Int = \xs ys ->+        case xs of+            Nil -> case ys of+                Nil -> True;+                Cons y ys' -> False;+                badList -> Error_listEquals badList;+            Cons x xs' -> case ys of+                Nil -> False;+                Cons y ys' -> case eq_Int x y of+                    True  -> equals_List_Int xs' ys';+                    False -> False;+                    badBool -> Error_listEquals_1 badBool;+                badList -> Error_listEquals_2 badList;+            badList -> Error_listEquals_3 badList+    |]++-- | Length of a list.+--+-- @+-- length : [a] -> Int+-- @+length = [program|+    length = \ =>+        letrec+            length' = \(length') n xs -> case xs of+                Nil -> Int# n;+                Cons y ys -> case +# n 1# of+                    n' -> length' n' ys;+                badList -> Error_length badList+        in length' 0#+    |]++-- | Zip two lists into one. If one list is longer than the other ignore the+-- exceeding elements.+--+-- @+-- zip [1,2,3,4,5] [10,20,30] ==> [(1,10),(2,20),(3,30)]+--+-- zip xs ys = zipWith Pair xs ys+-- @+--+-- @+-- zip : [a] -> [b] -> [(a,b)]+-- @+zip = [program|+    zip = \xs ys -> case xs of+        Nil -> Nil;+        Cons x xs' -> case ys of+            Nil -> Nil;+            Cons y ys' ->+                let tup  = \(x y)     -> Pair x y;+                    rest = \(xs' ys') => zip xs' ys'+                in Cons tup rest;+            badList -> Error_zip badList;+        badList -> Error_zip badList+    |]++-- | Zip two lists into one using a user-specified combining function.+-- If one list is longer than the other ignore the exceeding elements.+--+-- @+-- zipWith (+) [1,2,3,4,5] [10,20,30] ==> [11,22,33]+--+-- zipWith f xs ys = map f (zip xs ys)+-- @+--+-- @+-- zipWith : (a -> b -> c) -> [a] -> [b] -> [c]+-- @+zipWith = [program|+    zipWith = \f xs ys -> case xs of+        Nil -> Nil;+        Cons x xs' -> case ys of+            Nil -> Nil;+            Cons y ys' ->+                let fxy = \(f x y) => f x y;+                    rest = \(f xs' ys') => zipWith f xs' ys'+                in Cons fxy  rest;+            badList -> Error_zipWith badList;+        badList -> Error_zipWith badList+    |]++-- | Force the spine of a list.+--+-- @+-- forceSpine :: [a] -> [a]+-- @+forceSpine = [program|+    forceSpine = \xs ->+        letrec+            go = \(go) ys -> case ys of+                Nil        -> Done;+                Cons _ ys' -> go ys';+                badList    -> Error_forceSpine badList+        in case go xs of _ -> xs+    |]
+ src/Stg/Prelude/Maybe.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE OverloadedLists   #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes       #-}++module Stg.Prelude.Maybe (+    nothing,+    maybe,+) where++++import Prelude ()++import Stg.Language+import Stg.Parser.QuasiQuoter++++nothing, maybe :: Program++++-- | 'Nothing' as a top-level closure.+--+-- @+-- nothing : Maybe a+-- @+nothing = [program| nothing = \ -> Nothing |]++-- | Deconstructor of the 'Maybe' type.+--+-- @+-- maybe : b -> (a -> b) -> Maybe a -> b+-- @+maybe = [program|+    maybe = \nothing just x -> case x of+        Just j   -> just j;+        Nothing  -> nothing;+        badMaybe -> Error_badMaybe badMaybe |]
+ src/Stg/Prelude/Number.hs view
@@ -0,0 +1,123 @@+{-# LANGUAGE OverloadedLists   #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes       #-}++module Stg.Prelude.Number (+    -- * Arithmetic+    add,+    sub,+    mul,+    div,+    mod,++    -- * Comparisons+    eq_Int,+    lt_Int,+    leq_Int,+    gt_Int,+    geq_Int,+    neq_Int,++    -- * Other+    min,+    max,+) where++++import Prelude ()++import Data.Monoid ((<>))+import Data.Text   (Text)++import Stg.Language+import Stg.Parser.QuasiQuoter++-- $setup+-- >>> :set -XOverloadedStrings+-- >>> :set -XQuasiQuotes+-- >>> :module +Stg.Language.Prettyprint++++binaryOp :: Text -> PrimOp -> Alts -> Program+binaryOp name op primAlts =+    Program (Binds+        [(Var name, LambdaForm [] NoUpdate [Var "x", Var "y"]+            (Case (AppF (Var "x") []) (Alts (AlgebraicAlts+                [AlgebraicAlt (Constr "Int#") [Var "x'"]+                    (Case (AppF (Var "y") []) (Alts (AlgebraicAlts+                        [AlgebraicAlt (Constr "Int#") [Var "y'"]+                            (Case (AppP op (AtomVar (Var "x'")) (AtomVar (Var "y'")))+                                primAlts) ])+                        (DefaultBound (Var "err") (AppC (Constr ("Error_" <> name <> "_1")) [AtomVar (Var "err")])) ))])+                (DefaultBound (Var "err") (AppC (Constr ("Error_" <> name <> "_2")) [AtomVar (Var "err")])) )))])++++primToBool :: Alts+primToBool = [alts| 1# -> True; default -> False |]++eq_Int, lt_Int, leq_Int, gt_Int, geq_Int, neq_Int :: Program++-- |+eq_Int  = binaryOp "eq_Int"  Eq  primToBool++-- |+lt_Int  = binaryOp "lt_Int"  Lt  primToBool++-- |+leq_Int = binaryOp "leq_Int" Leq primToBool++-- |+gt_Int  = binaryOp "gt_Int"  Gt  primToBool++-- |+geq_Int = binaryOp "geq_Int" Geq primToBool++-- |+neq_Int = binaryOp "neq_Int" Neq primToBool++++primIdInt :: Alts+primIdInt = [alts| v -> Int# v |]++add, sub, mul, div, mod :: Program++-- |+add = binaryOp "add" Add primIdInt++-- |+sub = binaryOp "sub" Sub primIdInt++-- |+mul = binaryOp "mul" Mul primIdInt++-- |+div = binaryOp "div" Div primIdInt++-- |+mod = binaryOp "mod" Mod primIdInt++min :: Program+min = [program|+    min = \x y -> case x of+        Int# x' -> case y of+            Int# y' -> case <=# x' y' of+                1#      -> x;+                default -> y;+            badInt -> Error_min badInt;+        badInt -> Error_min badInt+    |]++max :: Program+max = [program|+    max = \x y -> case x of+        Int# x' -> case y of+            Int# y' -> case >=# x' y' of+                1# -> x;+                default -> y;+            badInt -> Error_min badInt;+        badInt -> Error_min badInt+    |]
+ src/Stg/Prelude/Tuple.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE OverloadedLists   #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes       #-}++module Stg.Prelude.Tuple (+    fst,+    snd,+    curry,+    uncurry,+    swap,++    equals_Pair_Int,+) where++++import Prelude ()++import Data.Monoid++import Stg.Language+import Stg.Parser.QuasiQuoter+import Stg.Prelude.Number++++fst, snd, curry, uncurry, swap :: Program+equals_Pair_Int :: Program++++-- | First element of a tuple.+--+-- @+-- fst : (a,b) -> a+-- @+fst = [program|+    fst = \tuple ->+        case tuple of+            Pair a b -> a;+            badPair  -> Error_fst badPair+    |]++-- | Second element of a tuple.+--+-- @+-- snd : (a,b) -> a+-- @+snd = [program|+    snd = \tuple ->+        case tuple of+            Pair a b -> b;+            badPair  -> Error_snd badPair+    |]++-- | Convert an uncurried function to a curried one.+--+-- @+-- curry : ((a, b) -> c) -> a -> b -> c+-- @+curry = [program|+    curry = \f x y ->+        let tuple = \(x y) -> Pair x y+        in f tuple+    |]++-- | Convert a curried function to an uncurried one.+--+-- @+-- uncurry : (a -> b -> c) -> (a, b) -> c+-- @+uncurry = fst <> snd <> [program|+    uncurry = \f tuple ->+        let fst' = \(tuple) -> fst tuple;+            snd' = \(tuple) -> snd tuple+        in f fst' snd'+    |]++-- | Swap the elements of a tuple.+--+-- @+-- swap : (a,b) -> (b,a)+-- @+swap = [program|+    swap = \tuple ->+        case tuple of+            Pair a b -> Pair b a;+            badPair  -> Error_snd badPair |]+++equals_Pair_Int = eq_Int <> [program|+    eq_Pair_Int = \tup1 tup2 ->+        case tup1 of+            Pair a b -> case tup2 of+                Pair x y -> case eq_Int a x of+                    True -> eq_Int b y;+                    False -> False;+                    badBool -> Error_eq_Pair badBool;+                badPair -> Error_eq_Pair badPair;+            badPair -> Error_eq_Pair badPair+    |]
+ src/Stg/Util.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Useful utilities that don't really fit in a specific location.+module Stg.Util (+    show',+    Validate(..),++    -- * Prettyprinter extensions+    commaSep,+    bulletList,+    pluralS,+) where++++import           Data.Bifunctor+import           Data.Monoid+import           Data.Text                    (Text)+import qualified Data.Text                    as T+import           Text.PrettyPrint.ANSI.Leijen hiding ((<>))++++-- | 'show' with 'Text' as codomain.+--+-- @+-- show' = 'T.pack' . 'show'+-- @+show' :: Show a => a -> Text+show' = T.pack . show++++-- | The validation version of 'Either'.+data Validate err a = Failure err | Success a++instance Functor (Validate a) where+    fmap _ (Failure err) = Failure err+    fmap f (Success x)   = Success (f x)++instance Bifunctor Validate where+    first _ (Success x)   = Success x+    first f (Failure err) = Failure (f err)+    second = fmap+    bimap f _ (Failure l) = Failure (f l)+    bimap _ g (Success r) = Success (g r)++-- ^ Return success or the accumulation of all failures+instance Monoid a => Applicative (Validate a) where+    pure = Success+    Success f <*> Success x = Success (f x)+    Success _ <*> Failure x = Failure x+    Failure x <*> Failure y = Failure (x <> y)+    Failure x <*> Success _ = Failure x++-- | @[a,b,c]  ==>  a, b, c@+commaSep :: [Doc] -> Doc+commaSep = encloseSep mempty mempty (comma <> space)++-- | Prefix all contained documents with a bullet symbol.+bulletList :: [Doc] -> Doc+bulletList = align . vsep . map (("  - " <>) . align)++-- | Add an \'s' for non-singleton lists.+pluralS :: [a] -> Doc+pluralS [_] = ""+pluralS _ = "s"
+ stack.yaml view
@@ -0,0 +1,35 @@+# This file was automatically generated by stack init+# For more information, see: http://docs.haskellstack.org/en/stable/yaml_configuration/++# Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2)+resolver: lts-5.10++# Local packages, usually specified by relative directory name+packages:+- '.'+# Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3)+extra-deps: []++# Override default flag values for local packages and extra-deps+flags: {}++# Extra package databases containing global packages+extra-package-dbs: []++# Control whether we use the GHC we find on the path+# system-ghc: true++# Require a specific version of stack, using version ranges+# require-stack-version: -any # Default+# require-stack-version: >= 1.0.0++# Override the architecture used by stack, especially useful on Windows+# arch: i386+# arch: x86_64++# Extra directories used by stack for building+# extra-include-dirs: [/path/to/dir]+# extra-lib-dirs: [/path/to/dir]++# Allow a newer minor version of GHC than the snapshot specifies+# compiler-check: newer-minor
+ stgi.cabal view
@@ -0,0 +1,175 @@+name:                stgi+version:             1+synopsis:            Educational implementation of the STG (Spineless Tagless+                     G-machine)+description:         See README.md+homepage:            https://github.com/quchen/stgi#readme+license:             BSD3+license-file:        LICENSE.md+author:              David Luposchainsky <dluposchainsky (λ) gmail (dot) com>+maintainer:          David Luposchainsky <dluposchainsky (λ) gmail (dot) com>+copyright:           David Luposchainsky <dluposchainsky (λ) gmail (dot) com>+category:            Development+build-type:          Simple+extra-source-files:  .stylish-haskell.yaml+                   , HLint.hs+                   , LICENSE.md+                   , README.md+                   , screenshot.png+                   , stack.yaml+cabal-version:       >=1.10+tested-with:         GHC >= 7.10 && <= 7.10.3++Flag doctest+  Description: Enable doctests+  Default:     False+++library+  hs-source-dirs:      src+  exposed-modules:     Data.Stack+                     , Stg.ExamplePrograms+                     , Stg.Language+                     , Stg.Language.Prettyprint+                     , Stg.Machine+                     , Stg.Machine.Env+                     , Stg.Machine.Evaluate+                     , Stg.Machine.GarbageCollection+                     , Stg.Machine.GarbageCollection.Common+                     , Stg.Machine.GarbageCollection.TriStateTracing+                     , Stg.Machine.GarbageCollection.TwoSpaceCopying+                     , Stg.Machine.Heap+                     , Stg.Machine.Types+                     , Stg.Marshal+                     , Stg.Marshal.FromStg+                     , Stg.Marshal.ToStg+                     , Stg.Parser.Parser+                     , Stg.Parser.QuasiQuoter+                     , Stg.Prelude+                     , Stg.Prelude.Bool+                     , Stg.Prelude.Function+                     , Stg.Prelude.List+                     , Stg.Prelude.Maybe+                     , Stg.Prelude.Number+                     , Stg.Prelude.Tuple+                     , Stg.Util+  ghc-options:         -Wall+  build-depends:       base >= 4.8 && < 5+                     , ansi-wl-pprint+                     , containers       >= 0.5+                     , deepseq          >= 1.4+                     , parsers          >= 0.12+                     , semigroups       >= 0.18+                     , template-haskell >= 2.10+                     , text             >= 1.2+                     , th-lift          >= 0.7+                     , transformers     >= 0.4+                     , trifecta         >= 1.5+  other-extensions:    DeriveGeneric+                     , FlexibleInstances+                     , GeneralizedNewtypeDeriving+                     , LambdaCase+                     , MultiWayIf+                     , OverloadedLists+                     , OverloadedStrings+                     , QuasiQuotes+                     , RankNTypes+                     , TemplateHaskell+                     , TupleSections+                     , TypeFamilies++  default-language:    Haskell2010++executable stgi-exe+  hs-source-dirs:      app+  main-is:             Main.hs+  other-modules:       CmdLineArgs+                       Stg.RunForPager+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N+  build-depends:       base+                     , stgi+                     , ansi-terminal+                     , semigroups+                     , text+  default-language:    Haskell2010++test-suite testsuite+  type:                exitcode-stdio-1.0+  hs-source-dirs:      test/Testsuite+  main-is:             Main.hs+  other-modules:       Test.Language+                     , Test.Language.Prettyprint+                     , Test.Machine+                     , Test.Machine.Evaluate+                     , Test.Machine.Evaluate.Errors+                     , Test.Machine.Evaluate.Programs+                     , Test.Machine.Evaluate.Rules+                     , Test.Machine.Evaluate.TestTemplates.MachineState+                     , Test.Machine.Evaluate.TestTemplates.MarshalledValue+                     , Test.Machine.Evaluate.TestTemplates.Util+                     , Test.Machine.GarbageCollection+                     , Test.Machine.Heap+                     , Test.Marshal+                     , Test.Orphans+                     , Test.Orphans.Language+                     , Test.Orphans.Machine+                     , Test.Orphans.Stack+                     , Test.Parser+                     , Test.Parser.Parser+                     , Test.Parser.QuasiQuoter+                     , Test.Prelude+                     , Test.Prelude.Bool+                     , Test.Prelude.Function+                     , Test.Prelude.List+                     , Test.Prelude.Maybe+                     , Test.Prelude.Number+                     , Test.Prelude.Tuple+                     , Test.Stack+                     , Test.Util+                     , Test.UtilTH+  build-depends:       base+                     , stgi+                     , ansi-wl-pprint+                     , containers >= 0.5+                     , deepseq >= 1.4+                     , semigroups >= 0.18+                     , tasty+                     , tasty-html+                     , tasty-hunit+                     , tasty-quickcheck, QuickCheck+                     , tasty-rerun+                     , tasty-smallcheck, smallcheck+                     , template-haskell+                     , text+  ghc-options:         -Wall -threaded -rtsopts -with-rtsopts=-N+  default-language:    Haskell2010+  other-extensions:    FlexibleContexts+                     , LambdaCase+                     , MultiParamTypeClasses+                     , NumDecimals+                     , OverloadedLists+                     , OverloadedStrings+                     , QuasiQuotes+                     , RankNTypes+                     , TemplateHaskell+  if flag(doctest)+    buildable: False+  else+    buildable: True++test-suite doctest+  type:                exitcode-stdio-1.0+  hs-source-dirs:      test/Doctest+  main-is:             Main.hs+  build-depends:       base+                     , doctest >= 0.10+  ghc-options:         -Wall -threaded -rtsopts -with-rtsopts=-N+  default-language:    Haskell2010+  if flag(doctest)+    buildable: True+  else+    buildable: False++source-repository head+  type:     git+  location: https://github.com/quchen/stgi
+ test/Doctest/Main.hs view
@@ -0,0 +1,6 @@+module Main (main) where++import Test.DocTest++main :: IO ()+main = doctest ["src"]
+ test/Testsuite/Main.hs view
@@ -0,0 +1,57 @@+module Main (main) where++++import Control.Concurrent+import Data.Monoid++import Test.Tasty+import Test.Tasty.Ingredients.Rerun+import Test.Tasty.Options+import Test.Tasty.QuickCheck+import Test.Tasty.Runners+import Test.Tasty.Runners.Html++import qualified Test.Language as Language+import qualified Test.Machine  as Machine+import qualified Test.Marshal  as Marshal+import qualified Test.Parser   as Parser+import qualified Test.Prelude  as Prelude+import qualified Test.Stack    as Stack++++main :: IO ()+main = do+    options <- testOptions+    defaultMainWithIngredients ingredients (options tests)++ingredients :: [Ingredient]+ingredients = [rerunningTests (htmlRunner : defaultIngredients)]++testOptions :: IO (TestTree -> TestTree)+testOptions = do+    numCapabilities <- getNumCapabilities+    (pure . appEndo . mconcat)+        [ runnerOptions numCapabilities+        , quickcheckOptions]++  where++    option :: IsOption v => v -> Endo TestTree+    option = Endo . localOption++    runnerOptions numThreads = option (NumThreads numThreads)+    quickcheckOptions =+        mconcat [ option (QuickCheckShowReplay False)+                , option (QuickCheckTests 1000)+                , option (QuickCheckMaxSize 5) ]++tests :: TestTree+tests = testGroup "STG"+    [ Stack.tests+    , Parser.tests+    , Machine.tests+    , Marshal.tests+    , Language.tests+    , Prelude.tests ]
+ test/Testsuite/Test/Language.hs view
@@ -0,0 +1,14 @@+module Test.Language (tests) where++++import Test.Tasty++import qualified Test.Language.Prettyprint as Pretty++++tests :: TestTree+tests = testGroup "Language"+    [ Pretty.tests+    ]
+ test/Testsuite/Test/Language/Prettyprint.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings     #-}++module Test.Language.Prettyprint (tests) where++++import           Data.Bifunctor+import           Data.Text      (Text)+import qualified Data.Text      as T++import Stg.Language.Prettyprint+import Stg.Parser.Parser        as Parser++import Test.Orphans             ()+import Test.QuickCheck.Property+import Test.SmallCheck.Series+import Test.Tasty+import Test.Tasty.QuickCheck    as QC+import Test.Tasty.SmallCheck    as SC++++tests :: TestTree+tests = localOption (QuickCheckMaxSize 3)+    ( testGroup "Plain prettyprinter is inverse of parser"+        [ inverseOfParserQC "Full program"      Parser.program+        , inverseOfParserQC "Bindings"          Parser.binds+        , inverseOfParserQC "Lambda form"       Parser.lambdaForm+        , inverseOfParserQC "Expression"        Parser.expr+        , inverseOfParserQC "Case alternatives" Parser.alts+        , inverseOfParserSC "Literal"           Parser.literal+        , inverseOfParserSC "Primop"            Parser.primOp+        , inverseOfParserQC "Atom"              Parser.atom ])++inverseOfParserQC+    :: (Arbitrary ast, Show ast, Eq ast, Pretty ast)+    => Text+    -> StgParser ast+    -> TestTree+inverseOfParserQC testName parser+  = QC.testProperty (T.unpack testName) (\inputAst ->+        case parserRoundtrip parser inputAst of+            Left err ->+                counterexample (T.unpack (prettyFailure inputAst err))+                               (property failed)+            Right parsedAst ->+                counterexample (T.unpack (prettySuccess inputAst parsedAst))+                               (inputAst == parsedAst) )++inverseOfParserSC+    :: (Serial IO ast, Show ast, Eq ast, Pretty ast)+    => Text+    -> StgParser ast+    -> TestTree+inverseOfParserSC testName parser+  = SC.testProperty (T.unpack testName) (SC.forAll (\inputAst ->+        case parserRoundtrip parser inputAst of+            Left err ->+                Left (T.unpack (prettyFailure inputAst err))+            Right parsedAst+                | inputAst == parsedAst -> Right ("" :: String)+                | otherwise -> Left (T.unpack (prettySuccess inputAst parsedAst)) ))++parserRoundtrip+    :: Pretty ast+    => StgParser ast+    -> ast+    -> Either Text ast+parserRoundtrip parser = first prettyprintPlain . parse parser . prettyprintPlain++prettySuccess :: Pretty ast => ast -> ast -> Text+prettySuccess inputAst parsedAst =+    T.unlines [ "Input AST:"+              , prettyprintPlain inputAst+              , "Parsed, parser inverse printed AST:"+              , prettyprintPlain parsedAst ]++prettyFailure :: Pretty ast => ast -> Text -> Text+prettyFailure inputAst err =+    T.unlines [ "Input AST:"+              , prettyprintPlain inputAst+              , "Parse error:"+              , err ]
+ test/Testsuite/Test/Machine.hs view
@@ -0,0 +1,17 @@+module Test.Machine (tests) where++++import Test.Tasty++import qualified Test.Machine.Evaluate          as Evaluate+import qualified Test.Machine.GarbageCollection as GarbageCollection+import qualified Test.Machine.Heap              as Heap++++tests :: TestTree+tests = testGroup "Machine"+    [ Heap.tests+    , Evaluate.tests+    , GarbageCollection.tests ]
+ test/Testsuite/Test/Machine/Evaluate.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE NumDecimals       #-}+{-# LANGUAGE OverloadedStrings #-}++module Test.Machine.Evaluate (tests) where++-- TODO: Important tests to add:+--   - Only case does evaluation+--   - Don't forget to add the variables closed over in let(rec)++++import qualified Test.Machine.Evaluate.Errors   as Errors+import qualified Test.Machine.Evaluate.Programs as Programs+import qualified Test.Machine.Evaluate.Rules    as Rules+import           Test.Tasty++++tests :: TestTree+tests = testGroup "Evaluate"+    [ Rules.tests+    , Programs.tests+    , Errors.tests ]
+ test/Testsuite/Test/Machine/Evaluate/Errors.hs view
@@ -0,0 +1,163 @@+{-# LANGUAGE NumDecimals       #-}+{-# LANGUAGE OverloadedLists   #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes       #-}++module Test.Machine.Evaluate.Errors (tests) where++++import Test.Tasty++import Stg.Language+import Stg.Machine.Types+import Stg.Parser.QuasiQuoter++import Test.Machine.Evaluate.TestTemplates.MachineState+import Test.Orphans                                     ()++++tests :: TestTree+tests = testGroup "Error conditions"+    [ updatableClosureWithArgs+    , returnIntWithEmptyReturnStack+    , updateClosureWithPrimitive+    , functionArgumentNotInScope+    , constructorArgumentNotInScope+    , primitiveArgumentNotInScope+    , algebraicReturnToPrimitiveAlts+    , primReturnToAlgAlts+    , loopEnterBlackHole+    , functionScrutinee+    , testGroup "Invalid operations"+        [ divisionByZero+        , moduloZero ]+    , badConArity+    ]++updatableClosureWithArgs :: TestTree+updatableClosureWithArgs = machineStateTest defSpec+    { testName = "Updatable closure with arguments"+    , source = Program (Binds+        [(Var "main",+            LambdaForm [] Update [Var "x"] (AppF (Var "x") []) )])+    , successPredicate = \state -> case stgInfo state of+        Info (StateError UpdatableClosureWithArgs) _ -> True+        _otherwise -> False }++returnIntWithEmptyReturnStack :: TestTree+returnIntWithEmptyReturnStack = machineStateTest defSpec+    { testName = "Closure with primitive body"+    , source = [stg| main = \ -> case 1# of v -> v |]+    , successPredicate = \state -> case stgInfo state of+        Info (StateError ReturnIntWithEmptyReturnStack) _ -> True+        _otherwise -> False }++updateClosureWithPrimitive :: TestTree+updateClosureWithPrimitive = machineStateTest defSpec+    { testName = "Closure update with primitive"+    , source = [stg| main = \ => case 1# of v -> v |]+    , successPredicate = \state -> case stgInfo state of+        Info (StateError UpdateClosureWithPrimitive) _ -> True+        _otherwise -> False }++functionArgumentNotInScope :: TestTree+functionArgumentNotInScope = machineStateTest defSpec+    { testName = "Function argument not in scope"+    , source = [stg| main = \ -> main x |]+    , successPredicate = \state -> case stgInfo state of+        Info (StateError VariablesNotInScope{}) _ -> True+        _otherwise -> False }++constructorArgumentNotInScope :: TestTree+constructorArgumentNotInScope = machineStateTest defSpec+    { testName = "Function argument not in scope"+    , source = [stg| main = \ -> Con x |]+    , successPredicate = \state -> case stgInfo state of+        Info (StateError VariablesNotInScope{}) _ -> True+        _otherwise -> False }++primitiveArgumentNotInScope :: TestTree+primitiveArgumentNotInScope = machineStateTest defSpec+    { testName = "Primitive function argument not in scope"+    , source = [stg| main = \ -> case +# x y of default -> Foo |]+    , successPredicate = \state -> case stgInfo state of+        Info (StateError VariablesNotInScope{}) _ -> True+        _otherwise -> False }++algebraicReturnToPrimitiveAlts :: TestTree+algebraicReturnToPrimitiveAlts = machineStateTest defSpec+    { testName = "Algebraic scrutinee with primitive alts"+    , source = [stg| main = \ -> case Con of 1# -> A; default -> B |]+    , successPredicate = \state -> case stgInfo state of+        Info (StateError AlgReturnToPrimAlts) _ -> True+        _otherwise -> False }++primReturnToAlgAlts :: TestTree+primReturnToAlgAlts = machineStateTest defSpec+    { testName = "Primitive scrutinee with algebraic alts"+    , source = [stg| main = \ -> case 1# of Con -> A; default -> B |]+    , successPredicate = \state -> case stgInfo state of+        Info (StateError PrimReturnToAlgAlts) _ -> True+        _otherwise -> False }++loopEnterBlackHole :: TestTree+loopEnterBlackHole = machineStateTest defSpec+    { testName = "Loop on entering black hole"+    , source = [stg| main = \ => main |]+    , successPredicate = \state -> case stgInfo state of+        Info (StateError EnterBlackhole) _ -> True+        _otherwise -> False }++functionScrutinee :: TestTree+functionScrutinee = machineStateTest defSpec+    { testName = "Function scrutinee"+    , failWithInfo = False+    , source = [stg|+        id = \x -> x;+        main = \ => case id of+            default -> Success+        |]+    , successPredicate = \state -> case stgInfo state of+        Info (StateError NonAlgPrimScrutinee) _ -> True+        _otherwise -> False }++divisionByZero :: TestTree+divisionByZero = machineStateTest defSpec+    { testName = "Division by zero"+    , failWithInfo = False+    , source = [stg|+        main = \ => case /# 1# 0# of+            default -> Failure+        |]+    , successPredicate = \state -> case stgInfo state of+        Info (StateError DivisionByZero) _ -> True+        _otherwise -> False }++moduloZero :: TestTree+moduloZero = machineStateTest defSpec+    { testName = "Modulo by zero"+    , failWithInfo = False+    , source = [stg|+        main = \ => case %# 1# 0# of+            default -> Failure+        |]+    , successPredicate = \state -> case stgInfo state of+        Info (StateError DivisionByZero) _ -> True+        _otherwise -> False }++badConArity :: TestTree+badConArity = machineStateTest defSpec+    { testName = "Bad constructor arity"+    , failWithInfo = False+    , source = [stg|+        x = \ -> Unit;+        y = \ -> Unit;+        main = \ => case Cons x y of+            Cons x -> Bad;+            default -> Baaad+        |]+    , successPredicate = \state -> case stgInfo state of+        Info (StateError BadConArity{}) _ -> True+        _otherwise -> False }
+ test/Testsuite/Test/Machine/Evaluate/Programs.hs view
@@ -0,0 +1,213 @@+{-# LANGUAGE BangPatterns      #-}+{-# LANGUAGE NumDecimals       #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes       #-}++-- | Tests of medium size, defined by terminating within a certain number of+-- steps (configured in 'defSpec').++-- These tests will be run with garbage collection enabled, and should have the+-- scope of small functions a Haskell beginner might play around with.+module Test.Machine.Evaluate.Programs (tests) where++++import Data.Foldable++import           Stg.Machine.Types+import           Stg.Marshal+import           Stg.Parser.QuasiQuoter+import qualified Stg.Prelude            as Stg++import           Test.Machine.Evaluate.TestTemplates.MachineState+import qualified Test.Machine.Evaluate.TestTemplates.MarshalledValue as MVal+import           Test.Machine.Evaluate.TestTemplates.Util+import           Test.Orphans                                        ()+import           Test.QuickCheck.Modifiers+import           Test.Tasty++++tests :: TestTree+tests = testGroup "Programs"+    [ add3+    , takeRepeat+    , fibonacci+    , testGroup "mean of a list"+        [ meanNaive+        , meanNaiveWithFoldl'+        , meanGood ]+    ]++add3 :: TestTree+add3 = machineStateTest defSpec+    { testName = "add3 x y z = x+y+z"+    , successPredicate = "main" `hasValue` (6 :: Integer)+    , source = [stg|+        add3 = \x y z -> case x of+            Int# i -> case y of+                Int# j -> case +# i j of+                    ij -> case z of+                        Int# k -> case +# ij k of+                            ijk -> Int# ijk;+                        badInt -> Error_add3_1 badInt;+                badInt -> Error_add3_2 badInt;+            badInt -> Error_add3_3 badInt;++        one   = \ -> Int# 1#;+        two   = \ -> Int# 2#;+        three = \ -> Int# 3#;+        main = \ => add3 one two three+        |] }++takeRepeat :: TestTree+takeRepeat = machineStateTest defSpec+    { testName = "take 2 (repeat ())"+    , successPredicate = "twoUnits" `hasValue` replicate 2 ()+    , source = mconcat+        [ toStg "two" (2 :: Integer)+        , Stg.take+        , Stg.repeat+        , Stg.foldr+        , Stg.force+        , [stg|+        consBang = \x xs -> case xs of v -> Cons x v;+        nil = \ -> Nil;+        forceSpine = \xs -> foldr consBang nil xs;++        twoUnits = \ =>+            letrec+                repeated = \(unit) => repeat unit;+                unit = \ -> Unit;+                take2 = \(repeated) => take two repeated+            in forceSpine take2;++        main = \ -> force twoUnits+        |] ]}++fibonacci :: TestTree+fibonacci = machineStateTest defSpec+    { testName = "Fibonacci sequence"+    , successPredicate = "main" `hasValue` take numFibos fibo+    , maxSteps = 10000+    , failWithInfo = True+    , source = mconcat+        [ toStg "zero" (0 :: Int)+        , toStg "one" (1 :: Int)+        , toStg "numFibos" (numFibos :: Int)+        , Stg.add+        , Stg.take+        , Stg.zipWith+        , Stg.force+        , [stg|+        main = \ =>+            letrec+                fibos = \(fibo) => take numFibos fibo;+                fibo = \ =>+                    letrec+                        fib0 = \(fib1) -> Cons zero fib1;+                        fib1 = \(fib2) -> Cons one fib2;+                        fib2 = \(fib0 fib1) => zipWith add fib0 fib1+                    in fib0+            in force fibos+        |] ]}+  where+    fibo :: [Integer]+    fibo = 0 : 1 : zipWith (+) fibo (tail fibo)+    numFibos :: Num a => a+    numFibos = 10++meanTestTemplate :: MVal.MarshalledValueTestSpec (NonEmptyList Integer) Integer+meanTestTemplate =+    let mean :: [Integer] -> Integer+        mean xs = let (total, count) = foldl' go (0,0) xs+                      go (!t, !c) x = (t+x, c+1)+                  in total `div` count+    in MVal.MarshalledValueTestSpec+        { MVal.testName = "Mena test template"+        , MVal.maxSteps = 1024+        , MVal.failWithInfo = False+        , MVal.failPredicate = const False+        , MVal.sourceSpec = \(NonEmpty inputList) -> MVal.MarshalSourceSpec+            { MVal.resultVar = "main"+            , MVal.expectedValue = mean inputList+            , MVal.source = mconcat+                [ Stg.add+                , Stg.div+                , toStg "zero" (0 :: Int)+                , toStg "one"  (1 :: Int)+                , toStg "inputList" inputList+                , [stg| main = \ => mean inputList |] ]}}++meanNaive :: TestTree+meanNaive = MVal.marshalledValueTest meanTestTemplate+    { MVal.testName = "Naïve: foldl and lazy tuple"+    , MVal.sourceSpec = \inputList -> (MVal.sourceSpec meanTestTemplate inputList)+        { MVal.source = mconcat+            [ MVal.source (MVal.sourceSpec meanTestTemplate inputList)+            , Stg.foldl+            , [stg|+            mean = \xs ->+                letrec+                    totals = \(go zeroTuple) -> foldl go zeroTuple;+                    zeroTuple = \ -> Tuple zero zero;+                    go = \acc x -> case acc of+                        Tuple t n ->+                            let tx = \(t x) => add t x;+                                n1 = \(n) => add n one+                            in Tuple tx n1;+                        badTuple -> Error_mean1 badTuple+                in case totals xs of+                    Tuple t n -> div t n;+                    badTuple -> Error_mean2 badTuple+            |] ]}}++meanNaiveWithFoldl' :: TestTree+meanNaiveWithFoldl' = MVal.marshalledValueTest meanTestTemplate+    { MVal.testName = "Naïve with insufficient optimization: foldl'"+    , MVal.sourceSpec = \inputList -> (MVal.sourceSpec meanTestTemplate inputList)+        { MVal.source = mconcat+            [ MVal.source (MVal.sourceSpec meanTestTemplate inputList)+            , Stg.foldl'+            , [stg|+            mean = \xs ->+                letrec+                    totals = \(go zeroTuple) -> foldl' go zeroTuple;+                    zeroTuple = \ -> Tuple zero zero;+                    go = \acc x -> case acc of+                        Tuple t n ->+                            let tx = \(t x) => add t x;+                                n1 = \(n) => add n one+                            in Tuple tx n1;+                        badTuple -> Error_mean1 badTuple+                in case totals xs of+                    Tuple t n -> div t n;+                    badTuple -> Error_mean2 badTuple+            |] ]}}++meanGood :: TestTree+meanGood = MVal.marshalledValueTest meanTestTemplate+    { MVal.testName = "Proper: foldl' and strict tuple"+    , MVal.failWithInfo = False+    , MVal.failPredicate = \stgState -> length (stgStack stgState) >= 9+    , MVal.sourceSpec = \inputList -> (MVal.sourceSpec meanTestTemplate inputList)+        { MVal.source = mconcat+            [ MVal.source (MVal.sourceSpec meanTestTemplate inputList)+            , Stg.foldl'+            , [stg|+            mean = \xs ->+                letrec+                    totals = \(go zeroTuple) -> foldl' go zeroTuple;+                    zeroTuple = \ -> Tuple zero zero;+                    go = \acc x -> case acc of+                        Tuple t n ->+                            let tx = \(t x) => add t x;+                                n1 = \(n) => add n one+                            in case tx of+                                default -> case n1 of+                                    default -> Tuple tx n1;+                        badTuple -> Error_mean1 badTuple+                in case totals xs of+                    Tuple t n -> div t n;+                    badTuple -> Error_mean2 badTuple+            |] ]}}
+ test/Testsuite/Test/Machine/Evaluate/Rules.hs view
@@ -0,0 +1,375 @@+{-# LANGUAGE LambdaCase          #-}+{-# LANGUAGE NumDecimals         #-}+{-# LANGUAGE OverloadedLists     #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE QuasiQuotes         #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Tests for each of the STG rules. The scope should be as small as possible+-- around the actual test subject as possible. (To test return-after-case+-- you have to combine case evaluation and return handling, but you do not+-- have to introduce new bindings with @let@, for example.)+module Test.Machine.Evaluate.Rules (tests) where+++++import Stg.Language+import Stg.Machine+import Stg.Machine.Types+import Stg.Parser.QuasiQuoter (stg)++import           Test.Machine.Evaluate.TestTemplates.MachineState    hiding+    (defSpec)+import qualified Test.Machine.Evaluate.TestTemplates.MachineState    as MachineTest+import qualified Test.Machine.Evaluate.TestTemplates.MarshalledValue as MVal++import Test.Orphans              ()+import Test.QuickCheck.Modifiers+import Test.Tasty++++tests :: TestTree+tests = testGroup "Rules"+    [ nonUpdatableFunctionApplication+    , testGroup "Let (rule 3)"+        [ testGroup "Non-recursive"+            [ letBinding+            , letMultiBinding+            , letNestedBinding ]+        , testGroup "Recursive"+            [ letrecBinding+            , letrecMultiBinding ]+        ]+    , testGroup "Case evaluation (rule 4)"+        [ testGroup "Default-only"+            [ defaultOnlyCase_unboundAlgebraic+            , defaultOnlyCase_boundAlgebraic+            , defaultOnlyCase_unboundPrimitive+            , defaultOnlyCase_boundPrimitive ]+        , testGroup "Algebraic alternatives"+            [ algebraicCase_normalMatch+            , algebraicCase_defaultUnboundMatch+            , algebraicCase_defaultBoundMatch ]+        , testGroup "Primitive alternatives"+            [ primitiveCase_normalMatch+            , primitiveCase_defaultUnboundMatch+            , primitiveCase_defaultBoundMatch ]+        ]+    , constructorApplication+    , literalEvaluation+    , literalApplication+    , primops+    , enterUpdatableClosure+    , algebraicReturnUpdate+    , missingArgsUpdate+    , testGroup "Primitive case evaluation shortcuts"+        [ primopShortcut_defaultBound+        , primopShortcut_normalMatch ]+    ]++defSpec :: MachineStateTestSpec+defSpec = MachineTest.defSpec+    { maxSteps  = 32+    , performGc = PerformGc (const Nothing) }++nonUpdatableFunctionApplication :: TestTree+nonUpdatableFunctionApplication = machineStateTest defSpec+    { testName = "Function application, enter non-updatable closure (rule 1 and 2)"+    , source = [stg|+        main = \ => case id unit of+            Unit -> Success;+            default -> TestFail;+        id = \x -> x;+        unit = \ -> Unit+        |] }++letBinding :: TestTree+letBinding = machineStateTest defSpec+    { testName = "Single binding"+    , source = [stg|+        main = \ =>+            let x = \ -> Success+            in x+        |] }++letMultiBinding :: TestTree+letMultiBinding = machineStateTest defSpec+    { testName = "Multiple bindings"+    , source = [stg|+        main = \ =>+            let id = \x -> x;+                one = \ -> Int# 1#+            in case id one of+                Int# y -> case y of+                    1# -> Success;+                    wrong -> TestFail wrong;+                default -> Error+        |] }++letNestedBinding :: TestTree+letNestedBinding = machineStateTest defSpec+    { testName = "Nested bindings"+    , source = [stg|+        main = \ =>+            let id = \x -> x;+                one = \ -> Int# 1#+            in let idOne = \(id one) -> case id one of v -> v+               in case idOne of+                   Int# y -> case y of+                       1# -> Success;+                       wrong -> TestFail wrong;+                   default -> Error+        |] }++letrecBinding :: TestTree+letrecBinding = machineStateTest defSpec+    { testName = "Single binding"+    , source = [stg| main = \ => letrec x = \ -> Success in x |] }++letrecMultiBinding :: TestTree+letrecMultiBinding = machineStateTest defSpec+    { testName = "Cross-referencing bindings"+    , source = [stg|+        main = \ =>+            letrec id = \x -> x;+                   idOne = \(id one) -> case id one of+                       v -> v;+                   one = \ -> Int# 1#+            in case idOne of+                Int# y -> case y of+                    1# -> Success;+                    default -> TestFail;+                default -> Error+        |] }++defaultOnlyCase_unboundAlgebraic :: TestTree+defaultOnlyCase_unboundAlgebraic = machineStateTest defSpec+    { testName = "Unbound, algebraic scrutinee (rule 7)"+    , source = [stg|+        main = \ => case x of+            default -> x;+        x = \ -> Success+        |] }++defaultOnlyCase_boundAlgebraic :: TestTree+defaultOnlyCase_boundAlgebraic = machineStateTest defSpec+    { testName = "Bound, algebraic scrutinee (rule 8)"+    , source = [stg|+        main = \ => case x of+            x -> x;+        x = \ -> Success+        |] }++defaultOnlyCase_unboundPrimitive :: TestTree+defaultOnlyCase_unboundPrimitive = machineStateTest defSpec+    { testName = "Unbound, primitive scrutinee (rule 13)"+    , source = [stg|+        main = \ => case 1# of+            default -> Success+        |] }++defaultOnlyCase_boundPrimitive :: TestTree+defaultOnlyCase_boundPrimitive = machineStateTest defSpec+    { testName = "Bound, primitive scrutinee (rule 12)"+    , source = [stg|+        main = \ => case 1# of+            x -> Success+        |] }++algebraicCase_normalMatch :: TestTree+algebraicCase_normalMatch = machineStateTest defSpec+    { testName = "Algebraic, normal match (rule 6)"+    , source = [stg|+        main = \ => case Nothing of+            Nothing -> Success;+            default -> TestFail+        |] }++algebraicCase_defaultUnboundMatch :: TestTree+algebraicCase_defaultUnboundMatch = machineStateTest defSpec+    { testName = "Algebraic, unbound default match (rule 7)"+    , source = [stg|+        main = \ => case Nothing of+            Just x  -> TestFail x;+            default -> Success+        |] }++algebraicCase_defaultBoundMatch :: TestTree+algebraicCase_defaultBoundMatch = machineStateTest defSpec+    { testName = "Algebraic, bound default match (rule 8)"+    , source = [stg|+        main = \ => case Nothing of+            Just x -> TestFail;+            v      -> Success++        |] }++primitiveCase_normalMatch :: TestTree+primitiveCase_normalMatch = machineStateTest defSpec+    { testName = "Primitive, normal match (rule 11)"+    , source = [stg|+        main = \ => case 1# of+            1#      -> Success;+            default -> TestFail+        |] }++primitiveCase_defaultUnboundMatch :: TestTree+primitiveCase_defaultUnboundMatch = machineStateTest defSpec+    { testName = "Primitive, unbound default match (rule 13)"+    , source = [stg|+        main = \ => case 1# of+            0#      -> TestFail;+            123#    -> TestFail;+            default -> Success+        |] }++primitiveCase_defaultBoundMatch :: TestTree+primitiveCase_defaultBoundMatch = machineStateTest defSpec+    { testName = "Primitive, unbound default match (rule 12)"+    , source = [stg|+        main = \ => case 1# of+            0#   -> TestFail;+            123# -> TestFail;+            -1#  -> TestFail;+            x    -> Success+        |] }++constructorApplication :: TestTree+constructorApplication = machineStateTest defSpec+    { testName = "Constructor application (rule 5)"+    , source = [stg|+        main = \ => case Just 1# of+            Just v -> Success;+            x      -> TestFail x+        |] }++literalEvaluation :: TestTree+literalEvaluation = machineStateTest defSpec+    { testName = "Literal evaluation (rule 9)"+    , source = [stg|+        main = \ => case 1# of+            1# -> Success;+            x  -> TestFail x+        |] }++literalApplication :: TestTree+literalApplication = machineStateTest defSpec+    { testName = "Literal application (rule 10)"+    , source = [stg|+        main = \ => case 1# of+            v1 -> case v1 of+                1# -> Success;+                x  -> TestFail x+        |] }++primops :: TestTree+primops = MVal.marshalledValueTest MVal.MarshalledValueTestSpec+    { MVal.testName = "Primops"+    , MVal.maxSteps = 1024+    , MVal.failWithInfo = True+    , MVal.failPredicate = const False+    , MVal.sourceSpec = \(op, arg1 :: Integer, NonZero arg2) -> MVal.MarshalSourceSpec+            -- arg2 is nonzero or the div/mod tests fail. Having their own tests+            -- is probably not worth the code duplication, so we just throw out+            -- the baby with the bathwater here.+        { MVal.resultVar = "main"+        , MVal.expectedValue = haskell op arg1 arg2+        , MVal.source = Program (Binds+            [(Var "main", LambdaForm [] Update []+                (Case (AppP op (AtomLit (Literal arg1)) (AtomLit (Literal arg2))) (Alts NoNonDefaultAlts+                    (DefaultBound (Var "x") (AppC (Constr "Int#") [AtomVar (Var "x")])) )))])}}+  where+    boolToPrim op x y = if op x y then 1 else 0+    haskell = \case+        Add -> (+)+        Sub -> (-)+        Mul -> (*)+        Div -> div+        Mod -> mod+        Eq  -> boolToPrim (==)+        Lt  -> boolToPrim (<)+        Leq -> boolToPrim (<=)+        Gt  -> boolToPrim (>)+        Geq -> boolToPrim (>=)+        Neq -> boolToPrim (/=)++enterUpdatableClosure :: TestTree+enterUpdatableClosure = machineStateTest defSpec+    { testName = "Enter updatable closure (rule 15)"+    , source = [stg|+        main = \ => case Unit of+            default -> Success+        |]+    , allSatisfied =+        [ \state -> case stgInfo state of+            Info (StateTransition Enter_UpdatableClosure) _ -> True+            _otherwise -> False ]+    }++algebraicReturnUpdate :: TestTree+algebraicReturnUpdate = machineStateTest defSpec+    { testName = "Update because of missing return frame (rule 16)"+    , source = [stg|+        main = \ => case updateMe of+            default -> Success;+        updateMe = \ => case Unit of default -> Unit+        |]+    , allSatisfied =+        [ \state -> case stgInfo state of+            Info (StateTransition ReturnCon_Update) _ -> True+            _otherwise -> False ]+    }++missingArgsUpdate :: TestTree+missingArgsUpdate = machineStateTest defSpec+    { testName = "Update because of missing argument frame (rule 17a)"+    , source = [stg|+        main = \ =>+            case flipTuple 1# 2# of+                Tuple a b -> case a of+                    2# -> case b of+                        1# -> Success;+                        bad -> TestFail bad;+                    bad -> TestFail bad;+                badTuple -> Error_badTuple badTuple;+        tuple = \x y -> Tuple x y;+        flip = \f x y -> f y x;+        flipTuple = \ => flip tuple+        |]+    , allSatisfied =+        [ \state -> case stgInfo state of+            Info (StateTransition Enter_PartiallyAppliedUpdate) _ -> True+            _otherwise -> False ]+    }++primopShortcut_defaultBound :: TestTree+primopShortcut_defaultBound = machineStateTest defSpec+    { testName = "Default bound match shortcut (rule 18)"+    , source = [stg|+        main = \ => case +# 1# 2# of+            1# -> TestFail 1#;+            2# -> TestFail 2#;+            v  -> Success+        |]+    , failPredicate = \state -> case stgCode state of+        Eval AppP{} _ -> True -- The point of the shortcut is to never reach+                              -- the AppP rule itself.+        _otherwise    -> False+    }++primopShortcut_normalMatch :: TestTree+primopShortcut_normalMatch = machineStateTest defSpec+    { testName = "Standard match shortcut (rule 19)"+    , source = [stg|+        main = \ => case 1# of+            one -> case +# one 2# of+                3#    -> Success;+                wrong -> TestFail wrong+        |]+    , failPredicate = \state -> case stgCode state of+        Eval AppP{} _ -> True -- The point of the shortcut is to never reach+                              -- the AppP rule itself.+        _otherwise    -> False+    }
+ test/Testsuite/Test/Machine/Evaluate/TestTemplates/MachineState.hs view
@@ -0,0 +1,149 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes       #-}++-- | Functions and types required to implement tests that check whether+-- a certain closure is reduced to the expected form by the STG.+module Test.Machine.Evaluate.TestTemplates.MachineState (+    MachineStateTestSpec(..),+    defSpec,+    machineStateTest,+) where++++import qualified Data.List                    as L+import qualified Data.List.NonEmpty           as NE+import           Data.Monoid+import           Data.Text                    (Text)+import qualified Data.Text                    as T+import           Text.PrettyPrint.ANSI.Leijen hiding ((<>))++import Stg.Language+import Stg.Language.Prettyprint+import Stg.Machine+import Stg.Machine.Types+import Stg.Parser.QuasiQuoter   (stg)++import Test.Machine.Evaluate.TestTemplates.Util+import Test.Tasty+import Test.Tasty.HUnit+import Test.Tasty.Runners.Html++++-- | Specify a test that is based on a certain predicate to hold in an+-- evaluation step.+data MachineStateTestSpec = MachineStateTestSpec+    { testName :: Text+        -- ^ Test name to display in the test overview.++    , successPredicate :: StgState -> Bool+        -- ^ Test predicate to determine whether the desired state has been+        -- reached.++    , failPredicate :: StgState -> Bool+        -- ^ Fail if this predicate holds. This can be used to constrain the+        -- heap size during the test, for example.++    , allSatisfied :: [StgState -> Bool]+        -- ^ All of these predicates have to hold for some (not necessarily the+        -- same) intermediate states. This is for example useful to check+        -- whether at some point rule 1 was applied, and at another rule 2.++    , source :: Program+        -- ^ STG program to run.++    , maxSteps :: Integer+        -- ^ Maximum number of steps to take++    , performGc :: PerformGc+        -- ^ Perform GC under which conditions?++    , failWithInfo :: Bool+        -- ^ Print program code and final state on test failure? Very useful for+        -- fixing tests.+    }++defSpec :: MachineStateTestSpec+defSpec = MachineStateTestSpec+    { testName             = "Default machine state test template"+    , successPredicate     = "main" `isLambdaForm` [stg| \ -> Success |]+    , failPredicate        = const False+    , allSatisfied         = []+    , source               = [stg| main = \ -> DummySource |]+    , maxSteps             = 1024+    , performGc            = PerformGc (const (Just triStateTracing))+    , failWithInfo         = False }++-- | Evaluate the @main@ closure of a STG program, and check whether the machine+-- state satisfies a predicate when it is evaluated.+machineStateTest :: MachineStateTestSpec -> TestTree+machineStateTest testSpec = askOption (\htmlOpt ->+    let pprDict = case htmlOpt of+            Just HtmlPath{} -> PrettyprinterDict prettyprintPlain (plain . pretty)+            Nothing         -> PrettyprinterDict prettyprint pretty+    in testCase (T.unpack (testName testSpec)) (test pprDict) )+  where+    program = initialState "main" (source testSpec)+    states = evalsUntil (RunForMaxSteps (maxSteps testSpec))+                        (HaltIf (successPredicate testSpec))+                        (performGc testSpec)+                        program+    finalState = NE.last states++    test :: PrettyprinterDict -> Assertion+    test pprDict = case L.find (failPredicate testSpec) states of+        Just badState -> fail_failPredicateTrue pprDict testSpec badState+        Nothing -> case NE.toList states `allSatisfyAtSomePoint` allSatisfied testSpec of+            True -> case stgInfo finalState of+                Info HaltedByPredicate _ -> pure ()+                _otherwise -> fail_successPredicateNotTrue pprDict testSpec finalState+            False -> (assertFailure . T.unpack)+                "No intermediate state satisfied the required predicate."++failWithInfoInfoText :: Doc+failWithInfoInfoText = "Run test case with failWithInfo to see the final state."++fail_successPredicateNotTrue+    :: PrettyprinterDict+    -> MachineStateTestSpec+    -> StgState+    -> Assertion+fail_successPredicateNotTrue+    (PrettyprinterDict pprText pprDoc)+    testSpec+    finalState+  = (assertFailure . T.unpack . pprText . vsep)+        [ "STG failed to satisfy predicate: "+            <> pprDoc (stgInfo finalState)+        , if failWithInfo testSpec+            then vsep+                [ hang 4 (vsep ["Program:", pprDoc (source testSpec)])+                , hang 4 (vsep ["Final state:", pprDoc finalState]) ]+            else failWithInfoInfoText ]++fail_failPredicateTrue+    :: PrettyprinterDict+    -> MachineStateTestSpec+    -> StgState+    -> Assertion+fail_failPredicateTrue+    (PrettyprinterDict pprText pprDoc)+    testSpec+    badState+  = (assertFailure . T.unpack . pprText . vsep)+        [ "Failure predicate held for an intemediate state"+        , if failWithInfo testSpec+            then vsep+                [ hang 4 (vsep ["Program:", pprDoc (source testSpec)])+                , hang 4 (vsep ["Bad state:", pprDoc badState]) ]+            else failWithInfoInfoText ]+++allSatisfyAtSomePoint+    :: [StgState]+    -> [StgState -> Bool]+    -> Bool+allSatisfyAtSomePoint states (p:ps)+  = L.any p states && allSatisfyAtSomePoint states ps+allSatisfyAtSomePoint _ [] = True
+ test/Testsuite/Test/Machine/Evaluate/TestTemplates/MarshalledValue.hs view
@@ -0,0 +1,190 @@+{-# LANGUAGE LambdaCase          #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE QuasiQuotes         #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Defines tests of STG programs that are based on marshalling a value into+-- the STG, forcing a value, and marshalling that value out again for comparison+-- with a reference.+module Test.Machine.Evaluate.TestTemplates.MarshalledValue (+    MarshalledValueTestSpec(..),+    MarshalSourceSpec(..),+    defSpec,+    marshalledValueTest,+) where++++import           Data.List.NonEmpty           (NonEmpty (..))+import           Data.Text                    (Text)+import qualified Data.Text                    as T+import           Text.PrettyPrint.ANSI.Leijen hiding ((<>))++import Stg.Language+import Stg.Language.Prettyprint+import Stg.Machine+import Stg.Machine.Types+import Stg.Marshal+import Stg.Parser.QuasiQuoter   (stg)++import Test.Machine.Evaluate.TestTemplates.Util+import Test.Orphans                             ()+import Test.Tasty+import Test.Tasty.QuickCheck+import Test.Tasty.Runners.Html++++-- | Specifies a test that is based on marshalling a value out of the STG and+-- comparing it to a known value.+data MarshalledValueTestSpec input output = MarshalledValueTestSpec+    { testName :: Text+        -- ^ The reference function's name. Used only for display purposes.++    , failPredicate :: StgState -> Bool+        -- ^ Fail if this predicate holds. This can be used to constrain the+        -- heap size during the test, for example.++    , sourceSpec :: input -> MarshalSourceSpec output+        --  * STG program to run++    , maxSteps :: Integer+        -- ^ Maximum number of steps to take++    , failWithInfo :: Bool+        -- ^ Print program code and final state on test failure?+    }++data MarshalSourceSpec output = MarshalSourceSpec+    { resultVar     :: Var      -- ^ value to observe the value of, e.g. @main@+    , expectedValue :: output   -- ^ expected result value+    , source        :: Program  -- ^ STG program to run+    }++defSpec :: MarshalledValueTestSpec input b+defSpec = MarshalledValueTestSpec+    { testName = "Default Haskell reference test spec template"+    , maxSteps = 1024+    , failWithInfo = False+    , failPredicate = const False+    , sourceSpec = \_ -> MarshalSourceSpec+        { resultVar = "main"+        , expectedValue = error "No expected value generator set in test"+        , source = [stg| main = \ -> DummySource |] }}++marshalledValueTest+    :: forall input output.+       ( Show input, Arbitrary input+       , Eq output, Show output, FromStg output, Pretty output )+    => MarshalledValueTestSpec input output+    -> TestTree+marshalledValueTest testSpec = askOption (\htmlOpt ->+    let pprDict = case htmlOpt of+            Just HtmlPath{} -> PrettyprinterDict prettyprintPlain (plain . pretty)+            Nothing         -> PrettyprinterDict prettyprint pretty+    in testProperty (T.unpack (testName testSpec)) (test pprDict) )+  where+    test :: ( Show input, Arbitrary input+            , Eq output, Show output, FromStg output, Pretty output )+         => PrettyprinterDict+         -> input+         -> Property+    test pprDict input =+        let program = initialState "main" (source (sourceSpec testSpec input))+            states = evalsUntil+                (RunForMaxSteps (maxSteps testSpec))+                (HaltIf (const False))+                (PerformGc (const Nothing))+                program+            verifyLoop (state :| _)+                | failPredicate testSpec state =+                    fail_failPredicateTrue pprDict testSpec input state+            verifyLoop (state :| rest) = case fromStg state (resultVar (sourceSpec testSpec input)) of+                Left err -> case err of+                    TypeMismatch -> fail_typeMismatch pprDict testSpec input state+                    IsBlackhole -> continue state rest+                    IsWrongLambdaType LambdaFun -> fail_functionValue pprDict testSpec input state+                    IsWrongLambdaType LambdaThunk -> continue state rest+                    IsWrongLambdaType LambdaCon -> error+                        "Critial error in test: found a constructor, expected\+                        \ a constructor, but still ran into the failure case\+                        \ somehow. Please report this as a bug."+                    BadArity -> fail_conArity pprDict testSpec input state+                    NotFound{} -> fail_notFound pprDict testSpec input state+                    AddrNotOnHeap -> fail_addrNotOnHeap pprDict testSpec input state+                    NoConstructorMatch -> fail_NoConstructorMatch pprDict testSpec input state+                Right actualValue -> assertEqual actualValue pprDict testSpec input state+            continue lastState = \case+                [] -> fail_valueNotFound pprDict testSpec input lastState+                (x:xs) -> verifyLoop (x :| xs)++        in verifyLoop states++assertEqual+    :: (Eq output, Pretty output)+    => output+    -> PrettyprinterDict+    -> MarshalledValueTestSpec input output+    -> input+    -> StgState+    -> Property+assertEqual+    actual+    (PrettyprinterDict pprText pprDoc)+    testSpec+    input+    finalState+  = counterexample failText (actual == expected)+  where+    expected = expectedValue (sourceSpec testSpec input)+    failText = (T.unpack . pprText . vsep)+        [ "Machine produced an invalid result."+        , "Expected:" <+> pprDoc expected+        , "Actual:  " <+> pprDoc actual+        , if failWithInfo testSpec+            then vsep+                [ hang 4 (vsep ["Program:", pprDoc (source (sourceSpec testSpec input))])+                , hang 4 (vsep ["Final state:", pprDoc finalState]) ]+            else failWithInfoInfoText ]++failWithInfoInfoText :: Doc+failWithInfoInfoText = "Run test case with failWithInfo to see the final state."++fail_template+    :: Doc+    -> PrettyprinterDict+    -> MarshalledValueTestSpec input a+    -> input+    -> StgState+    -> Property+fail_template+    failMessage+    (PrettyprinterDict pprText pprDoc)+    testSpec+    input+    finalState+  = counterexample failText False+  where+    failText = (T.unpack . pprText . vsep)+        [ failMessage+        , "Final machine state info:"+            <+> pprDoc (stgInfo finalState)+        , if failWithInfo testSpec+            then vsep+                [ hang 4 (vsep ["Program:", pprDoc (source (sourceSpec testSpec input))])+                , hang 4 (vsep ["Final state:", pprDoc finalState]) ]+            else failWithInfoInfoText ]++fail_failPredicateTrue, fail_valueNotFound, fail_typeMismatch, fail_conArity,+    fail_notFound, fail_addrNotOnHeap, fail_NoConstructorMatch, fail_functionValue+    :: PrettyprinterDict -> MarshalledValueTestSpec a b -> a -> StgState -> Property+fail_failPredicateTrue  = fail_template "Failure predicate held for an intemediate state"+fail_valueNotFound      = fail_template "None of the machine states produce a (marshallable)\+                                        \ value to compare the expected value to"+fail_typeMismatch       = fail_template "Type mismatch in input/expected output"+fail_conArity           = fail_template "Bad constructor arity in created value"+fail_notFound           = fail_template "Variable not found"+fail_addrNotOnHeap      = fail_template "Address not found on heap"+fail_NoConstructorMatch = fail_template "No constructor match"+fail_functionValue      = fail_template "Function value encountered; can only do algebraic"
+ test/Testsuite/Test/Machine/Evaluate/TestTemplates/Util.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes        #-}++module Test.Machine.Evaluate.TestTemplates.Util (+    hasValue,+    isLambdaForm,+    PrettyprinterDict(..),+) where+++import           Data.Monoid+import           Data.Text                    (Text)+import qualified Data.Text                    as T+import           Text.PrettyPrint.ANSI.Leijen (Doc)++import Stg.Language+import Stg.Machine.Env+import Stg.Machine.Heap  as H+import Stg.Machine.Types+import Stg.Marshal+import Stg.Util++++-- | Check whether a variable has a certain value in an STG state.+hasValue+    :: (Eq value, FromStg value)+    => Var+    -> value+    -> StgState+    -> Bool+var `hasValue` x = \state -> fromStg state var == Right x++-- | Build a state predicate that asserts that a certain 'Var' maps to+-- a 'LambdaForm' in the heap.+isLambdaForm :: Var -> LambdaForm -> StgState -> Bool+var `isLambdaForm` lambdaForm = \state -> case varLookup state var of+    VarLookupClosure (Closure lf _) -> lf == lambdaForm+    _otherwise                      -> False++-- | Used as the result of 'varLookup'.+data VarLookupResult =+    VarLookupError Text+    | VarLookupPrim Integer+    | VarLookupClosure Closure+    | VarLookupBlackhole+    deriving (Eq, Ord, Show)++-- | Look up the value of a 'Var' on the 'Heap' of a 'StgState'.+varLookup :: StgState -> Var -> VarLookupResult+varLookup state var =+    case globalVal (stgGlobals state) (AtomVar var) of+        Failure (NotInScope notInScope) -> VarLookupError+            (T.intercalate ", " (map (\(Var v) -> v) notInScope) <> " not in global scope")+        Success (Addr addr) -> case H.lookup addr (stgHeap state) of+            Just (HClosure closure)  -> VarLookupClosure closure+            Just (Blackhole _bhTick) -> VarLookupBlackhole+            Nothing                  -> VarLookupError "not found on heap"+        Success (PrimInt i) -> VarLookupPrim i++data PrettyprinterDict = PrettyprinterDict (forall a. Pretty a => a -> Text)+                                           (forall a. Pretty a => a -> Doc)
+ test/Testsuite/Test/Machine/GarbageCollection.hs view
@@ -0,0 +1,129 @@+{-# LANGUAGE NumDecimals       #-}+{-# LANGUAGE OverloadedLists   #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes       #-}++module Test.Machine.GarbageCollection (tests) where++++import           Control.DeepSeq+import qualified Data.List.NonEmpty as NE+import qualified Data.Map           as M+import           Data.Monoid+import qualified Data.Set           as S+import           Data.Text          (Text)+import qualified Data.Text          as T++import           Stg.Language.Prettyprint+import           Stg.Machine+import           Stg.Machine.GarbageCollection.Common+import           Stg.Machine.Types+import           Stg.Marshal+import           Stg.Parser.QuasiQuoter+import qualified Stg.Prelude                          as Stg++import Test.Orphans     ()+import Test.Tasty+import Test.Tasty.HUnit++++tests :: TestTree+tests = testGroup "Garbage collection"+    [ gcTests "Tri-state tracing" triStateTracing+    , gcTests "Two space copying" twoSpaceCopying ]++gcTests :: Text -> GarbageCollectionAlgorithm -> TestTree+gcTests name algorithm = testGroup (T.unpack name)+    [ test algorithm | test <- [ splitHeapTest+                               , fibonacciSumTest ]]++prettyIndented :: Pretty a => a -> Text+prettyIndented = T.unlines . map ("    " <>) . T.lines . prettyprint++splitHeapTest :: GarbageCollectionAlgorithm -> TestTree+splitHeapTest algorithm = testGroup "Split heap in dead/alive"+    [ deadAddressesFound+    , deadAndAliveContainAll ]+  where+    addr ~> closure = (MemAddr addr, HClosure closure)+    dirtyHeap = Heap+        [ 0 ~> Closure [stg| \(cyclic used1) -> Used cyclic used1 |]+                       [Addr (MemAddr addr) | addr <- [4,1] ]+        , 1 ~> Closure [stg| \(used2 prim) -> Used used2 prim |]+                       [Addr (MemAddr 2), PrimInt 1]+        , 2 ~> Closure [stg| \ -> Used   |] []+        , 3 ~> Closure [stg| \ -> Unused |] []+        , 4 ~> Closure [stg| \(cyclic) -> Used cyclic |]+                       [Addr (MemAddr 4)] ]+    globals = Globals [("main", Addr (MemAddr 0))]+    expectedDead = [MemAddr 3]++    dummyState = StgState+        { stgCode    = ReturnInt 1+        , stgStack   = mempty+        , stgHeap    = dirtyHeap+        , stgGlobals = globals+        , stgSteps   = 0+        , stgInfo    = Info GarbageCollection [] }++    errorMsg = T.unlines+        [ "Globals:"+        , prettyIndented globals+        , "Dirty heap:"+        , prettyIndented dirtyHeap+        , "Clean heap:"+        , prettyIndented cleanHeap ]++    (deadAddrs, _forwards, StgState{stgHeap = cleanHeap})+      = splitHeapWith algorithm dummyState++    deadAddressesFound = testCase "Dead addresses are found" test+      where+        test = assertEqual (T.unpack errorMsg)+                           expectedDead+                           deadAddrs++    deadAndAliveContainAll = testCase "Heap shrinks by number of dead addresses" test+      where+        expectedNewHeapSize = let Heap old = dirtyHeap+                              in M.size old - S.size deadAddrs+        actualNewHeapSize = let Heap new = cleanHeap+                            in M.size new+        test = assertEqual (T.unpack errorMsg)+                           expectedNewHeapSize+                           actualNewHeapSize+++fibonacciSumTest :: GarbageCollectionAlgorithm -> TestTree+fibonacciSumTest algorithm = testCase "Long-running program" test+  where+    -- This program choked on the new copying GC (ran into an infinite loop),+    -- so it is added as a test case. It's much rather a sanity test than a+    -- minimal example displaying the actual issue, however.+    source = mconcat+            [ Stg.add+            , toStg "zero" (0 :: Int)+            , Stg.foldl'+            , Stg.zipWith ] <> [stg|++        flipConst = \x y -> y;+        main = \ =>+            letrec+                fibo = \ =>+                    letrec+                        fib0 = \(fib1) -> Cons zero fib1;+                        fib1 = \(fib2) =>+                            let one = \ -> Int# 1#+                            in Cons one fib2;+                        fib2 = \(fib0 fib1) => zipWith add fib0 fib1+                    in fib0+            in foldl' flipConst zero fibo+        |]+    prog = initialState "main" source+    states = NE.take 1e3 (evalsUntil (RunForMaxSteps 1e10)+                                     (HaltIf (const False))+                                     (PerformGc (const (Just algorithm)))+                                     prog )+    test = rnf states `seq` pure ()
+ test/Testsuite/Test/Machine/Heap.hs view
@@ -0,0 +1,41 @@+module Test.Machine.Heap (tests) where++++import Data.Monoid++import           Stg.Language.Prettyprint+import qualified Stg.Machine.Heap         as Heap++import Test.Orphans          ()+import Test.Tasty+import Test.Tasty.QuickCheck+import Test.Util+++tests :: TestTree+tests = testGroup "Heap"+    [ testProperty "Lookup single inserted item"+        (\closure heap ->+            let (addr, heap') = Heap.alloc closure heap+            in Heap.lookup addr heap' ==*== Just closure )+    , testProperty "Heap grows with allocated elements"+        (\heap closures ->+            let (_addrs, heap') = Heap.allocMany closures heap+            in Heap.size heap' ==*== Heap.size heap + length closures )+    , testProperty "Update heap overwrites old values"+        (\closure1 closure2 heap ->+            let (addr1, heap1) = Heap.alloc closure1 heap+                heap2 = Heap.update addr1 closure2 heap1+            in counterexample (show (pretty heap2)+                                <> "\ndoes not contain "+                                <> show (pretty closure2))+                              (Heap.lookup addr1 heap2 == Just closure2) )++    , testProperty "Lookup many inserted items" (\closures heap ->+        let (addrs, heap') = Heap.allocMany closures heap+        in traverse (\addr -> Heap.lookup addr heap') addrs+           ==+           Just closures+        )+    ]
+ test/Testsuite/Test/Marshal.hs view
@@ -0,0 +1,173 @@+{-# LANGUAGE NumDecimals         #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE QuasiQuotes         #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Test.Marshal (tests) where++++import qualified Data.List.NonEmpty as NE+import           Data.Proxy+import           Data.Text          (Text)+import qualified Data.Text          as T++import Stg.Language.Prettyprint+import Stg.Machine+import Stg.Marshal+import Stg.Parser.QuasiQuoter++import Test.Orphans          ()+import Test.Tasty+import Test.Tasty.QuickCheck++tests :: TestTree+tests = testGroup "Marshalling"+    [ boolRoundtrip+    , integerRoundtrip+    , unitRoundtrip+    , listRoundtrip+    , nestedListRoundtrip+    , maybeRoundtrip+    , nestedMaybeRoundtrip+    , eitherRoundtrip+    , testGroup "Tuples"+        [tuple2Roundtrip+        , tuple3Roundtrip+        , tuple4Roundtrip+        , tuple5Roundtrip ]+    , crazyRoundtrip+    ]++-- | Specifies a test that is based on the reduction of a closure.+data RoundtripSpec a = RoundtripSpec+    { testName :: Text++    , testType :: Proxy a+        -- ^ Pin down the type of @a@++    , maxSteps :: Integer+    }++defSpec :: RoundtripSpec a+defSpec = RoundtripSpec+    { testName = "Default test spec"+    , testType = Proxy+    , maxSteps = 10e3}++roundTripTest+    :: forall a. (Arbitrary a, ToStg a, FromStg a, Show a, Eq a)+    => RoundtripSpec a+    -> TestTree+roundTripTest spec = testProperty (T.unpack (testName spec)) test+  where+    test :: (Arbitrary a, ToStg a, FromStg a, Show a, Eq a) => a -> Property+    test payload = counterexample (T.unpack (prettyprint finalState))+                                  (expected === Right payload)+      where+        source = mconcat+            [ toStg "payload" payload+            , [stg|+                main = \ => case forceUntyped payload of _ -> Done;++                forceUntyped = \value -> case value of+                    Unit -> Done;++                    Nothing -> Done;+                    Just x -> forceUntyped x;++                    True -> Done;+                    False -> Done;++                    Int# _ -> Done;++                    Left l -> forceUntyped l;+                    Right r -> forceUntyped r;++                    Pair x y -> case forceUntyped x of+                        _ -> forceUntyped y;+                    Triple x y z -> case forceUntyped x of+                        _ -> case forceUntyped y of+                            _ -> forceUntyped z;++                    Nil -> Done;+                    Cons x xs -> case forceUntyped x of+                        _ -> forceUntyped xs;++                    _ -> Error+                 |]]+        prog = initialState "main" source+        states = evalsUntil+            (RunForMaxSteps (maxSteps spec))+            (HaltIf (const False))+            (PerformGc (const Nothing))+            prog+        finalState = garbageCollect triStateTracing (NE.last states)+        expected = fromStg finalState "payload"+++boolRoundtrip :: TestTree+boolRoundtrip = roundTripTest defSpec+    { testName = "Bool"+    , testType = Proxy :: Proxy Bool }++integerRoundtrip :: TestTree+integerRoundtrip = roundTripTest defSpec+    { testName = "Integer"+    , testType = Proxy :: Proxy Integer }++unitRoundtrip :: TestTree+unitRoundtrip = roundTripTest defSpec+    { testName = "Unit"+    , testType = Proxy :: Proxy () }++listRoundtrip :: TestTree+listRoundtrip = roundTripTest defSpec+    { testName = "List"+    , testType = Proxy :: Proxy [Integer] }++nestedListRoundtrip :: TestTree+nestedListRoundtrip = roundTripTest defSpec+    { testName = "Nested list"+    , testType = Proxy :: Proxy [[Integer]] }++maybeRoundtrip :: TestTree+maybeRoundtrip = roundTripTest defSpec+    { testName = "Maybe"+    , testType = Proxy :: Proxy (Maybe Integer) }++nestedMaybeRoundtrip :: TestTree+nestedMaybeRoundtrip = roundTripTest defSpec+    { testName = "Maybe"+    , testType = Proxy :: Proxy (Maybe (Maybe Integer)) }++eitherRoundtrip :: TestTree+eitherRoundtrip = roundTripTest defSpec+    { testName = "Maybe"+    , testType = Proxy :: Proxy (Either Integer Bool) }++tuple2Roundtrip :: TestTree+tuple2Roundtrip = roundTripTest defSpec+    { testName = "2-tuple"+    , testType = Proxy :: Proxy (Integer, Integer) }++tuple3Roundtrip :: TestTree+tuple3Roundtrip = roundTripTest defSpec+    { testName = "3-tuple"+    , testType = Proxy :: Proxy (Integer, Integer, Integer) }++tuple4Roundtrip :: TestTree+tuple4Roundtrip = roundTripTest defSpec+    { testName = "4-tuple"+    , testType = Proxy :: Proxy (Integer, Integer, Integer, Integer) }++tuple5Roundtrip :: TestTree+tuple5Roundtrip = roundTripTest defSpec+    { testName = "5-tuple"+    , testType = Proxy :: Proxy (Integer, Integer, Integer, Integer, Integer) }++crazyRoundtrip :: TestTree+crazyRoundtrip = roundTripTest defSpec+    { testName = "Crazy giant type"+    , testType = Proxy :: Proxy [Either ([[[Integer]]], [Maybe ()]) (Maybe [([Bool], Integer, [Bool])])]+    , maxSteps = 10e5 }
+ test/Testsuite/Test/Orphans.hs view
@@ -0,0 +1,5 @@+module Test.Orphans () where++import Test.Orphans.Language ()+import Test.Orphans.Machine  ()+import Test.Orphans.Stack    ()
+ test/Testsuite/Test/Orphans/Language.hs view
@@ -0,0 +1,166 @@+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE QuasiQuotes           #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}++module Test.Orphans.Language () where++++import           Control.Applicative+import qualified Data.List.NonEmpty  as NonEmpty+import qualified Data.Map            as M+import           Data.Monoid         hiding (Alt)+import           Data.Ratio+import           Data.Text           (Text)+import qualified Data.Text           as T++import Stg.Language+import Stg.Parser.QuasiQuoter++import Test.SmallCheck.Series+import Test.Tasty.QuickCheck+import Test.Util++++--------------------------------------------------------------------------------+-- Helpers++shrinkBut1stLetter :: Text -> [Text]+shrinkBut1stLetter text = case T.uncons text of+    Nothing -> []+    Just (x, xs) ->+        let shrunkenRest = map T.pack . shrink . T.unpack+        in map (T.singleton x <>) (shrunkenRest xs)++reservedKeywords :: [Var]+reservedKeywords = ["let", "in", "case", "of", "default"]+++--------------------------------------------------------------------------------+-- QuickCheck++instance Arbitrary Program where+    arbitrary = arbitrary1 Program+    shrink = genericShrink++instance Arbitrary Binds where+    arbitrary = do+        xs <- listOf1 (scaled (2%3) arbitrary)+        pure (Binds (M.fromList xs))+    shrink (Binds b) =+          [binds| bind = \ -> Unit |]+        : [binds| bind1 = \ -> Unit1; bind2 = \ -> Unit2 |]+        : (map (Binds . M.fromList) . shrinkBut1st . M.toList) b+      where+        -- Bindings have to be non-empty, we ensure at least one element is in+        -- the shrunken result.+        shrinkBut1st [] = []+        shrinkBut1st (x:xs) = liftA2 (:) (shrink x) (shrink xs)++instance Arbitrary LambdaForm where+    arbitrary = do+        free <- arbitrary+        updateFlag <- arbitrary+        bound <- case updateFlag of+            Update -> pure []+            NoUpdate -> arbitrary+        body <- oneof+            ([ arbitrary3 Let+            , arbitrary2 Case+            -- Lambdas cannot have primitive type, so we exclude AppP and Lit+            , arbitrary2 AppF ]+            <>+            -- Standard constructors are never updatable, so we exclude those+            [arbitrary2 AppC | updateFlag == NoUpdate] )+        pure (LambdaForm free updateFlag bound body)+    shrink lf =+          [lambdaForm| \ -> x |]+        : [lambdaForm| \ => x |]+        : [lambdaForm| \x -> x |]+        : [lambdaForm| \(y) x -> x |]+        : [lambdaForm| \(y z) x w -> Con x y z w |]+        : filter isValid (genericShrink lf)+      where+        isValid (LambdaForm _ Update (_:_) AppF{}) = False+        isValid (LambdaForm _ Update (_:_) AppC{}) = False+        isValid (LambdaForm _ _      _     AppP{}) = False+        isValid (LambdaForm _ _      _     Lit{} ) = False+        isValid _ = True++instance Arbitrary UpdateFlag where+    arbitrary = allEnums+    shrink = genericShrink++instance Arbitrary Rec where+    arbitrary = allEnums+    shrink = genericShrink++instance Arbitrary Expr where+    arbitrary = oneof+        [ arbitrary3 Let+        , arbitrary2 Case+        , arbitrary2 AppF+        , arbitrary2 AppC+        , arbitrary3 AppP+        , arbitrary1 Lit ]+    shrink = genericShrink++instance Arbitrary Alts where+    arbitrary = arbitrary2 Alts++instance Arbitrary NonDefaultAlts where+    arbitrary = oneof+        [ pure NoNonDefaultAlts+        , fmap (AlgebraicAlts . NonEmpty.fromList)+            (listOf1 (scaled (2%3) (arbitrary3 AlgebraicAlt)))+        , fmap (PrimitiveAlts . NonEmpty.fromList)+            (listOf1 (scaled (2%3) (arbitrary2 PrimitiveAlt))) ]++instance Arbitrary DefaultAlt where+    arbitrary = oneof [arbitrary1 DefaultNotBound, arbitrary2 DefaultBound]+    shrink = genericShrink++instance Arbitrary Literal where+    arbitrary = resize 128 (arbitrary1 Literal)+    shrink = genericShrink++instance Arbitrary PrimOp where+    arbitrary = allEnums+    shrink = genericShrink++word, lower, upper :: Gen Text+word = T.pack <$> listOf (elements (['a'..'z'] <> ['A'..'Z'] <> ['0'..'9'] <> "\'_"))+lower = T.singleton <$> elements ['a'..'z']+upper = T.singleton <$> elements ['A'..'Z']++instance Arbitrary Var where+    arbitrary = do+        var <- (\head' tail' -> Var (head' <> tail')) <$> lower <*> word+        if var `elem` reservedKeywords+            then arbitrary+            else pure var+    shrink (Var var) = map Var (shrinkBut1stLetter var)++instance Arbitrary Atom where+    arbitrary = oneof [arbitrary1 AtomVar, arbitrary1 AtomLit]+    shrink = genericShrink++instance Arbitrary Constr where+    arbitrary = (\head' tail' hash -> Constr (head' <> tail' <> hash))+                <$> upper+                <*> word+                <*> frequency [(3, pure ""), (1, pure "#")]+    shrink (Constr constr) = map Constr (shrinkBut1stLetter constr)+++--------------------------------------------------------------------------------+-- SmallCheck++instance Monad m => Serial m Literal+instance Monad m => Serial m PrimOp+instance Monad m => Serial m Rec+instance Monad m => Serial m UpdateFlag
+ test/Testsuite/Test/Orphans/Machine.hs view
@@ -0,0 +1,131 @@+{-# LANGUAGE OverloadedStrings #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}++module Test.Orphans.Machine () where++++import qualified Data.Map    as M+import           Data.Monoid+import qualified Data.Set    as S+import qualified Data.Text   as T++import Stg.Machine.Types++import Test.Orphans.Language ()+import Test.Orphans.Stack    ()+import Test.Tasty.QuickCheck+import Test.Util++++instance Arbitrary StgState where+    arbitrary = StgState+            <$> arbitrary+            <*> arbitrary+            <*> arbitrary+            <*> arbitrary+            <*> arbitrary+            <*> arbitrary++instance Arbitrary MemAddr where+    arbitrary = arbitrary1 MemAddr++instance Arbitrary StackFrame where+    arbitrary = oneof [ arbitrary1 ArgumentFrame+                      , arbitrary2 ReturnFrame+                      , arbitrary1 UpdateFrame ]++instance Arbitrary Value where+    arbitrary = oneof [ arbitrary1 Addr+                      , arbitrary1 PrimInt ]++instance Arbitrary Code where+    arbitrary = oneof [ arbitrary2 Eval+                      , arbitrary1 Enter+                      , arbitrary2 ReturnCon+                      , arbitrary1 ReturnInt ]++instance (Arbitrary k, Arbitrary v) => Arbitrary (Mapping k v) where+    arbitrary = arbitrary2 Mapping++instance Arbitrary Globals where+    arbitrary = arbitrary1 (Globals . M.fromList)++instance Arbitrary Locals where+    arbitrary = arbitrary1 (Locals . M.fromList)++instance Arbitrary Closure where+    arbitrary = arbitrary2 Closure++instance Arbitrary Heap where+    arbitrary = arbitrary1 (Heap . M.fromList)++instance Arbitrary HeapObject where+    arbitrary = oneof [ arbitrary1 HClosure+                      , arbitrary1 Blackhole ]++instance Arbitrary Info where+    arbitrary = arbitrary2 Info++instance Arbitrary InfoShort where+    arbitrary = oneof [ pure NoRulesApply+                      , pure MaxStepsExceeded+                      , pure HaltedByPredicate+                      , arbitrary1 StateTransition+                      , arbitrary1 StateError+                      , pure StateInitial ]++instance Arbitrary InfoDetail where+    arbitrary = oneof+        [ arbitrary2 Detail_FunctionApplication+        , arbitrary2 Detail_UnusedLocalVariables+        , arbitrary2 Detail_EnterNonUpdatable+        , arbitrary2 Detail_EvalLet+        , arbitrary0 Detail_EvalCase+        , arbitrary1 Detail_EnterUpdatable+        , arbitrary2 Detail_ConUpdate+        , arbitrary1 Detail_PapUpdate+        , arbitrary0 Detail_ReturnIntCannotUpdate+        , arbitrary0 Detail_StackNotEmpty+        , Detail_GarbageCollected+            <$> ((\x -> "GC algorithm: " <> T.pack x) <$> arbitrary)+            <*> (S.fromList <$> arbitrary)+            <*> (M.fromList <$> arbitrary)+        , arbitrary2 Detail_EnterBlackHole ]++instance Arbitrary StateTransition where+    arbitrary = oneof+        [ arbitrary0 Enter_NonUpdatableClosure+        , arbitrary0 Enter_PartiallyAppliedUpdate+        , arbitrary0 Enter_UpdatableClosure+        , arbitrary0 Eval_AppC+        , arbitrary0 Eval_AppP+        , arbitrary0 Eval_Case+        , arbitrary0 Eval_Case_Primop_Normal+        , arbitrary0 Eval_Case_Primop_DefaultBound+        , arbitrary0 Eval_FunctionApplication+        , arbitrary1 Eval_Let+        , arbitrary0 Eval_Lit+        , arbitrary0 Eval_LitApp+        , arbitrary0 ReturnCon_DefBound+        , arbitrary0 ReturnCon_DefUnbound+        , arbitrary0 ReturnCon_Match+        , arbitrary0 ReturnCon_Update+        , arbitrary0 ReturnInt_DefBound+        , arbitrary0 ReturnInt_DefUnbound+        , arbitrary0 ReturnInt_Match ]++instance Arbitrary StateError where+    arbitrary = oneof+        [ arbitrary1 VariablesNotInScope+        , arbitrary0 UpdatableClosureWithArgs+        , arbitrary0 ReturnIntWithEmptyReturnStack+        , arbitrary0 AlgReturnToPrimAlts+        , arbitrary0 PrimReturnToAlgAlts+        , arbitrary0 InitialStateCreationFailed+        , arbitrary0 EnterBlackhole ]++instance Arbitrary NotInScope where+    arbitrary = arbitrary1 NotInScope
+ test/Testsuite/Test/Orphans/Stack.hs view
@@ -0,0 +1,18 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Test.Orphans.Stack () where++++import GHC.Exts++import Data.Stack (Stack)++import Test.Tasty.QuickCheck as QC+import Test.Util++++instance Arbitrary a => Arbitrary (Stack a) where+    arbitrary = arbitrary1 fromList+    shrink = map fromList . shrink . toList
+ test/Testsuite/Test/Parser.hs view
@@ -0,0 +1,13 @@+module Test.Parser (tests) where++++import Test.Tasty++import qualified Test.Parser.Parser      as Parser+import qualified Test.Parser.QuasiQuoter as QuasiQuoter++++tests :: TestTree+tests = testGroup "Parser" [Parser.tests, QuasiQuoter.tests]
+ test/Testsuite/Test/Parser/Parser.hs view
@@ -0,0 +1,224 @@+{-# LANGUAGE OverloadedLists   #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes       #-}++module Test.Parser.Parser (tests) where++++import           Data.Bifunctor+import           Data.Monoid+import           Data.Text      (Text)+import qualified Data.Text      as T++import           Stg.Language+import           Stg.Language.Prettyprint+import           Stg.Parser.Parser+import qualified Stg.Parser.QuasiQuoter   as QQ++import Test.Orphans     ()+import Test.Tasty+import Test.Tasty.HUnit++++tests :: TestTree+tests = testGroup "Hand-written cases"+    [ simpleParses+    , badParses+    , stresstest ]++++shouldParseTo+    :: Text  -- ^ Test name+    -> Text  -- ^ Parser input+    -> Binds -- ^ Expected STG bindings+    -> TestTree+shouldParseTo testName input output = testCase (T.unpack testName) test+  where+    actual = first prettyprint (parse program input)+    expected = Right (Program output)+    failMessage = case actual of+       Left err -> T.unlines+          [ "============="+          , "Could not parse"+          , (T.unlines . map (" > " <>) . T.lines) input+          , "Error encountered:"+          , (T.unlines . map (" > " <>) . T.lines) err+          , "=============" ]+       Right r -> prettyprint r+    test = assertEqual (T.unpack failMessage) expected actual++++simpleParses :: TestTree+simpleParses = testGroup "Well-written programs"+    [ shouldParseTo "Simple binding to boxed literal"+        "one = \\ -> Int# 1#"+        (Binds [("one", LambdaForm [] NoUpdate []+                          (AppC "Int#" [AtomLit (Literal 1)]) )])++    , shouldParseTo "Constructor application"+        "con = \\ -> Maybe b 1#"+        (Binds [("con", LambdaForm [] NoUpdate []+                          (AppC "Maybe"+                                 [AtomVar "b" , AtomLit (Literal 1)] ))])++    , shouldParseTo "Bound pattern"+        "id = \\ x -> case x of y -> y"+        (Binds [("id", LambdaForm [] NoUpdate ["x"]+                          (Case (AppF "x" [])+                                (Alts NoNonDefaultAlts+                                      (DefaultBound "y" (AppF "y" []))) ))])++    , shouldParseTo "Primitive function application"+        "add1 = \\n -> case +# n 1# of n' -> Int# n'"+        (Binds [("add1", LambdaForm [] NoUpdate ["n"]+                            (Case (AppP Add (AtomVar "n") (AtomLit (Literal 1)))+                                (Alts NoNonDefaultAlts+                                      (DefaultBound "n'" (AppC "Int#" [AtomVar "n'"])))))])+++    , shouldParseTo "Let"+        "a = \\ ->                                                           \n\+        \    let y = \\(a) x -> Foo x                                        \n\+        \    in Con y"+       (Binds [("a", LambdaForm [] NoUpdate []+                         (Let NonRecursive (Binds+                             [("y", LambdaForm ["a"] NoUpdate ["x"]+                                        (AppC "Foo" [AtomVar "x"]))])+                             (AppC "Con" [AtomVar "y"])))])++    , shouldParseTo "fix"+        "fix = \\f ->                                                        \n\+        \    letrec x = \\(f x) => f x in x"+        (Binds+            [("fix", LambdaForm [] NoUpdate ["f"]+                         (Let Recursive+                             (Binds [("x", LambdaForm ["f","x"] Update []+                                         (AppF "f" [AtomVar "x"]))])+                             (AppF "x" [])))])++    , shouldParseTo "factorial"+        "fac = \\n ->                                                        \n\+        \   case n of                                                        \n\+        \       0#      -> Int# 1#;                                          \n\+        \       default -> case -# n 1# of                                   \n\+        \           nMinusOne ->                                             \n\+        \                let fac' = \\(nMinusOne) => fac nMinusOne           \n\+        \                in case fac' of                                     \n\+        \                    Int# facNMinusOne -> case *# n facNMinusOne of  \n\+        \                        result -> Int# result;                      \n\+        \                    err -> Error_fac err                            "+        (Binds+            [(Var "fac",LambdaForm [] NoUpdate [Var "n"]+                (Case (AppF (Var "n") []) (Alts (PrimitiveAlts+                    [PrimitiveAlt (Literal 0)+                                  (AppC (Constr "Int#")+                                        [AtomLit (Literal 1)] )])+                    (DefaultNotBound+                        (Case (AppP Sub (AtomVar (Var "n")) (AtomLit (Literal 1))) (Alts+                            NoNonDefaultAlts+                            (DefaultBound (Var "nMinusOne")+                                (Let NonRecursive+                                    (Binds+                                        [(Var "fac'",LambdaForm [Var "nMinusOne"] Update []+                                            (AppF (Var "fac") [AtomVar (Var "nMinusOne")]) )])+                                    (Case (AppF (Var "fac'") []) (Alts (AlgebraicAlts+                                        [AlgebraicAlt (Constr "Int#") [Var "facNMinusOne"]+                                            (Case (AppP Mul (AtomVar (Var "n")) (AtomVar (Var "facNMinusOne"))) (Alts+                                                NoNonDefaultAlts+                                                (DefaultBound (Var "result") (AppC (Constr "Int#") [AtomVar (Var "result")])) ))])+                                        (DefaultBound (Var "err") (AppC (Constr "Error_fac") [AtomVar (Var "err")])) ))))))))))])++   , shouldParseTo "map with comment"+        "-- Taken from the 1992 STG paper, page 21.                          \n\+        \map = \\f xs ->                                                     \n\+        \    case xs of                                                      \n\+        \        Nil -> Nil;                                                 \n\+        \        Cons y ys -> let fy = \\(f y) => f y;                       \n\+        \                         mfy = \\(f ys) => map f ys                 \n\+        \                     in Cons fy mfy;                                \n\+        \        default -> badListError                                     "+       (Binds+           [ ("map", LambdaForm [] NoUpdate ["f","xs"]+                 (Case (AppF "xs" []) (Alts (AlgebraicAlts+                     [ AlgebraicAlt "Nil" []+                           (AppC "Nil" [])+                     , AlgebraicAlt "Cons" ["y","ys"]+                           (Let NonRecursive+                               (Binds [ ("fy", LambdaForm ["f","y"] Update []+                                                   (AppF "f" [AtomVar "y"]))+                                      , ("mfy", LambdaForm ["f","ys"] Update []+                                                    (AppF "map" [AtomVar "f", AtomVar "ys"])) ])+                               (AppC "Cons" [AtomVar "fy", AtomVar "mfy"])) ])+                     (DefaultNotBound (AppF "badListError" [])) )))])++    , shouldParseTo "map, differently implemented"+         "-- Taken from the 1992 STG paper, page 22.                         \n\+         \map = \\f ->                                                       \n\+         \    letrec mf = \\(f mf) xs ->                                     \n\+         \        case xs of                                                 \n\+         \            Nil -> Nil;                                            \n\+         \            Cons y ys -> let fy = \\(f y) => f y;                  \n\+         \                             mfy = \\(mf ys) => mf ys              \n\+         \                         in Cons fy mfy;                           \n\+         \            default -> badListError                                \n\+         \    in mf                                                          "+        (Binds+            [ ("map", LambdaForm [] NoUpdate ["f"]+                  (Let Recursive+                      (Binds+                          [ ("mf", LambdaForm ["f","mf"] NoUpdate ["xs"]+                                (Case (AppF "xs" []) (Alts (AlgebraicAlts+                                        [ AlgebraicAlt "Nil" []+                                              (AppC "Nil" [])+                                        , AlgebraicAlt "Cons" ["y","ys"]+                                              (Let NonRecursive+                                                  (Binds+                                                      [ ("fy", LambdaForm ["f","y"] Update []+                                                            (AppF "f" [AtomVar "y"]))+                                                      , ("mfy", LambdaForm ["mf","ys"] Update []+                                                            (AppF "mf" [AtomVar "ys"]) )])+                                                  (AppC "Cons" [AtomVar "fy", AtomVar "mfy"]) )])+                                    (DefaultNotBound (AppF "badListError" [])) )))])+                      (AppF "mf" [])))])+    ]++shouldFailToParse+    :: Text -- ^ Test name+    -> Text -- ^ Parser input+    -> TestTree+shouldFailToParse testName input = testCase (T.unpack testName) test+  where+    test = case parse program input of+        Right ast -> (assertFailure . T.unpack . T.unlines)+            [ "Parser should have failed, but succeeded to parse to"+            , (T.unlines . map (" > " <>) . T.lines . prettyprint) ast ]+        Left _err -> pure ()++badParses :: TestTree+badParses = testGroup "Parsers that should fail"+    [ shouldFailToParse "Updatable lambda forms don't take arguments"+        "x = \\y => z"+    , shouldFailToParse "Standard constructors are not updatable"+        "x = \\(y) => Con y"+    , shouldFailToParse "Pattern variables have to be unique"+        "x = \\ -> case x of Tuple x x -> X; _ -> _"+    ]++stresstest :: TestTree+stresstest = testGroup "Stress test"+    [ shouldParseTo "As few as possible spaces"+        "x=\\y->case x of default->z"+        [QQ.binds| x = \y -> case x of default -> z |]+    , testGroup "Too few spaces"+        [ shouldFailToParse "casex of"+            "x=\\y->casex of default->z"+        , shouldFailToParse "case xof"+            "x=\\y->case xof default->z"+        , shouldFailToParse "ofdefault"+            "x=\\y->case x ofdefault->z"+        ]+    ]
+ test/Testsuite/Test/Parser/QuasiQuoter.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes       #-}++module Test.Parser.QuasiQuoter (tests) where++++import Data.Bifunctor++import Stg.Language.Prettyprint+import Stg.Parser.Parser        as Parser+import Stg.Parser.QuasiQuoter   as QQ++import Test.Tasty+import Test.Tasty.HUnit++++tests :: TestTree+tests = testGroup "Quasiquoter"+    [ testCase "Simple definition"+        (let actual = Right [stg| f = \ -> Hello |]+             expected = first prettyprint (parse Parser.program "f = \\ -> Hello")+         in assertEqual "" expected actual)+    ]
+ test/Testsuite/Test/Prelude.hs view
@@ -0,0 +1,23 @@+module Test.Prelude (tests) where++++import Test.Tasty++import qualified Test.Prelude.Bool     as Bool+import qualified Test.Prelude.Function as Function+import qualified Test.Prelude.List     as List+import qualified Test.Prelude.Maybe    as Maybe+import qualified Test.Prelude.Number   as Number+import qualified Test.Prelude.Tuple    as Tuple++++tests :: TestTree+tests = testGroup "Prelude"+    [ Bool.tests+    , Function.tests+    , List.tests+    , Maybe.tests+    , Number.tests+    , Tuple.tests ]
+ test/Testsuite/Test/Prelude/Bool.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE QuasiQuotes         #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Test.Prelude.Bool (tests) where++++import Data.Bool++import           Stg.Marshal+import           Stg.Parser.QuasiQuoter+import qualified Stg.Prelude            as Stg++import Test.Machine.Evaluate.TestTemplates.MarshalledValue+import Test.Orphans                                        ()+import Test.Tasty++++tests :: TestTree+tests = testGroup "Bool"+    [ testAnd2+    , testOr2+    , testNot+    , testBool ]++testAnd2 :: TestTree+testAnd2 = marshalledValueTest defSpec+    { testName = "and2 (&&)"+    , failWithInfo = True+    , sourceSpec = \(b1, b2) -> MarshalSourceSpec+        { resultVar = "main"+        , expectedValue = b1 && b2+        , source = mconcat+            [ toStg "b1" b1+            , toStg "b2" b2+            , Stg.and2+            , [stg| main = \ => and2 b1 b2 |] ]}}++testOr2 :: TestTree+testOr2 = marshalledValueTest defSpec+    { testName = "or2 (||)"+    , sourceSpec = \(b1, b2) -> MarshalSourceSpec+        { resultVar = "main"+        , expectedValue = b1 || b2+        , source = mconcat+            [ toStg "b1" b1+            , toStg "b2" b2+            , Stg.or2+            , [stg| main = \ => or2 b1 b2 |] ]}}++testNot :: TestTree+testNot = marshalledValueTest defSpec+    { testName = "not"+    , sourceSpec = \b -> MarshalSourceSpec+        { resultVar = "main"+        , expectedValue = not b+        , source = mconcat+            [ toStg "b" b+            , Stg.not+            , [stg| main = \ => not b |] ]}}++testBool :: TestTree+testBool = marshalledValueTest defSpec+    { testName = "bool"+    , maxSteps = 1024+    , failPredicate = const False+    , sourceSpec = \(t :: Integer, f, p) -> MarshalSourceSpec+        { resultVar = "main"+        , expectedValue = bool t f p+        , source = mconcat+            [ toStg "p" p+            , toStg "t" t+            , toStg "f" f+            , Stg.bool+            , [stg| main = \ => bool t f p |] ]}}
+ test/Testsuite/Test/Prelude/Function.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE QuasiQuotes         #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Test.Prelude.Function (tests) where++++import Data.Function++import           Stg.Marshal+import           Stg.Parser.QuasiQuoter+import qualified Stg.Prelude            as Stg++import Test.Machine.Evaluate.TestTemplates.MarshalledValue+import Test.Orphans                                        ()+import Test.QuickCheck.Modifiers+import Test.Tasty++++tests :: TestTree+tests = testGroup "Function"+    [ testId+    , testConst+    , testCompose+    , testFix ]++testId :: TestTree+testId = marshalledValueTest defSpec+    { testName = "id"+    , sourceSpec = \(x :: Integer) -> MarshalSourceSpec+        { resultVar = "main"+        , expectedValue = x+        , source = mconcat+            [ toStg "x" x+            , Stg.id+            , [stg| main = \ => id x |] ]}}++testConst :: TestTree+testConst = marshalledValueTest defSpec+    { testName = "const"+    , sourceSpec = \(x :: Integer, y :: Integer) -> MarshalSourceSpec+        { resultVar = "main"+        , expectedValue = x+        , source = mconcat+            [ toStg "x" x+            , toStg "y" y+            , Stg.const+            , [stg| main = \ => const x y |] ]}}+++testCompose :: TestTree+testCompose = marshalledValueTest defSpec+    { testName = "compose (.)"+    , sourceSpec = \x -> MarshalSourceSpec+        { resultVar = "main"+        , expectedValue = ((*3) . (+2)) x+        , source = mconcat+            [ toStg "x"     (x :: Integer)+            , toStg "two"   (2 :: Integer)+            , toStg "three" (3 :: Integer)+            , Stg.add+            , Stg.mul+            , Stg.compose+            , Stg.const+            , [stg|+            plus2 = \x -> add x two;+            times3 = \x -> mul x three;+            plus2times3 = \ -> compose times3 plus2;+            main = \ => plus2times3 x |] ]}}++testFix :: TestTree+testFix = marshalledValueTest defSpec+    { testName = "fix"+    , sourceSpec = \(NonNegative (n :: Integer)) -> MarshalSourceSpec+        { resultVar = "main"+        , expectedValue =+            let fac' = \rec m -> if m == 0 then 1 else m * rec (m-1)+                fac = fix fac'+            in fac n+        , source = mconcat+            [ toStg "n" n+            , toStg "zero" (0 :: Integer)+            , toStg "one" (1 :: Integer)+            , Stg.sub+            , Stg.mul+            , Stg.fix+            , Stg.leq_Int+            , Stg.const+            , [stg|+            fac' = \rec m -> case leq_Int m zero of+                True -> one;+                False -> case sub m one of+                    mMinusOne -> case rec mMinusOne of+                        recMMinusOne -> mul m recMMinusOne;+                badBool -> Error_fac' badBool;++            fac = \ => fix fac';++            main = \ => fac n |] ]}}
+ test/Testsuite/Test/Prelude/List.hs view
@@ -0,0 +1,349 @@+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE QuasiQuotes         #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Test.Prelude.List (tests) where++++import qualified Data.List   as L+import           Data.Monoid+import           Data.Text   (Text)++import           Stg.Language+import           Stg.Machine.Types+import           Stg.Marshal+import           Stg.Parser.QuasiQuoter+import qualified Stg.Prelude            as Stg++import Test.Machine.Evaluate.TestTemplates.MarshalledValue+import Test.Orphans                                        ()+import Test.QuickCheck.Modifiers+import Test.Tasty++++tests :: TestTree+tests = testGroup "List"+    [ testConcat2+    , testReverse+    , testLength+    , testCycle+    , testIterate+    , testRepeat+    , testReplicate+    , testGroup "Sort"+        [ testSort+        , testNaiveSort ]+    , testFilter+    , testMap+    , testZip+    , testZipWith+    , testGroup "Folds"+        [ testFoldr+        , testFoldl+        , testFoldl' ]+    ]++testFilter :: TestTree+testFilter = marshalledValueTest defSpec+    { testName = "filter"+    , sourceSpec = \(xs, threshold :: Integer) -> MarshalSourceSpec+        { resultVar = "main"+        , expectedValue = filter (> threshold) xs+        , source = mconcat+            [ toStg "inputList" xs+            , toStg "threshold" threshold+            , Stg.gt_Int+            , Stg.force+            , Stg.filter+            , [stg|+            main = \ =>+                letrec+                    positive = \x -> gt_Int x threshold;+                    filtered = \(positive) => filter positive inputList+                in force filtered+            |] ]}}++testSort :: TestTree+testSort = marshalledValueTest defSpec+    { testName = "sort (Haskell/base version)"+    , failWithInfo = True+    , sourceSpec = \(xs :: [Integer]) -> MarshalSourceSpec+        { resultVar = "main"+        , expectedValue = L.sort xs+        , source = mconcat+            [ toStg "inputList" xs+            , Stg.sort+            , Stg.force+            , [stg|+            main = \ =>+                let sorted = \ => sort inputList+                in force sorted+            |] ]}}++testNaiveSort :: TestTree+testNaiveSort = marshalledValueTest defSpec+    { testName = "sort (naive version)"+    , sourceSpec = \(xs :: [Integer]) -> MarshalSourceSpec+        { resultVar = "main"+        , expectedValue = L.sort xs+        , source = mconcat+            [ toStg "inputList" xs+            , Stg.naiveSort+            , Stg.force+            , [stg|+            main = \ =>+                let sorted = \ => naiveSort inputList+                in force sorted+            |] ]}}++testMap :: TestTree+testMap = marshalledValueTest defSpec+    { testName = "map"+    , sourceSpec = \(xs, offset :: Integer) -> MarshalSourceSpec+        { resultVar = "main"+        , expectedValue = map (+offset) xs+        , source = mconcat+            [ Stg.add+            , Stg.map+            , Stg.force+            , toStg "offset" offset+            , toStg "inputList" xs+            , [stg|+            main = \ =>+                letrec+                    plusOffset = \n -> add n offset;+                    result = \(plusOffset) => map plusOffset inputList+                in force result+            |] ]}}++testZip :: TestTree+testZip = marshalledValueTest defSpec+    { testName = "zip, map"+    , sourceSpec = \(list1, list2 :: [Integer]) ->  MarshalSourceSpec+        { resultVar = "main"+        , expectedValue = zipWith (+) list1 list2+        , source = mconcat+            [ toStg "list1" list1+            , toStg "list2" list2+            , Stg.add+            , Stg.map+            , Stg.uncurry+            , Stg.zip+            , Stg.force+            , [stg|+            main = \ =>+                letrec+                    zipped   = \ -> zip list1 list2;+                    addTuple = \ -> uncurry add;+                    summed   = \(addTuple zipped) => map addTuple zipped+                in force summed+            |] ]}}++testZipWith :: TestTree+testZipWith = marshalledValueTest defSpec+    { testName = "zipWith (+)"+    , sourceSpec = \(list1, list2 :: [Integer]) -> MarshalSourceSpec+        { resultVar = "main"+        , expectedValue = zipWith (+) list1 list2+        , source = mconcat+            [ toStg "list1" list1+            , toStg "list2" list2+            , Stg.add+            , Stg.zipWith+            , Stg.force+            , [stg|+            main = \ =>+                let zipped = \ => zipWith add list1 list2+                in force zipped+            |] ]}}+++testFoldr, testFoldl, testFoldl' :: TestTree+testFoldr  = foldSumTemplate+    "foldr"+    foldr+    (Stg.foldr <> [stg| fold = \ -> foldr |])+    (const False)+testFoldl  = foldSumTemplate+    "foldl"+    foldl+    (Stg.foldl <> [stg| fold = \ -> foldl |])+    (const False)+testFoldl' = foldSumTemplate+    "foldl'"+    L.foldl'+    (Stg.foldl' <> [stg| fold = \ -> foldl' |])+    (\stgState -> length (stgStack stgState) >= 8) -- Stack should stay small!++foldSumTemplate+    :: Text+        -- ^ Fold function name++    -> (forall a. (a -> a -> a) -> a -> [a] -> a)+        -- ^ Haskell reference fold function++    -> Program+        -- ^ STG Program with binding associating "fold" with the desired fold+        -- function, e.g. foldr++    -> (StgState -> Bool)+        -- ^ Failure predicate; useful in foldl' to check bounded stack size++    -> TestTree+foldSumTemplate foldName foldF foldStg failP+  = marshalledValueTest defSpec+    { testName = foldName+    , maxSteps = 1024+    , failPredicate = failP+    , sourceSpec = \(z :: Integer, xs) ->  MarshalSourceSpec+        { resultVar = "main"+        , expectedValue = foldF (+) z xs+        , source = mconcat+            [ foldStg+            , Stg.add+            , Stg.force+            , toStg "z" z+            , toStg "input" xs+            , [stg|+            main = \ =>+                let result = \ => fold add z input+                in force result+            |] ]}}++testConcat2 :: TestTree+testConcat2 = marshalledValueTest defSpec+    { testName = "(++)"+    , sourceSpec = \(list1, list2 :: [Integer]) -> MarshalSourceSpec+        { resultVar = "main"+        , expectedValue = list1 ++ list2+        , source = mconcat+            [ toStg "list1" list1+            , toStg "list2" list2+            , Stg.concat2+            , Stg.force+            , [stg|+            main = \ =>+                let concatenated = \ => concat2 list1 list2+                in force concatenated+            |] ]}}++testReverse :: TestTree+testReverse = marshalledValueTest defSpec+    { testName = "reverse"+    , maxSteps = 1024+    , sourceSpec = \(xs :: [Integer]) -> MarshalSourceSpec+        { resultVar = "main"+        , expectedValue = reverse xs+        , source = mconcat+            [ toStg "input" xs+            , Stg.reverse+            , Stg.force+            , [stg|+            main = \ =>+                let reversed = \ => reverse input+                in force reversed+            |] ]}}++testCycle :: TestTree+testCycle = marshalledValueTest defSpec+    { testName = "cycle (+take)"+    , sourceSpec = \(NonEmpty (list :: [Integer]), NonNegative n) -> MarshalSourceSpec+        { resultVar = "main"+        , expectedValue = take n (cycle list)+        , source = mconcat+            [ toStg "n" n+            , toStg "list" list+            , Stg.take+            , Stg.cycle+            , Stg.force+            , [stg|+            main = \ =>+                letrec+                    cycled = \ -> cycle list;+                    takeCycled = \(cycled) => take n cycled+                in force takeCycled+            |] ]}}++testRepeat :: TestTree+testRepeat = marshalledValueTest defSpec+    { testName = "repeat (+take)"+    , sourceSpec = \(item :: Integer, NonNegative n) -> MarshalSourceSpec+        { resultVar = "main"+        , expectedValue =replicate n item+        , source = mconcat+            [ toStg "n" n+            , toStg "item" item+            , Stg.take+            , Stg.repeat+            , Stg.force+            , [stg|+            main = \ =>+                letrec+                    repeated = \ -> repeat item;+                    takeRepeated = \(repeated) => take n repeated+                in force takeRepeated+            |] ]}}++testReplicate :: TestTree+testReplicate = marshalledValueTest defSpec+    { testName = "replicate"+    , failWithInfo = True+    , maxSteps = 1024+    , failPredicate = \stgState -> case stgCode stgState of+        Eval AppP {} _ -> True+        _ -> False+    , sourceSpec = \(item :: Integer, n) -> MarshalSourceSpec+        { resultVar = "main"+        , expectedValue = replicate n item+        , source = mconcat+            [ toStg "n" n+            , toStg "item" item+            , Stg.replicate+            , Stg.force+            , [stg|+            main = \ =>+                let replicated = \ => replicate n item+                in force replicated+            |] ]}}++testIterate :: TestTree+testIterate = marshalledValueTest defSpec+    { testName = "iterate (+take)"+    , sourceSpec = \(seed, offset :: Integer, NonNegative n) -> MarshalSourceSpec+        { resultVar = "main"+        , expectedValue = take n (iterate (+offset) seed)+        , source = mconcat+            [ toStg "n" n+            , toStg "offset" offset+            , toStg "seed" seed+            , Stg.add+            , Stg.take+            , Stg.iterate+            , Stg.force+            , [stg|+            main = \ =>+                letrec+                    addOffset = \ -> add offset;+                    iterated = \(addOffset) -> iterate addOffset seed;+                    takeIterated = \(iterated) => take n iterated+                in force takeIterated+            |] ]}}++testLength :: TestTree+testLength = marshalledValueTest defSpec+    { testName = "length"+    , sourceSpec = \(xs :: [Integer]) -> MarshalSourceSpec+        { resultVar = "main"+        , expectedValue = fromIntegral (length xs) :: Integer+        , source = mconcat+            [ toStg "input" xs+            , Stg.length+            , Stg.force+            , [stg|+            main = \ =>+                let len = \ => length input+                in force len+            |] ]}}
+ test/Testsuite/Test/Prelude/Maybe.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE QuasiQuotes         #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Test.Prelude.Maybe (tests) where++++import           Stg.Marshal+import           Stg.Parser.QuasiQuoter+import qualified Stg.Prelude            as Stg++import Test.Machine.Evaluate.TestTemplates.MarshalledValue+import Test.Orphans                                        ()+import Test.Tasty++++tests :: TestTree+tests = testGroup "Maybe"+    [ testMaybe ]++testMaybe :: TestTree+testMaybe = marshalledValueTest defSpec+    { testName = "maybe"+    , sourceSpec = \(nothingCase, maybeInt :: Maybe Integer, offset) -> MarshalSourceSpec+        { resultVar = "main"+        , expectedValue = maybe nothingCase (+offset) maybeInt+        , source = mconcat+            [ toStg "nothingCase" nothingCase+            , toStg "maybeInt" maybeInt+            , toStg "offset" offset+            , Stg.maybe+            , Stg.add+            , [stg|+                main = \ =>+                    let addOffset = \x -> add x offset+                    in maybe nothingCase addOffset maybeInt |]]}}
+ test/Testsuite/Test/Prelude/Number.hs view
@@ -0,0 +1,113 @@+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE QuasiQuotes         #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Test.Prelude.Number (tests) where++++import Data.Monoid+import Data.Text   (Text)++import           Stg.Language+import           Stg.Marshal+import           Stg.Parser.QuasiQuoter+import qualified Stg.Prelude            as Stg++import Test.Machine.Evaluate.TestTemplates.MarshalledValue+import Test.Orphans                                        ()+import Test.QuickCheck.Modifiers+import Test.Tasty++++tests :: TestTree+tests = testGroup "Number"+    [ testGroup "Comparison"+        [ testEq+        , testLt+        , testLeq+        , testGt+        , testGeq+        , testNeq ]+    , testGroup "Arithmetic"+        [ testAdd+        , testSub+        , testMul+        , testDiv+        , testMod ]+    , testMin+    , testMax ]++testEq, testLt, testLeq, testGt, testGeq, testNeq :: TestTree+testEq  = testComparison "==" (==) (Stg.eq_Int  <> [stg| stgFunc = \ -> eq_Int  |])+testLt  = testComparison "<"  (<)  (Stg.lt_Int  <> [stg| stgFunc = \ -> lt_Int  |])+testLeq = testComparison "<=" (<=) (Stg.leq_Int <> [stg| stgFunc = \ -> leq_Int |])+testGt  = testComparison ">"  (>)  (Stg.gt_Int  <> [stg| stgFunc = \ -> gt_Int  |])+testGeq = testComparison ">=" (>=) (Stg.geq_Int <> [stg| stgFunc = \ -> geq_Int |])+testNeq = testComparison "/=" (/=) (Stg.neq_Int <> [stg| stgFunc = \ -> neq_Int |])++-- | Test an Integer comparison operator+testComparison+    :: Text -- ^ Test name+    -> (Integer -> Integer -> Bool) -- ^ Comparison operator+    -> Program -- ^ STG definition of the comparison function, named "stgFunc"+    -> TestTree+testComparison name  haskellRef stgFuncDef = marshalledValueTest defSpec+    { testName = name+    , sourceSpec = \(x, y) -> MarshalSourceSpec+        { resultVar = "main"+        , expectedValue = haskellRef x y+        , source = mconcat+            [ toStg "x" x+            , toStg "y" y+            , stgFuncDef+            , [stg| main = \ => stgFunc x y |] ]}}++testAdd, testSub, testMul, testDiv, testMod :: TestTree+testAdd = testArithmetic "+"   (+) (Stg.add <> [stg| stgFunc = \ -> add |])+testSub = testArithmetic "-"   (-) (Stg.sub <> [stg| stgFunc = \ -> sub |])+testMul = testArithmetic "*"   (*) (Stg.mul <> [stg| stgFunc = \ -> mul |])+testDiv = testArithmetic "div" div (Stg.div <> [stg| stgFunc = \ -> div |])+testMod = testArithmetic "mod" mod (Stg.mod <> [stg| stgFunc = \ -> mod |])++-- | Test an arithmetic operator+testArithmetic+    :: Text -- ^ Test name+    -> (Integer -> Integer -> Integer) -- ^ Arithmetic operator+    -> Program -- ^ STG definition of the comparison function, named "stgFunc"+    -> TestTree+testArithmetic name  haskellRef stgFuncDef = marshalledValueTest defSpec+    { testName = name+    , sourceSpec = \(x, NonZero y) -> MarshalSourceSpec+        { resultVar = "main"+        , expectedValue = haskellRef x y+        , source = mconcat+            [ toStg "x" x+            , toStg "y" y+            , stgFuncDef+            , [stg| main = \ => stgFunc x y |] ]}}++testMin :: TestTree+testMin = marshalledValueTest defSpec+    { testName = "min"+    , sourceSpec = \(x, y :: Integer) -> MarshalSourceSpec+        { resultVar = "main"+        , expectedValue = min x y+        , source = mconcat+            [ toStg "x" x+            , toStg "y" y+            , Stg.min+            , [stg| main = \ => min x y |] ]}}++testMax :: TestTree+testMax = marshalledValueTest defSpec+    { testName = "max"+    , sourceSpec = \(x, y :: Integer) -> MarshalSourceSpec+        { resultVar = "main"+        , expectedValue = max x y+        , source = mconcat+            [ toStg "x" x+            , toStg "y" y+            , Stg.max+            , [stg| main = \ => max x y |] ]}}
+ test/Testsuite/Test/Prelude/Tuple.hs view
@@ -0,0 +1,95 @@+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE QuasiQuotes         #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Test.Prelude.Tuple (tests) where++++import qualified Data.Tuple as T++import           Stg.Marshal+import           Stg.Parser.QuasiQuoter+import qualified Stg.Prelude            as Stg++import Test.Machine.Evaluate.TestTemplates.MarshalledValue+import Test.Orphans                                        ()+import Test.Tasty++++tests :: TestTree+tests = testGroup "Tuple"+    [ testFst+    , testSnd+    , testCurry+    , testUncurry+    , testSwap+    ]++testFst :: TestTree+testFst = marshalledValueTest defSpec+    { testName = "fst"+    , failWithInfo = True+    , sourceSpec = \(tuple :: (Integer, Integer)) -> MarshalSourceSpec+        { resultVar = "main"+        , expectedValue = fst tuple+        , source = mconcat+            [ toStg "tuple" tuple+            , Stg.fst+            , [stg| main = \ => fst tuple |] ]}}++testSnd :: TestTree+testSnd = marshalledValueTest defSpec+    { testName = "snd"+    , sourceSpec = \(tuple :: (Integer, Integer)) -> MarshalSourceSpec+        { resultVar = "main"+        , expectedValue = snd tuple+        , source = mconcat+            [ toStg "tuple" tuple+            , Stg.snd+            , [stg| main = \ => snd tuple |] ]}}++testCurry :: TestTree+testCurry = marshalledValueTest defSpec+    { testName = "curry"+    , sourceSpec = \(x,y :: Integer) -> MarshalSourceSpec+        { resultVar = "main"+        , expectedValue = x+y+        , source = mconcat+            [ toStg "x" x+            , toStg "y" y+            , Stg.curry+            , Stg.add+            , [stg|+            addPair = \tuple -> case tuple of+                Pair a b -> add a b;+                badPair  -> Error_addPair badTuple;++            main = \ => curry addPair x y+            |] ]}}++testUncurry :: TestTree+testUncurry = marshalledValueTest defSpec+    { testName = "uncurry"+    , sourceSpec = \(tuple :: (Integer, Integer)) -> MarshalSourceSpec+        { resultVar = "main"+        , expectedValue = uncurry (+) tuple+        , source = mconcat+            [ toStg "tuple" tuple+            , Stg.uncurry+            , Stg.add+            , [stg| main = \ => uncurry add tuple |] ]}}++testSwap :: TestTree+testSwap = marshalledValueTest defSpec+    { testName = "swap"+    , sourceSpec = \(tuple :: (Integer, Integer)) -> MarshalSourceSpec+        { resultVar = "main"+        , expectedValue = T.swap tuple+        , source = mconcat+            [ toStg "tuple" tuple+            , Stg.swap+            , Stg.equals_Pair_Int+            , [stg| main = \ => swap tuple |] ]}}
+ test/Testsuite/Test/Stack.hs view
@@ -0,0 +1,68 @@+module Test.Stack (tests) where++++import Data.Foldable+import Data.Monoid+import GHC.Exts      (fromList)++import Data.Stack++import Test.Orphans          ()+import Test.Tasty+import Test.Tasty.QuickCheck as QC++++tests :: TestTree+tests = testGroup "Stack" [test_popN, fromToList, test_mappend]++test_popN :: TestTree+test_popN = testGroup "forEachPop"+    [ againstReference+    , roundtrip ]+  where+    againstReference = QC.testProperty+        "Agrees with naive implementation"+        (\xs stack ->+            let _ = stack :: Stack Int+                _ = xs :: [()]+            in xs `forEachPop` stack === xs `naive` stack )+      where+        naive :: [x] -> Stack a -> Maybe ([a], Stack a)+        naive xs stack+            | length xs > length stack = Nothing+            | otherwise =+                let (before, after) = splitAt (length xs) (toList stack)+                in Just (before, fromList after)++    roundtrip = QC.testProperty+        "pop-then-push"+        (\xs stack ->+            let popped = xs `forEachPop` stack+                _ = stack :: Stack Int+                _ = xs :: [Int]+            in case popped of+                Just (a,b) -> a <>> b === stack+                Nothing -> classify True "overpopped"+                    (length xs > length stack) )++fromToList :: TestTree+fromToList = testGroup "List conversion"+    [ QC.testProperty+        "toList . fromList = id"+        (\xs -> let _ = xs :: [Int]+                in fromStack (toStack xs) === xs )+    , QC.testProperty+        "fromList . toList = id"+        (\xs -> let _ = xs :: [Int]+                in fromStack (toStack xs) === xs )]+  where+    toStack = fromList :: [Int] -> Stack Int+    fromStack = toList :: Stack Int -> [Int]++test_mappend :: TestTree+test_mappend = QC.testProperty+    "mappend = mappend for lists"+    (\xs ys -> let _ = xs :: Stack Int+               in xs <> ys === fromList (toList xs <> toList ys) )
+ test/Testsuite/Test/Util.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell   #-}++-- | Various testing utilities.+module Test.Util (+    scaled,+    allEnums,+    arbitrary0,+    arbitrary1,+    arbitrary2,+    arbitrary3,++    (==*==),+) where++++import Data.Ratio+import Text.PrettyPrint.ANSI.Leijen hiding ((<$>))++import Test.QuickCheck+import Test.UtilTH++++-- | Scale the size parameter of a Quickcheck generator by a 'Ratio'. Useful+-- to implement exponential cutoff for recursive generators.+scaled+    :: Ratio Int+    -> Gen a+    -> Gen a+scaled factor = scale (\n -> n * numerator factor `quot` denominator factor)++allEnums :: (Enum a, Bounded a) => Gen a+allEnums = elements [minBound ..]++$(arbitraryN 0)+$(arbitraryN 1)+$(arbitraryN 2)+$(arbitraryN 3)++infix 4 ==*==+(==*==) :: (Eq a, Pretty a) => a -> a -> Property+x ==*== y = counterexample example (x == y)+  where+    example = (show . align . vsep) [pretty x, "is not equal to", pretty y]
+ test/Testsuite/Test/UtilTH.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell   #-}++module Test.UtilTH (+    arbitraryN,+) where++++import GHC.Natural+import Language.Haskell.TH++import Test.QuickCheck+++arbitraryN :: Natural -> DecsQ+arbitraryN n = sequence [arbitraryNType n, arbitraryNValue n]++++arbitraryName :: Natural -> Name+arbitraryName n = mkName ("arbitrary" ++ show n)++++-- | Generate n-ary arbitrary chains.+--+-- @+-- arbitraryN n :: (Arbitrary a, Arbitrary b, ...) -> (a -> b -> ... -> g) -> Gen g+-- arbitraryN n = \f -> f <$> arbitrary <*> arbitrary <*> ...+--                            ^------  n arbitraries  ------^+-- @+arbitraryNValue :: Natural -> DecQ+arbitraryNValue n+  = valD (varP (arbitraryName n)) (normalB (lamE [varP f] [| $(chainOfArbitraries n) |])) []+  where+    chainOfArbitraries 0 = [| pure $(varE f) |]+    chainOfArbitraries 1 = [| $(varE f) <$> arbitrary |]+    chainOfArbitraries m = [| $(chainOfArbitraries (m-1)) <*> arbitrary |]+    f = mkName "f"++++arbitraryNType :: Natural -> DecQ+arbitraryNType n+  = sigD (arbitraryName n) (forallT forallArgs constraints functionType)+  where+    forallArgs = map PlainTV (gName:names)+    constraints = cxt [[t| Arbitrary $(varT name)|] | name <- names]+    functionType = [t| $(foldr (\name rest -> [t|$(varT name) -> $(rest)|]) (varT gName) names)+                      -> Gen $(varT gName)|]+    names = take (fromIntegral n) [mkName [x] | x <- filter (/= 'g') ['a'..]]+    gName = mkName "g"