stgi 1 → 1.0.1
raw patch · 14 files changed
+138/−85 lines, 14 files
Files
- README.md +8/−5
- src/Stg/Machine/Evaluate.hs +48/−37
- src/Stg/Machine/GarbageCollection/Common.hs +6/−4
- src/Stg/Machine/GarbageCollection/TwoSpaceCopying.hs +1/−1
- src/Stg/Machine/Heap.hs +5/−5
- src/Stg/Machine/Types.hs +2/−0
- src/Stg/Parser/Parser.hs +3/−9
- src/Stg/Prelude.hs +1/−0
- src/Stg/Prelude/List.hs +26/−15
- src/Stg/Util.hs +2/−2
- stgi.cabal +13/−2
- test/Testsuite/Test/Machine/Evaluate.hs +0/−4
- test/Testsuite/Test/Machine/Heap.hs +2/−1
- test/Testsuite/Test/Prelude/List.hs +21/−0
README.md view
@@ -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:  -[](https://travis-ci.org/quchen/stgi)+[](https://travis-ci.org/quchen/stgi)+[](https://en.wikipedia.org/wiki/BSD_License)+[](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.
src/Stg/Machine/Evaluate.hs view
@@ -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)))
src/Stg/Machine/GarbageCollection/Common.hs view
@@ -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
src/Stg/Machine/GarbageCollection/TwoSpaceCopying.hs view
@@ -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 ()
src/Stg/Machine/Heap.hs view
@@ -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)
src/Stg/Machine/Types.hs view
@@ -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)
src/Stg/Parser/Parser.hs view
@@ -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.
src/Stg/Prelude.hs view
@@ -21,6 +21,7 @@ cycle, take, filter,+ partition, repeat, replicate, sort,
src/Stg/Prelude/List.hs view
@@ -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. --
src/Stg/Util.hs view
@@ -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)
stgi.cabal view
@@ -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:+ .+ <<http://i.imgur.com/ouPwfgW.png>>+ .+ For further information, see README.md. homepage: https://github.com/quchen/stgi#readme license: BSD3 license-file: LICENSE.md
test/Testsuite/Test/Machine/Evaluate.hs view
@@ -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
test/Testsuite/Test/Machine/Heap.hs view
@@ -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))
test/Testsuite/Test/Prelude/List.hs view
@@ -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