diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -4,14 +4,17 @@ STGi is a visual STG implementation to help understand Haskell's execution model. -It does this by guiding through the runnning of a program, showing stack and -heap, and giving explanations of the applied transition rules. Here what an +It does this by guiding through the running of a program, showing stack and +heap, and giving explanations of the applied transition rules. Here is what an intermediate state looks like: ![](screenshot.png) -[![](https://travis-ci.org/quchen/stgi.svg?branch=master)](https://travis-ci.org/quchen/stgi) +[![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) +[![Hackage](https://img.shields.io/hackage/v/stgi.svg?style=flat-square)](http://hackage.haskell.org/packages/search?terms=stgi) + Table of contents ----------------- @@ -169,7 +172,7 @@ The right-hand side is called a *lambda form*, and is closely related to the usual lambda from Haskell. - - Bound variables are the lambda paramaters just like in Haskell. + - Bound variables are the lambda parameters just like in Haskell. - Free variables are the variables used in the `body` that are not bound or global. This means that variables from the parent scope are not automatically in scope, but you can get them into scope by adding them to @@ -319,7 +322,7 @@ - Closures with non-empty argument lists and constructors are already in WHNF, so they are never updatable. -- When a value is only entered once, updating it is unnessecary work. Deciding +- When a value is only entered once, updating it is unnecessary work. Deciding whether a potentially updatable closure should actually be updatable is what the *update analysis* would do in a compiler when translating into the STG. diff --git a/src/Stg/Machine/Evaluate.hs b/src/Stg/Machine/Evaluate.hs --- a/src/Stg/Machine/Evaluate.hs +++ b/src/Stg/Machine/Evaluate.hs @@ -34,34 +34,37 @@ 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 - -> Maybe (Either DefaultAlt AlgebraicAlt) + -> Validate AltError (AltMatch AlgebraicAlt) lookupAlgebraicAlt (Alts (AlgebraicAlts alts) def) constr - = Just (case L.find matchingAlt alts of - Just alt -> Right alt - _otherwise -> Left def ) - where - matchingAlt (AlgebraicAlt c _ _) = c == constr -lookupAlgebraicAlt (Alts PrimitiveAlts{} _) _ = Nothing -lookupAlgebraicAlt (Alts NoNonDefaultAlts{} def) _ = Just (Left def) + = 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 - -> Maybe (Either DefaultAlt PrimitiveAlt) + -> Validate AltError (AltMatch PrimitiveAlt) lookupPrimitiveAlt (Alts (PrimitiveAlts alts) def) lit - = Just (case L.find matchingAlt alts of - Just alt -> Right alt - _otherwise -> Left def ) - where - matchingAlt (PrimitiveAlt lit' _) = lit' == lit -lookupPrimitiveAlt (Alts AlgebraicAlts{} _) _ = Nothing -lookupPrimitiveAlt (Alts NoNonDefaultAlts{} def) _ = Just (Left def) + = 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 _ _ _) = @@ -166,7 +169,8 @@ in H.allocMany preallocatedObjs heap -- The local environment enriched by the definitions in the 'let'. - locals' = let newMappings = zipWith Mapping letVars (map Addr newAddrs) + 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 @@ -179,9 +183,9 @@ Success closures -> -- As promised above, the preallocated dummy closures are now -- discarded, and replaced with the newly formed closures. - let heap' = H.updateMany - newAddrs - (map HClosure closures) + let addrToClosure addr closure = Mapping addr (HClosure closure) + heap' = H.updateMany + (zipWith addrToClosure newAddrs closures) heapWithPreallocations in s { stgCode = Eval expr locals' , stgHeap = heap' @@ -209,14 +213,14 @@ | Success (PrimInt xVal) <- localVal locals x , Success (PrimInt yVal) <- localVal locals y , Success opXY <- applyPrimOp op xVal yVal - , Just altLookup <- lookupPrimitiveAlt alts (Literal opXY) + , Success altLookup <- lookupPrimitiveAlt alts (Literal opXY) = let (locals', expr) = case altLookup of - Left (DefaultBound pat e) + DefaultMatches (DefaultBound pat e) -> (addLocals [Mapping pat (PrimInt opXY)] locals, e) - Left (DefaultNotBound e) + DefaultMatches (DefaultNotBound e) -> (locals, e) - Right (PrimitiveAlt _opXY e) + AltMatches (PrimitiveAlt _opXY e) -> (locals, e) in s { stgCode = Eval expr locals' @@ -255,7 +259,8 @@ stgRule s@StgState { stgCode = ReturnCon con ws , stgStack = ReturnFrame alts locals :< stack' } - | Just (Right (AlgebraicAlt _con vars expr)) <- lookupAlgebraicAlt alts con + | Success (AltMatches (AlgebraicAlt _con vars expr)) <- + lookupAlgebraicAlt alts con , length ws == length vars = let locals' = addLocals (zipWith Mapping vars ws) locals @@ -272,7 +277,8 @@ stgRule s@StgState { stgCode = ReturnCon con _ws , stgStack = ReturnFrame alts locals :< stack' } - | Just (Left (DefaultNotBound expr)) <- lookupAlgebraicAlt alts con + | Success (DefaultMatches (DefaultNotBound expr)) <- + lookupAlgebraicAlt alts con = s { stgCode = Eval expr locals , stgStack = stack' @@ -286,7 +292,8 @@ , stgStack = ReturnFrame alts locals :< stack' , stgHeap = heap , stgSteps = steps } - | Just (Left (DefaultBound v expr)) <- lookupAlgebraicAlt alts con + | Success (DefaultMatches (DefaultBound v expr)) <- + lookupAlgebraicAlt alts con = let locals' = addLocals [Mapping v (Addr addr)] locals (addr, heap') = H.alloc (HClosure closure) heap @@ -322,7 +329,8 @@ stgRule s@StgState { stgCode = ReturnInt k , stgStack = ReturnFrame alts locals :< stack' } - | Just (Right (PrimitiveAlt _k expr)) <- lookupPrimitiveAlt alts (Literal k) + | Success (AltMatches (PrimitiveAlt _k expr)) <- + lookupPrimitiveAlt alts (Literal k) = s { stgCode = Eval expr locals , stgStack = stack' @@ -334,7 +342,8 @@ stgRule s@StgState { stgCode = ReturnInt k , stgStack = ReturnFrame alts locals :< stack' } - | Just (Left (DefaultBound v expr)) <- lookupPrimitiveAlt alts (Literal k) + | Success (DefaultMatches (DefaultBound v expr)) <- + lookupPrimitiveAlt alts (Literal k) = let locals' = addLocals [Mapping v (PrimInt k)] locals @@ -349,7 +358,8 @@ stgRule s@StgState { stgCode = ReturnInt k , stgStack = ReturnFrame alts locals :< stack' } - | Just (Left (DefaultNotBound expr)) <- lookupPrimitiveAlt alts (Literal k) + | Success (DefaultMatches (DefaultNotBound expr)) <- + lookupPrimitiveAlt alts (Literal k) = s { stgCode = Eval expr locals , stgStack = stack' @@ -400,7 +410,7 @@ = let stack' = UpdateFrame addr :< stack locals = makeLocals (zipWith Mapping free freeVals) - heap' = H.update addr (Blackhole tick) heap + heap' = H.update (Mapping addr (Blackhole tick)) heap in s { stgCode = Eval body locals , stgStack = stack' @@ -420,7 +430,7 @@ = let vs = let newVar _old i = Var ("upd16_" <> show' steps <> "-" <> show' i) in zipWith newVar ws [0::Integer ..] lf = LambdaForm vs NoUpdate [] (AppC con (map AtomVar vs)) - heap' = H.update addr (HClosure (Closure lf ws)) heap + heap' = H.update (Mapping addr (HClosure (Closure lf ws))) heap in s { stgCode = ReturnCon con ws , stgStack = stack' @@ -450,7 +460,7 @@ freeVars updatedClosure = Closure (LambdaForm freeVars NoUpdate [] fxs1) freeVals - heap' = H.update addrUpdate (HClosure updatedClosure) heap + heap' = H.update (Mapping addrUpdate (HClosure updatedClosure)) heap in s { stgCode = Enter addrEnter , stgStack = argFrames <>> stack' @@ -465,7 +475,7 @@ popArgsUntilUpdate withArgsStack = let (argFrames, argsPoppedStack) = S.span isArgFrame withArgsStack in Just ( filter isArgFrame (F.toList argFrames) - , argsPoppedStack) + , argsPoppedStack ) @@ -571,7 +581,7 @@ -- Non-algebraic scrutinee -- -- For more information on this, see 'Stg.Prelude.seq'. -noRuleApplies s@StgState -- TODO: Make sure this catches the right states +noRuleApplies s@StgState { stgCode = Enter _ , stgStack = ReturnFrame{} :< _} @@ -586,11 +596,12 @@ = s { stgInfo = Info (StateError DivisionByZero) [] } --- (6) Algebraic constructor return, standard match +-- Bad constructor arity: different number of arguments in code segment +-- and in return frame noRuleApplies s@StgState { stgCode = ReturnCon con ws , stgStack = ReturnFrame alts _ :< _ } - | Just (Right (AlgebraicAlt _con vars _)) <- lookupAlgebraicAlt alts con + | Success (AltMatches (AlgebraicAlt _con vars _)) <- lookupAlgebraicAlt alts con , length ws /= length vars = s { stgInfo = Info (StateError (BadConArity (length ws) (length vars))) diff --git a/src/Stg/Machine/GarbageCollection/Common.hs b/src/Stg/Machine/GarbageCollection/Common.hs --- a/src/Stg/Machine/GarbageCollection/Common.hs +++ b/src/Stg/Machine/GarbageCollection/Common.hs @@ -22,9 +22,9 @@ --- | Split the heap contained in a machine state in two parts: the dead objects --- that can safely be discarded, and the alive ones that are still needed by --- the program. +-- | Split the heap contained in a machine state in three parts: the dead +-- objects that can safely be discarded, a maping from old to new addresses if +-- definitions were moved, and the final state with a cleaned up heap. splitHeapWith :: GarbageCollectionAlgorithm -> StgState @@ -39,7 +39,7 @@ -- | Collect all mentioned addresses in a machine element. -- -- Note that none of the types in "Stg.Language" contain addresses, since an --- address is not something present in the STG _language_, only in the execution +-- address is not something present in the STG __language__, only in the execution -- contest the language is put in in the "Stg.Machine" modules. class Addresses a where -- | All contained addresses in the order they appear, but without @@ -49,6 +49,8 @@ -- | All contained addresses in the order they appear, with duplicates. addrs' :: a -> Seq MemAddr + + {-# MINIMAL addrs' #-} nubSeq :: Ord a => Seq a -> Seq a nubSeq = go mempty diff --git a/src/Stg/Machine/GarbageCollection/TwoSpaceCopying.hs b/src/Stg/Machine/GarbageCollection/TwoSpaceCopying.hs --- a/src/Stg/Machine/GarbageCollection/TwoSpaceCopying.hs +++ b/src/Stg/Machine/GarbageCollection/TwoSpaceCopying.hs @@ -201,7 +201,7 @@ updateClosure :: MemAddr -> Closure -> Gc () updateClosure addr closure = do gcState@GcState { toHeap = heap } <- getGcState - let heap' = H.update addr (HClosure closure) heap + let heap' = H.update (Mapping addr (HClosure closure)) heap putGcState gcState { toHeap = heap' } registerForEvacuation :: [MemAddr] -> Gc () diff --git a/src/Stg/Machine/Heap.hs b/src/Stg/Machine/Heap.hs --- a/src/Stg/Machine/Heap.hs +++ b/src/Stg/Machine/Heap.hs @@ -31,13 +31,13 @@ lookup addr (Heap heap) = M.lookup addr heap -- | Update a value on the heap. -update :: MemAddr -> HeapObject -> Heap -> Heap -update addr obj (Heap h) = Heap (M.adjust (const obj) addr h) +update :: Mapping MemAddr HeapObject -> Heap -> Heap +update (Mapping addr obj) (Heap h) = Heap (M.adjust (const obj) addr h) -- | Update many values on the heap. -updateMany :: [MemAddr] -> [HeapObject] -> Heap -> Heap -updateMany addrs objs heap = - L.foldl' (\h (addr, obj) -> update addr obj h) heap (zip addrs objs) +updateMany :: [Mapping MemAddr HeapObject] -> Heap -> Heap +updateMany mappings heap = + L.foldl' (\h mapping -> update mapping h) heap mappings -- | Store a value in the heap at an unused address. alloc :: HeapObject -> Heap -> (MemAddr, Heap) diff --git a/src/Stg/Machine/Types.hs b/src/Stg/Machine/Types.hs --- a/src/Stg/Machine/Types.hs +++ b/src/Stg/Machine/Types.hs @@ -199,6 +199,8 @@ ReturnInt i -> "ReturnInt" <+> pretty (Literal i) -- | A single key -> value association. +-- +-- Used to make 2-tuples to be inserted into association maps clearer. data Mapping k v = Mapping k v deriving (Eq, Ord, Show, Generic) diff --git a/src/Stg/Parser/Parser.hs b/src/Stg/Parser/Parser.hs --- a/src/Stg/Parser/Parser.hs +++ b/src/Stg/Parser/Parser.hs @@ -16,7 +16,7 @@ -- e.g. with @Int#@. -- * A lambda's head is written @\\(free) bound -> body@, where @free@ and -- @bound@ are space-separated variable lists, instead of the paper's --- @(free) \\n (bound) -> body@, which uses comma-separated lists. The +-- @{free} \\n {bound} -> body@, which uses comma-separated lists. The -- update flag @\\u@ is signified using a double arrow @=>@ instead of the -- normal arrow @->@. module Stg.Parser.Parser ( @@ -180,16 +180,12 @@ expr :: (Monad parser, TokenParsing parser) => parser Expr expr = choice [let', case', appF, appC, appP, lit] "expression" where - letHead - :: (Monad parser, TokenParsing parser) - => parser (Binds -> Expr -> Expr) let', case', appF, appC, appP, lit :: (Monad parser, TokenParsing parser) => parser Expr - letHead = reserved "letrec" *> pure (Let Recursive) - <|> reserved "let" *> pure (Let NonRecursive) - let' = letHead + let' = Let + <$> (Recursive <$ reserved "letrec" <|> NonRecursive <$ reserved "let") <*> binds <* reserved "in" <*> expr @@ -217,7 +213,6 @@ <|> AtomLit <$> literal "atom (variable or literal)" - -- | Parse a primitive operation. -- -- @ @@ -241,7 +236,6 @@ literal :: TokenParsing parser => parser Literal literal = token (Literal <$> integer' <* char '#') "integer literal" - -- | Parse non-default alternatives. The list of alternatives can be either -- empty, all algebraic, or all primitive. diff --git a/src/Stg/Prelude.hs b/src/Stg/Prelude.hs --- a/src/Stg/Prelude.hs +++ b/src/Stg/Prelude.hs @@ -21,6 +21,7 @@ cycle, take, filter, + partition, repeat, replicate, sort, diff --git a/src/Stg/Prelude/List.hs b/src/Stg/Prelude/List.hs --- a/src/Stg/Prelude/List.hs +++ b/src/Stg/Prelude/List.hs @@ -13,6 +13,7 @@ cycle, take, filter, + partition, repeat, replicate, sort, @@ -45,7 +46,7 @@ nil, concat2, foldl, foldl', foldr, iterate, cycle, take, filter, repeat, replicate, sort, map, equals_List_Int, length, zip, zipWith, - reverse, forceSpine, naiveSort :: Program + reverse, forceSpine, naiveSort, partition :: Program -- | The empty list as a top-level closure. @@ -196,6 +197,20 @@ badList -> Error_filter_2 badList |] +partition = nil <> [program| + partition = \p xs -> case xs of + Nil -> Pair nil nil; + Cons y ys -> case partition p ys of + Pair yes no -> case p y of + True -> let yes' = \(y yes) -> Cons y yes + in Pair yes' no; + False -> let no' = \(y no) -> Cons y no + in Pair yes no'; + badBool -> Error_partition1 badBool; + badPair -> Error_partition2 badPair; + badList -> Error_partition3 badList + |] + -- | reverse a list. -- -- @ @@ -356,24 +371,20 @@ -- @ -- naiveSort : [Int] -> [Int] -- @ -naiveSort = mconcat [leq_Int, gt_Int, filter, concat2] <> [program| +naiveSort = mconcat [leq_Int, gt_Int, partition, concat2] <> [program| naiveSort = \xs -> case xs of Nil -> Nil; Cons pivot xs' -> - let beforePivotSorted = \(pivot xs') => - letrec - atMostPivot = \(pivot) y -> leq_Int y pivot; - beforePivot = \(xs' atMostPivot) => filter atMostPivot xs' - in naiveSort beforePivot; - - afterPivotSorted = \(pivot xs') => + let leqPivot = \(pivot) y -> leq_Int y pivot + in case partition leqPivot xs' of + Pair leqPivotXs gtPivotXs -> letrec - moreThanPivot = \(pivot) y -> gt_Int y pivot; - afterPivot = \(xs' moreThanPivot) => filter moreThanPivot xs' - in naiveSort afterPivot - in let fromPivotOn = \(pivot afterPivotSorted) -> Cons pivot afterPivotSorted - in concat2 beforePivotSorted fromPivotOn; - badList -> Error_sort badList |] + leqPivotSorted = \(leqPivotXs) => naiveSort leqPivotXs; + gtPivotSorted = \(gtPivotXs) => naiveSort gtPivotXs; + fromPivotOn = \(pivot gtPivotSorted) -> Cons pivot gtPivotSorted + in concat2 leqPivotSorted fromPivotOn; + badPair -> Error_sort_badPair badPair; + badList -> Error_sort_badList badList |] -- | Apply a function to each element of a list. -- diff --git a/src/Stg/Util.hs b/src/Stg/Util.hs --- a/src/Stg/Util.hs +++ b/src/Stg/Util.hs @@ -31,7 +31,7 @@ --- | The validation version of 'Either'. +-- | 'Either' with an accumulating 'Applicative' instance data Validate err a = Failure err | Success a instance Functor (Validate a) where @@ -45,7 +45,7 @@ bimap f _ (Failure l) = Failure (f l) bimap _ g (Success r) = Success (g r) --- ^ Return success or the accumulation of all failures +-- | Return success or the accumulation of all failures instance Monoid a => Applicative (Validate a) where pure = Success Success f <*> Success x = Success (f x) diff --git a/stgi.cabal b/stgi.cabal --- a/stgi.cabal +++ b/stgi.cabal @@ -1,8 +1,19 @@ name: stgi -version: 1 +version: 1.0.1 synopsis: Educational implementation of the STG (Spineless Tagless G-machine) -description: See README.md +description: STGi is a visual STG implementation to help understand + Haskell's execution model. + . + It does this by guiding through the running of a program, + showing stack and heap, and giving explanations of the + applied transition rules. + . + Here is what an intermediate state looks like: + . + <> + . + For further information, see README.md. homepage: https://github.com/quchen/stgi#readme license: BSD3 license-file: LICENSE.md diff --git a/test/Testsuite/Test/Machine/Evaluate.hs b/test/Testsuite/Test/Machine/Evaluate.hs --- a/test/Testsuite/Test/Machine/Evaluate.hs +++ b/test/Testsuite/Test/Machine/Evaluate.hs @@ -3,10 +3,6 @@ module Test.Machine.Evaluate (tests) where --- TODO: Important tests to add: --- - Only case does evaluation --- - Don't forget to add the variables closed over in let(rec) - import qualified Test.Machine.Evaluate.Errors as Errors diff --git a/test/Testsuite/Test/Machine/Heap.hs b/test/Testsuite/Test/Machine/Heap.hs --- a/test/Testsuite/Test/Machine/Heap.hs +++ b/test/Testsuite/Test/Machine/Heap.hs @@ -6,6 +6,7 @@ import Stg.Language.Prettyprint import qualified Stg.Machine.Heap as Heap +import Stg.Machine.Types import Test.Orphans () import Test.Tasty @@ -26,7 +27,7 @@ , testProperty "Update heap overwrites old values" (\closure1 closure2 heap -> let (addr1, heap1) = Heap.alloc closure1 heap - heap2 = Heap.update addr1 closure2 heap1 + heap2 = Heap.update (Mapping addr1 closure2) heap1 in counterexample (show (pretty heap2) <> "\ndoes not contain " <> show (pretty closure2)) diff --git a/test/Testsuite/Test/Prelude/List.hs b/test/Testsuite/Test/Prelude/List.hs --- a/test/Testsuite/Test/Prelude/List.hs +++ b/test/Testsuite/Test/Prelude/List.hs @@ -37,6 +37,7 @@ [ testSort , testNaiveSort ] , testFilter + , testPartition , testMap , testZip , testZipWith @@ -64,6 +65,26 @@ positive = \x -> gt_Int x threshold; filtered = \(positive) => filter positive inputList in force filtered + |] ]}} + +testPartition :: TestTree +testPartition = marshalledValueTest defSpec + { testName = "filter" + , sourceSpec = \(xs, threshold :: Integer) -> MarshalSourceSpec + { resultVar = "main" + , expectedValue = L.partition (> threshold) xs + , source = mconcat + [ toStg "inputList" xs + , toStg "threshold" threshold + , Stg.gt_Int + , Stg.force + , Stg.partition + , [stg| + main = \ => + letrec + positive = \x -> gt_Int x threshold; + partitioned = \(positive) => partition positive inputList + in force partitioned |] ]}} testSort :: TestTree