diff --git a/.stylish-haskell.yaml b/.stylish-haskell.yaml new file mode 100644 --- /dev/null +++ b/.stylish-haskell.yaml @@ -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 diff --git a/HLint.hs b/HLint.hs new file mode 100644 --- /dev/null +++ b/HLint.hs @@ -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 ==> () diff --git a/LICENSE.md b/LICENSE.md new file mode 100644 --- /dev/null +++ b/LICENSE.md @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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 = \() -> +``` + +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 + ``` + + Introduce local definitions, just like Haskell's `let`. + + - **Let** + + ```haskell + let <...bindings...> in + ``` + + Like `letrec`, but the bindings cannot refer to each other (or themselves). + In other words, `let` is non-recursive. + + - **Case** + + ```haskell + case of + ``` + + Evaluate the `` (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 `` are semicolon-separated list of alternatives of the form + + ```haskell + Constructor -> -- algebraic + 1# -> -- 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 -> -- bound default; v is in scope in the expression + default -> -- unbound default + ``` + + - **Function application** + + ```haskell + function + ``` + + Like Haskell's function application. The `` are primitive values or + variables. + + - **Primitive application** + + ```haskell + primop# + ``` + + 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 + ``` + + 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 = +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) => + 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 diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/CmdLineArgs.hs b/app/CmdLineArgs.hs new file mode 100644 --- /dev/null +++ b/app/CmdLineArgs.hs @@ -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...]" diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -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 diff --git a/app/Stg/RunForPager.hs b/app/Stg/RunForPager.hs new file mode 100644 --- /dev/null +++ b/app/Stg/RunForPager.hs @@ -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 diff --git a/screenshot.png b/screenshot.png new file mode 100644 Binary files /dev/null and b/screenshot.png differ diff --git a/src/Data/Stack.hs b/src/Data/Stack.hs new file mode 100644 --- /dev/null +++ b/src/Data/Stack.hs @@ -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) diff --git a/src/Stg/ExamplePrograms.hs b/src/Stg/ExamplePrograms.hs new file mode 100644 --- /dev/null +++ b/src/Stg/ExamplePrograms.hs @@ -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 + |]] diff --git a/src/Stg/Language.hs b/src/Stg/Language.hs new file mode 100644 --- /dev/null +++ b/src/Stg/Language.hs @@ -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 +-- . +-- +-- 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 diff --git a/src/Stg/Language/Prettyprint.hs b/src/Stg/Language/Prettyprint.hs new file mode 100644 --- /dev/null +++ b/src/Stg/Language/Prettyprint.hs @@ -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))) "") diff --git a/src/Stg/Machine.hs b/src/Stg/Machine.hs new file mode 100644 --- /dev/null +++ b/src/Stg/Machine.hs @@ -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 in
". + -- 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 diff --git a/src/Stg/Machine/Env.hs b/src/Stg/Machine/Env.hs new file mode 100644 --- /dev/null +++ b/src/Stg/Machine/Env.hs @@ -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 diff --git a/src/Stg/Machine/Evaluate.hs b/src/Stg/Machine/Evaluate.hs new file mode 100644 --- /dev/null +++ b/src/Stg/Machine/Evaluate.hs @@ -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] } diff --git a/src/Stg/Machine/GarbageCollection.hs b/src/Stg/Machine/GarbageCollection.hs new file mode 100644 --- /dev/null +++ b/src/Stg/Machine/GarbageCollection.hs @@ -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 diff --git a/src/Stg/Machine/GarbageCollection/Common.hs b/src/Stg/Machine/GarbageCollection/Common.hs new file mode 100644 --- /dev/null +++ b/src/Stg/Machine/GarbageCollection/Common.hs @@ -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) diff --git a/src/Stg/Machine/GarbageCollection/TriStateTracing.hs b/src/Stg/Machine/GarbageCollection/TriStateTracing.hs new file mode 100644 --- /dev/null +++ b/src/Stg/Machine/GarbageCollection/TriStateTracing.hs @@ -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 diff --git a/src/Stg/Machine/GarbageCollection/TwoSpaceCopying.hs b/src/Stg/Machine/GarbageCollection/TwoSpaceCopying.hs new file mode 100644 --- /dev/null +++ b/src/Stg/Machine/GarbageCollection/TwoSpaceCopying.hs @@ -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 } diff --git a/src/Stg/Machine/Heap.hs b/src/Stg/Machine/Heap.hs new file mode 100644 --- /dev/null +++ b/src/Stg/Machine/Heap.hs @@ -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)) diff --git a/src/Stg/Machine/Types.hs b/src/Stg/Machine/Types.hs new file mode 100644 --- /dev/null +++ b/src/Stg/Machine/Types.hs @@ -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 \"<>\"" ] + + 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 diff --git a/src/Stg/Marshal.hs b/src/Stg/Marshal.hs new file mode 100644 --- /dev/null +++ b/src/Stg/Marshal.hs @@ -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 diff --git a/src/Stg/Marshal/FromStg.hs b/src/Stg/Marshal/FromStg.hs new file mode 100644 --- /dev/null +++ b/src/Stg/Marshal/FromStg.hs @@ -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 diff --git a/src/Stg/Marshal/ToStg.hs b/src/Stg/Marshal/ToStg.hs new file mode 100644 --- /dev/null +++ b/src/Stg/Marshal/ToStg.hs @@ -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)) diff --git a/src/Stg/Parser/Parser.hs b/src/Stg/Parser/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Stg/Parser/Parser.hs @@ -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 +-- +-- 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" diff --git a/src/Stg/Parser/QuasiQuoter.hs b/src/Stg/Parser/QuasiQuoter.hs new file mode 100644 --- /dev/null +++ b/src/Stg/Parser/QuasiQuoter.hs @@ -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" diff --git a/src/Stg/Prelude.hs b/src/Stg/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/Stg/Prelude.hs @@ -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 |] diff --git a/src/Stg/Prelude/Bool.hs b/src/Stg/Prelude/Bool.hs new file mode 100644 --- /dev/null +++ b/src/Stg/Prelude/Bool.hs @@ -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 + |] diff --git a/src/Stg/Prelude/Function.hs b/src/Stg/Prelude/Function.hs new file mode 100644 --- /dev/null +++ b/src/Stg/Prelude/Function.hs @@ -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 |] diff --git a/src/Stg/Prelude/List.hs b/src/Stg/Prelude/List.hs new file mode 100644 --- /dev/null +++ b/src/Stg/Prelude/List.hs @@ -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 + |] diff --git a/src/Stg/Prelude/Maybe.hs b/src/Stg/Prelude/Maybe.hs new file mode 100644 --- /dev/null +++ b/src/Stg/Prelude/Maybe.hs @@ -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 |] diff --git a/src/Stg/Prelude/Number.hs b/src/Stg/Prelude/Number.hs new file mode 100644 --- /dev/null +++ b/src/Stg/Prelude/Number.hs @@ -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 + |] diff --git a/src/Stg/Prelude/Tuple.hs b/src/Stg/Prelude/Tuple.hs new file mode 100644 --- /dev/null +++ b/src/Stg/Prelude/Tuple.hs @@ -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 + |] diff --git a/src/Stg/Util.hs b/src/Stg/Util.hs new file mode 100644 --- /dev/null +++ b/src/Stg/Util.hs @@ -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" diff --git a/stack.yaml b/stack.yaml new file mode 100644 --- /dev/null +++ b/stack.yaml @@ -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 diff --git a/stgi.cabal b/stgi.cabal new file mode 100644 --- /dev/null +++ b/stgi.cabal @@ -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 +maintainer: David Luposchainsky +copyright: David Luposchainsky +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 diff --git a/test/Doctest/Main.hs b/test/Doctest/Main.hs new file mode 100644 --- /dev/null +++ b/test/Doctest/Main.hs @@ -0,0 +1,6 @@ +module Main (main) where + +import Test.DocTest + +main :: IO () +main = doctest ["src"] diff --git a/test/Testsuite/Main.hs b/test/Testsuite/Main.hs new file mode 100644 --- /dev/null +++ b/test/Testsuite/Main.hs @@ -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 ] diff --git a/test/Testsuite/Test/Language.hs b/test/Testsuite/Test/Language.hs new file mode 100644 --- /dev/null +++ b/test/Testsuite/Test/Language.hs @@ -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 + ] diff --git a/test/Testsuite/Test/Language/Prettyprint.hs b/test/Testsuite/Test/Language/Prettyprint.hs new file mode 100644 --- /dev/null +++ b/test/Testsuite/Test/Language/Prettyprint.hs @@ -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 ] diff --git a/test/Testsuite/Test/Machine.hs b/test/Testsuite/Test/Machine.hs new file mode 100644 --- /dev/null +++ b/test/Testsuite/Test/Machine.hs @@ -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 ] diff --git a/test/Testsuite/Test/Machine/Evaluate.hs b/test/Testsuite/Test/Machine/Evaluate.hs new file mode 100644 --- /dev/null +++ b/test/Testsuite/Test/Machine/Evaluate.hs @@ -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 ] diff --git a/test/Testsuite/Test/Machine/Evaluate/Errors.hs b/test/Testsuite/Test/Machine/Evaluate/Errors.hs new file mode 100644 --- /dev/null +++ b/test/Testsuite/Test/Machine/Evaluate/Errors.hs @@ -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 } diff --git a/test/Testsuite/Test/Machine/Evaluate/Programs.hs b/test/Testsuite/Test/Machine/Evaluate/Programs.hs new file mode 100644 --- /dev/null +++ b/test/Testsuite/Test/Machine/Evaluate/Programs.hs @@ -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 + |] ]}} diff --git a/test/Testsuite/Test/Machine/Evaluate/Rules.hs b/test/Testsuite/Test/Machine/Evaluate/Rules.hs new file mode 100644 --- /dev/null +++ b/test/Testsuite/Test/Machine/Evaluate/Rules.hs @@ -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 + } diff --git a/test/Testsuite/Test/Machine/Evaluate/TestTemplates/MachineState.hs b/test/Testsuite/Test/Machine/Evaluate/TestTemplates/MachineState.hs new file mode 100644 --- /dev/null +++ b/test/Testsuite/Test/Machine/Evaluate/TestTemplates/MachineState.hs @@ -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 diff --git a/test/Testsuite/Test/Machine/Evaluate/TestTemplates/MarshalledValue.hs b/test/Testsuite/Test/Machine/Evaluate/TestTemplates/MarshalledValue.hs new file mode 100644 --- /dev/null +++ b/test/Testsuite/Test/Machine/Evaluate/TestTemplates/MarshalledValue.hs @@ -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" diff --git a/test/Testsuite/Test/Machine/Evaluate/TestTemplates/Util.hs b/test/Testsuite/Test/Machine/Evaluate/TestTemplates/Util.hs new file mode 100644 --- /dev/null +++ b/test/Testsuite/Test/Machine/Evaluate/TestTemplates/Util.hs @@ -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) diff --git a/test/Testsuite/Test/Machine/GarbageCollection.hs b/test/Testsuite/Test/Machine/GarbageCollection.hs new file mode 100644 --- /dev/null +++ b/test/Testsuite/Test/Machine/GarbageCollection.hs @@ -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 () diff --git a/test/Testsuite/Test/Machine/Heap.hs b/test/Testsuite/Test/Machine/Heap.hs new file mode 100644 --- /dev/null +++ b/test/Testsuite/Test/Machine/Heap.hs @@ -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 + ) + ] diff --git a/test/Testsuite/Test/Marshal.hs b/test/Testsuite/Test/Marshal.hs new file mode 100644 --- /dev/null +++ b/test/Testsuite/Test/Marshal.hs @@ -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 } diff --git a/test/Testsuite/Test/Orphans.hs b/test/Testsuite/Test/Orphans.hs new file mode 100644 --- /dev/null +++ b/test/Testsuite/Test/Orphans.hs @@ -0,0 +1,5 @@ +module Test.Orphans () where + +import Test.Orphans.Language () +import Test.Orphans.Machine () +import Test.Orphans.Stack () diff --git a/test/Testsuite/Test/Orphans/Language.hs b/test/Testsuite/Test/Orphans/Language.hs new file mode 100644 --- /dev/null +++ b/test/Testsuite/Test/Orphans/Language.hs @@ -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 diff --git a/test/Testsuite/Test/Orphans/Machine.hs b/test/Testsuite/Test/Orphans/Machine.hs new file mode 100644 --- /dev/null +++ b/test/Testsuite/Test/Orphans/Machine.hs @@ -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 diff --git a/test/Testsuite/Test/Orphans/Stack.hs b/test/Testsuite/Test/Orphans/Stack.hs new file mode 100644 --- /dev/null +++ b/test/Testsuite/Test/Orphans/Stack.hs @@ -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 diff --git a/test/Testsuite/Test/Parser.hs b/test/Testsuite/Test/Parser.hs new file mode 100644 --- /dev/null +++ b/test/Testsuite/Test/Parser.hs @@ -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] diff --git a/test/Testsuite/Test/Parser/Parser.hs b/test/Testsuite/Test/Parser/Parser.hs new file mode 100644 --- /dev/null +++ b/test/Testsuite/Test/Parser/Parser.hs @@ -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" + ] + ] diff --git a/test/Testsuite/Test/Parser/QuasiQuoter.hs b/test/Testsuite/Test/Parser/QuasiQuoter.hs new file mode 100644 --- /dev/null +++ b/test/Testsuite/Test/Parser/QuasiQuoter.hs @@ -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) + ] diff --git a/test/Testsuite/Test/Prelude.hs b/test/Testsuite/Test/Prelude.hs new file mode 100644 --- /dev/null +++ b/test/Testsuite/Test/Prelude.hs @@ -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 ] diff --git a/test/Testsuite/Test/Prelude/Bool.hs b/test/Testsuite/Test/Prelude/Bool.hs new file mode 100644 --- /dev/null +++ b/test/Testsuite/Test/Prelude/Bool.hs @@ -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 |] ]}} diff --git a/test/Testsuite/Test/Prelude/Function.hs b/test/Testsuite/Test/Prelude/Function.hs new file mode 100644 --- /dev/null +++ b/test/Testsuite/Test/Prelude/Function.hs @@ -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 |] ]}} diff --git a/test/Testsuite/Test/Prelude/List.hs b/test/Testsuite/Test/Prelude/List.hs new file mode 100644 --- /dev/null +++ b/test/Testsuite/Test/Prelude/List.hs @@ -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 + |] ]}} diff --git a/test/Testsuite/Test/Prelude/Maybe.hs b/test/Testsuite/Test/Prelude/Maybe.hs new file mode 100644 --- /dev/null +++ b/test/Testsuite/Test/Prelude/Maybe.hs @@ -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 |]]}} diff --git a/test/Testsuite/Test/Prelude/Number.hs b/test/Testsuite/Test/Prelude/Number.hs new file mode 100644 --- /dev/null +++ b/test/Testsuite/Test/Prelude/Number.hs @@ -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 |] ]}} diff --git a/test/Testsuite/Test/Prelude/Tuple.hs b/test/Testsuite/Test/Prelude/Tuple.hs new file mode 100644 --- /dev/null +++ b/test/Testsuite/Test/Prelude/Tuple.hs @@ -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 |] ]}} diff --git a/test/Testsuite/Test/Stack.hs b/test/Testsuite/Test/Stack.hs new file mode 100644 --- /dev/null +++ b/test/Testsuite/Test/Stack.hs @@ -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) ) diff --git a/test/Testsuite/Test/Util.hs b/test/Testsuite/Test/Util.hs new file mode 100644 --- /dev/null +++ b/test/Testsuite/Test/Util.hs @@ -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] diff --git a/test/Testsuite/Test/UtilTH.hs b/test/Testsuite/Test/UtilTH.hs new file mode 100644 --- /dev/null +++ b/test/Testsuite/Test/UtilTH.hs @@ -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"