stgi 1.0.1 → 1.1

raw patch · 59 files changed

+2345/−1441 lines, 59 filesdep +prettyprinterdep +prettyprinter-ansi-terminaldep ~semigroupsdep ~trifectaPVP ok

version bump matches the API change (PVP)

Dependencies added: prettyprinter, prettyprinter-ansi-terminal

Dependency ranges changed: semigroups, trifecta

API changes (from Hackage documentation)

Files

• .hlint.yaml +50/−0
• .stylish-haskell.yaml +44/−9
• HLint.hs +0/−23
• README.md +6/−3
• app/CmdLineArgs.hs +1/−2
• app/Main.hs +26/−8
• app/Stg/RunForPager.hs +22/−13
• src/Data/Stack.hs +14/−11
• src/Stg/ExamplePrograms.hs +57/−12
• src/Stg/Language.hs +112/−126
• src/Stg/Language/Prettyprint.hs +82/−18
• src/Stg/Machine.hs +43/−34
• src/Stg/Machine/Env.hs +0/−2
• src/Stg/Machine/Evaluate.hs +54/−591
• src/Stg/Machine/Evaluate/Common.hs +89/−0
• src/Stg/Machine/Evaluate/ErrorTransitions.hs +196/−0
• src/Stg/Machine/Evaluate/ValidTransitions.hs +609/−0
• src/Stg/Machine/GarbageCollection.hs +2/−1
• src/Stg/Machine/GarbageCollection/Common.hs +3/−1
• src/Stg/Machine/GarbageCollection/TriStateTracing.hs +0/−1
• src/Stg/Machine/GarbageCollection/TwoSpaceCopying.hs +3/−2
• src/Stg/Machine/Types.hs +196/−194
• src/Stg/Marshal/FromStg.hs +12/−13
• src/Stg/Marshal/ToStg.hs +7/−7
• src/Stg/Parser/Parser.hs +37/−33
• src/Stg/Parser/QuasiQuoter.hs +2/−2
• src/Stg/Prelude.hs +15/−72
• src/Stg/Prelude/Bool.hs +3/−0
• src/Stg/Prelude/Function.hs +4/−0
• src/Stg/Prelude/List.hs +18/−6
• src/Stg/Prelude/Maybe.hs +6/−3
• src/Stg/Prelude/Number.hs +20/−14
• src/Stg/Prelude/Tuple.hs +7/−4
• src/Stg/StaticAnalysis.hs +90/−0
• src/Stg/Util.hs +5/−19
• stack.yaml +2/−32
• stgi.cabal +16/−6
• test/Testsuite/Main.hs +14/−11
• test/Testsuite/Test/ExamplePrograms.hs +184/−0
• test/Testsuite/Test/Language/Prettyprint.hs +9/−9
• test/Testsuite/Test/Machine/Evaluate.hs +0/−1
• test/Testsuite/Test/Machine/Evaluate/Errors.hs +0/−1
• test/Testsuite/Test/Machine/Evaluate/Programs.hs +0/−2
• test/Testsuite/Test/Machine/Evaluate/Rules.hs +4/−5
• test/Testsuite/Test/Machine/Evaluate/TestTemplates/MachineState.hs +21/−31
• test/Testsuite/Test/Machine/Evaluate/TestTemplates/MarshalledValue.hs +38/−45
• test/Testsuite/Test/Machine/Evaluate/TestTemplates/Util.hs +3/−8
• test/Testsuite/Test/Machine/GarbageCollection.hs +17/−15
• test/Testsuite/Test/Machine/Heap.hs +6/−6
• test/Testsuite/Test/Marshal.hs +8/−5
• test/Testsuite/Test/Orphans/Language.hs +8/−6
• test/Testsuite/Test/Orphans/Machine.hs +18/−19
• test/Testsuite/Test/Parser/Parser.hs +6/−6
• test/Testsuite/Test/Parser/QuasiQuoter.hs +1/−1
• test/Testsuite/Test/Prelude/Bool.hs +0/−1
• test/Testsuite/Test/Prelude/List.hs +2/−3
• test/Testsuite/Test/Prelude/Tuple.hs +0/−1
• test/Testsuite/Test/StaticAnalysis.hs +147/−0
• test/Testsuite/Test/Util.hs +6/−3

@@ -0,0 +1,50 @@+# Avoiding lambdas is not always a good idea if you keep in mind that GHC's+# inliner will only consider fully applied functions.+- ignore: {name: "Avoid lambda"}++# Naming can be useful+- ignore: {name: "Eta reduce"}+- ignore: {name: "Redundant lambda"}+- ignore: {name: "Use const"}++# Sometimes, it can make code more readable if underscores are allowed as a+# form of a "large" separator. For example, one might give all tests the prefix+# "test_", followed by a camel-case test name.+- ignore: {name: "Use camelCase"}++# Sometimes a »case« can be clearer+- ignore: {name: "Use fromMaybe"}+- ignore: {name: "Use if"}++# Obfuscation much?+- ignore: {name: "Use uncurry"}+- ignore: {name: "Use first"}+- ignore: {name: "Use second"}++# I don’t like $+- error:+    name: Use parentheses instead of $+    lhs: f $ x+    rhs: f (x)++# AMP fallout+- error:+    name: generalize mapM+    lhs: mapM+    rhs: traverse+- error:+    name: generalize mapM_+    lhs: mapM_+    rhs: traverse_+- error:+    name: generalize forM+    lhs: forM+    rhs: for+- error:+    name: generalize forM_+    lhs: forM_+    rhs: for_+- error:+    name: Avoid return+    lhs: return+    rhs: pure

@@ -15,6 +15,14 @@   #     # true.   #     add_language_pragma: true +  # Align the right hand side of some elements.  This is quite conservative+  # and only applies to statements where each element occupies a single+  # line.+  - simple_align:+      cases: false+      top_level_patterns: false+      records: false+   # Import cleanup   - imports:       # There are different ways we can align names and lists.@@ -33,7 +41,7 @@       # Default: global.       align: group -      # Folowing options affect only import list alignment.+      # The following options affect only import list alignment.       #       # List align has following options:       #@@ -53,7 +61,7 @@       #   > import qualified Data.List      as List       #   >     (concat, foldl, foldr, head, init, last, length)       #-      # Default: after alias+      # Default: after_alias       list_align: after_alias        # Long list align style takes effect when import is too long. This is@@ -67,7 +75,7 @@       #   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.+      #   Type with constructor list acts like single import.       #       #   > import qualified Data.Map as M       #   >     ( empty@@ -79,11 +87,29 @@       # Default: inline       long_list_align: new_line_multiline +      # Align empty list (importing instances)+      #+      # Empty list align has following options+      #+      # - inherit: inherit list_align setting+      #+      # - right_after: () is right after the module name:+      #+      #   > import Vector.Instances ()+      #+      # Default: inherit+      empty_list_align: inherit+       # List padding determines indentation of import list on lines after import.-      # This option affects 'list_align' and 'long_list_align'.+      # This option affects 'long_list_align'.+      #+      # - <integer>: constant value+      #+      # - module_name: align under start of module name.+      #   Useful for 'file' and 'group' align settings.       list_padding: 4 -      # Separate lists option affects formating of import list for type+      # Separate lists option affects formatting of import list for type       # or class. The only difference is single space between type and list       # of constructors, selectors and class functions.       #@@ -116,7 +142,7 @@        # Align affects alignment of closing pragma brackets.       #-      # - true: Brackets are aligned in same collumn.+      # - true: Brackets are aligned in same column.       #       # - false: Brackets are not aligned together. There is only one space       #   between actual import and closing bracket.@@ -128,9 +154,6 @@       # 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@@ -143,6 +166,18 @@ # 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++# By default, line endings are converted according to the OS. You can override+# preferred format here.+#+# - native: Native newline format. CRLF on Windows, LF on other OSes.+#+# - lf: Convert to LF ("\n").+#+# - crlf: Convert to CRLF ("\r\n").+#+# Default: native.+newline: lf  # Sometimes, language extensions are specified in a cabal file or from the # command line instead of using language pragmas in the file. stylish-haskell

@@ -1,23 +0,0 @@-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 ==> ()

@@ -10,11 +10,14 @@  ![](screenshot.png) -[![Master build](https://img.shields.io/travis/quchen/stgi/master.svg?style=flat-square&label=Master build)](https://travis-ci.org/quchen/stgi)-[![BSD3](https://img.shields.io/badge/License-BSD-blue.svg?style=flat-square)](https://en.wikipedia.org/wiki/BSD_License)+[![Release](https://img.shields.io/github/release/quchen/stgi.svg?style=flat-square&label=Latest%20release)](https://github.com/quchen/stgi/releases) [![Hackage](https://img.shields.io/hackage/v/stgi.svg?style=flat-square)](http://hackage.haskell.org/packages/search?terms=stgi)+[![BSD3](https://img.shields.io/badge/License-BSD-blue.svg?style=flat-square)](https://en.wikipedia.org/wiki/BSD_License) +[![Master build](https://img.shields.io/travis/quchen/stgi/master.svg?style=flat-square&label=Master%20build)](https://travis-ci.org/quchen/stgi) ++ Table of contents ----------------- @@ -305,7 +308,7 @@ evaluation model the STG implements. For example, evaluating `main` in  ```haskell-add = <add two boxed ints>+add2 = … -- <add two boxed ints> one = \ -> Int# 1#; two = \ -> Int# 2#; main = \ => add2 one two

@@ -1,4 +1,3 @@-{-# LANGUAGE LambdaCase        #-} {-# LANGUAGE OverloadedStrings #-}  module CmdLineArgs (@@ -49,7 +48,7 @@                         Nothing            -> Nothing                 in \opts -> opts { optNumStates = parsed } )             "int" )-        "Colourize output"+        "Number of states to show. Negative counts from the end."     , Option ['v'] ["verbosity"]         (OptArg             (\x ->

@@ -1,6 +1,3 @@-{-# LANGUAGE LambdaCase        #-}-{-# LANGUAGE OverloadedStrings #-}- module Main (main) where  @@ -26,9 +23,30 @@     let numStates = optNumStates opts         verbosity = optVerbosity opts -    let prog = Example.addTwoNumbers 1 2+    let prog = Example.implies True False -    runForPager (if ansi then prettyprint else prettyprintPlain)-                numStates-                verbosity-                prog+    _finalState <-+        runForPager (if ansi then richRenderer else plainRenderer)+                    numStates+                    verbosity+                    prog+    pure ()++richRenderer :: Renderer+richRenderer = Renderer+    { renderProgram   = renderRich . prettyStgi+    , renderState     = renderRich . prettyStgi+    , renderInfo      = renderRich . prettyStgi+    , renderInfoShort = renderRich . prettyStgi+    }++plainRenderer :: Renderer+plainRenderer = Renderer+    { renderProgram   = renderPlain . unit . prettyStgi+    , renderState     = renderPlain . unit . prettyStgi+    , renderInfo      = renderPlain . unit . prettyStgi+    , renderInfoShort = renderPlain . unit . prettyStgi+    }++unit :: m StgiAnn -> m StgiAnn+unit = id

@@ -1,9 +1,10 @@+{-# LANGUAGE FlexibleContexts  #-} {-# 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+module Stg.RunForPager (runForPager, Renderer(..)) where   @@ -21,14 +22,20 @@ import Stg.Util  +data Renderer = Renderer+    { renderProgram   :: Program   -> Text+    , renderState     :: StgState  -> Text+    , renderInfo      :: Info      -> Text+    , renderInfoShort :: InfoShort -> Text+    }  runForPager-    :: (forall a. Pretty a => a -> Text)+    :: Renderer     -> Maybe Int -- ^ Steps to show. Negative numbers count from the end.     -> Int       -- ^ Verbosity level     -> Program-    -> IO ()-runForPager ppr showSteps verbosity prog =+    -> IO StgState+runForPager renderer showSteps verbosity prog =     let allStates = evalsUntil RunIndefinitely                                (HaltIf (const False))                                (PerformGc (const (Just triStateTracing)))@@ -43,30 +50,32 @@         T.putStrLn fatLine         T.putStrLn "Program:"         T.putStrLn line-        T.putStrLn (ppr prog)+        T.putStrLn (renderProgram renderer prog)         let loop (state :| rest) = do                 T.putStrLn fatLine-                printInfo ppr verbosity state line-                T.putStrLn (ppr state)+                printInfo renderer verbosity state line+                T.putStrLn (renderState renderer state)                 case rest of                     [] -> pure state                     (s:ss) -> loop (s:|ss)-        _finalState <- loop states+        finalState <- loop states         T.putStrLn fatLine+        pure finalState + printInfo-    :: (forall a. Pretty a => a -> Text)+    :: Renderer     -> Int     -> StgState     -> Text -- ^ Line     -> IO ()-printInfo ppr verbosity state line =+printInfo renderer 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 ))+                (if | verbosity == 2 -> renderInfo renderer (stgInfo state)+                    | verbosity == 1 -> renderInfoShort renderer (let Info shortInfo _ = stgInfo state+                                                                  in shortInfo ))             T.putStrLn line )  -- | Take the last N elements of a list (in original order).

@@ -1,5 +1,4 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeFamilies      #-}+{-# LANGUAGE TypeFamilies #-}  -- | A simple stack type. Very similar to an ordinary list, but with a more -- specialized API.@@ -15,6 +14,7 @@ import           Control.DeepSeq import           Data.Foldable                as F import           Data.Monoid+import qualified Data.Semigroup               as Semigroup import qualified GHC.Exts                     as OL import           Prelude                      hiding (span) import qualified Prelude                      as P@@ -33,25 +33,28 @@     pretty = prettyList . toList  instance Functor Stack where-    fmap _ Empty = Empty+    fmap _ Empty     = Empty     fmap f (x :< xs) = f x :< fmap f xs  instance Foldable Stack where-    foldMap _ Empty = mempty+    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)+    mappend = (Semigroup.<>) +instance Semigroup.Semigroup (Stack a) where+    Empty <> s = s+    (x :< xs) <> 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 Empty     = ()     rnf (x :< xs) = rnf x `seq` rnf xs  -- | Push a list of items onto the stack. The first item will be at the@@ -59,16 +62,16 @@ (<>>) :: [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.+-- | For each list element, pop one element off the 'Stack'. Fail if not enough+-- elements are present. 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+    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)+               in (OL.fromList a, OL.fromList b)

@@ -1,4 +1,3 @@-{-# LANGUAGE LambdaCase        #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes       #-} @@ -8,8 +7,11 @@      -- * Simple introductory programs +        implies,         addTwoNumbers,         calculateLength,+        mapNot,+        mapNotForced,      -- * Sum of list @@ -73,6 +75,21 @@   +-- | A program that calculates @x and not y@. This is probably the simplest+-- example program worth showing. It demonstrates how functions are evaluated,+-- has an update for the @main@ closure, and shows how nested functions result+-- in @let@ allocations.+implies :: Bool -> Bool -> Program+implies p q = mconcat+    [ Stg.or2+    , Stg.not+    , toStg "p" p+    , toStg "q" q+    , [program|+    main = \ => let notP = \ -> not p+                in or2 notP q+    |]]+ -- | A program that adds two numbers. addTwoNumbers :: Integer -> Integer -> Program addTwoNumbers x y = mconcat@@ -84,16 +101,44 @@     |]]  -- | A program that measures the length of a list.-calculateLength :: [Integer] -> Program+calculateLength :: ToStg a => [a] -> Program calculateLength xs = mconcat     [ Stg.length     , toStg "xs" xs     , [program|-    main = \ => case length xs of r -> r+    main = \ => length xs     |]] +-- | Negate a list of booleans, but non-strictly. This program does almost+-- nothing, because nothing forces the list.+mapNot :: [Bool] -> Program+mapNot xs = mconcat+    [ Stg.not+    , Stg.map+    , toStg "xs" xs+    , [program|+    main = \ => map not xs+    |]] +-- | Negate a list of booleans strictly.+mapNotForced :: [Bool] -> Program+mapNotForced xs = mconcat+    [ Stg.not+    , Stg.map+    , toStg "xs" xs+    , [program|+    main = \ => let mapped = \ => map not xs+                in force mapped;+    force = \bs -> case bs of+        Nil -> Nil;+        Cons y ys -> case y of+            someBool -> case force ys of+                someList -> Cons someBool someList;+        badList -> error_force badList+    |]] ++ -- | Program to sum up a list, but with the @sum@ function left undefined. sumTemplate :: [Integer] -> Program sumTemplate list = mconcat@@ -258,7 +303,7 @@         in fib n     |]] --- | Calculate the n-th Fibonacci number using the more effective formula+-- | Calculate the n-th Fibonacci number using the more efficient formula -- -- @ -- fib = fib' 0 1@@ -268,8 +313,8 @@ -- @ -- -- 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.+-- implementation. For example, calculating the 10th Fibonacci number (55) takes+-- only 490 steps, compared to the many thousands of the exponential version. fibonacciImproved :: Integer -> Program fibonacciImproved n = mconcat     [ Stg.add@@ -291,7 +336,7 @@     |]]  -- | List concatenation example with the 'concat' definition left out.-listConcatTemplate :: [[Integer]] -> Program+listConcatTemplate :: ToStg a => [[a]] -> Program listConcatTemplate xss = mconcat     [ toStg "xss" xss     , Stg.concat2@@ -317,7 +362,7 @@ -- and store it in the @main@ closure. -- -- This computation is __linear__ in the number of elements of the sublists.-listConcatRightAssociated :: [[Integer]] -> Program+listConcatRightAssociated :: ToStg a => [[a]] -> Program listConcatRightAssociated xss = mconcat     [ listConcatTemplate xss     , Stg.foldr@@ -332,7 +377,7 @@ -- and store it in the @main@ closure. -- -- This computation is __quadratic__ in the number of elements of the sublists.-listConcatLeftAssociated :: [[Integer]] -> Program+listConcatLeftAssociated :: ToStg a => [[a]] -> Program listConcatLeftAssociated xss = mconcat     [ listConcatTemplate xss     , Stg.foldl'@@ -395,12 +440,12 @@ --            in repeatX -- @ ----- This program does only a total of three heap allocations before continously+-- This program does only a total of three heap allocations before continuously -- running without interruption: one for the @repeated@ value, one for the--- self-referencing cons cell, and one beacuse of how 'Stg.forceSpine' works.+-- self-referencing cons cell, and one because of how 'Stg.forceSpine' works. -- -- Note how much smaller the cycles between the traversal of two neighbouring--- list cells is!+-- list cells are! repeatSharing :: Program repeatSharing = mconcat     [ Stg.forceSpine

@@ -1,7 +1,8 @@-{-# LANGUAGE DeriveGeneric     #-}-{-# LANGUAGE LambdaCase        #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell   #-}+{-# LANGUAGE DeriveGeneric         #-}+{-# LANGUAGE LambdaCase            #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE TemplateHaskell       #-}  -- | The STG language syntax tree, modeled after the description in the -- 1992 paper@@ -41,78 +42,60 @@   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           Data.List.NonEmpty        (NonEmpty (..))+import qualified Data.List.NonEmpty        as NonEmpty+import           Data.Map                  (Map)+import qualified Data.Map                  as M+import qualified Data.Semigroup            as Semigroup+import           Data.Text                 (Text)+import qualified Data.Text                 as T+import           Data.Text.Prettyprint.Doc import           GHC.Exts import           GHC.Generics import           Language.Haskell.TH.Lift-import           Text.PrettyPrint.ANSI.Leijen hiding ((<>)) --- $setup--- >>> :set -XQuasiQuotes--- >>> import Stg.Parser.QuasiQuoter+import Stg.Language.Prettyprint   --- | 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-    }-+-- $setup+-- >>> :set -XQuasiQuotes+-- >>> import Stg.Parser.QuasiQuoter  --- | An STG program consists of bindings.+-- | An STG 'Program' is the unit that can be loaded by the STG machine. It+-- consists of a set of bindings. newtype Program = Program Binds     deriving (Eq, Ord, Show, Generic) --- | Left-biased union of the contained bindings.+-- | __Right-biased union__ of the contained bindings. This makes for a poor man's+-- module system by appending multiple, potentially partially incomplete,+-- 'Programs' to each other.+--+-- @+-- 'Stg.Prelude.map' <> 'Stg.Prelude.filter' <> ['Stg.Parser.QuasiQuoter.stg'| … actual source … |]+-- @ instance Monoid Program where     mempty = Program mempty-    Program x `mappend` Program y = Program (x <> y)+    mappend = (Semigroup.<>) +instance Semigroup.Semigroup Program where+    Program x <> 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.+-- | __Right-biased__ union. See 'Monoid' 'Program' for further information. instance Monoid Binds where     mempty = Binds mempty-    Binds x `mappend` Binds y = Binds (y <> x)+    mappend = (Semigroup.<>) +instance Semigroup.Semigroup Binds where+    Binds x <> Binds y = Binds (x <> y)+ instance Show Binds where     show (Binds binds) = "(Binds " <> show (M.assocs binds) <> ")" @@ -123,6 +106,10 @@ -- >>> [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+    -- ^ * Free variables (excluding globals)+    --   * Update flag+    --   * Bound variables+    --   * Body     deriving (Eq, Ord, Show, Generic)  -- | Possible classification of lambda forms.@@ -132,10 +119,10 @@     | LambdaThunk -- ^ Thunk (everything else)     deriving (Eq, Ord, Show) -instance Pretty LambdaType where-    pretty = \case-        LambdaCon -> "Con"-        LambdaFun -> "Fun"+instance PrettyStgi LambdaType where+    prettyStgi = \case+        LambdaCon   -> "Con"+        LambdaFun   -> "Fun"         LambdaThunk -> "Thunk"  -- | Classify the type of a lambda form based on its shape.@@ -145,16 +132,17 @@     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+-- | The update flag distinguishes updatable from non-updatable lambda forms.+data UpdateFlag =+      Update -- ^ Overwrite the heap object in-place with its reduced value+             -- once available, making recurring access cheap+    | NoUpdate -- ^ Don't touch the heap object after evaluation     deriving (Eq, Ord, Show, Generic, Enum, Bounded)  -- | Distinguishes @let@ from @letrec@.-data Rec = NonRecursive | Recursive+data Rec =+      NonRecursive -- ^ Bindings have no access to each other+    | Recursive -- ^ Bindings can be given to each other as free variables     deriving (Eq, Ord, Show, Generic, Enum, Bounded)  -- | An expression in the STG language.@@ -164,7 +152,7 @@     | 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#@+    | LitE !Literal            -- ^ Literal expression @1#@     deriving (Eq, Ord, Show, Generic)  -- | List of possible alternatives in a 'Case' expression.@@ -269,18 +257,18 @@ -------------------------------------------------------------------------------- -- Pretty instances -semicolonTerminated :: [Doc] -> Doc-semicolonTerminated = align . vsep . punctuate (semicolon style ";")+semicolonTerminated :: [Doc StgiAnn] -> Doc StgiAnn+semicolonTerminated = align . vsep . punctuate (annotate (AstAnn Semicolon) ";") -instance Pretty Program where-    pretty (Program binds) = pretty binds+instance PrettyStgi Program where+    prettyStgi (Program binds) = prettyStgi binds -instance Pretty Binds where-    pretty (Binds bs) =+instance PrettyStgi Binds where+    prettyStgi (Binds bs) =         (semicolonTerminated . map prettyBinding . M.assocs) bs       where         prettyBinding (var, lambda) =-            pretty var <+> "=" <+> pretty lambda+            prettyStgi var <+> "=" <+> prettyStgi lambda  -- | Prettyprint a 'LambdaForm', given prettyprinters for the free variable -- list.@@ -288,9 +276,9 @@ -- Introduced so 'Stg.Machine.Types.Closure' can hijack it to display -- the free value list differently. prettyLambda-    :: ([Var] -> Doc) -- ^ Free variable list printer+    :: ([Var] -> Doc StgiAnn) -- ^ Free variable list printer     -> LambdaForm-    -> Doc+    -> Doc StgiAnn prettyLambda pprFree (LambdaForm free upd bound expr) =     (prettyExp . prettyUpd . prettyBound . prettyFree) "\\"   where@@ -299,68 +287,68 @@     prettyUpd = (<+> case upd of Update   -> "=>"                                  NoUpdate -> "->" )     prettyBound | null bound = id-                | null free = (<> prettyList bound)-                | otherwise = (<+> prettyList bound)-    prettyExp = (<+> pretty expr)+                | null free = (<> hsep (map prettyStgi bound))+                | otherwise = (<+> hsep (map prettyStgi bound))+    prettyExp = (<+> prettyStgi expr) -instance Pretty LambdaForm where-    pretty = prettyLambda prettyList+instance PrettyStgi LambdaForm where+    prettyStgi = prettyLambda (hsep . map prettyStgi) -instance Pretty Rec where-    pretty = \case+instance PrettyStgi Rec where+    prettyStgi = \case         NonRecursive -> ""         Recursive    -> "rec" -instance Pretty Expr where-    pretty = \case+instance PrettyStgi Expr where+    prettyStgi = \case         Let rec binds expr ->-            let inBlock = indent 4 (keyword style "in" <+> pretty expr)+            let inBlock = indent 4 (annotate (AstAnn Keyword) "in" <+> prettyStgi expr)                 bindingBlock = line <> indent 4 (-                    keyword style ("let" <> pretty rec) <+> pretty binds )+                    annotate (AstAnn Keyword) ("let" <> prettyStgi rec) <+> prettyStgi binds )             in vsep [bindingBlock, inBlock] -        Case expr alts -> vsep [ hsep [ keyword style "case"-                                      , pretty expr-                                      , keyword style "of" ]-                               , indent 4 (align (pretty alts)) ]+        Case expr alts -> vsep [ hsep [ annotate (AstAnn Keyword) "case"+                                      , prettyStgi expr+                                      , annotate (AstAnn Keyword) "of" ]+                               , indent 4 (align (prettyStgi alts)) ] -        AppF var []   -> pretty var-        AppF var args -> pretty var <+> prettyList args+        AppF var []   -> prettyStgi var+        AppF var args -> prettyStgi var <+> hsep (map prettyStgi args) -        AppC con []   -> pretty con-        AppC con args -> pretty con <+> prettyList args+        AppC con []   -> prettyStgi con+        AppC con args -> prettyStgi con <+> hsep (map prettyStgi args) -        AppP op arg1 arg2 -> pretty op <+> pretty arg1 <+> pretty arg2+        AppP op arg1 arg2 -> prettyStgi op <+> prettyStgi arg1 <+> prettyStgi arg2 -        Lit lit -> pretty lit+        LitE lit -> prettyStgi 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 PrettyStgi Alts where+    prettyStgi (Alts NoNonDefaultAlts def) = prettyStgi def+    prettyStgi (Alts (AlgebraicAlts alts) def) =+        semicolonTerminated (map prettyStgi (toList alts) <> [prettyStgi def])+    prettyStgi (Alts (PrimitiveAlts alts) def) =+        semicolonTerminated (map prettyStgi (toList alts) <> [prettyStgi 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 PrettyStgi AlgebraicAlt where+    prettyStgi (AlgebraicAlt con [] expr)+        = prettyStgi con <+> "->" <+> prettyStgi expr+    prettyStgi (AlgebraicAlt con args expr)+        = prettyStgi con <+> hsep (map prettyStgi args) <+> "->" <+> prettyStgi expr -instance Pretty PrimitiveAlt where-    pretty (PrimitiveAlt lit expr) =-        pretty lit <+> "->" <+> pretty expr+instance PrettyStgi PrimitiveAlt where+    prettyStgi (PrimitiveAlt lit expr) =+        prettyStgi lit <+> "->" <+> prettyStgi expr -instance Pretty DefaultAlt where-    pretty = \case-        DefaultNotBound expr  -> "default" <+> "->" <+> pretty expr-        DefaultBound var expr -> pretty var <+> "->" <+> pretty expr+instance PrettyStgi DefaultAlt where+    prettyStgi = \case+        DefaultNotBound expr  -> "default" <+> "->" <+> prettyStgi expr+        DefaultBound var expr -> prettyStgi var <+> "->" <+> prettyStgi expr -instance Pretty Literal where-    pretty (Literal i) = prim style (integer i <> "#")+instance PrettyStgi Literal where+    prettyStgi (Literal i) = annotate (AstAnn Prim) (pretty i <> "#") -instance Pretty PrimOp where-    pretty op = prim style (case op of+instance PrettyStgi PrimOp where+    prettyStgi op = annotate (AstAnn Prim) (case op of         Add -> "+#"         Sub -> "-#"         Mul -> "*#"@@ -373,18 +361,16 @@         Geq -> ">=#"         Neq -> "/=#" ) -instance Pretty Var where-    pretty (Var name) = variable style (string (T.unpack name))-    prettyList = hsep . map pretty+instance PrettyStgi Var where+    prettyStgi (Var name) = annotate (AstAnn Variable) (pretty name) -instance Pretty Atom where-    pretty = \case-        AtomVar var -> pretty var-        AtomLit lit -> pretty lit-    prettyList = hsep . map pretty+instance PrettyStgi Atom where+    prettyStgi = \case+        AtomVar var -> prettyStgi var+        AtomLit lit -> prettyStgi lit -instance Pretty Constr where-    pretty (Constr name) = constructor style (string (T.unpack name))+instance PrettyStgi Constr where+    prettyStgi (Constr name) = annotate (AstAnn Constructor) (pretty name)  instance NFData Program instance NFData Binds

@@ -1,31 +1,95 @@-{-# LANGUAGE LambdaCase        #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE LambdaCase            #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings     #-}  -- | Prettyprinting STG elements in various formats. module Stg.Language.Prettyprint (-    Pretty(..),-    prettyprint,-    prettyprintPlain,+    PrettyStgi(..),+    StgiAnn(..),+    StateAnn(..),+    AstAnn(..),++    renderRich,+    renderPlain,+    prettyprintOldAnsi, ) where   -import           Data.Text                    (Text)-import qualified Data.Text                    as T-import           Prelude                      hiding ((<$>))-import           Text.PrettyPrint.ANSI.Leijen+import           Data.Text                                 (Text)+import qualified Data.Text                                 as T+import           Data.Text.Prettyprint.Doc+import           Data.Text.Prettyprint.Doc.Render.Terminal as PrettyAnsi+import           Data.Text.Prettyprint.Doc.Render.Text     as PrettyPlain+import           Prelude                                   hiding ((<$>))+import qualified Text.PrettyPrint.ANSI.Leijen              as Leijen   +renderRich :: Doc StgiAnn -> Text+renderRich = PrettyAnsi.renderStrict . alterAnnotationsS (Just . terminalStyle) . layoutPretty layoutOptions+  where+    terminalStyle :: StgiAnn -> AnsiStyle+    terminalStyle = \case+        StateAnn x -> case x of+            Headline       -> colorDull Blue+            Address        -> colorDull Cyan+            AddressCore    -> underlined+            ClosureType    -> bold+            StackFrameType -> bold+        AstAnn x -> case x of+            Keyword     -> colorDull White+            Prim        -> colorDull Green+            Variable    -> colorDull Yellow+            Constructor -> colorDull Magenta+            Semicolon   -> colorDull White++renderPlain :: Doc ann -> Text+renderPlain = PrettyPlain.renderStrict . layoutPretty layoutOptions++layoutOptions :: LayoutOptions+layoutOptions = defaultLayoutOptions { layoutPageWidth = Unbounded }+ -- | Prettyprint a value as 'Text', including styles such as colours.-prettyprint :: Pretty a => a -> Text-prettyprint = prettyprintModified id+prettyprintOldAnsi :: Leijen.Doc -> Text+prettyprintOldAnsi input = T.pack (Leijen.displayS (Leijen.renderPretty 0.4 1000 input) "") --- | Prettyprint a value as 'Text', stripped off all style information such as--- colours.-prettyprintPlain :: Pretty a => a -> Text-prettyprintPlain = prettyprintModified plain+class PrettyStgi a where+    prettyStgi :: a -> Doc StgiAnn -prettyprintModified :: Pretty a => (Doc -> Doc) -> a -> Text-prettyprintModified modifier input =-    T.pack (displayS (renderPretty 0.4 1000 (modifier (pretty input))) "")+data StgiAnn+    = StateAnn StateAnn+    | AstAnn AstAnn++-- | Semantic annotations for rendering.+data StateAnn+    = Headline+        -- ^ Style of headlines in the state overview, such as \"Heap" and+        --   "Frame i".++    | Address+        -- ^ Style of memory addresses, including @0x@ prefix.++    | AddressCore+        -- ^ Style of memory addresses; applied only to the actual address+        --   number, such as @ff@ in @0xff@.++    | ClosureType+        -- ^ Style of the type of a closure, such as BLACKHOLE or FUN.++    | StackFrameType+        -- ^ Style of the stack frame annotation, such as UPD or ARG.++-- | The different semantic annotations an STG AST element can have.+data AstAnn+    = Keyword+    | Prim+    | Variable+    | Constructor+    | Semicolon++instance PrettyStgi Bool where prettyStgi = pretty+instance PrettyStgi Int where prettyStgi = pretty+instance PrettyStgi Integer where prettyStgi = pretty+instance (PrettyStgi a, PrettyStgi b) => PrettyStgi (a,b) where prettyStgi (a,b) = tupled [prettyStgi a, prettyStgi b]+instance PrettyStgi a => PrettyStgi [a] where prettyStgi = list . map prettyStgi

@@ -1,6 +1,4 @@-{-# LANGUAGE LambdaCase        #-}-{-# LANGUAGE OverloadedLists   #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedLists #-}  -- | User-facing API to work with STG programs. module Stg.Machine (@@ -23,7 +21,8 @@ ) where  -import           Data.List.NonEmpty (NonEmpty (..))++import           Data.List.NonEmpty (NonEmpty (..), (<|)) import qualified Data.List.NonEmpty as NE  import Stg.Language@@ -71,6 +70,7 @@             { stgInfo = Info (StateError InitialStateCreationFailed) [] }  + -- | Predicate to decide whether the machine should halt. data RunForSteps =       RunIndefinitely -- ^ Do not terminate based on the number of steps@@ -98,6 +98,9 @@ evalUntil runForSteps halt performGc state     = NE.last (evalsUntil runForSteps halt performGc state) +data AttemptGc = GcPossible | SkipGc+    deriving (Eq, Ord, Show)+ -- | Evaluate the STG, and record all intermediate states. -- -- * Stop when a predicate holds.@@ -114,47 +117,53 @@     -> StgState          -- ^ Initial state     -> NonEmpty StgState -- ^ Initial state plus intermediate states evalsUntil runForSteps (HaltIf haltIf) (PerformGc performGc)-  = NE.fromList . go False+  = step SkipGc   where-    terminate = (:[])-    go attemptGc = \case+    terminateWith :: a -> NonEmpty a+    terminateWith = pure -        state@StgState{ stgSteps = steps }-            | RunForMaxSteps maxSteps <- runForSteps-            , steps >= maxSteps-            -> terminate (state { stgInfo = Info MaxStepsExceeded [] })+    isInitialOrTransition state = case stgInfo state of+        Info StateTransition{} _ -> True+        Info StateInitial      _ -> True+        _otherwise               -> False -        state | haltIf state-            -> terminate (state { stgInfo = Info HaltedByPredicate [] })+    -- Max steps exceeded+    step _ state+        | RunForMaxSteps maxSteps <- runForSteps+        , stgSteps state >= maxSteps+        = terminateWith (state { stgInfo = Info MaxStepsExceeded [] }) -        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)+    -- Halting predicate triggered+    step _ state+        | haltIf state+        = terminateWith (state { stgInfo = Info HaltedByPredicate [] }) -        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)+    -- Normal state transition, attempt GC+    step gcPossible state+        | isInitialOrTransition state+        , gcPossible == GcPossible+        , Just gcAlgorithm <- performGc state+        = case garbageCollect gcAlgorithm state of+            stateGc@StgState{stgInfo = Info GarbageCollection _} ->+                state <| stateGc <| step SkipGc (evalStep stateGc)+            _otherwise -> state <| step GcPossible (evalStep state) -        state@StgState{ stgInfo = Info GarbageCollection _ }-            -> state : go False (evalStep state)+    -- Normal state transition, no GC+    step _ state+        | isInitialOrTransition state+        = state <| step GcPossible (evalStep state) -        state-            -> terminate state+    -- Garbage collection triggered last time+    step _ state@StgState{ stgInfo = Info GarbageCollection _ }+        = state <| step SkipGc (evalStep state) +    -- Anything else: terminateWith in the current state+    step _ state = terminateWith state+ -- | Check whether a state is terminal. terminated :: StgState -> Bool terminated StgState{stgInfo = Info info _} = case info of-    StateTransition{}    -> False+    StateTransition{}   -> False     StateInitial{}      -> False     GarbageCollection{} -> False     _otherwise          -> True

@@ -1,5 +1,3 @@-{-# LANGUAGE OverloadedStrings #-}- -- | Defines operations on local and global variable environments. module Stg.Machine.Env ( 

@@ -1,6 +1,4 @@-{-# LANGUAGE LambdaCase        #-}-{-# LANGUAGE OverloadedLists   #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedLists #-}  -- | Evaluate STG 'Program's. module Stg.Machine.Evaluate (@@ -9,96 +7,15 @@   -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.Foldable -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 qualified Data.Stack                            as S+import qualified Stg.Machine.Evaluate.ErrorTransitions as Error+import qualified Stg.Machine.Evaluate.ValidTransitions as Valid 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) ]---- | Successful alternative match, used for finding the right branch in @case@-data AltMatch alt = AltMatches alt | DefaultMatches DefaultAlt--data AltError = BadAlt -- ^ Alg/prim alternative in prim/alg case---- | Look up an algebraic constructor among the given alternatives, and return--- the first match. If nothing matches, return the default alternative.-lookupAlgebraicAlt-    :: Alts-    -> Constr-    -> Validate AltError (AltMatch AlgebraicAlt)-lookupAlgebraicAlt (Alts (AlgebraicAlts alts) def) constr-  = let matchingAlt (AlgebraicAlt c _ _) = c == constr-    in Success (case L.find matchingAlt alts of-        Just alt   -> AltMatches alt-        _otherwise -> DefaultMatches def )-lookupAlgebraicAlt (Alts PrimitiveAlts{} _) _ = Failure BadAlt-lookupAlgebraicAlt (Alts NoNonDefaultAlts{} def) _ = Success (DefaultMatches def)---- | 'lookupAlgebraicAlt' for primitive literals.-lookupPrimitiveAlt-    :: Alts-    -> Literal-    -> Validate AltError (AltMatch PrimitiveAlt)-lookupPrimitiveAlt (Alts (PrimitiveAlts alts) def) lit-  = let matchingAlt (PrimitiveAlt lit' _) = lit' == lit-    in Success (case L.find matchingAlt alts of-        Just alt   -> AltMatches alt-        _otherwise -> DefaultMatches def )-lookupPrimitiveAlt (Alts AlgebraicAlts{} _) _ = Failure BadAlt-lookupPrimitiveAlt (Alts NoNonDefaultAlts{} def) _ = Success (DefaultMatches 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@@ -106,515 +23,61 @@   --- | 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 varToAddr var addr = Mapping var (Addr addr)-                      newMappings = zipWith varToAddr letVars 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 addrToClosure addr closure = Mapping addr (HClosure closure)-                heap' = H.updateMany-                    (zipWith addrToClosure newAddrs 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-    , Success altLookup <- lookupPrimitiveAlt alts (Literal opXY)--  = let (locals', expr) = case altLookup of-            DefaultMatches (DefaultBound pat e)-                -> (addLocals [Mapping pat (PrimInt opXY)] locals, e)-            DefaultMatches (DefaultNotBound e)-                -> (locals, e)-            AltMatches (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' }-    | Success (AltMatches (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' }-    | Success (DefaultMatches (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 }-    | Success (DefaultMatches (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' }-    | Success (AltMatches (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' }-    | Success (DefaultMatches (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' }-    | Success (DefaultMatches (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.---+-- | Transition rules detailed in the 1992 paper, along with error rules to+-- help if none of them applies. ----- 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 (Mapping addr (Blackhole tick)) heap+-- This is the place to modify the ruleset of the machine, for example+-- 'Valid.rule1819' can be removed to yield a less efficient, yet equally+-- correct, STG implementation.+rules :: [StgState -> Maybe StgState]+rules =+    [ Valid.rule1_functionApp+    , Valid.rule2_enterNonUpdatable+    , Valid.rule3_let+    , Valid.rule1819_casePrimopShortcut -- before rule 4 because it takes+                                        -- precedence over it in certain cases!+    , Valid.rule4_case+    , Valid.rule5_constructorApp+    , Valid.rule6_algebraicNormalMatch+    , Valid.rule7_algebraicUnboundDefaultMatch+    , Valid.rule8_algebraicBoundDefaultMatch+    , Valid.rule9_primitiveLiteralEval+    , Valid.rule10_primitiveLiteralApp+    , Valid.rule11_primitiveNormalMatch+    , Valid.rule12_primitiveBoundDefaultMatch+    , Valid.rule13_primitiveUnboundDefaultMatch+    , Valid.rule14_primop+    , Valid.rule15_enterUpdatable+    , Valid.rule16_missingReturnUpdate+    , Valid.rule17a_missingArgUpdate -    in s { stgCode  = Eval body locals-         , stgStack = stack'-         , stgHeap  = heap'-         , stgInfo  = Info (StateTransition Enter_UpdatableClosure)-                           [Detail_EnterUpdatable addr] }+    , Error.updatableClosureWithArgs+    , Error.returnWithEmptyReturnStack+    , Error.functionArgumentNotInScope+    , Error.constructorArgumentNotInScope+    , Error.primopArgumentNotInScope+    , Error.algReturnToPrimAlts+    , Error.primReturnToAlgAlts+    , Error.enterBlackhole+    , Error.updateClosureWithPrimitive+    , Error.nonAlgPrimScrutinee+    , Error.divisionByZero+    , Error.badConArity ]   --- (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 (Mapping 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] }+-- | Apply a single applicable STG evaluation rule to continue to the next step.+stgRule :: StgState -> StgState+stgRule state = case asum [ rule state | rule <- rules ] of+    Nothing     -> noRulesApply state+    Just state' -> state'   --- (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 (Mapping addrUpdate (HClosure updatedClosure)) heap--    in s { stgCode  = Enter addrEnter-         , stgStack = argFrames <>> stack'-         , stgHeap  = heap'-         , stgInfo  = Info (StateTransition Enter_PartiallyAppliedUpdate)-                           [Detail_PapUpdate addrUpdate] }-+-- | Fallback if none of the known rules applies.+noRulesApply :: StgState -> StgState+noRulesApply s = s { stgInfo = Info NoRulesApply detail }   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-    { 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) [] }---- Bad constructor arity: different number of arguments in code segment--- and in return frame-noRuleApplies s@StgState-    { stgCode  = ReturnCon con ws-    , stgStack = ReturnFrame alts _ :< _ }-    | Success (AltMatches (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] }+    detail = case stgStack s of+        S.Empty -> []+        _else   -> [Detail_StackNotEmpty]

@@ -0,0 +1,89 @@+{-# LANGUAGE LambdaCase #-}++-- | Definitions useful for all state transition modules.+module Stg.Machine.Evaluate.Common (++    -- * Primops+    PrimError(..),+    applyPrimOp,++    -- * Algebraic matching+    AltMatch(..),+    AltError(..),+    lookupAlgebraicAlt,++    -- * Primitive matching+    lookupPrimitiveAlt,++) where++++import qualified Data.List as L++import Stg.Language+import Stg.Util++++-- | Possible errors of primops+data PrimError = Div0 -- ^ Division by zero++-- | Apply a primop to two actual integers+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 (/=)+++++-- | Successful alternative match, used for finding the right branch in @case@+data AltMatch alt = AltMatches alt | DefaultMatches DefaultAlt++-- | Possible errors when looking up alternatives+data AltError = BadAlt -- ^ Algebraic\/primitive alternative in+                       -- primitive\/algebraic case++-- | Look up an algebraic constructor among the given alternatives, and return+-- the first match. If nothing matches, return the default alternative.+lookupAlgebraicAlt+    :: Alts+    -> Constr+    -> Validate AltError (AltMatch AlgebraicAlt)+lookupAlgebraicAlt (Alts (AlgebraicAlts alts) def) constr+  = let matchingAlt (AlgebraicAlt c _ _) = c == constr+    in Success (case L.find matchingAlt alts of+        Just alt   -> AltMatches alt+        _otherwise -> DefaultMatches def )+lookupAlgebraicAlt (Alts PrimitiveAlts{} _) _ = Failure BadAlt+lookupAlgebraicAlt (Alts NoNonDefaultAlts{} def) _ = Success (DefaultMatches def)++++-- | 'lookupAlgebraicAlt' for primitive literals.+lookupPrimitiveAlt+    :: Alts+    -> Literal+    -> Validate AltError (AltMatch PrimitiveAlt)+lookupPrimitiveAlt (Alts (PrimitiveAlts alts) def) lit+  = let matchingAlt (PrimitiveAlt lit' _) = lit' == lit+    in Success (case L.find matchingAlt alts of+        Just alt   -> AltMatches alt+        _otherwise -> DefaultMatches def )+lookupPrimitiveAlt (Alts AlgebraicAlts{} _) _ = Failure BadAlt+lookupPrimitiveAlt (Alts NoNonDefaultAlts{} def) _ = Success (DefaultMatches def)

@@ -0,0 +1,196 @@+{-# LANGUAGE OverloadedLists #-}++-- | STG error transitions, in order to provide useful information to the user.+module Stg.Machine.Evaluate.ErrorTransitions (+    updatableClosureWithArgs,+    returnWithEmptyReturnStack,+    functionArgumentNotInScope,+    constructorArgumentNotInScope,+    primopArgumentNotInScope,+    algReturnToPrimAlts,+    primReturnToAlgAlts,+    enterBlackhole,+    updateClosureWithPrimitive,+    nonAlgPrimScrutinee,+    divisionByZero,+    badConArity,+) where++++import           Data.Stack                  (Stack (..))+import           Stg.Language+import           Stg.Machine.Env+import           Stg.Machine.Evaluate.Common+import qualified Stg.Machine.Heap            as H+import           Stg.Machine.Types+import           Stg.Util++++-- | Page 39, 2nd paragraph: "[...] closures with non-empty argument lists are+-- never updatable [...]"+updatableClosureWithArgs :: StgState -> Maybe StgState+updatableClosureWithArgs s@StgState+    { stgCode = Enter addr+    , stgHeap = heap }+    | Just (HClosure (Closure (LambdaForm _ Update (_:_) _) _))+        <- H.lookup addr heap++  = Just (s { stgInfo = Info (StateError UpdatableClosureWithArgs) [] })++updatableClosureWithArgs _ = Nothing++++-- | 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."+returnWithEmptyReturnStack :: StgState -> Maybe StgState+returnWithEmptyReturnStack s@StgState+    { stgCode  = ReturnInt{}+    , stgStack = Empty }++  = Just (s { stgInfo = Info (StateError ReturnIntWithEmptyReturnStack)+                             [Detail_ReturnIntCannotUpdate] })++returnWithEmptyReturnStack _ = Nothing++++-- | A function was applied to an argument that was neither globally defined+-- nor in the local environment+functionArgumentNotInScope :: StgState -> Maybe StgState+functionArgumentNotInScope s@StgState+    { stgCode    = Eval (AppF f xs) locals+    , stgGlobals = globals }+    | Failure notInScope <- vals locals globals (AtomVar f : xs)++  = Just (s { stgInfo = Info (StateError (VariablesNotInScope notInScope)) [] })++functionArgumentNotInScope _ = Nothing++++-- | A constructor was applied to an argument that was neither globally defined+-- nor in the local environment+constructorArgumentNotInScope :: StgState -> Maybe StgState+constructorArgumentNotInScope s@StgState+    { stgCode    = Eval (AppC _con xs) locals+    , stgGlobals = globals }+    | Failure notInScope <- vals locals globals xs++  = Just (s { stgInfo = Info (StateError (VariablesNotInScope notInScope)) [] })++constructorArgumentNotInScope _ = Nothing++++-- | A primitive operation was applied to an argument that was neither globally+-- defined nor in the local environment+primopArgumentNotInScope :: StgState -> Maybe StgState+primopArgumentNotInScope s@StgState+    { stgCode = Eval (AppP _op x y) locals }+    | Failure notInScope <- traverse (localVal locals) ([x,y] :: [Atom])++  = Just (s { stgInfo = Info (StateError (VariablesNotInScope notInScope)) [] })++primopArgumentNotInScope _ = Nothing++++-- | Algebraic constructor return, but primitive alternative on return frame+algReturnToPrimAlts :: StgState -> Maybe StgState+algReturnToPrimAlts s@StgState+    { stgCode  = ReturnCon{}+    , stgStack = ReturnFrame (Alts PrimitiveAlts{} _) _ :< _ }++  = Just (s { stgInfo = Info (StateError AlgReturnToPrimAlts) [] })++algReturnToPrimAlts _ = Nothing++++-- | Primitive return, but algebraic alternative on return frame+primReturnToAlgAlts :: StgState -> Maybe StgState+primReturnToAlgAlts s@StgState+    { stgCode  = ReturnInt _+    , stgStack = ReturnFrame (Alts AlgebraicAlts{} _) _ :< _ }++  = Just (s { stgInfo = Info (StateError PrimReturnToAlgAlts) [] })++primReturnToAlgAlts _ = Nothing++++-- | A black hole was entered, and the infinite recursion detection triggered+-- as a result+enterBlackhole :: StgState -> Maybe StgState+enterBlackhole s@StgState+    { stgCode  = Enter addr+    , stgHeap  = heap }+    | Just (Blackhole bhTick) <- H.lookup addr heap++  = Just (s+        { stgInfo = Info (StateError EnterBlackhole)+                       [Detail_EnterBlackHole addr bhTick] })++enterBlackhole _ = Nothing++++-- | Closures are always lifted, not primitive+updateClosureWithPrimitive :: StgState -> Maybe StgState+updateClosureWithPrimitive s@StgState+    { stgCode  = ReturnInt _+    , stgStack = UpdateFrame _ :< _}++  = Just (s+        { stgInfo  = Info (StateError UpdateClosureWithPrimitive)+                        [Detail_UpdateClosureWithPrimitive] })++updateClosureWithPrimitive _ = Nothing++++-- | Non-algebraic scrutinee+--+-- For more information on this, see 'Stg.Prelude.seq'.+nonAlgPrimScrutinee :: StgState -> Maybe StgState+nonAlgPrimScrutinee s@StgState+    { stgCode  = Enter _+    , stgStack = ReturnFrame{} :< _}++  = Just (s { stgInfo  = Info (StateError NonAlgPrimScrutinee) [] })++nonAlgPrimScrutinee _ = Nothing++++-- | A primitive division had zero as denominator+divisionByZero :: StgState -> Maybe StgState+divisionByZero 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++  = Just (s { stgInfo  = Info (StateError DivisionByZero) [] })++divisionByZero _ = Nothing++++-- | Bad constructor arity: different number of arguments in code segment and in+-- return frame+badConArity :: StgState -> Maybe StgState+badConArity s@StgState+    { stgCode  = ReturnCon con ws+    , stgStack = ReturnFrame alts _ :< _ }+    | Success (AltMatches (AlgebraicAlt _con vars _)) <- lookupAlgebraicAlt alts con+    , length ws /= length vars++  = Just (s { stgInfo  = Info (StateError (BadConArity (length ws) (length vars)))+                                          [Detail_BadConArity] })++badConArity _ = Nothing

@@ -0,0 +1,609 @@+{-# LANGUAGE OverloadedLists   #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Valid transitions from one state to another. Error conditions are handled+-- separately in "ErrorTransitions" if possible.+module Stg.Machine.Evaluate.ValidTransitions (+    rule1_functionApp,+    rule2_enterNonUpdatable,+    rule3_let,+    rule4_case,+    rule5_constructorApp,+    rule6_algebraicNormalMatch,+    rule7_algebraicUnboundDefaultMatch,+    rule8_algebraicBoundDefaultMatch,+    rule9_primitiveLiteralEval,+    rule10_primitiveLiteralApp,+    rule11_primitiveNormalMatch,+    rule12_primitiveBoundDefaultMatch,+    rule13_primitiveUnboundDefaultMatch,+    rule14_primop,+    rule15_enterUpdatable,+    rule16_missingReturnUpdate,+    rule17_missingArgUpdate,+    rule17a_missingArgUpdate,+    rule1819_casePrimopShortcut,+) where++++import           Data.Bifunctor+import qualified Data.Foldable  as F+import qualified Data.Map       as M+import           Data.Monoid    hiding (Alt)+import qualified Data.Set       as S++import           Data.Stack                  (Stack (..), (<>>))+import qualified Data.Stack                  as S+import           Stg.Language+import           Stg.Machine.Env+import           Stg.Machine.Evaluate.Common+import qualified Stg.Machine.Heap            as H+import           Stg.Machine.Types+import           Stg.StaticAnalysis+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) ]++++-- | Rule 1: Function application+--+-- Push argument values onto the stack, and enter the function's address.+rule1_functionApp :: StgState -> Maybe StgState+rule1_functionApp 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 Just (s+        { stgCode  = Enter addr+        , stgStack = stack'+        , stgInfo  = Info+            (StateTransition Rule1_Eval_FunctionApplication)+            ( Detail_FunctionApplication f xs+            : mkDetail_UnusedLocalVariables (f : [ var | AtomVar var <- xs ]) locals )})++rule1_functionApp _ = Nothing++++isArgFrame :: StackFrame -> Bool+isArgFrame ArgumentFrame{} = True+isArgFrame _else           = False++++-- | Rule 2: Enter non-updatable closure+--+-- Fetch all arguments from the stack, bind them to the lambda's variables, and+-- continue evaluating the body.+rule2_enterNonUpdatable :: StgState -> Maybe StgState+rule2_enterNonUpdatable 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 Just (s+        { stgCode  = Eval body locals+        , stgStack = stack'+        , stgInfo  = Info (StateTransition Rule2_Enter_NonUpdatableClosure)+                          [Detail_EnterNonUpdatable addr boundLocals] })++rule2_enterNonUpdatable _ = Nothing++++-- | Create a 'Closure' out of a 'LambdaForm', given a local environment.+liftLambdaToClosure :: Locals -> LambdaForm -> Validate NotInScope Closure+liftLambdaToClosure locals lf@(LambdaForm free _ _ _) =+    case traverse (first (:[]) . localVal locals . AtomVar) free of+        Success freeVals   -> Success (Closure lf freeVals)+        Failure notInScope -> Failure (mconcat notInScope)++++-- | Rule 3: let(rec)+--+-- Allocate closures for each definition on the heap, making sure references to+-- existing (or recursive) definitions are correct, and add the bindings to the+-- local environment. Proceed by evaluating the @in@ part of the @let@.+rule3_let :: StgState -> Maybe StgState+rule3_let 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 varToAddr var addr = Mapping var (Addr addr)+                      newMappings = zipWith varToAddr letVars 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 Just (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 addrToClosure addr closure = Mapping addr (HClosure closure)+                heap' = H.updateMany+                    (zipWith addrToClosure newAddrs closures)+                    heapWithPreallocations+            in s { stgCode = Eval expr locals'+                 , stgHeap = heap'+                 , stgInfo = Info (StateTransition (Rule3_Eval_Let rec))+                                  [Detail_EvalLet letVars newAddrs] }+        Failure notInScope ->+            s { stgInfo = Info (StateError (VariablesNotInScope notInScope)) [] })++rule3_let _ = Nothing++++-- | Rule 4: Case evaluation+--+-- Push a return frame with the possible branches, and continue evaluating the+-- scrutinee.+--+-- Compared to the paper, this rule was improved by removing local bindings that+-- are not used at all in the alternatives, which would unnecessarily prolong+-- the garbage collection lifetime of unused bindings.+rule4_case :: StgState -> Maybe StgState+rule4_case s@StgState+    { stgCode  = Eval (Case expr alts) locals+    , stgStack = stack }++  = let stack' = ReturnFrame alts (removeUnusedLocals locals) :< stack++        removeUnusedLocals (Locals unpackedLocals) =+            let freeInBody var _val = var `S.member` freeVariables alts+            in Locals (M.filterWithKey freeInBody unpackedLocals)++    in Just (s+        { stgCode  = Eval expr locals+        , stgStack = stack'+        , stgInfo  = Info (StateTransition Rule4_Eval_Case)+                          [Detail_EvalCase] })++rule4_case _ = Nothing++++-- | Rule 5: Constructor application+--+-- Simply transition into the 'ReturnCon' state.+rule5_constructorApp :: StgState -> Maybe StgState+rule5_constructorApp s@StgState+    { stgCode    = Eval (AppC con xs) locals+    , stgGlobals = globals }+    | Success valsXs <- vals locals globals xs++  = Just (s+        { stgCode = ReturnCon con valsXs+        , stgInfo = Info+            (StateTransition Rule5_Eval_AppC)+            (mkDetail_UnusedLocalVariables [ var | AtomVar var <- xs ] locals) })++rule5_constructorApp _ = Nothing++++-- | Rule 6: Algebraic constructor return, standard match+--+-- Continue with the branch of the matched constructor, extending the local+-- environment with the matched pattern variables' values.+rule6_algebraicNormalMatch :: StgState -> Maybe StgState+rule6_algebraicNormalMatch s@StgState+    { stgCode  = ReturnCon con ws+    , stgStack = ReturnFrame alts locals :< stack' }+    | Success (AltMatches (AlgebraicAlt _con vars expr)) <-+        lookupAlgebraicAlt alts con+    , length ws == length vars++  = let locals' = addLocals (zipWith Mapping vars ws) locals++    in Just (s+        { stgCode  = Eval expr locals'+        , stgStack = stack'+        , stgInfo  = Info (StateTransition Rule6_ReturnCon_Match)+                          [Detail_ReturnCon_Match con vars] })++rule6_algebraicNormalMatch _ = Nothing++++-- | Rule 7: Algebraic constructor return, unbound default match+--+-- None of the given alternatives matched, so simply continue with the default+-- branch.+rule7_algebraicUnboundDefaultMatch :: StgState -> Maybe StgState+rule7_algebraicUnboundDefaultMatch s@StgState+    { stgCode  = ReturnCon con _ws+    , stgStack = ReturnFrame alts locals :< stack' }+    | Success (DefaultMatches (DefaultNotBound expr)) <-+        lookupAlgebraicAlt alts con++  = Just (s+        { stgCode  = Eval expr locals+        , stgStack = stack'+        , stgInfo  = Info (StateTransition Rule7_ReturnCon_DefUnbound) [] })++rule7_algebraicUnboundDefaultMatch _ = Nothing++++-- | Rule 8: Algebraic constructor return, bound default match+--+-- None of the given alternatives matched, so continue with the default branch.+-- Also allocate the default-matched value on the heap and extend the local+-- environment with its binding to retain a reference to the scrutinized value.+rule8_algebraicBoundDefaultMatch :: StgState -> Maybe StgState+rule8_algebraicBoundDefaultMatch s@StgState+    { stgCode  = ReturnCon con ws+    , stgStack = ReturnFrame alts locals :< stack'+    , stgHeap  = heap+    , stgSteps = steps }+    | Success (DefaultMatches (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 Just (s { stgCode  = Eval expr locals'+         , stgStack = stack'+         , stgHeap  = heap'+         , stgInfo  = Info (StateTransition Rule8_ReturnCon_DefBound)+                           [Detail_ReturnConDefBound v addr] })++rule8_algebraicBoundDefaultMatch _ = Nothing++++-- | Rule 9: Literal evaluation+--+-- Simply transition into the 'ReturnInt' state.+rule9_primitiveLiteralEval :: StgState -> Maybe StgState+rule9_primitiveLiteralEval s@StgState { stgCode = Eval (LitE (Literal k)) _locals}+  = Just (s+        { stgCode = ReturnInt k+        , stgInfo = Info (StateTransition Rule9_Lit) [] })++rule9_primitiveLiteralEval _ = Nothing++++-- | Rule 10: Literal application+--+-- Simply transition into the 'ReturnInt' state.+rule10_primitiveLiteralApp :: StgState -> Maybe StgState+rule10_primitiveLiteralApp s@StgState { stgCode = Eval (AppF f []) locals }+    | Success (PrimInt k) <- val locals mempty (AtomVar f)++  = Just (s+        { stgCode = ReturnInt k+        , stgInfo = Info (StateTransition Rule10_LitApp)+                         (mkDetail_UnusedLocalVariables [f] locals) })++rule10_primitiveLiteralApp _ = Nothing++++-- | Rule 11: Primitive return, standard match found+--+-- Like 'rule4_case', but for primitives.+rule11_primitiveNormalMatch :: StgState -> Maybe StgState+rule11_primitiveNormalMatch s@StgState+    { stgCode  = ReturnInt k+    , stgStack = ReturnFrame alts locals :< stack' }+    | Success (AltMatches (PrimitiveAlt _k expr)) <-+        lookupPrimitiveAlt alts (Literal k)++  = Just (s+        { stgCode  = Eval expr locals+        , stgStack = stack'+        , stgInfo  = Info (StateTransition Rule11_ReturnInt_Match) [] })++rule11_primitiveNormalMatch _ = Nothing++++-- | Rule 12: Primitive return, bound default match+--+-- Similar to 'rule8_algebraicBoundDefaultMatch', but for primtives. Since the+-- bound variable is primitive, this rule is a bit sompler since we can store+-- the value directly in its binding, instead of allocating it on the heap and+-- storing the address.+rule12_primitiveBoundDefaultMatch :: StgState -> Maybe StgState+rule12_primitiveBoundDefaultMatch s@StgState+    { stgCode  = ReturnInt k+    , stgStack = ReturnFrame alts locals :< stack' }+    | Success (DefaultMatches (DefaultBound v expr)) <-+        lookupPrimitiveAlt alts (Literal k)++  = let locals' = addLocals [Mapping v (PrimInt k)] locals++    in Just ( s+        { stgCode  = Eval expr locals'+        , stgStack = stack'+        , stgInfo  = Info (StateTransition Rule12_ReturnInt_DefBound)+                          [Detail_ReturnIntDefBound v k] })++rule12_primitiveBoundDefaultMatch _ = Nothing++++-- | Rule 13: Primitive return, unbound default match+--+-- Like 'rule7_algebraicUnboundDefaultMatch', but for primitives.+rule13_primitiveUnboundDefaultMatch :: StgState -> Maybe StgState+rule13_primitiveUnboundDefaultMatch s@StgState+    { stgCode  = ReturnInt k+    , stgStack = ReturnFrame alts locals :< stack' }+    | Success (DefaultMatches (DefaultNotBound expr)) <-+        lookupPrimitiveAlt alts (Literal k)++  = Just (s+        { stgCode  = Eval expr locals+        , stgStack = stack'+        , stgInfo  = Info (StateTransition Rule13_ReturnInt_DefUnbound) [] })++rule13_primitiveUnboundDefaultMatch _ = Nothing++++-- | Rule 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.+--+-- This rule is shadowed by 'rule1819_casePrimopShortcut', which handles+-- primitive application more efficiently, without the need for an intermediate+-- 'ReturnInt' state.+rule14_primop :: StgState -> Maybe StgState+rule14_primop 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++  = Just (s+        { stgCode = ReturnInt result+        , stgInfo = Info (StateTransition Rule14_Eval_AppP)+                         (mkDetail_UnusedLocalVariables [var | AtomVar var <- [x,y]]+                                                        locals )})++rule14_primop _ = Nothing++++-- | Rule 15: Enter updatable closure+--+-- Evaluate the address pointed to, and store its future update in an+-- 'UpdateFrame'.+--+-- In theory this could just do what 'rule2_enterNonUpdatable' does, plus the+-- update frame. However, since lambda forms that take arguments never form+-- updatable closures, there is no need for 'ArgumentFrame' handling in this+-- rule.+rule15_enterUpdatable :: StgState -> Maybe StgState+rule15_enterUpdatable 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 (Mapping addr (Blackhole tick)) heap++    in Just ( s+        { stgCode  = Eval body locals+        , stgStack = stack'+        , stgHeap  = heap'+        , stgInfo  = Info (StateTransition Rule15_Enter_UpdatableClosure)+                          [Detail_EnterUpdatable addr] })++rule15_enterUpdatable _ = Nothing++++-- | Rule 16: Update because of missing 'ReturnFrame'+--+-- A 'ReturnCon' state requires a 'ReturnFrame' to continue, but there is an+-- 'UpdateFrame' in the way. The latter has to be eliminated by performing an+-- update with the returned constructor before attempting the return once more.+rule16_missingReturnUpdate :: StgState -> Maybe StgState+rule16_missingReturnUpdate 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 (Mapping addr (HClosure (Closure lf ws))) heap++    in Just (s+        { stgCode  = ReturnCon con ws+        , stgStack = stack'+        , stgHeap  = heap'+        , stgInfo  = Info (StateTransition Rule16_ReturnCon_Update)+                          [Detail_ConUpdate con addr] })++rule16_missingReturnUpdate _ = Nothing++++-- | 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 :: Stack StackFrame -> Maybe ([StackFrame], Stack StackFrame)+popArgsUntilUpdate withArgsStack+  = let (argFrames, argsPoppedStack) = S.span isArgFrame withArgsStack+    in Just ( filter isArgFrame (F.toList argFrames)+            , argsPoppedStack )++++-- | Rule 17: Enter partially applied closure, update because of missing+-- 'ArgumentFrame'+--+-- There are not enough 'ArgFrame's on the stack for a lambda's arguments,+-- because an update frame blocks access to more.+--+-- Although this rule is a bit simpler to understand compared to rule 17a, it is+-- hard to implement in a real STG compiler, since a new closure has to be made+-- up during runtime, which means runtime code generation. Rule 17a remedies+-- this problem. This rule (17) is included for comparison anyway.+rule17_missingArgUpdate :: StgState -> Maybe StgState+rule17_missingArgUpdate s@StgState+    { stgCode  = Enter addrEnter+    , stgStack = stack+    , stgHeap  = heap }+    | Just (HClosure (Closure (LambdaForm vs NoUpdate xs body) wsf))+        <- H.lookup addrEnter heap+    , Just (argFrames, UpdateFrame addrUpdate :< stack')+        <- popArgsUntilUpdate stack++  = let (xs1, xs2) = splitAt (length argFrames) xs+        updatedClosure =+            let freeVars = vs <> xs1+                freeVals = wsf <> [af | ArgumentFrame af <- argFrames]+            in Closure (LambdaForm freeVars NoUpdate xs2 body) freeVals++        heap' = H.update (Mapping addrUpdate (HClosure updatedClosure)) heap++    in Just (s+        { stgCode  = Enter addrEnter+        , stgStack = argFrames <>> stack'+        , stgHeap  = heap'+        , stgInfo  = Info (StateTransition Rule17_Enter_PartiallyAppliedUpdate)+                          [Detail_PapUpdate addrUpdate] })++rule17_missingArgUpdate _ = Nothing++++-- | Rule 17a: Enter partially applied closure, update because of missing+-- 'ArgumentFrame'+--+-- This is a better version of rule 17, since it does not neccessitate runtime+-- code generation. All required closures can be precompiled.+rule17a_missingArgUpdate :: StgState -> Maybe StgState+rule17a_missingArgUpdate 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)+        updatedClosure =+            let freeVars = f : xs1+                freeVals = zipWith const+                    (Addr addrEnter : F.foldMap (\(ArgumentFrame v) -> [v]) argFrames)+                    freeVars+            in Closure (LambdaForm freeVars NoUpdate [] fxs1) freeVals++        heap' = H.update (Mapping addrUpdate (HClosure updatedClosure)) heap++    in Just (s+        { stgCode  = Enter addrEnter+        , stgStack = argFrames <>> stack'+        , stgHeap  = heap'+        , stgInfo  = Info (StateTransition Rule17a_Enter_PartiallyAppliedUpdate)+                          [Detail_PapUpdate addrUpdate] })++rule17a_missingArgUpdate _ = Nothing++++-- | Rules 18, 19: Shortcut for evaluating/matching primops+--+-- This rule allows evaluating primops without the overhead of allocating an+-- intermediate return stack frame. In order to trigger, it must be applied with+-- higher precedence than 'rule4_case'.+--+-- When reading the source here for educational purposes, you should skip this+-- rule until you've seen the normal case rule ('rule4_case') and the normal primop+-- rule ('rule14_primop').+--+-- This rule has the slight modification compared to the paper in that it works+-- for both bound and unbound default cases.+rule1819_casePrimopShortcut :: StgState -> Maybe StgState+rule1819_casePrimopShortcut 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+    , Success altLookup <- lookupPrimitiveAlt alts (Literal opXY)++  = let (locals', expr) = case altLookup of+            DefaultMatches (DefaultBound pat e)+                -> (addLocals [Mapping pat (PrimInt opXY)] locals, e)+            DefaultMatches (DefaultNotBound e)+                -> (locals, e)+            AltMatches (PrimitiveAlt _opXY e)+                -> (locals, e)++    in Just (+        s { stgCode = Eval expr locals'+          , stgInfo = Info (StateTransition Rule1819_Eval_Case_Primop_Shortcut) [] })++rule1819_casePrimopShortcut _ = Nothing

@@ -1,5 +1,4 @@ {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE LambdaCase        #-}  -- | Remove unused heap objects. module Stg.Machine.GarbageCollection (@@ -22,6 +21,8 @@   +-- | Apply a garbage collection algorithm to the heap of the current machine+-- state, and return the resulting cleaned state. garbageCollect :: GarbageCollectionAlgorithm -> StgState -> StgState garbageCollect algorithm@(GarbageCollectionAlgorithm name _) state   = let (deadAddrs, forwards, state') = splitHeapWith algorithm state

@@ -31,10 +31,12 @@     -> (Set MemAddr, Map MemAddr MemAddr, StgState) splitHeapWith (GarbageCollectionAlgorithm _name gc) = gc +-- | A garbage collection algorithm is a specific way to get rid of unused heap+-- objects. data GarbageCollectionAlgorithm = GarbageCollectionAlgorithm     Text     (StgState -> (Set MemAddr, Map MemAddr MemAddr, StgState))-        -- ^ Dead addresses, moved addresses, new state+        -- ^ @<Algorithm name> (<state> -> (<dead addresses>, <moved addresses>, <new state>)@  -- | Collect all mentioned addresses in a machine element. --

@@ -1,5 +1,4 @@ {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE LambdaCase        #-} {-# LANGUAGE OverloadedStrings #-}  -- | Tri-state ("tri-colour") garbage collector.

@@ -32,7 +32,8 @@   --- | Remove all unused addresses by moving them to a safe location.+-- | Move all used addresses by moving them to a safe location, and delete the+-- leftovers. twoSpaceCopying :: GarbageCollectionAlgorithm twoSpaceCopying = GarbageCollectionAlgorithm     "Two-space copying"@@ -66,7 +67,7 @@      , toScavenge :: Seq MemAddr         -- ^ Heap objects already evacuated, but not yet scavenged. Contains-        -- only objects that are also in the 'toHeap'.+        -- only objects that are also in the @toHeap@.      , toEvacuate :: Seq MemAddr         -- ^ Heap objects known to be alive, but not yet evacuated.

@@ -1,6 +1,10 @@ {-# LANGUAGE DeriveGeneric              #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE InstanceSigs               #-} {-# LANGUAGE LambdaCase                 #-}+{-# LANGUAGE MultiParamTypeClasses      #-} {-# LANGUAGE MultiWayIf                 #-} {-# LANGUAGE OverloadedLists            #-} {-# LANGUAGE OverloadedStrings          #-}@@ -9,7 +13,7 @@ -- | Types used in the execution of the STG machine. module Stg.Machine.Types (     StgState(..),-    StgStateStyle(..),+    StgiAnn(..),     StackFrame(..),     MemAddr(..),     Value(..),@@ -34,18 +38,18 @@  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           Data.Map                  (Map)+import qualified Data.Map                  as M+import qualified Data.Semigroup            as Semigroup+import           Data.Set                  (Set)+import           Data.Text                 (Text)+import           Data.Text.Prettyprint.Doc import           GHC.Generics-import           Text.PrettyPrint.ANSI.Leijen hiding ((<>)) import           Text.Printf  import Data.Stack import Stg.Language+import Stg.Language.Prettyprint import Stg.Util  @@ -69,66 +73,38 @@         -- ^ The environment consisting of the top-level definitions.      , stgSteps :: !Integer-        -- ^ A counter, used to generte fresh variable names from.+        -- ^ A counter, used to generte fresh variable names and for orientation+        -- purposes.      , 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+-- | 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)) ])+instance PrettyStgi StgState where+    prettyStgi state = align (vsep+        [ annotate (StateAnn Headline) "Code:" <+> prettyStgi (stgCode state)+        , nest 4 (vsep [annotate (StateAnn Headline) "Stack", prettyStack (stgStack state) ])+        , nest 4 (vsep [annotate (StateAnn Headline) "Heap" <> " (" <> pretty (heapSize (stgHeap state)) <+> "entries)"+                       , prettyStgi (stgHeap state) ])+        , nest 4 (vsep [annotate (StateAnn Headline) "Globals", prettyStgi (stgGlobals state)])+        , nest 4 (annotate (StateAnn Headline) "Step:" <+> pretty (stgSteps state)) ])  -- | Prettyprint a 'Stack'.-prettyStack :: Pretty a => Stack a -> Doc+prettyStack :: PrettyStgi a => Stack a -> Doc StgiAnn prettyStack Empty = "(empty)" prettyStack stack = (align . vsep) prettyFrames   where     prettyFrame frame i = hsep-        [ headline style (int i <> ".")-        , align (pretty frame) ]+        [ annotate (StateAnn Headline) (pretty i <> ".")+        , align (prettyStgi frame) ]     prettyFrames = zipWith prettyFrame (toList stack) (reverse [1..length stack]) --- ^ A stack frame of the unified stack that includes arguments, returns, and--- updates.+-- | Stack frames unify arguments, returns, and updates. data StackFrame =       ArgumentFrame Value         -- ^ Argument frames store values on the argument stack, so that they@@ -147,32 +123,31 @@      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+instance PrettyStgi StackFrame where+    prettyStgi = \case+        ArgumentFrame val -> annotate (StateAnn StackFrameType) "Arg" <+> prettyStgi val+        ReturnFrame alts locals -> annotate (StateAnn StackFrameType) "Ret" <+>+            (align . vsep) [ fill 7 (annotate (StateAnn Headline) "Alts:")   <+> align (prettyStgi alts)+                           , fill 7 (annotate (StateAnn Headline) "Locals:") <+> align (prettyStgi locals) ]+        UpdateFrame addr -> annotate (StateAnn StackFrameType) "Upd" <+> prettyStgi 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))+instance PrettyStgi MemAddr where+    prettyStgi (MemAddr addr) = annotate (StateAnn Address) ("0x" <> annotate (StateAnn AddressCore) (hexAddr addr))       where-        hexAddr = text . printf "%02x"+        hexAddr = pretty . (printf "%02x" :: Int -> String)  -- | 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+instance PrettyStgi Value where+    prettyStgi = \case+        Addr addr -> prettyStgi addr+        PrimInt i -> prettyStgi (Literal i)  -- | The different code states the STG can be in. data Code =@@ -182,21 +157,21 @@           -- | Load the closure at a certain heap address         | Enter MemAddr -          -- | Sub-computation terminated with algebraic constructor+          -- | Sub-computation terminated with an algebraic 'Constr'uctor         | ReturnCon Constr [Value]            -- | Sub-computation terminated with a primitive integer         | ReturnInt Integer     deriving (Eq, Ord, Show, Generic) -instance Pretty Code where-    pretty = \case+instance PrettyStgi Code where+    prettyStgi = \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)+            [ "Eval" <+> prettyStgi expr+            , annotate (StateAnn Headline) "Locals:" <+> prettyStgi locals ]+        Enter addr -> "Enter" <+> prettyStgi addr+        ReturnCon constr args -> "ReturnCon" <+> prettyStgi constr <+> hsep (map prettyStgi args)+        ReturnInt i -> "ReturnInt" <+> prettyStgi (Literal i)  -- | A single key -> value association. --@@ -204,38 +179,38 @@ 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+instance (PrettyStgi k, PrettyStgi v) => PrettyStgi (Mapping k v) where+    prettyStgi (Mapping k v) = prettyStgi k <+> "->" <+> prettyStgi v  -- | Prettyprint a 'Map', @key -> value@.-prettyMap :: (Pretty k, Pretty v) => Map k v -> Doc+prettyMap :: (PrettyStgi k, PrettyStgi v) => Map k v -> Doc StgiAnn prettyMap m | M.null m = "(empty)"-prettyMap m = (align . vsep) [ pretty (Mapping k v) | (k,v) <- M.assocs m ]+prettyMap m = (align . vsep) [ prettyStgi (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)+    deriving (Eq, Ord, Show, Semigroup.Semigroup, Monoid, Generic) -instance Pretty Globals where-    pretty (Globals globals) = prettyMap globals+instance PrettyStgi Globals where+    prettyStgi (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)+    deriving (Eq, Ord, Show, Semigroup.Semigroup, Monoid, Generic) -instance Pretty Locals where-    pretty (Locals locals) = prettyMap locals+instance PrettyStgi Locals where+    prettyStgi (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]+instance PrettyStgi Info where+    prettyStgi = \case+        Info short []      -> prettyStgi short+        Info short details -> vsep [prettyStgi short, vsep (map prettyStgi details)]  -- | Short machine status info. This field may be used programmatically, in -- particular it tells the stepper whether the machine has halted.@@ -268,68 +243,70 @@       -- ^ A garbage collection step, in which no ordinary evaluation is done.     deriving (Eq, Ord, Show, Generic) -instance Pretty InfoShort where-    pretty = \case+instance PrettyStgi InfoShort where+    prettyStgi = \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+        StateError err    -> "Errorenous state:" <+> prettyStgi err+        StateTransition t -> prettyStgi t         StateInitial      -> "Initial state"         GarbageCollection -> "Garbage collection" +-- | Classifies which rule has been applied in order to reach the current state. 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+      Rule1_Eval_FunctionApplication+    | Rule2_Enter_NonUpdatableClosure+    | Rule3_Eval_Let Rec+    | Rule4_Eval_Case+    | Rule5_Eval_AppC+    | Rule6_ReturnCon_Match+    | Rule7_ReturnCon_DefUnbound+    | Rule8_ReturnCon_DefBound+    | Rule9_Lit+    | Rule10_LitApp+    | Rule11_ReturnInt_Match+    | Rule12_ReturnInt_DefBound+    | Rule13_ReturnInt_DefUnbound+    | Rule14_Eval_AppP+    | Rule15_Enter_UpdatableClosure+    | Rule16_ReturnCon_Update+    | Rule17_Enter_PartiallyAppliedUpdate+    | Rule17a_Enter_PartiallyAppliedUpdate+    | Rule1819_Eval_Case_Primop_Shortcut     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"+instance PrettyStgi StateTransition where+    prettyStgi = \case+        Rule1_Eval_FunctionApplication       -> "Function application"+        Rule2_Enter_NonUpdatableClosure      -> "Enter non-updatable closure"+        Rule3_Eval_Let NonRecursive          -> "Let evaluation"+        Rule3_Eval_Let Recursive             -> "Letrec evaluation"+        Rule4_Eval_Case                      -> "Case evaluation"+        Rule5_Eval_AppC                      -> "Constructor application"+        Rule6_ReturnCon_Match                -> "Algebraic constructor return, standard match"+        Rule7_ReturnCon_DefUnbound           -> "Algebraic constructor return, unbound default match"+        Rule8_ReturnCon_DefBound             -> "Algebraic constructor return, bound default match"+        Rule9_Lit                            -> "Literal evaluation"+        Rule10_LitApp                        -> "Literal application"+        Rule11_ReturnInt_Match               -> "Primitive constructor return, standard match found"+        Rule12_ReturnInt_DefBound            -> "Primitive constructor return, bound default match"+        Rule13_ReturnInt_DefUnbound          -> "Primitive constructor return, unbound default match"+        Rule14_Eval_AppP                     -> "Primitive function application"+        Rule15_Enter_UpdatableClosure        -> "Enter updatable closure"+        Rule16_ReturnCon_Update              -> "Update by constructor return"+        Rule17_Enter_PartiallyAppliedUpdate  -> "Enter partially applied closure"+        Rule17a_Enter_PartiallyAppliedUpdate -> "Enter partially applied closure"+        Rule1819_Eval_Case_Primop_Shortcut   -> "Case evaluation of primop: taking a shortcut" --- | Type safety wrapper.+-- | Type safety wrapper to report variables that were not in scope. newtype NotInScope = NotInScope [Var]-    deriving (Eq, Ord, Show, Generic, Monoid)+    deriving (Eq, Ord, Show, Generic, Semigroup.Semigroup, Monoid) -instance Pretty NotInScope where-    pretty (NotInScope vars) = commaSep (map pretty vars)+instance PrettyStgi NotInScope where+    prettyStgi (NotInScope vars) = commaSep (map prettyStgi vars) +-- | Like 'StateTransition', but for invalid transitions. data StateError =       VariablesNotInScope NotInScope     | UpdatableClosureWithArgs@@ -341,33 +318,48 @@     | UpdateClosureWithPrimitive     | NonAlgPrimScrutinee     | DivisionByZero-    | BadConArity Int Int+    | BadConArity Int Int -- ^ scrutinee arity, pattern arity     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"+instance PrettyStgi StateError where+    prettyStgi = \case+        VariablesNotInScope notInScope -> prettyStgi 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+++-- | Prettyprint an arity.+--+-- >>> let ppr = Data.Text.IO.putStrLn . Stg.Language.Prettyprint.renderPlain+-- >>> for_ [0..5] (ppr . pprArity)+-- nullary+-- unary+-- binary+-- ternary+-- 4-ary+-- 5-ary+pprArity :: Int -> Doc ann pprArity = \case     0 -> "nullary"     1 -> "unary"     2 -> "binary"     3 -> "ternary"-    n -> int n <> "-ary"+    n -> pretty n <> "-ary" +-- | Used to store meta-information about state transitions in order to be+-- rendered as a helpful hint. data InfoDetail =       Detail_FunctionApplication Var [Atom]     | Detail_UnusedLocalVariables [Var] Locals@@ -388,67 +380,75 @@     | Detail_BadConArity     deriving (Eq, Ord, Show, Generic) -instance Pretty InfoDetail where-    prettyList = vsep . map pretty-    pretty items = bulletList (case items of+-- | Prefix all contained documents with a bullet symbol.+bulletList :: [Doc ann] -> Doc ann+bulletList = align . vsep . map (("  - " <>) . align)++pluralS :: [a] -> Doc ann+pluralS [_] = "s"+pluralS _ = ""++instance PrettyStgi InfoDetail where+    prettyStgi :: InfoDetail -> Doc StgiAnn+    prettyStgi items = bulletList (case items of         Detail_FunctionApplication val [] ->-            ["Inspect value" <+> pretty val]+            ["Inspect value" <+> prettyStgi val]         Detail_FunctionApplication function args ->             [ "Apply function"-              <+> pretty function+              <+> prettyStgi function               <+> "to argument" <> pluralS args-              <+> commaSep (map pretty args) ]+              <+> commaSep (map prettyStgi 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 <> ")"]+                pprDiscardedBind var val = [prettyStgi var <+> "(" <> prettyStgi 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+            [ "Enter closure at" <+> prettyStgi addr             , if null args-                then pretty addr <+> "does not take any arguments, so no frames are popped"+                then prettyStgi 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) ])]+                        , commaSep (foldMap (\arg -> [prettyStgi arg]) args) ])]          Detail_EvalLet vars addrs ->             [ hsep                 [ "Local environment extended by"-                , commaSep (foldMap (\var -> [pretty var]) vars) ]+                , commaSep (foldMap (\var -> [prettyStgi var]) vars) ]             , hsep                 [ "Allocate new closure" <> pluralS vars <+> "at"-                , commaSep (zipWith (\var addr -> pretty addr <+> "(" <> pretty var <> ")") vars addrs)+                , commaSep (zipWith (\var addr -> prettyStgi addr <+> "(" <> prettyStgi 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"]+            ["Pattern" <+> prettyStgi (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) ]+            [ "Allocate closure at" <+> prettyStgi addr <+> "for the bound value"+            , "Extend local environment with" <+> prettyStgi (Mapping var addr) ]          Detail_ReturnIntDefBound var i ->-            [ "Extend local environment with" <+> pretty (Mapping var (PrimInt i)) ]+            [ "Extend local environment with" <+> prettyStgi (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" ]+            [ "Push a new update frame with the entered address" <+> prettyStgi addr+            , "Overwrite the heap object at" <+> prettyStgi 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"  ]+            [ "Trying to return" <+> prettyStgi con <> ", but there is no return frame on the top of the stack"+            , "Update closure at" <+> prettyStgi 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 ]+            , "Try to reveal more arguments by performing the update for" <+> prettyStgi updAddr ]          Detail_ReturnIntCannotUpdate ->             ["No closure has primitive type, so we cannot update one with a primitive int"]@@ -459,19 +459,19 @@             , "Please report this to the project maintainers!" ]          Detail_GarbageCollected algorithm deadAddrs movedAddrs -> mconcat-            [ [ "Algorithm: " <> string (T.unpack algorithm) ]+            [ [ "Algorithm: " <> pretty 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])+            pprAddrs = commaSep . foldMap (\addr -> [prettyStgi addr])             pluralES [_] = ""             pluralES _ = "es" -            pprMoved = commaSep . map (\(x, y) -> pretty (Mapping x y)) . M.assocs+            pprMoved = commaSep . map (\(x, y) -> prettyStgi (Mapping x y)) . M.assocs          Detail_EnterBlackHole addr tick ->-            [ "Heap address" <+> pretty addr <+> "is a black hole, created in step" <+> pretty tick+            [ "Heap address" <+> prettyStgi addr <+> "is a black hole, created in step" <+> pretty tick             , "Entering a black hole means a thunk depends on its own evaluation"             , "This is the functional equivalent of an infinite loop"             , "GHC reports this condition as \"<<loop>>\"" ]@@ -486,20 +486,22 @@ data Closure = Closure LambdaForm [Value]     deriving (Eq, Ord, Show, Generic) -instance Pretty Closure where-    pretty (Closure lambdaForm []) = pretty lambdaForm-    pretty (Closure lambda freeVals) =+instance PrettyStgi Closure where+    prettyStgi (Closure lambdaForm []) = prettyStgi lambdaForm+    prettyStgi (Closure lambda freeVals) =         prettyLambda prettyFree lambda       where-        prettyFree vars = commaSep (zipWith (\k v -> pretty (Mapping k v)) vars freeVals)+        prettyFree vars = commaSep (zipWith (\k v -> prettyStgi (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)+    deriving (Eq, Ord, Show, Generic, Semigroup.Semigroup, Monoid) -instance Pretty Heap where-    pretty (Heap heap) = prettyMap heap+instance PrettyStgi Heap where+    prettyStgi (Heap heap) = prettyMap heap +-- | Heap objects are what is stored on the heap. The most common and also most+-- important one are closures. data HeapObject =       HClosure Closure     | Blackhole Integer@@ -517,14 +519,14 @@         -- display purposes.     deriving (Eq, Ord, Show, Generic) -instance Pretty HeapObject where-    pretty ho = typeOf ho <+> pprHo ho+instance PrettyStgi HeapObject where+    prettyStgi 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)+            HClosure closure -> align (prettyStgi closure)+            Blackhole tick   -> "(from step" <+> pretty tick <> ")"+        typeOf = annotate (StateAnn ClosureType) . \case+            HClosure (Closure lf _free) -> prettyStgi (classify lf)             Blackhole _ -> "Blackhole"  instance NFData StgState@@ -533,7 +535,7 @@ 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` ()+    rnf (Mapping k v) = rnf (k,v) instance NFData Globals instance NFData Locals instance NFData Info

@@ -50,12 +50,14 @@      {-# MINIMAL fromStgAddr #-} +-- | Classifies the different errors that can happen when extracting a value+-- from an STG state. 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@+    | BadArity            -- ^ e.g. @Cons x y z@     | NotFound NotInScope -- ^ An unsuccessful variable lookup     | AddrNotOnHeap     | NoConstructorMatch  -- ^ None of the given alternatives matched the given@@ -68,8 +70,7 @@ -- Slighly bent version of 'Env.globalVal' to fit the types in this module -- better. globalVal-    :: FromStg value-    => StgState+    :: StgState     -> (Value -> Either FromStgError value) -- ^ What to do with the value if found     -> Var                                  -- ^ Name of the global value to inspect     -> Either FromStgError value@@ -99,11 +100,10 @@ -- | Inspect whether a closure at a certain memory address matches the desired -- criteria. inspect-    :: FromStg value-    => StgState+    :: 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.+        -- 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@@ -118,7 +118,6 @@     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 ->@@ -129,7 +128,7 @@         [ True  <$ matchCon0 "True"  closure         , False <$ matchCon0 "False" closure ]) --- | Boxed (@Int\# 1\#@) or unboxed (@1#@)+-- | Works for both boxed (@Int\# 1\#@) and unboxed (@1#@) integers. instance FromStg Integer where     fromStg stgState var = case Env.globalVal (stgGlobals stgState) (AtomVar var) of         Failure _ -> Left (NotFound (NotInScope [var]))@@ -196,7 +195,7 @@ liftToMatcher :: Either e a -> Either (Maybe e) a liftToMatcher = first Just --- | Like 'matchCon2', but for nullary 'Constr'uctors.+-- | Like @matchCon2@, but for nullary 'Constr'uctors. matchCon0 :: Constr -> Closure -> Either (Maybe FromStgError) () matchCon0 _ (Closure lambdaForm _)     | classify lambdaForm == LambdaThunk = Left (Just (IsWrongLambdaType LambdaThunk))@@ -207,7 +206,7 @@         _xs -> Left (Just BadArity) matchCon0 _ _ = Left Nothing --- | Like 'matchCon2', but for unary 'Constr'uctors.+-- | 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))@@ -236,7 +235,7 @@         _xs   -> Left (Just BadArity) matchCon2 _ _ = Left Nothing --- | Like 'matchCon2', but for ternary 'Constr'uctors.+-- | 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))@@ -247,7 +246,7 @@         _xs     -> Left (Just BadArity) matchCon3 _ _ = Left Nothing --- | Like 'matchCon2', but for 4-ary 'Constr'uctors.+-- | 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))@@ -258,7 +257,7 @@         _xs       -> Left (Just BadArity) matchCon4 _ _ = Left Nothing --- | Like 'matchCon2', but for 5-ary 'Constr'uctors.+-- | 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))

@@ -1,4 +1,3 @@-{-# LANGUAGE LambdaCase        #-} {-# LANGUAGE OverloadedLists   #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes       #-}@@ -27,7 +26,8 @@  -- $setup -- >>> :set -XOverloadedStrings--- >>> let ppr = Data.Text.IO.putStrLn . Stg.Language.Prettyprint.prettyprintPlain+-- >>> import Stg.Language.Prettyprint+-- >>> let ppr = Data.Text.IO.putStrLn . Stg.Language.Prettyprint.renderPlain . prettyStgi   @@ -153,8 +153,8 @@     toStgWithGlobals name dataValues = do         tell Stg.nil         case dataValues of-            (x:xs) -> do-                (Just inExpression, letBindings)+            x:xs -> do+                (inExpression, letBindings)                     <- mkListBinds Nothing (NonEmpty.zip [0..] (x :| xs))                 let rec = if null xs then NonRecursive else Recursive                 pure (Program (Binds [(name, LambdaForm [] Update []@@ -171,7 +171,7 @@                           -- 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)+            -> Writer Program (Expr, Binds)         mkListBinds inExpression ((i, value) :| rest) = do              let valueVar = Var (genPrefix <> show' i <> "_value")@@ -190,10 +190,10 @@                             consExpr )                     consExpr = AppC (Constr "Cons") (map AtomVar [valueVar, nextConsVar]) -                    inExpression' = inExpression <|> Just consExpr+                    Just inExpression' = inExpression <|> Just consExpr                  recursiveBinds <- case rest of-                    (i',v') : isvs -> fmap snd (mkListBinds inExpression' ((i',v') :| isvs))+                    (i',v') : isvs -> fmap snd (mkListBinds (Just inExpression') ((i',v') :| isvs))                     _nil           -> pure mempty                  pure (inExpression', consBind <> recursiveBinds)

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP                        #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase                 #-} {-# LANGUAGE OverloadedLists            #-}@@ -70,11 +71,11 @@ 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+    Failure ErrInfo{ _errDoc = e } -> Left e  -- | Skip a certain token. Useful to consume, but not otherwise use, certain -- tokens.-skipToken :: TokenParsing parser => parser a -> parser ()+skipToken :: StgParser a -> StgParser () skipToken = void . token  -- | A parser for an STG syntax element.@@ -85,7 +86,7 @@     someSpace = skipMany (void (satisfy isSpace) <|> comment)  -- | Syntax rules for parsing variable-looking like identifiers.-varId :: TokenParsing parser => IdentifierStyle parser+varId :: IdentifierStyle StgParser varId = IdentifierStyle     { _styleName = "variable"     , _styleStart = lower <|> char '_'@@ -96,17 +97,17 @@  -- | 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 :: StgParser Var var = ident varId  -- | Skip a reserved variable identifier.-reserved :: (Monad parser, TokenParsing parser) => Text -> parser ()+reserved :: Text -> StgParser () 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 :: StgParser Constr con = highlight Constructor constructor <?> "constructor"   where     constructor = token (do@@ -116,18 +117,18 @@         (pure . Constr . T.pack) (start : body <> end) )  -- | Parse an STG program.-program :: (Monad parser, TokenParsing parser) => parser Program+program :: StgParser 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 :: StgParser 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 :: StgParser () comment = skipToken (highlight Comment (lineComment <|> blockComment)) <?> ""   where     lineComment  = try (symbol "--") *> manyTill anyChar (char '\n')@@ -135,10 +136,10 @@  -- | 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 :: StgParser LambdaForm lambdaForm = lf >>= validateLambda <?> "lambda form"   where-    lf :: (Monad parser, TokenParsing parser) => parser LambdaForm+    lf :: StgParser LambdaForm     lf = (\free bound upd body -> LambdaForm free upd bound body)          <$  token (char '\\')          <*> (parens (some var) <|> pure [])@@ -148,25 +149,23 @@      validateLambda = \case         LambdaForm _ Update [] AppC{} ->-           fail "Standard constructors are never updatable"+            fail "Standard constructors are never updatable (\"=>\" instead of \"->\")"         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#)"+            fail "Lambda forms with non-empty argument lists are never updatable (\"=>\" instead of \"->\")"+        LambdaForm _ _ _ LitE{} ->+            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"+            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 :: StgParser UpdateFlag     updateArrow = token (symbol "->" *> pure NoUpdate                      <|> symbol "=>" *> pure Update                      <?> "update arrow" )  -- | Parse an arrow token, @->@.-arrow :: TokenParsing parser => parser ()+arrow :: StgParser () arrow = skipToken (symbol "->")  -- | Parse an expression, which can be@@ -177,12 +176,10 @@ --   * constructor application, @C (...)@ --   * primitive application, @p# (...)@ --   * literal, @1#@-expr :: (Monad parser, TokenParsing parser) => parser Expr+expr :: StgParser Expr expr = choice [let', case', appF, appC, appP, lit] <?> "expression"   where-    let', case', appF, appC, appP, lit-        :: (Monad parser, TokenParsing parser)-        => parser Expr+    let', case', appF, appC, appP, lit :: StgParser Expr      let' = Let         <$> (Recursive <$ reserved "letrec" <|> NonRecursive <$ reserved "let")@@ -199,16 +196,17 @@     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"+    lit = LitE <$> literal <?> "literal expression"  -- | Parse the alternatives given in a @case@ expression.-alts :: (Monad parser, TokenParsing parser) => parser Alts+alts :: StgParser Alts alts = Alts        <$> nonDefaultAlts        <*> defaultAlt        <?> "case alternatives" -atom :: (Monad parser, TokenParsing parser) => parser Atom+-- | Parse an atom+atom :: StgParser Atom atom = AtomVar <$> var    <|> AtomLit <$> literal    <?> "atom (variable or literal)"@@ -218,7 +216,7 @@ -- @ -- +# -- @-primOp :: TokenParsing parser => parser PrimOp+primOp :: StgParser PrimOp primOp = choice ops <?> "primitive function"   where     ops = [ "+"  ~> Add@@ -234,7 +232,13 @@           , ">"  ~> Gt ]     op ~> val = token (try (string op <* char '#')) *> pure val -literal :: TokenParsing parser => parser Literal+-- | Parse an integer literal+--+-- @+-- 1#+-- -123#+-- @+literal :: StgParser Literal literal = token (Literal <$> integer' <* char '#') <?> "integer literal"  -- | Parse non-default alternatives. The list of alternatives can be either@@ -249,7 +253,7 @@ -- 1# -> ... -- 2# -> ... -- @-nonDefaultAlts :: (Monad parser, TokenParsing parser) => parser NonDefaultAlts+nonDefaultAlts :: StgParser NonDefaultAlts nonDefaultAlts = AlgebraicAlts . NonEmpty.fromList <$> some algebraicAlt              <|> PrimitiveAlts . NonEmpty.fromList <$> some primitiveAlt              <|> pure NoNonDefaultAlts@@ -260,7 +264,7 @@ -- @ -- Cons x xs -> ... -- @-algebraicAlt :: (Monad parser, TokenParsing parser) => parser AlgebraicAlt+algebraicAlt :: StgParser AlgebraicAlt algebraicAlt = try (AlgebraicAlt <$> con)            <*> (many var >>= disallowDuplicates)            <*  arrow@@ -283,7 +287,7 @@ -- @ -- 1# -> ... -- @-primitiveAlt :: (Monad parser, TokenParsing parser) => parser PrimitiveAlt+primitiveAlt :: StgParser PrimitiveAlt primitiveAlt = try (PrimitiveAlt <$> literal) <* arrow <*> expr <* semi     <?> "primitive case alternative" @@ -297,7 +301,7 @@ -- @ -- v -> ... -- @-defaultAlt :: (Monad parser, TokenParsing parser) => parser DefaultAlt+defaultAlt :: StgParser DefaultAlt defaultAlt = DefaultNotBound <$ reserved "default" <* arrow <*> expr          <|> DefaultBound <$> var <* arrow <*> expr          <?> "default alternative"

@@ -95,7 +95,7 @@     -- 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)))+        Left err -> Left (prettyprintOldAnsi ("  -" <+> text (T.unpack parserName) <> ":" <+> plain (align err)))         Right r -> Right r )  -- | Build a quasiquoter from a 'Parser'.@@ -107,7 +107,7 @@ 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)))+        Left err  -> fail (T.unpack ("Invalid STG " <> elementName <> ":\n" <> prettyprintOldAnsi (plain err)))         Right ast -> [| ast |]  -- | Quasiquoter for 'Stg.Language.Program's.

@@ -1,81 +1,19 @@ {-# 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".+-- This module should be imported qualified to avoid clashes with standard+-- Haskell definitions. module Stg.Prelude (-    -- * Maybe-    maybe,-    nothing,--    -- * Lists-    nil,-    concat2,-    reverse,-    foldl,-    foldl',-    foldr,-    iterate,-    cycle,-    take,-    filter,-    partition,-    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,+    module Stg.Prelude,+    module Stg.Prelude.Bool,+    module Stg.Prelude.Function,+    module Stg.Prelude.List,+    module Stg.Prelude.Maybe,+    module Stg.Prelude.Number,+    module Stg.Prelude.Tuple, ) where  @@ -90,6 +28,11 @@ import Stg.Prelude.Maybe import Stg.Prelude.Number import Stg.Prelude.Tuple++{-# ANN module "HLint: ignore Use import/export shortcut" #-}+    -- Haddock doesn't like this trick :-/++  -- | Force a value to normal form and return it. --

@@ -2,6 +2,9 @@ {-# LANGUAGE QuasiQuotes     #-}  -- | Boolean functions, like in "Data.Bool".+--+-- This module should be imported qualified to avoid clashes with standard+-- Haskell definitions. module Stg.Prelude.Bool (     and2,     or2,

@@ -1,5 +1,9 @@ {-# LANGUAGE QuasiQuotes #-} +-- | Definitions found in Haskell's "Data.Function".+--+-- This module should be imported qualified to avoid clashes with standard+-- Haskell definitions. module Stg.Prelude.Function (     seq,     id,

@@ -1,7 +1,10 @@-{-# LANGUAGE OverloadedLists   #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes       #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE QuasiQuotes     #-} +-- | Definitions found in Haskell's "Data.List".+--+-- This module should be imported qualified to avoid clashes with standard+-- Haskell definitions. module Stg.Prelude.List (     nil,     concat2,@@ -197,6 +200,15 @@         badList -> Error_filter_2 badList     |] +-- | Separate a list into parts that do and do not satisfy a predicate.+--+-- @+-- partition even [1..6] = ([2,4,6], [1,3,5])+-- @+--+-- @+-- partition : (a -> Bool) -> [a] -> ([a], [a])+-- @ partition = nil <> [program|     partition = \p xs -> case xs of         Nil -> Pair nil nil;@@ -496,9 +508,9 @@ forceSpine = [program|     forceSpine = \xs ->         letrec-            go = \(go) ys -> case ys of+            force = \(force) ys -> case ys of                 Nil        -> Done;-                Cons _ ys' -> go ys';+                Cons _ ys' -> force ys';                 badList    -> Error_forceSpine badList-        in case go xs of _ -> xs+        in case force xs of default -> xs     |]

@@ -1,7 +1,10 @@-{-# LANGUAGE OverloadedLists   #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes       #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE QuasiQuotes     #-} +-- | Functions as found in Haskell's "Data.Maybe" module.+--+-- This module should be imported qualified to avoid clashes with standard+-- Haskell definitions. module Stg.Prelude.Maybe (     nothing,     maybe,

@@ -2,6 +2,10 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes       #-} +-- | Operations on boxed integers.+--+-- This module should be imported qualified to avoid clashes with standard+-- Haskell definitions. module Stg.Prelude.Number (     -- * Arithmetic     add,@@ -60,22 +64,22 @@  eq_Int, lt_Int, leq_Int, gt_Int, geq_Int, neq_Int :: Program --- |-eq_Int  = binaryOp "eq_Int"  Eq  primToBool+-- | Equality of boxed integers+eq_Int = binaryOp "eq_Int" Eq primToBool --- |-lt_Int  = binaryOp "lt_Int"  Lt  primToBool+-- | Less-than for boxed integers+lt_Int = binaryOp "lt_Int" Lt primToBool --- |+-- | Less-or-equal for boxed integers leq_Int = binaryOp "leq_Int" Leq primToBool --- |-gt_Int  = binaryOp "gt_Int"  Gt  primToBool+-- | Greater-than for boxed integers+gt_Int = binaryOp "gt_Int" Gt primToBool --- |+-- | Greater-or-equal for boxed integers geq_Int = binaryOp "geq_Int" Geq primToBool --- |+-- | Inequality of boxed integers neq_Int = binaryOp "neq_Int" Neq primToBool  @@ -85,21 +89,22 @@  add, sub, mul, div, mod :: Program --- |+-- | Binary addition of boxed integers add = binaryOp "add" Add primIdInt --- |+-- | Difference of boxed integers sub = binaryOp "sub" Sub primIdInt --- |+-- | Binary multiplication of boxed integers mul = binaryOp "mul" Mul primIdInt --- |+-- | Boxed integer division div = binaryOp "div" Div primIdInt --- |+-- | Boxed integer modulo operator mod = binaryOp "mod" Mod primIdInt +-- | Minimum of two boxed integers min :: Program min = [program|     min = \x y -> case x of@@ -111,6 +116,7 @@         badInt -> Error_min badInt     |] +-- | Maximum of two boxed integers max :: Program max = [program|     max = \x y -> case x of

@@ -1,7 +1,10 @@-{-# LANGUAGE OverloadedLists   #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes       #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE QuasiQuotes     #-} +-- | Definitions found in Haskell's "Data.Tuple".+--+-- This module should be imported qualified to avoid clashes with standard+-- Haskell definitions. module Stg.Prelude.Tuple (     fst,     snd,@@ -87,7 +90,7 @@             Pair a b -> Pair b a;             badPair  -> Error_snd badPair |] -+-- | Equality of pairs of boxed integers. equals_Pair_Int = eq_Int <> [program|     eq_Pair_Int = \tup1 tup2 ->         case tup1 of

@@ -0,0 +1,90 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase        #-}++-- | Extract Haskell values from running STG programs.+module Stg.StaticAnalysis (+    FreeVariables (..),+) where++++import           Data.Map    as M+import           Data.Monoid+import           Data.Set    (Set)+import qualified Data.Set    as S++import Stg.Language++++-- Difference operator, akin to 'Monoid's '<>'.+(-<>) :: Ord a => Set a -> Set a -> Set a+(-<>) = S.difference+infix 6 -<> -- 6 like <>++-- | Overloading class for determining the free variables of an object.+class FreeVariables ast where+    freeVariables :: ast -> Set Var++instance (Foldable f, FreeVariables a) => FreeVariables (f a) where+    freeVariables = foldMap freeVariables++instance FreeVariables Program where+    freeVariables (Program prog) = freeVariables prog++instance FreeVariables Binds where+    freeVariables (Binds bs) = freeVariables bs++-- All the variables bound in a set of bindings.+bindNames :: Binds -> Set Var+bindNames (Binds bs) = M.keysSet bs++instance FreeVariables Expr where+    freeVariables = \case+        Let _rec binds expr -> (freeVariables expr -<> bindNames binds)+                                <> freeVariables binds+        Case expr alts      -> freeVariables expr <> freeVariables alts+        AppF f args         -> freeVariables f    <> freeVariables args+        AppC _con args      -> freeVariables args+        AppP _op arg1 arg2  -> freeVariables arg1 <> freeVariables arg2+        LitE lit            -> freeVariables lit++-- | Only takes into account the explicit free variable list of the lambda. This+-- means that globals, which are not explicitly free, will not be considered+-- free variables.+instance FreeVariables LambdaForm where+    freeVariables (LambdaForm frees _upd _bound _expr) = S.fromList frees++instance FreeVariables Alts where+    freeVariables (Alts nonDefaultAlt defaultAlt)+      = freeVariables nonDefaultAlt <> freeVariables defaultAlt++instance FreeVariables NonDefaultAlts where+    freeVariables = \case+        NoNonDefaultAlts   -> mempty+        AlgebraicAlts alts -> freeVariables alts+        PrimitiveAlts alts -> freeVariables alts++instance FreeVariables AlgebraicAlt where+    freeVariables (AlgebraicAlt _con patVars expr)+      = freeVariables expr -<> freeVariables patVars++instance FreeVariables PrimitiveAlt where+    freeVariables (PrimitiveAlt lit expr)+      = freeVariables lit <> freeVariables expr++instance FreeVariables DefaultAlt where+    freeVariables = \case+        DefaultNotBound expr  -> freeVariables expr+        DefaultBound var expr -> freeVariables expr -<> freeVariables var++instance FreeVariables Var where+    freeVariables var = S.singleton var++instance FreeVariables Literal where+    freeVariables _lit = mempty++instance FreeVariables Atom where+    freeVariables = \case+        AtomVar var -> freeVariables var+        AtomLit lit -> freeVariables lit

@@ -1,5 +1,3 @@-{-# LANGUAGE OverloadedStrings #-}- -- | Useful utilities that don't really fit in a specific location. module Stg.Util (     show',@@ -7,17 +5,14 @@      -- * 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 ((<>))+import           Data.Text                 (Text)+import qualified Data.Text                 as T+import           Data.Text.Prettyprint.Doc   @@ -50,18 +45,9 @@     pure = Success     Success f <*> Success x = Success (f x)     Success _ <*> Failure x = Failure x-    Failure x <*> Failure y = Failure (x <> y)+    Failure x <*> Failure y = Failure (x `mappend` y)     Failure x <*> Success _ = Failure x  -- | @[a,b,c]  ==>  a, b, c@-commaSep :: [Doc] -> Doc+commaSep :: [Doc ann] -> Doc ann 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"

@@ -1,35 +1,5 @@-# 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+resolver: lts-9.12 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

@@ -1,5 +1,5 @@ name:                stgi-version:             1.0.1+version:             1.1 synopsis:            Educational implementation of the STG (Spineless Tagless                      G-machine) description:         STGi is a visual STG implementation to help understand@@ -23,7 +23,7 @@ category:            Development build-type:          Simple extra-source-files:  .stylish-haskell.yaml-                   , HLint.hs+                   , .hlint.yaml                    , LICENSE.md                    , README.md                    , screenshot.png@@ -45,6 +45,9 @@                      , Stg.Machine                      , Stg.Machine.Env                      , Stg.Machine.Evaluate+                     , Stg.Machine.Evaluate.ErrorTransitions+                     , Stg.Machine.Evaluate.Common+                     , Stg.Machine.Evaluate.ValidTransitions                      , Stg.Machine.GarbageCollection                      , Stg.Machine.GarbageCollection.Common                      , Stg.Machine.GarbageCollection.TriStateTracing@@ -63,20 +66,24 @@                      , Stg.Prelude.Maybe                      , Stg.Prelude.Number                      , Stg.Prelude.Tuple+                     , Stg.StaticAnalysis                      , Stg.Util   ghc-options:         -Wall   build-depends:       base >= 4.8 && < 5                      , ansi-wl-pprint+                     , prettyprinter >= 1+                     , prettyprinter-ansi-terminal >= 1                      , containers       >= 0.5                      , deepseq          >= 1.4                      , parsers          >= 0.12-                     , semigroups       >= 0.18+                     , semigroups       >= 0.16                      , template-haskell >= 2.10                      , text             >= 1.2                      , th-lift          >= 0.7                      , transformers     >= 0.4-                     , trifecta         >= 1.5-  other-extensions:    DeriveGeneric+                     , trifecta         >= 1.6+  other-extensions:    CPP+                     , DeriveGeneric                      , FlexibleInstances                      , GeneralizedNewtypeDeriving                      , LambdaCase@@ -110,6 +117,7 @@   main-is:             Main.hs   other-modules:       Test.Language                      , Test.Language.Prettyprint+                     , Test.ExamplePrograms                      , Test.Machine                      , Test.Machine.Evaluate                      , Test.Machine.Evaluate.Errors@@ -136,14 +144,16 @@                      , Test.Prelude.Number                      , Test.Prelude.Tuple                      , Test.Stack+                     , Test.StaticAnalysis                      , Test.Util                      , Test.UtilTH   build-depends:       base                      , stgi                      , ansi-wl-pprint+                     , prettyprinter >= 1                      , containers >= 0.5                      , deepseq >= 1.4-                     , semigroups >= 0.18+                     , semigroups >= 0.16                      , tasty                      , tasty-html                      , tasty-hunit

@@ -12,12 +12,14 @@ 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+import qualified Test.ExamplePrograms as ExamplePrograms+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+import qualified Test.StaticAnalysis  as StaticAnalysis   @@ -44,14 +46,15 @@     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+    [ ExamplePrograms.tests+    , Language.tests     , Machine.tests     , Marshal.tests-    , Language.tests-    , Prelude.tests ]+    , Parser.tests+    , Prelude.tests+    , Stack.tests+    , StaticAnalysis.tests ]

@@ -0,0 +1,184 @@+{-# LANGUAGE BangPatterns        #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Test.ExamplePrograms (tests) where++++import qualified Data.List as L++import Stg.ExamplePrograms+import Stg.Machine.Types++import qualified Test.Machine.Evaluate.TestTemplates.MachineState    as MST+import           Test.Machine.Evaluate.TestTemplates.MarshalledValue+import           Test.Orphans                                        ()+import           Test.QuickCheck.Modifiers+import           Test.Tasty++++tests :: TestTree+tests = testGroup "Example programs"+    [ testGroup "Simple examples"+        [testImplies+        , testAddTwoNumbers+        , testCalculateLength ]+    , testGroup "map"+        [ testMapNot+        , testMapNotForced ]+    , testGroup "Sum using folds"+        [ testSumFoldl'+        , testSumFoldl+        , testSumFoldl'ViaFoldr+        , testSumFoldr ]+    , testGroup "Fibonacci"+        [ testFibonacciNaive+        , testFibonacciImproved+        , testFibonacciZipWith ]+    , testGroup "Concatenation"+        [ testListConcatLeftAssociated+        , testListConcatRightAssociated ]+    , testGroup "Sorting"+        [ testNaiveSort+        , testLibrarySort ]+    ]++++testImplies :: TestTree+testImplies = marshalledValueTest defSpec+    { testName = "Implication"+    , sourceSpec = \(x,y) -> MarshalSourceSpec+        { resultVar = "main"+        , expectedValue = x <= y+        , source = implies x y }}++testAddTwoNumbers :: TestTree+testAddTwoNumbers = marshalledValueTest defSpec+    { testName = "Add two numbers"+    , sourceSpec = \(x,y) -> MarshalSourceSpec+        { resultVar = "main"+        , expectedValue = x+y+        , source = addTwoNumbers x y }}++testCalculateLength :: TestTree+testCalculateLength = marshalledValueTest defSpec+    { testName = "Length of a list"+    , sourceSpec = \(xs :: [Integer]) -> MarshalSourceSpec+        { resultVar = "main"+        , expectedValue = fromIntegral (length xs) :: Integer+        , source = calculateLength xs }}++testMapNot :: TestTree+testMapNot = MST.machineStateTest MST.defSpec+    { MST.testName = "map not, not forced"+    , MST.successPredicate = \state -> case stgInfo state of+        Info short _long -> short == NoRulesApply+    , MST.source = mapNot [True, False, True]+    , MST.maxSteps = 20}++testMapNotForced :: TestTree+testMapNotForced = marshalledValueTest defSpec+    { testName = "map not, forced"+    , sourceSpec = \xs -> MarshalSourceSpec+        { resultVar = "main"+        , expectedValue = map not xs+        , source = mapNotForced xs }}++testSumFoldl' :: TestTree+testSumFoldl' = marshalledValueTest defSpec+    { testName = "Sum via foldl'"+    , sourceSpec = \xs -> MarshalSourceSpec+        { resultVar = "main"+        , expectedValue = sum xs :: Integer+        , source = sum_foldl' xs }}++testSumFoldl :: TestTree+testSumFoldl = marshalledValueTest defSpec+    { testName = "Sum via foldl"+    , sourceSpec = \xs -> MarshalSourceSpec+        { resultVar = "main"+        , expectedValue = sum xs :: Integer+        , source = sum_foldl xs }}++testSumFoldl'ViaFoldr :: TestTree+testSumFoldl'ViaFoldr = marshalledValueTest defSpec+    { testName = "Sum via foldl' implemented with foldr"+    , sourceSpec = \xs -> MarshalSourceSpec+        { resultVar = "main"+        , expectedValue = sum xs :: Integer+        , source = sum_foldl'ViaFoldr xs }}++testSumFoldr :: TestTree+testSumFoldr = marshalledValueTest defSpec+    { testName = "Sum via foldr"+    , sourceSpec = \xs -> MarshalSourceSpec+        { resultVar = "main"+        , expectedValue = sum xs :: Integer+        , source = sum_foldr xs }}++fibo :: Integer -> Integer+fibo = fibo' 0 1+  where+    fibo' !a !_b n | n <= 0 = a+    fibo'  a   b n = fibo' b (a+b) (n-1)++testFibonacciNaive :: TestTree+testFibonacciNaive = marshalledValueTest defSpec+    { testName = "Naive Fibonacci"+    , sourceSpec = \(NonNegative n) ->+        let smallerN = mod n 16+        in MarshalSourceSpec+            { resultVar = "main"+            , expectedValue = fibo smallerN+            , source = fibonacciNaive smallerN }}++testFibonacciImproved :: TestTree+testFibonacciImproved = marshalledValueTest defSpec+    { testName = "Improved linear Fibonacci"+    , sourceSpec = \(NonNegative n) -> MarshalSourceSpec+        { resultVar = "main"+        , expectedValue = fibo n+        , source = fibonacciImproved n }}++testFibonacciZipWith :: TestTree+testFibonacciZipWith = MST.machineStateTest MST.defSpec+    { MST.testName = "Fibonacci via zipWith"+    , MST.successPredicate = \state -> case stgCode state of+        ReturnCon "Int#" [PrimInt n] -> n == fibo 10+        _otherwise  -> False+    , MST.source = fibonacciZipWith }++testListConcatLeftAssociated :: TestTree+testListConcatLeftAssociated = marshalledValueTest defSpec+    { testName = "List concatenation, left-associated"+    , sourceSpec = \xss -> MarshalSourceSpec+        { resultVar = "main"+        , expectedValue = concat xss :: [Integer]+        , source = listConcatLeftAssociated xss }}++testListConcatRightAssociated :: TestTree+testListConcatRightAssociated = marshalledValueTest defSpec+    { testName = "List concatenation, right-associated"+    , sourceSpec = \xss -> MarshalSourceSpec+        { resultVar = "main"+        , expectedValue = concat xss :: [Integer]+        , source = listConcatRightAssociated xss }}++testNaiveSort :: TestTree+testNaiveSort = marshalledValueTest defSpec+    { testName = "Sort using naive Quicksort-inspired algorithm"+    , sourceSpec = \xs -> MarshalSourceSpec+        { resultVar = "main"+        , expectedValue = L.sort xs :: [Integer]+        , source = naiveSort xs }}++testLibrarySort :: TestTree+testLibrarySort = marshalledValueTest defSpec+    { testName = "Sort using the standard Haskell list sort"+    , sourceSpec = \xs -> MarshalSourceSpec+        { resultVar = "main"+        , expectedValue = L.sort xs :: [Integer]+        , source = librarySort xs }}

@@ -35,7 +35,7 @@         , inverseOfParserQC "Atom"              Parser.atom ])  inverseOfParserQC-    :: (Arbitrary ast, Show ast, Eq ast, Pretty ast)+    :: (Arbitrary ast, Show ast, Eq ast, PrettyStgi ast)     => Text     -> StgParser ast     -> TestTree@@ -50,7 +50,7 @@                                (inputAst == parsedAst) )  inverseOfParserSC-    :: (Serial IO ast, Show ast, Eq ast, Pretty ast)+    :: (Serial IO ast, Show ast, Eq ast, PrettyStgi ast)     => Text     -> StgParser ast     -> TestTree@@ -64,22 +64,22 @@                 | otherwise -> Left (T.unpack (prettySuccess inputAst parsedAst)) ))  parserRoundtrip-    :: Pretty ast+    :: PrettyStgi ast     => StgParser ast     -> ast     -> Either Text ast-parserRoundtrip parser = first prettyprintPlain . parse parser . prettyprintPlain+parserRoundtrip parser = first prettyprintOldAnsi . parse parser . renderPlain . prettyStgi -prettySuccess :: Pretty ast => ast -> ast -> Text+prettySuccess :: PrettyStgi ast => ast -> ast -> Text prettySuccess inputAst parsedAst =     T.unlines [ "Input AST:"-              , prettyprintPlain inputAst+              , renderPlain (prettyStgi inputAst)               , "Parsed, parser inverse printed AST:"-              , prettyprintPlain parsedAst ]+              , renderPlain (prettyStgi parsedAst) ] -prettyFailure :: Pretty ast => ast -> Text -> Text+prettyFailure :: PrettyStgi ast => ast -> Text -> Text prettyFailure inputAst err =     T.unlines [ "Input AST:"-              , prettyprintPlain inputAst+              , renderPlain (prettyStgi inputAst)               , "Parse error:"               , err ]

@@ -1,4 +1,3 @@-{-# LANGUAGE NumDecimals       #-} {-# LANGUAGE OverloadedStrings #-}  module Test.Machine.Evaluate (tests) where

@@ -1,4 +1,3 @@-{-# LANGUAGE NumDecimals       #-} {-# LANGUAGE OverloadedLists   #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes       #-}

@@ -1,5 +1,4 @@ {-# LANGUAGE BangPatterns      #-}-{-# LANGUAGE NumDecimals       #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes       #-} @@ -90,7 +89,6 @@     { testName = "Fibonacci sequence"     , successPredicate = "main" `hasValue` take numFibos fibo     , maxSteps = 10000-    , failWithInfo = True     , source = mconcat         [ toStg "zero" (0 :: Int)         , toStg "one" (1 :: Int)

@@ -1,5 +1,4 @@ {-# LANGUAGE LambdaCase          #-}-{-# LANGUAGE NumDecimals         #-} {-# LANGUAGE OverloadedLists     #-} {-# LANGUAGE OverloadedStrings   #-} {-# LANGUAGE QuasiQuotes         #-}@@ -268,7 +267,7 @@ primops = MVal.marshalledValueTest MVal.MarshalledValueTestSpec     { MVal.testName = "Primops"     , MVal.maxSteps = 1024-    , MVal.failWithInfo = True+    , MVal.failWithInfo = False     , 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@@ -304,7 +303,7 @@         |]     , allSatisfied =         [ \state -> case stgInfo state of-            Info (StateTransition Enter_UpdatableClosure) _ -> True+            Info (StateTransition Rule15_Enter_UpdatableClosure) _ -> True             _otherwise -> False ]     } @@ -318,7 +317,7 @@         |]     , allSatisfied =         [ \state -> case stgInfo state of-            Info (StateTransition ReturnCon_Update) _ -> True+            Info (StateTransition Rule16_ReturnCon_Update) _ -> True             _otherwise -> False ]     } @@ -340,7 +339,7 @@         |]     , allSatisfied =         [ \state -> case stgInfo state of-            Info (StateTransition Enter_PartiallyAppliedUpdate) _ -> True+            Info (StateTransition Rule17a_Enter_PartiallyAppliedUpdate) _ -> True             _otherwise -> False ]     } 

@@ -11,12 +11,12 @@   -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 qualified Data.List                             as L+import qualified Data.List.NonEmpty                    as NE+import           Data.Text                             (Text)+import qualified Data.Text                             as T+import           Data.Text.Prettyprint.Doc+import           Data.Text.Prettyprint.Doc.Render.Text  import Stg.Language import Stg.Language.Prettyprint@@ -27,7 +27,6 @@ import Test.Machine.Evaluate.TestTemplates.Util import Test.Tasty import Test.Tasty.HUnit-import Test.Tasty.Runners.Html   @@ -78,11 +77,7 @@ -- | 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) )+machineStateTest testSpec = testCase (T.unpack (testName testSpec)) test   where     program = initialState "main" (source testSpec)     states = evalsUntil (RunForMaxSteps (maxSteps testSpec))@@ -91,54 +86,49 @@                         program     finalState = NE.last states -    test :: PrettyprinterDict -> Assertion-    test pprDict = case L.find (failPredicate testSpec) states of-        Just badState -> fail_failPredicateTrue pprDict testSpec badState+    test :: Assertion+    test = case L.find (failPredicate testSpec) states of+        Just badState -> fail_failPredicateTrue 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+                _otherwise -> fail_successPredicateNotTrue testSpec finalState             False -> (assertFailure . T.unpack)                 "No intermediate state satisfied the required predicate." -failWithInfoInfoText :: Doc+failWithInfoInfoText :: Doc ann failWithInfoInfoText = "Run test case with failWithInfo to see the final state."  fail_successPredicateNotTrue-    :: PrettyprinterDict-    -> MachineStateTestSpec+    :: MachineStateTestSpec     -> StgState     -> Assertion fail_successPredicateNotTrue-    (PrettyprinterDict pprText pprDoc)     testSpec     finalState-  = (assertFailure . T.unpack . pprText . vsep)+  = (assertFailure . T.unpack . renderStrict . layoutPretty defaultLayoutOptions . vsep)         [ "STG failed to satisfy predicate: "-            <> pprDoc (stgInfo finalState)+            <> prettyStgi (stgInfo finalState)         , if failWithInfo testSpec             then vsep-                [ hang 4 (vsep ["Program:", pprDoc (source testSpec)])-                , hang 4 (vsep ["Final state:", pprDoc finalState]) ]+                [ hang 4 (vsep ["Program:", prettyStgi (source testSpec)])+                , hang 4 (vsep ["Final state:", prettyStgi finalState]) ]             else failWithInfoInfoText ]  fail_failPredicateTrue-    :: PrettyprinterDict-    -> MachineStateTestSpec+    :: MachineStateTestSpec     -> StgState     -> Assertion fail_failPredicateTrue-    (PrettyprinterDict pprText pprDoc)     testSpec     badState-  = (assertFailure . T.unpack . pprText . vsep)+  = (assertFailure . T.unpack . renderStrict . layoutPretty defaultLayoutOptions . 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]) ]+                [ hang 4 (vsep ["Program:", prettyStgi (source testSpec)])+                , hang 4 (vsep ["Bad state:", prettyStgi badState]) ]             else failWithInfoInfoText ]-  allSatisfyAtSomePoint     :: [StgState]

@@ -16,10 +16,11 @@   -import           Data.List.NonEmpty           (NonEmpty (..))-import           Data.Text                    (Text)-import qualified Data.Text                    as T-import           Text.PrettyPrint.ANSI.Leijen hiding ((<>))+import           Data.List.NonEmpty                    (NonEmpty (..))+import           Data.Text                             (Text)+import qualified Data.Text                             as T+import           Data.Text.Prettyprint.Doc+import           Data.Text.Prettyprint.Doc.Render.Text  import Stg.Language import Stg.Language.Prettyprint@@ -28,11 +29,9 @@ import Stg.Marshal import Stg.Parser.QuasiQuoter   (stg) -import Test.Machine.Evaluate.TestTemplates.Util-import Test.Orphans                             ()+import Test.Orphans          () import Test.Tasty import Test.Tasty.QuickCheck-import Test.Tasty.Runners.Html   @@ -76,21 +75,16 @@ marshalledValueTest     :: forall input output.        ( Show input, Arbitrary input-       , Eq output, Show output, FromStg output, Pretty output )+       , Eq output, Show output, FromStg output, PrettyStgi 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) )+marshalledValueTest testSpec = testProperty (T.unpack (testName testSpec)) test   where     test :: ( Show input, Arbitrary input-            , Eq output, Show output, FromStg output, Pretty output )-         => PrettyprinterDict-         -> input+            , Eq output, Show output, FromStg output, PrettyStgi output )+         => input          -> Property-    test pprDict input =+    test input =         let program = initialState "main" (source (sourceSpec testSpec input))             states = evalsUntil                 (RunForMaxSteps (maxSteps testSpec))@@ -99,88 +93,87 @@                 program             verifyLoop (state :| _)                 | failPredicate testSpec state =-                    fail_failPredicateTrue pprDict testSpec input state+                    fail_failPredicateTrue 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+                    TypeMismatch -> fail_typeMismatch testSpec input state                     IsBlackhole -> continue state rest-                    IsWrongLambdaType LambdaFun -> fail_functionValue pprDict testSpec input state+                    IsWrongLambdaType LambdaFun -> fail_functionValue 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+                    BadArity -> fail_conArity testSpec input state+                    NotFound{} -> fail_notFound testSpec input state+                    AddrNotOnHeap -> fail_addrNotOnHeap testSpec input state+                    NoConstructorMatch -> fail_NoConstructorMatch testSpec input state+                Right actualValue -> assertEqual actualValue testSpec input state             continue lastState = \case-                [] -> fail_valueNotFound pprDict testSpec input lastState+                [] -> fail_valueNotFound testSpec input lastState                 (x:xs) -> verifyLoop (x :| xs)          in verifyLoop states  assertEqual-    :: (Eq output, Pretty output)+    :: forall input output. (Eq output, PrettyStgi output)     => output-    -> PrettyprinterDict     -> MarshalledValueTestSpec input output     -> input     -> StgState     -> Property assertEqual     actual-    (PrettyprinterDict pprText pprDoc)     testSpec     input     finalState-  = counterexample failText (actual == expected)+  = counterexample (failText expected) (actual == expected)   where+    expected :: output     expected = expectedValue (sourceSpec testSpec input)-    failText = (T.unpack . pprText . vsep)++    failText :: PrettyStgi a => a -> String+    failText ex = (T.unpack . renderStrict . layoutPretty defaultLayoutOptions . vsep)         [ "Machine produced an invalid result."-        , "Expected:" <+> pprDoc expected-        , "Actual:  " <+> pprDoc actual+        , "Expected:" <+> (prettyStgi ex :: Doc StgiAnn)+        , "Actual:  " <+> (prettyStgi actual :: Doc StgiAnn)         , if failWithInfo testSpec             then vsep-                [ hang 4 (vsep ["Program:", pprDoc (source (sourceSpec testSpec input))])-                , hang 4 (vsep ["Final state:", pprDoc finalState]) ]+                [ hang 4 (vsep ["Program:", prettyStgi (source (sourceSpec testSpec input))])+                , hang 4 (vsep ["Final state:", prettyStgi finalState]) ]             else failWithInfoInfoText ] -failWithInfoInfoText :: Doc+failWithInfoInfoText :: Doc ann failWithInfoInfoText = "Run test case with failWithInfo to see the final state."  fail_template-    :: Doc-    -> PrettyprinterDict+    :: Doc StgiAnn     -> MarshalledValueTestSpec input a     -> input     -> StgState     -> Property fail_template     failMessage-    (PrettyprinterDict pprText pprDoc)     testSpec     input     finalState   = counterexample failText False   where-    failText = (T.unpack . pprText . vsep)+    failText = (T.unpack . renderStrict . layoutPretty defaultLayoutOptions . vsep)         [ failMessage         , "Final machine state info:"-            <+> pprDoc (stgInfo finalState)+            <+> (prettyStgi (stgInfo finalState) :: Doc StgiAnn)         , if failWithInfo testSpec             then vsep-                [ hang 4 (vsep ["Program:", pprDoc (source (sourceSpec testSpec input))])-                , hang 4 (vsep ["Final state:", pprDoc finalState]) ]+                [ hang 4 (vsep ["Program:", prettyStgi (source (sourceSpec testSpec input)) :: Doc StgiAnn])+                , hang 4 (vsep ["Final state:", prettyStgi finalState :: Doc StgiAnn]) ]             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+    :: 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)\+fail_valueNotFound      = fail_template "None of the machine states produced 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"

@@ -4,14 +4,12 @@ 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           Data.Text                 (Text)+import qualified Data.Text                 as T+import           Data.Text.Prettyprint.Doc  import Stg.Language import Stg.Machine.Env@@ -57,6 +55,3 @@             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)

@@ -1,19 +1,21 @@-{-# LANGUAGE NumDecimals       #-}-{-# LANGUAGE OverloadedLists   #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes       #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# 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 qualified Data.List.NonEmpty                    as NE+import qualified Data.Map                              as M+import qualified Data.Set                              as S+import           Data.Text                             (Text)+import qualified Data.Text                             as T+import           Data.Text.Prettyprint.Doc+import           Data.Text.Prettyprint.Doc.Render.Text  import           Stg.Language.Prettyprint import           Stg.Machine@@ -39,8 +41,8 @@     [ test algorithm | test <- [ splitHeapTest                                , fibonacciSumTest ]] -prettyIndented :: Pretty a => a -> Text-prettyIndented = T.unlines . map ("    " <>) . T.lines . prettyprint+prettyIndented :: SimpleDocStream ann -> Text+prettyIndented = T.unlines . map ("    " <>) . T.lines . renderStrict  splitHeapTest :: GarbageCollectionAlgorithm -> TestTree splitHeapTest algorithm = testGroup "Split heap in dead/alive"@@ -70,11 +72,11 @@      errorMsg = T.unlines         [ "Globals:"-        , prettyIndented globals+        , prettyIndented (layoutPretty defaultLayoutOptions (prettyStgi globals :: Doc StgiAnn))         , "Dirty heap:"-        , prettyIndented dirtyHeap+        , prettyIndented (layoutPretty defaultLayoutOptions (prettyStgi dirtyHeap :: Doc StgiAnn))         , "Clean heap:"-        , prettyIndented cleanHeap ]+        , prettyIndented (layoutPretty defaultLayoutOptions (prettyStgi cleanHeap :: Doc StgiAnn)) ]      (deadAddrs, _forwards, StgState{stgHeap = cleanHeap})       = splitHeapWith algorithm dummyState

@@ -2,7 +2,7 @@   -import Data.Monoid+import Data.Text.Prettyprint.Doc  import           Stg.Language.Prettyprint import qualified Stg.Machine.Heap         as Heap@@ -11,26 +11,26 @@ 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 )+            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 )+            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 (Mapping addr1 closure2) heap1-            in counterexample (show (pretty heap2)+            in counterexample (show (prettyStgi heap2 :: Doc StgiAnn)                                 <> "\ndoes not contain "-                                <> show (pretty closure2))+                                <> show (prettyStgi closure2 :: Doc StgiAnn))                               (Heap.lookup addr1 heap2 == Just closure2) )      , testProperty "Lookup many inserted items" (\closures heap ->

@@ -7,10 +7,11 @@   -import qualified Data.List.NonEmpty as NE+import qualified Data.List.NonEmpty        as NE import           Data.Proxy-import           Data.Text          (Text)-import qualified Data.Text          as T+import           Data.Text                 (Text)+import qualified Data.Text                 as T+import           Data.Text.Prettyprint.Doc  import Stg.Language.Prettyprint import Stg.Machine@@ -21,6 +22,8 @@ import Test.Tasty import Test.Tasty.QuickCheck ++ tests :: TestTree tests = testGroup "Marshalling"     [ boolRoundtrip@@ -61,8 +64,8 @@     -> 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))+    test :: a -> Property+    test payload = counterexample (T.unpack ((renderPlain :: Doc StgiAnn -> Text) (prettyStgi finalState)))                                   (expected === Right payload)       where         source = mconcat

@@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE LambdaCase            #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings     #-} {-# LANGUAGE QuasiQuotes           #-}@@ -85,11 +86,12 @@         : [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+        isValid = \case+            LambdaForm _ Update (_:_) AppF{} -> False+            LambdaForm _ Update (_:_) AppC{} -> False+            LambdaForm _ _      _     AppP{} -> False+            LambdaForm _ _      _     LitE{} -> False+            _other -> True  instance Arbitrary UpdateFlag where     arbitrary = allEnums@@ -106,7 +108,7 @@         , arbitrary2 AppF         , arbitrary2 AppC         , arbitrary3 AppP-        , arbitrary1 Lit ]+        , arbitrary1 LitE ]     shrink = genericShrink  instance Arbitrary Alts where

@@ -97,25 +97,24 @@  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 ]+        [ arbitrary0 Rule1_Eval_FunctionApplication+        , arbitrary0 Rule2_Enter_NonUpdatableClosure+        , arbitrary1 Rule3_Eval_Let+        , arbitrary0 Rule4_Eval_Case+        , arbitrary0 Rule5_Eval_AppC+        , arbitrary0 Rule6_ReturnCon_Match+        , arbitrary0 Rule7_ReturnCon_DefUnbound+        , arbitrary0 Rule8_ReturnCon_DefBound+        , arbitrary0 Rule9_Lit+        , arbitrary0 Rule10_LitApp+        , arbitrary0 Rule11_ReturnInt_Match+        , arbitrary0 Rule12_ReturnInt_DefBound+        , arbitrary0 Rule13_ReturnInt_DefUnbound+        , arbitrary0 Rule14_Eval_AppP+        , arbitrary0 Rule15_Enter_UpdatableClosure+        , arbitrary0 Rule16_ReturnCon_Update+        , arbitrary0 Rule17a_Enter_PartiallyAppliedUpdate+        , arbitrary0 Rule1819_Eval_Case_Primop_Shortcut ]  instance Arbitrary StateError where     arbitrary = oneof

@@ -7,9 +7,9 @@   import           Data.Bifunctor-import           Data.Monoid-import           Data.Text      (Text)-import qualified Data.Text      as T+import           Data.Text                 (Text)+import qualified Data.Text                 as T+import           Data.Text.Prettyprint.Doc  import           Stg.Language import           Stg.Language.Prettyprint@@ -37,7 +37,7 @@     -> TestTree shouldParseTo testName input output = testCase (T.unpack testName) test   where-    actual = first prettyprint (parse program input)+    actual = first prettyprintOldAnsi (parse program input)     expected = Right (Program output)     failMessage = case actual of        Left err -> T.unlines@@ -47,7 +47,7 @@           , "Error encountered:"           , (T.unlines . map (" > " <>) . T.lines) err           , "=============" ]-       Right r -> prettyprint r+       Right r -> (renderPlain :: Doc StgiAnn -> Text) (prettyStgi r)     test = assertEqual (T.unpack failMessage) expected actual  @@ -195,7 +195,7 @@     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 ]+            , (T.unlines . map (" > " <>) . T.lines . (renderPlain :: Doc StgiAnn -> Text) . prettyStgi) ast ]         Left _err -> pure ()  badParses :: TestTree

@@ -20,6 +20,6 @@ tests = testGroup "Quasiquoter"     [ testCase "Simple definition"         (let actual = Right [stg| f = \ -> Hello |]-             expected = first prettyprint (parse Parser.program "f = \\ -> Hello")+             expected = first prettyprintOldAnsi (parse Parser.program "f = \\ -> Hello")          in assertEqual "" expected actual)     ]

@@ -28,7 +28,6 @@ testAnd2 :: TestTree testAnd2 = marshalledValueTest defSpec     { testName = "and2 (&&)"-    , failWithInfo = True     , sourceSpec = \(b1, b2) -> MarshalSourceSpec         { resultVar = "main"         , expectedValue = b1 && b2

@@ -69,7 +69,8 @@  testPartition :: TestTree testPartition = marshalledValueTest defSpec-    { testName = "filter"+    { testName = "partition"+    , failWithInfo = True     , sourceSpec = \(xs, threshold :: Integer) -> MarshalSourceSpec         { resultVar = "main"         , expectedValue = L.partition (> threshold) xs@@ -90,7 +91,6 @@ testSort :: TestTree testSort = marshalledValueTest defSpec     { testName = "sort (Haskell/base version)"-    , failWithInfo = True     , sourceSpec = \(xs :: [Integer]) -> MarshalSourceSpec         { resultVar = "main"         , expectedValue = L.sort xs@@ -311,7 +311,6 @@ testReplicate :: TestTree testReplicate = marshalledValueTest defSpec     { testName = "replicate"-    , failWithInfo = True     , maxSteps = 1024     , failPredicate = \stgState -> case stgCode stgState of         Eval AppP {} _ -> True

@@ -31,7 +31,6 @@ testFst :: TestTree testFst = marshalledValueTest defSpec     { testName = "fst"-    , failWithInfo = True     , sourceSpec = \(tuple :: (Integer, Integer)) -> MarshalSourceSpec         { resultVar = "main"         , expectedValue = fst tuple

@@ -0,0 +1,147 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedLists   #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes       #-}++module Test.StaticAnalysis (tests) where++++import           Data.Foldable+import           Data.Set                  (Set)+import qualified Data.Text                 as T+import           Data.Text.Prettyprint.Doc++import Stg.Language+import Stg.Language.Prettyprint+import Stg.Parser.QuasiQuoter+import Stg.StaticAnalysis+import Stg.Util++import Test.Orphans     ()+import Test.Tasty+import Test.Tasty.HUnit++{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}++++tests :: TestTree+tests = testGroup "Static analysis"+    [ testGroup "Free variables"+        [ testGroup "Expr"+            [ testGroup "Let"+                [ testLet+                , testLetStress ]+            , testGroup "Case"+                [ testCaseAlg+                , testCasePrim ]+                , testCaseDefaultOnly+            , testAppF+            , testCon+            , testPrimop+            , testLitE+            ]+        , testShadowGlobal+        ]+    ]++pprFreeVars :: Set Var -> Doc StgiAnn+pprFreeVars = commaSep . map prettyStgi . toList++assertFreeVariablesEqual :: Set Var -> Set Var -> Assertion+assertFreeVariablesEqual expected actual+  = assertBool err (expected == actual)+  where+    err = (T.unpack . renderPlain . hang 4 . vsep)+        [ "Free variables:"+        , "Expected: " <> pprFreeVars expected+        , "Actual:   " <> pprFreeVars actual ]++testLet :: TestTree+testLet = testCase "Simple binding" test+  where+    source = [expr| let f = \(a) b -> a b c in f x |]+    expected =  ["a", "x"]+    actual = freeVariables source+    test = assertFreeVariablesEqual expected actual++testLetStress :: TestTree+testLetStress = testCase "Aliasing" test+  where+    source = [expr| let a = \ -> XXX;+                        f = \(a) b ->+                            let g = \(b) -> b x;+                                h = \ -> f+                            in g h+                    in f x |]+    expected = ["a", "x"]+    actual = freeVariables source+    test = assertFreeVariablesEqual expected actual++testCaseAlg :: TestTree+testCaseAlg = testCase "Algebraic" test+  where+    source = [expr| case f x of Con y -> f y; v -> g v |]+    expected =  ["f", "g", "x"]+    actual = freeVariables source+    test = assertFreeVariablesEqual expected actual++testCasePrim :: TestTree+testCasePrim = testCase "Primitive" test+  where+    source = [expr| case f x of 1# -> f y; v -> g v |]+    expected = ["f", "g", "x", "y"]+    actual = freeVariables source+    test = assertFreeVariablesEqual expected actual++testCaseDefaultOnly :: TestTree+testCaseDefaultOnly = testCase "Default only" test+  where+    source = [expr| case f x of v -> h v |]+    expected =  ["f", "h", "x"]+    actual = freeVariables source+    test = assertFreeVariablesEqual expected actual++testAppF :: TestTree+testAppF = testCase "Function application" test+  where+    source = [expr| f x y |]+    expected = ["f", "x", "y"]+    actual = freeVariables source+    test = assertFreeVariablesEqual expected actual++testCon :: TestTree+testCon = testCase "Constructor application" test+  where+    source = [expr| Con y z |]+    expected =  ["y", "z"]+    actual = freeVariables source+    test = assertFreeVariablesEqual expected actual++testPrimop :: TestTree+testPrimop = testCase "Primop" test+  where+    source = [expr| +# p q |]+    expected =  ["p", "q"]+    actual = freeVariables source+    test = assertFreeVariablesEqual expected actual++testLitE :: TestTree+testLitE = testCase "Literal" test+  where+    source = [expr| 1# |]+    expected =   []+    actual = freeVariables source+    test = assertFreeVariablesEqual expected actual++testShadowGlobal :: TestTree+testShadowGlobal = testCase "Shadowing a global" test+  where+    source = [program|+        id = \b -> b;+        main = \ -> let f = \id -> id+                    in f |]+    expected =  []+    actual = freeVariables source+    test = assertFreeVariablesEqual expected actual

@@ -1,3 +1,4 @@+{-# LANGUAGE FlexibleContexts  #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell   #-} @@ -16,8 +17,10 @@   import Data.Ratio-import Text.PrettyPrint.ANSI.Leijen hiding ((<$>))+import Data.Text.Prettyprint.Doc +import Stg.Language.Prettyprint+ import Test.QuickCheck import Test.UtilTH @@ -40,7 +43,7 @@ $(arbitraryN 3)  infix 4 ==*==-(==*==) :: (Eq a, Pretty a) => a -> a -> Property+(==*==) :: (Eq a, PrettyStgi a) => a -> a -> Property x ==*== y = counterexample example (x == y)   where-    example = (show . align . vsep) [pretty x, "is not equal to", pretty y]+    example = (show . align . vsep) [prettyStgi x :: Doc StgiAnn, "is not equal to", prettyStgi y]