├── test ├── empty.stg ├── error.stg ├── ones.stg ├── apply.stg ├── blackhole.stg ├── non_exhaustive_pattern.stg ├── sum.stg ├── sum_error.stg ├── take.stg ├── append.stg ├── fac.stg ├── map_pap.stg ├── seq.stg ├── map.stg ├── fibs.stg └── docs.stg ├── .gitignore ├── Setup.lhs ├── README.md ├── .github └── workflows │ └── haskell.yml ├── src ├── Ministg │ ├── Utils.hs │ ├── CallStack.hs │ ├── Annotate.hs │ ├── Pretty.hs │ ├── GC.hs │ ├── Arity.hs │ ├── Lexer.hs │ ├── TraceEval.hs │ ├── Parser.hs │ ├── Options.hs │ ├── State.hs │ ├── AST.hs │ └── Eval.hs └── Main.hs ├── LICENSE ├── ministg.cabal └── data └── Prelude.stg /test/empty.stg: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist/ 2 | -------------------------------------------------------------------------------- /test/error.stg: -------------------------------------------------------------------------------- 1 | main = ERROR; 2 | -------------------------------------------------------------------------------- /test/ones.stg: -------------------------------------------------------------------------------- 1 | ones = CON(Cons one ones); 2 | main = THUNK(ones) 3 | -------------------------------------------------------------------------------- /test/apply.stg: -------------------------------------------------------------------------------- 1 | twentytwo = CON(I 22); 2 | main = THUNK(apply const true twentytwo) 3 | -------------------------------------------------------------------------------- /test/blackhole.stg: -------------------------------------------------------------------------------- 1 | # this should crash with a blackhole. 2 | main = THUNK(main); 3 | -------------------------------------------------------------------------------- /Setup.lhs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env runhaskell 2 | > import Distribution.Simple 3 | > main = defaultMain 4 | -------------------------------------------------------------------------------- /test/non_exhaustive_pattern.stg: -------------------------------------------------------------------------------- 1 | foo = CON(Foo); 2 | end = CON(End); 3 | main = THUNK( 4 | case foo of { Bar -> end; } 5 | ); 6 | -------------------------------------------------------------------------------- /test/sum.stg: -------------------------------------------------------------------------------- 1 | list1 = CON(Cons one nil); 2 | list2 = CON(Cons two list1); 3 | list3 = CON(Cons three list2); 4 | main = THUNK(sum list3) 5 | -------------------------------------------------------------------------------- /test/sum_error.stg: -------------------------------------------------------------------------------- 1 | list1 = CON(Cons one nil); 2 | list2 = CON(Cons error list1); 3 | list3 = CON(Cons three list2); 4 | main = THUNK(sum list3); 5 | -------------------------------------------------------------------------------- /test/take.stg: -------------------------------------------------------------------------------- 1 | ones = CON(Cons one ones); 2 | main = THUNK(let { result = THUNK(take three ones); 3 | f = THUNK(forcelist result)} in seq f result ) 4 | -------------------------------------------------------------------------------- /test/append.stg: -------------------------------------------------------------------------------- 1 | list1 = CON(Cons one nil); 2 | list2 = CON(Cons one list1); 3 | list3 = CON(Cons zero list2); 4 | list4 = THUNK(append list3 list3); 5 | list5 = THUNK(append list4 list4); 6 | main = THUNK(let { f = THUNK(forcelist list5)} in seq f list5) 7 | -------------------------------------------------------------------------------- /test/fac.stg: -------------------------------------------------------------------------------- 1 | fac = FUN (x -> 2 | case eqInt x zero of { 3 | True -> one; 4 | False -> let { s = THUNK(subInt x one); 5 | rec = THUNK(fac s) } 6 | in multInt x rec 7 | }); 8 | 9 | main = THUNK (fac seven) 10 | -------------------------------------------------------------------------------- /test/map_pap.stg: -------------------------------------------------------------------------------- 1 | # in Haskell: main = head (map const [7,2,1]) 10 2 | 3 | list1 = CON(Cons one nil); 4 | list2 = CON(Cons two list1); 5 | list3 = CON(Cons seven list2); 6 | main = THUNK(let { mc = THUNK(map const list3); 7 | constSeven = THUNK(head mc); 8 | } in constSeven ten); 9 | -------------------------------------------------------------------------------- /test/seq.stg: -------------------------------------------------------------------------------- 1 | # haskell: main = let x = 1 + 2 in seq x (foo x) 2 | main = THUNK(let {x = THUNK(plusInt one two); 3 | res = THUNK(foo x)} in seq x res); 4 | 5 | # compare with 6 | # haskell: main = foo (1 + 2) 7 | # main = THUNK(let {x = THUNK(plusInt one two) } in foo x); 8 | 9 | 10 | foo = FUN(x -> three) 11 | -------------------------------------------------------------------------------- /test/map.stg: -------------------------------------------------------------------------------- 1 | pzero = CON(Z); 2 | pone = CON(S pzero); 3 | list1 = CON(Cons pone nil); 4 | list2 = CON(Cons pone list1); 5 | list3 = CON(Cons pone list2); 6 | list4 = CON(Cons pone list3); 7 | consttrue = PAP(const true); 8 | main = THUNK( let { result = THUNK(map const list4); 9 | f = THUNK(forcelist result) 10 | } in seq f result ) 11 | -------------------------------------------------------------------------------- /test/fibs.stg: -------------------------------------------------------------------------------- 1 | # fibs = 1 : 1 : zipWith (+) fibs (tail fibs) 2 | 3 | fibs = THUNK(let { tailFibs = THUNK(tail fibs); 4 | zippedList = THUNK(zipWith plusInt fibs tailFibs); 5 | tailList = CON(Cons one zippedList); 6 | list = CON(Cons one tailList) 7 | } in list); 8 | 9 | main = THUNK( let { result = THUNK(take five fibs); 10 | f = THUNK(forcelist result) 11 | } in seq f result) 12 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ![Haskell CI](https://github.com/andreabedini/ministg/workflows/Haskell%20CI/badge.svg) 2 | 3 | Thank you for trying Ministg. Check out the [Documentation]. 4 | 5 | ## Usage 6 | 7 | ``` 8 | cabal run ministg -- data/Prelude.stg test/sum.stg 9 | ``` 10 | 11 | Note that the prelude is not automatically imported and has to be 12 | explicitly loaded. 13 | 14 | 15 | ## Feedback, feature requests or bug reports 16 | 17 | Bernie Pope: , alternatively issues on github. 18 | 19 | [Documentation]: http://www.haskell.org/haskellwiki/Ministg 20 | -------------------------------------------------------------------------------- /.github/workflows/haskell.yml: -------------------------------------------------------------------------------- 1 | name: Haskell CI 2 | 3 | on: [push] 4 | 5 | jobs: 6 | build: 7 | 8 | runs-on: ubuntu-latest 9 | strategy: 10 | matrix: 11 | ghc: [ '8.6.5', '8.8.1' ] 12 | steps: 13 | - uses: actions/checkout@v1 14 | - uses: actions/setup-haskell@v1 15 | with: 16 | ghc-version: ${{ matrix.ghc }} 17 | cabal-version: '3.0' 18 | - name: Install dependencies 19 | run: | 20 | cabal update 21 | cabal build --only-dependencies 22 | - name: Build 23 | run: | 24 | cabal configure --enable-tests 25 | cabal build 26 | - name: Run tests 27 | run: cabal test 28 | -------------------------------------------------------------------------------- /test/docs.stg: -------------------------------------------------------------------------------- 1 | nil = CON(Nil); 2 | zero = CON(I 0); 3 | one = CON(I 1); 4 | two = CON(I 2); 5 | three = CON(I 3); 6 | 7 | plusInt = FUN(x y -> 8 | case x of { 9 | I i -> case y of { 10 | I j -> case plus# i j of { 11 | x -> let { result = CON (I x) } in result }}}); 12 | 13 | foldl = FUN(f acc list -> 14 | case list of { 15 | Nil -> acc; 16 | Cons h t -> let { newAcc = THUNK(f acc h) } in foldl f newAcc t 17 | }); 18 | 19 | # lazy sum with a well-known space leak 20 | sum = FUN(list -> foldl plusInt zero list); 21 | 22 | list1 = CON(Cons one nil); 23 | list2 = CON(Cons two list1); 24 | list3 = CON(Cons three list2); 25 | 26 | main = THUNK(sum list3); 27 | -------------------------------------------------------------------------------- /src/Ministg/Utils.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Ministg.Utils 4 | -- Copyright : (c) 2009-2012 Bernie Pope 5 | -- License : BSD-style 6 | -- Maintainer : florbitous@gmail.com 7 | -- Stability : experimental 8 | -- Portability : ghc 9 | -- 10 | -- Some handy utilities. 11 | ----------------------------------------------------------------------------- 12 | module Ministg.Utils where 13 | 14 | import Control.Monad 15 | ( liftM ) 16 | import System.IO.Error (catchIOError) 17 | 18 | safeReadFile :: FilePath -> IO (Either String String) 19 | safeReadFile file 20 | = catchIOError (rightReadFile file) $ \error -> return $ Left $ show error 21 | where 22 | rightReadFile :: FilePath -> IO (Either String String) 23 | rightReadFile file = liftM Right $ readFile file 24 | -------------------------------------------------------------------------------- /src/Ministg/CallStack.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | ----------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Ministg.CallStack 5 | -- Copyright : (c) 2009-2012 Bernie Pope 6 | -- License : BSD-style 7 | -- Maintainer : florbitous@gmail.com 8 | -- Stability : experimental 9 | -- Portability : ghc 10 | -- 11 | -- Stack of program annotations. Simulate a call stack. 12 | ----------------------------------------------------------------------------- 13 | 14 | module Ministg.CallStack (CallStack, push, showCallStack, prettyCallStack) where 15 | 16 | import Ministg.Pretty 17 | #if MIN_VERSION_base(4,11,0) 18 | import Prelude hiding ((<>)) 19 | #endif 20 | 21 | type CallStack = [String] 22 | 23 | push :: String -> CallStack -> CallStack 24 | push = (:) 25 | 26 | showCallStack :: CallStack -> String 27 | showCallStack = unlines 28 | 29 | prettyCallStack :: CallStack -> Doc 30 | prettyCallStack [] = empty 31 | prettyCallStack stack = char '<' <> hcat (punctuate (text "|") (map text stack)) <> char '>' 32 | -------------------------------------------------------------------------------- /src/Ministg/Annotate.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Ministg.Annotate 4 | -- Copyright : (c) 2009-2012 Bernie Pope 5 | -- License : BSD-style 6 | -- Maintainer : florbitous@gmail.com 7 | -- Stability : experimental 8 | -- Portability : ghc 9 | -- 10 | -- Add stack annotations to top-level functions in ministg programs. 11 | ----------------------------------------------------------------------------- 12 | module Ministg.Annotate where 13 | 14 | import Ministg.AST 15 | 16 | class Annotate t where 17 | annotate :: t -> t 18 | 19 | instance Annotate a => Annotate [a] where 20 | annotate = map annotate 21 | 22 | instance Annotate Program where 23 | annotate (Program decls) = Program $ annotate decls 24 | 25 | instance Annotate Decl where 26 | -- don't annotate functions which are already annotated (by the user) 27 | annotate decl@(Decl _ (Fun _ (Stack {}))) = decl 28 | annotate (Decl var (Fun args body)) 29 | = Decl var (Fun args (Stack var body)) 30 | -- don't annotate thunks which are already annotated (by the user) 31 | annotate decl@(Decl _ (Thunk (Stack {}) _)) = decl 32 | annotate decl@(Decl var (Thunk body callStack)) 33 | = Decl var (Thunk (Stack var body) callStack) 34 | annotate other = other 35 | -------------------------------------------------------------------------------- /src/Ministg/Pretty.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Ministg.Pretty 4 | -- Copyright : (c) 2009-2012 Bernie Pope 5 | -- License : BSD-style 6 | -- Maintainer : florbitous@gmail.com 7 | -- Stability : experimental 8 | -- Portability : ghc 9 | -- 10 | -- Convenient class wrapper for pretty printing. 11 | ----------------------------------------------------------------------------- 12 | 13 | module Ministg.Pretty (module Ministg.Pretty, module HPJ) where 14 | 15 | import Text.PrettyPrint.HughesPJ as HPJ 16 | 17 | class Pretty a where 18 | pretty :: a -> Doc 19 | 20 | prettyText :: Pretty a => a -> String 21 | prettyText = render . pretty 22 | 23 | parensIf :: Pretty a => (a -> Bool) -> a -> Doc 24 | parensIf test x = if test x then parens $ pretty x else pretty x 25 | 26 | tuple :: Pretty a => [a] -> Doc 27 | tuple = parens . hsep . punctuate comma . map pretty 28 | 29 | instance Pretty Int where 30 | pretty = int 31 | 32 | instance Pretty Integer where 33 | pretty = integer 34 | 35 | instance Pretty Char where 36 | pretty = char 37 | 38 | instance Pretty Double where 39 | pretty = double 40 | 41 | instance Pretty Bool where 42 | pretty True = text "True" 43 | pretty False = text "False" 44 | 45 | instance Pretty a => Pretty (Maybe a) where 46 | pretty Nothing = empty 47 | pretty (Just x) = pretty x 48 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2009 Bernard James Pope 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions 7 | are met: 8 | 1. Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 2. Redistributions in binary form must reproduce the above copyright 11 | notice, this list of conditions and the following disclaimer in the 12 | documentation and/or other materials provided with the distribution. 13 | 3. Neither the name of the author nor the names of his contributors 14 | may be used to endorse or promote products derived from this software 15 | without specific prior written permission. 16 | 17 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 18 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 19 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 20 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR 21 | CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 22 | EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, 23 | PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 24 | PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 25 | LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 26 | NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 27 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 28 | -------------------------------------------------------------------------------- /src/Ministg/GC.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Ministg.GC 4 | -- Copyright : (c) 2009-2012 Bernie Pope 5 | -- License : BSD-style 6 | -- Maintainer : florbitous@gmail.com 7 | -- Stability : experimental 8 | -- Portability : ghc 9 | -- 10 | -- Garbage collection for ministg. 11 | ----------------------------------------------------------------------------- 12 | module Ministg.GC where 13 | 14 | import Data.Set as Set hiding (map) 15 | import Data.Map as Map hiding (map, fold) 16 | import Control.Monad.Trans (liftIO) 17 | import Control.Monad.State (gets) 18 | import Ministg.Pretty 19 | import Ministg.State 20 | import Ministg.AST 21 | 22 | garbageCollect :: Exp -> Stack -> Heap -> Eval Heap 23 | garbageCollect exp stack heap = do 24 | wantGC <- gets state_gc 25 | if wantGC 26 | then return $ collect roots heap Map.empty 27 | else return heap 28 | where 29 | roots = freeVars exp `Set.union` freeVars stack 30 | 31 | collect :: Set Var -> Heap -> Heap -> Heap 32 | collect vars oldHeap newHeap 33 | = collector vars newHeap 34 | where 35 | collector vars newHeap 36 | | Set.null vars = newHeap 37 | | otherwise = collector newVars nextHeap 38 | where 39 | (newVars, nextHeap) = fold collectVar (Set.empty, newHeap) vars 40 | collectVar :: Var -> (Set Var, Heap) -> (Set Var, Heap) 41 | collectVar var (vars, heap) 42 | | Map.member var heap = (vars, heap) 43 | | otherwise = (newVars, newHeap) 44 | where 45 | object = lookupHeap var oldHeap 46 | newVars = freeVars object `Set.union` vars 47 | newHeap = updateHeap var object heap 48 | -------------------------------------------------------------------------------- /ministg.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: >=1.8 2 | name: ministg 3 | version: 0.3 4 | license: BSD3 5 | license-file: LICENSE 6 | copyright: (c) 2009-2012 Bernard James Pope 7 | maintainer: florbitous@gmail.com 8 | author: Bernard James Pope 9 | stability: experimental 10 | tested-with: ghc ==7.4.1 ghc ==8.6.5 ghc ==8.8.1 11 | homepage: http://www.haskell.org/haskellwiki/Ministg 12 | synopsis: an interpreter for an operational semantics for the STG machine. 13 | description: 14 | ministg is an interpreter for a simple high-level operational semantics for the STG machine. The 15 | semantics is taken from the research paper "Making a fast curry: push/enter vs. eval/apply 16 | for higher-order languages", by Simon Marlow and Simon Peyton Jones. It provides the option 17 | to trace the execution of the interpreter, rendering each step in a HTML file. This is useful 18 | for understanding the behaviour of the STG machine, and also useful for experimenting with 19 | changes to the machine. It also supports an experimental call stack tracing facility. 20 | category: Language 21 | build-type: Simple 22 | extra-source-files: 23 | README.md 24 | test/*.stg 25 | 26 | source-repository head 27 | type: git 28 | location: https://github.com/bjpop/ministg.git 29 | 30 | library 31 | exposed-modules: 32 | Ministg.AST 33 | Ministg.Lexer 34 | Ministg.Parser 35 | Ministg.Utils 36 | Ministg.Eval 37 | Ministg.Arity 38 | Ministg.Pretty 39 | Ministg.State 40 | Ministg.TraceEval 41 | Ministg.CallStack 42 | Ministg.Options 43 | Ministg.GC 44 | Ministg.Annotate 45 | hs-source-dirs: src 46 | build-depends: 47 | base >=3 && <5, 48 | monads-tf -any, 49 | transformers <0.6, 50 | containers <0.7, 51 | parsec >=3 && <3.2, 52 | pretty <1.2, 53 | xhtml <3000.3, 54 | filepath <1.5 55 | 56 | executable ministg 57 | main-is: src/Main.hs 58 | build-depends: 59 | ministg -any, 60 | base >=3 && <5, 61 | directory <1.4 62 | -------------------------------------------------------------------------------- /src/Ministg/Arity.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -XTypeSynonymInstances #-} 2 | ----------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Ministg.Arity 5 | -- Copyright : (c) 2009-2012 Bernie Pope 6 | -- License : BSD-style 7 | -- Maintainer : florbitous@gmail.com 8 | -- Stability : experimental 9 | -- Portability : ghc 10 | -- 11 | -- Arity analysis of ministg programs: compute how many arguments each 12 | -- top-level and let-bound function has, and annotate the application sites 13 | -- of those functions. 14 | ----------------------------------------------------------------------------- 15 | 16 | module Ministg.Arity (runArity, Arity) where 17 | 18 | import qualified Data.Map as Map 19 | import Data.Map (Map) 20 | import Control.Monad.Reader 21 | import Control.Applicative 22 | import Ministg.AST 23 | import Data.List (foldl') 24 | 25 | -- | A mapping from variable names (names of functions) to their respective 26 | -- arities. 27 | type ArityMap = Map Var Int 28 | -- | A monad for pushing arity information down the AST, taking care of 29 | -- variable scope. 30 | type A a = Reader ArityMap a 31 | 32 | -- | Arity analysis of a program fragment. 33 | runArity :: Arity a => a -> a 34 | runArity x = runReader (arity x) Map.empty 35 | 36 | -- | Overloaded arity function. 37 | class Arity a where 38 | arity :: a -> A a 39 | 40 | instance Arity Alt where 41 | arity (PatAlt con args body) = 42 | PatAlt con args <$> local (clearVars args) (arity body) 43 | arity (DefaultAlt var body) = 44 | DefaultAlt var <$> local (clearVars [var]) (arity body) 45 | 46 | instance Arity Object where 47 | arity (Fun args body) = Fun args <$> local (clearVars args) (arity body) 48 | arity (Thunk exp cs) = Thunk <$> arity exp <*> pure cs 49 | arity other = return other 50 | 51 | instance Arity Program where 52 | arity (Program decls) = Program <$> (local (Map.union as) $ mapM arity decls) 53 | where 54 | as :: ArityMap 55 | as = Map.fromList [ (var, countArgs obj) | Decl var obj <- decls, isFun obj] 56 | 57 | -- | Count the number of arguments (really parameters) of a function object). 58 | countArgs :: Object -> Int 59 | countArgs (Fun args _) = length args 60 | countArgs other = error $ "countArgs called on non function: " ++ show other 61 | 62 | instance Arity Decl where 63 | arity (Decl var object) = Decl var <$> arity object 64 | 65 | instance Arity Exp where 66 | arity (FunApp _oldArity var args) = 67 | FunApp <$> asks (Map.lookup var) <*> pure var <*> pure args 68 | arity (Let var object exp) 69 | | isFun object = 70 | Let var <$> arity object <*> local (Map.insert var $ countArgs object) (arity exp) 71 | | otherwise = Let var <$> arity object <*> local (clearVars [var]) (arity exp) 72 | arity (Case exp alts) = Case <$> arity exp <*> mapM arity alts 73 | arity (Stack annotation exp) = Stack annotation <$> arity exp 74 | arity exp@(Atom {}) = return exp 75 | arity exp@(PrimApp {}) = return exp 76 | 77 | -- | Remove a list of variables from an ArityMap. 78 | clearVars :: [Var] -> ArityMap -> ArityMap 79 | clearVars vars map = foldl' (flip Map.delete) map vars 80 | -------------------------------------------------------------------------------- /data/Prelude.stg: -------------------------------------------------------------------------------- 1 | error = ERROR; 2 | unit = CON(Unit); 3 | true = CON(True); 4 | false = CON(False); 5 | nil = CON(Nil); 6 | zero = CON(I 0); 7 | one = CON(I 1); 8 | two = CON(I 2); 9 | three = CON(I 3); 10 | four = CON(I 4); 11 | five = CON(I 5); 12 | six = CON(I 6); 13 | seven = CON(I 7); 14 | eight = CON(I 8); 15 | nine = CON(I 9); 16 | ten = CON(I 10); 17 | 18 | multInt = FUN(x y -> 19 | case x of { 20 | I i -> case y of { 21 | I j -> case mult# i j of { 22 | x -> let { result = CON (I x) } in result }}}); 23 | 24 | plusInt = FUN(x y -> 25 | case x of { 26 | I i -> case y of { 27 | I j -> case plus# i j of { 28 | x -> let { result = CON (I x) } in result }}}); 29 | 30 | subInt = FUN(x y -> 31 | case x of 32 | { I i -> 33 | case y of 34 | { I j -> case sub# i j of 35 | { x -> let { result = CON (I x) } in result }}}); 36 | 37 | eqInt = FUN(x y -> 38 | case x of 39 | { I i -> 40 | case y of 41 | { I j -> case eq# i j of 42 | { x -> intToBool# x }}}); 43 | 44 | append = FUN(l1 l2 -> 45 | case l1 of 46 | { Nil -> l2; 47 | Cons hd tl -> let { rec = THUNK(append tl l2); 48 | result = CON(Cons hd rec) } 49 | in result }); 50 | 51 | const = FUN(x y -> x); 52 | apply = FUN(f x -> f x); 53 | 54 | map = FUN(f list -> 55 | case list of { 56 | Nil -> nil; 57 | Cons h t -> let { x = THUNK(f h); rec = THUNK(map f t); res = CON(Cons x rec) } in res 58 | }); 59 | 60 | take = FUN(n xs -> 61 | case eqInt n zero of 62 | { True -> nil; 63 | False -> case xs of 64 | { Nil -> nil; 65 | Cons hd tl -> let { m = THUNK(subInt n one); 66 | rec = THUNK(take m tl); 67 | result = CON(Cons hd rec) } in result }}); 68 | 69 | head = FUN(xs -> case xs of { Cons hd tl -> hd }); 70 | tail = FUN(xs -> case xs of { Cons hd tl -> tl }); 71 | 72 | foldl = FUN(f acc list -> 73 | case list of { 74 | Nil -> acc; 75 | Cons h t -> let { newAcc = THUNK(f acc h) } in foldl f newAcc t 76 | }); 77 | 78 | # lazy sum with a well-known space leak 79 | sum = FUN(list -> foldl plusInt zero list); 80 | 81 | zipWith = FUN(f list1 list2 -> 82 | case list1 of { 83 | Nil -> nil; 84 | Cons h1 t1 -> 85 | case list2 of { 86 | Nil -> nil; 87 | Cons h2 t2 -> 88 | let { newHead = THUNK(f h1 h2); 89 | newTail = THUNK(zipWith f t1 t2); 90 | result = CON(Cons newHead newTail) 91 | } in result 92 | } 93 | }); 94 | 95 | seq = FUN(x y -> case x of { z -> y }); 96 | 97 | forcelist = FUN(list -> 98 | case list of { 99 | Nil -> unit; 100 | Cons h t -> let { rec = THUNK(forcelist t) } in seq h rec }); 101 | -------------------------------------------------------------------------------- /src/Main.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Main 4 | -- Copyright : (c) 2009-2012 Bernie Pope 5 | -- License : BSD-style 6 | -- Maintainer : florbitous@gmail.com 7 | -- Stability : experimental 8 | -- Portability : ghc 9 | -- 10 | -- The main module of ministg. An interpreter for the operational semantics 11 | -- of the STG machine, as set out in the "How to make a fast curry" paper 12 | -- by Simon Marlow and Simon Peyton Jones. 13 | ----------------------------------------------------------------------------- 14 | 15 | module Main where 16 | 17 | import Data.Monoid (mconcat) 18 | import System.Exit (exitFailure) 19 | import Ministg.AST (Program (Program)) 20 | import Ministg.Parser (parser) 21 | import Ministg.Lexer (lexer, Token) 22 | import Control.Monad (when, unless) 23 | import System.Environment (getArgs) 24 | import System.Directory (doesDirectoryExist, createDirectory) 25 | import Ministg.Utils (safeReadFile) 26 | import Ministg.Arity (runArity) 27 | import Ministg.Eval (run) 28 | import Ministg.Pretty (prettyText) 29 | import Ministg.Options (processOptions, Flag (..), Dumped (..), existsFlag, getTraceDir) 30 | import Ministg.Annotate 31 | 32 | -- | The main driver of the program. 33 | main :: IO () 34 | main = do 35 | args <- getArgs 36 | (flags, files) <- processOptions args 37 | -- create trace directory if necessary 38 | when (existsFlag flags Trace) $ do 39 | let traceDir = getTraceDir flags 40 | dirExist <- doesDirectoryExist traceDir 41 | unless dirExist $ createDirectory traceDir 42 | -- parse the files 43 | programs <- traverse (parseFile flags) files 44 | -- Program userProgram <- parseFile flags files 45 | -- optionally include the Prelude 46 | let fullProgram = mconcat programs 47 | -- possibly annotate the program with stack markers 48 | let annotated = if existsFlag flags Annotate 49 | then annotate fullProgram else fullProgram 50 | -- compute arities of known functions 51 | let arityProgram = runArity annotated 52 | dump flags DumpArity (prettyText arityProgram) 53 | "The program after arity analysis:\n" 54 | -- interpret the program 55 | run flags arityProgram 56 | 57 | parseFile :: [Flag] -> FilePath -> IO Program 58 | parseFile flags file = do 59 | tryContents <- safeReadFile file 60 | case tryContents of 61 | Left errorMsg -> do putStrLn $ "Error reading from file: " ++ file 62 | putStrLn errorMsg >> exitFailure 63 | Right contents -> 64 | -- parse the program 65 | case parser file contents of 66 | Left e -> putStrLn ("Parse error: " ++ show e) >> exitFailure 67 | Right program -> do 68 | dump flags DumpAST (show program) $ "The AST of the program from " ++ file ++ ":\n" 69 | dump flags DumpParsed (prettyText program) $ 70 | "The parsed program from " ++ file ++ ":\n" 71 | return program 72 | 73 | dump :: [Flag] -> Dumped -> String -> String -> IO () 74 | dump flags dumped str msg = 75 | when (existsFlag flags $ Dump dumped) $ do 76 | putStrLn msg 77 | putStrLn str 78 | putStr "\n" 79 | -------------------------------------------------------------------------------- /src/Ministg/Lexer.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Ministg.Lexer 4 | -- Copyright : (c) 2009-2012 Bernie Pope 5 | -- License : BSD-style 6 | -- Maintainer : florbitous@gmail.com 7 | -- Stability : experimental 8 | -- Portability : ghc 9 | -- 10 | -- Lexical analysis for ministg programs. 11 | ----------------------------------------------------------------------------- 12 | 13 | module Ministg.Lexer 14 | ( Token (..) 15 | , Symbol (..) 16 | , Ident 17 | , lexer 18 | ) 19 | where 20 | 21 | import Data.Char 22 | ( isDigit 23 | , isAlpha 24 | , isPrint 25 | , isLower 26 | ) 27 | 28 | import Text.ParserCombinators.Parsec hiding (token) 29 | import Control.Applicative hiding ((<|>), many) 30 | 31 | newtype Token = Token (SourcePos, Symbol) 32 | 33 | instance Show Token where 34 | show (Token (pos, symbol)) = show symbol 35 | 36 | type Ident = String 37 | 38 | data Symbol 39 | = Variable Ident 40 | | Constructor Ident 41 | | Natural Integer 42 | | QuotedString String 43 | | Equals 44 | | BackSlash 45 | | RightArrow 46 | | Let 47 | | In 48 | | Case 49 | | Of 50 | | LeftParen 51 | | RightParen 52 | | LeftBrace 53 | | RightBrace 54 | | SemiColon 55 | | Fun 56 | | Con 57 | | Pap 58 | | Thunk 59 | | Plus 60 | | Minus 61 | | Times 62 | | Equality 63 | | GreaterThan 64 | | LessThan 65 | | GreaterThanEquals 66 | | LessThanEquals 67 | | IntToBool 68 | | Stack 69 | | Error 70 | deriving (Eq, Show) 71 | 72 | lexer :: String -> String -> Either ParseError [Token] 73 | lexer = parse tokenise 74 | 75 | tokenise :: Parser [Token] 76 | tokenise = skip *> sepEndBy token skip <* eof 77 | 78 | skip :: Parser () 79 | skip = skipMany (comment <|> whiteSpace) 80 | 81 | whiteSpace :: Parser () 82 | whiteSpace = space >> return () 83 | 84 | comment :: Parser () 85 | comment = singleLineComment 86 | 87 | singleLineComment :: Parser () 88 | singleLineComment = string "#" >> manyTill anyChar eol >> return () 89 | 90 | eol :: Parser () 91 | eol = newline >> return () 92 | 93 | -- XXX Perhaps it is not sensible to divide the tokens based on their 94 | -- syntactic role. Sometimes tokens from different syntactic classes can have 95 | -- the same prefix. 96 | token :: Parser Token 97 | token = 98 | punctuation <|> 99 | keyword <|> 100 | variable <|> 101 | constructor <|> 102 | parenthesis <|> 103 | number <|> 104 | quotedString 105 | 106 | number :: Parser Token 107 | number = tokenPos parseNum Natural 108 | where 109 | parseNum :: Parser Integer 110 | parseNum = read <$> many1 digit 111 | 112 | quotedString :: Parser Token 113 | quotedString = tokenPos parseString QuotedString 114 | where 115 | parseString :: Parser String 116 | parseString = char '"' *> manyTill anyChar (char '"') 117 | 118 | variable :: Parser Token 119 | variable = tokenPos (parseIdent lower) Variable 120 | 121 | constructor :: Parser Token 122 | constructor = tokenPos (parseIdent upper) Constructor 123 | 124 | parseIdent :: Parser Char -> Parser String 125 | parseIdent firstChar = (:) <$> firstChar <*> many (char '_' <|> alphaNum) 126 | 127 | keyword :: Parser Token 128 | keyword = 129 | key "let" Let <|> 130 | key "in" In <|> 131 | key "case" Case <|> 132 | key "of" Of <|> 133 | key "FUN" Fun <|> 134 | key "CON" Con <|> 135 | key "PAP" Pap <|> 136 | key "THUNK" Thunk <|> 137 | key "plus#" Plus <|> 138 | key "sub#" Minus <|> 139 | key "mult#" Times <|> 140 | key "eq#" Equality <|> 141 | key "lt#" LessThan <|> 142 | key "lte#" LessThanEquals <|> 143 | key "gt#" GreaterThan <|> 144 | key "gte#" GreaterThanEquals <|> 145 | key "intToBool#" IntToBool <|> 146 | key "ERROR" Error <|> 147 | key "stack" Stack 148 | where 149 | key :: String -> Symbol -> Parser Token 150 | key str keyWord = tokenPos (try kwParser) (const keyWord) 151 | where 152 | kwParser = string str >> notFollowedBy alphaNum 153 | 154 | parenthesis :: Parser Token 155 | parenthesis = 156 | simpleTok "(" LeftParen <|> 157 | simpleTok ")" RightParen <|> 158 | simpleTok "{" LeftBrace <|> 159 | simpleTok "}" RightBrace 160 | 161 | punctuation :: Parser Token 162 | punctuation = 163 | simpleTok "=" Equals 164 | <|> simpleTok ";" SemiColon 165 | <|> simpleTok "\\" BackSlash 166 | <|> simpleTok "->" RightArrow 167 | 168 | simpleTok :: String -> Symbol -> Parser Token 169 | simpleTok str token = tokenPos (string str) (const token) 170 | 171 | tokenPos :: Parser a -> (a -> Symbol) -> Parser Token 172 | tokenPos parser mkToken = 173 | Token <$> ((,) <$> getPosition <*> (mkToken <$> parser)) 174 | -------------------------------------------------------------------------------- /src/Ministg/TraceEval.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -XPatternGuards #-} 2 | ----------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Ministg.TraceEval 5 | -- Copyright : (c) 2009-2012 Bernie Pope 6 | -- License : BSD-style 7 | -- Maintainer : florbitous@gmail.com 8 | -- Stability : experimental 9 | -- Portability : ghc 10 | -- 11 | -- Trace the evaluation steps of the interpreter and generate HTML output. 12 | ----------------------------------------------------------------------------- 13 | 14 | module Ministg.TraceEval (traceEval, traceEnd, traceMaxStepsExceeded) where 15 | 16 | import System.FilePath ((<.>), ()) 17 | import Control.Monad (when, join) 18 | import Control.Monad.Trans (liftIO) 19 | import Control.Monad.State (gets) 20 | import Control.Applicative ((<$>)) 21 | import Text.XHtml.Transitional as Html 22 | import Text.XHtml.Table hiding (()) 23 | import Data.Map as Map (toList) 24 | import Ministg.AST 25 | import Ministg.CallStack (CallStack, push, showCallStack) 26 | import Ministg.Pretty as Pretty (pretty, Doc, ($$), nest, render, text) 27 | import Ministg.State 28 | import Data.List as List (sortBy) 29 | 30 | traceEval :: Exp -> Stack -> Heap -> Eval () 31 | traceEval exp stack heap = do 32 | traceOn <- gets state_trace 33 | when traceOn $ 34 | join (writeTraceFile <$> makeHtml exp stack heap) 35 | 36 | traceMaxStepsExceeded :: Eval () 37 | traceMaxStepsExceeded = do 38 | maxSteps <- gets state_maxTraceSteps 39 | lastTracePage ("Maximum trace steps " ++ show maxSteps ++ " exceeded") 40 | 41 | traceEnd :: Eval () 42 | traceEnd = do 43 | traceOn <- gets state_trace 44 | when traceOn $ lastTracePage "The computation has completed" 45 | 46 | lastTracePage :: String -> Eval () 47 | lastTracePage msg = join (writeTraceFile <$> lastPage msg) 48 | 49 | writeTraceFile :: Html -> Eval () 50 | writeTraceFile html = do 51 | traceFile <- nextTraceFileName 52 | liftIO $ writeFile traceFile $ renderHtml html 53 | 54 | nextTraceFileName :: Eval FilePath 55 | nextTraceFileName = do 56 | traceDir <- gets state_traceDir 57 | count <- gets state_stepCount 58 | return $ traceDir mkHtmlFileName count 59 | 60 | lastPage :: String -> Eval Html 61 | lastPage msg = do 62 | count <- gets state_stepCount 63 | return (theHead +++ theBody count) 64 | where 65 | theHead = header << thetitle << msg 66 | theBody count 67 | = body << (mainHeading +++ navigation) 68 | where 69 | mainHeading = h1 << msg 70 | navigation = paragraph ((anchor << "previous") ! [href $ mkHtmlFileName (count - 1)]) 71 | 72 | makeHtml :: Exp -> Stack -> Heap -> Eval Html 73 | makeHtml exp stack heap = do 74 | count <- gets state_stepCount 75 | rule <- gets state_lastRule 76 | callStack <- gets state_callStack 77 | wantCallStack <- gets state_traceCallStack 78 | return $ headAndBody count rule 79 | (if wantCallStack then Just callStack else Nothing) 80 | where 81 | headAndBody count rule maybeCallStack = theHead +++ theBody 82 | where 83 | stepStr = "Step " ++ show count 84 | theHead = header << thetitle << stepStr 85 | theBody = 86 | body << (mainHeading +++ navigation +++ ruleSection +++ expStackSection +++ heapSection) 87 | where 88 | mainHeading = h1 << stepStr 89 | navigation = paragraph (previous +++ " " +++ next) 90 | previous = if count == 0 then noHtml 91 | else (anchor << "previous") ! [href $ mkHtmlFileName (count - 1)] 92 | next = (anchor << "next") ! [href $ mkHtmlFileName (count + 1)] 93 | ruleSection = if null rule then noHtml 94 | else (h3 << "Most recent rule applied") +++ (paragraph << rule) 95 | expStackSection = (h3 << "Stack and Code") +++ expStackCallTable exp stack maybeCallStack 96 | heapSection = (h3 << "Heap") +++ heapTable heap 97 | 98 | expStackCallTable :: Exp -> Stack -> Maybe CallStack -> Html 99 | expStackCallTable exp stack maybeCallStack 100 | = simpleTable [border 3, cellpadding 10] [thestyle "vertical-align:top"] rows 101 | where 102 | rows | Just callStack <- maybeCallStack = 103 | [stackExprHeading ++ callStackHeading, stackExprData ++ callStackData callStack] 104 | | otherwise = [stackExprHeading, stackExprData] 105 | where 106 | stackExprHeading = [stringToHtml "Stack", stringToHtml "Expression"] 107 | stackExprData = [stackTable stack, pre << expStr] 108 | callStackHeading = [stringToHtml "Call Stack"] 109 | callStackData callStack = [callStackTable callStack] 110 | expStr = render $ pretty exp 111 | 112 | stackTable :: Stack -> Html 113 | stackTable [] = noHtml 114 | stackTable stack 115 | = simpleTable [border 1, cellpadding 5, cellspacing 0] 116 | [] (map stackRow stack) 117 | where 118 | stackRow :: Continuation -> [Html] 119 | stackRow cont = [ pre << (render $ pretty cont) ] 120 | 121 | callStackTable :: CallStack -> Html 122 | callStackTable [] = noHtml 123 | callStackTable stack 124 | = simpleTable [border 1, cellpadding 5, cellspacing 0] 125 | [] (map stackRow stack) 126 | where 127 | stackRow :: String -> [Html] 128 | stackRow str = [ pre << str ] 129 | 130 | heapTable :: Heap -> Html 131 | heapTable heap 132 | = simpleTable [border 3, cellpadding 5, cellspacing 0] 133 | [] (headingRow : map heapRow mappings) 134 | where 135 | headingRow = [stringToHtml "Variable", stringToHtml "Object"] 136 | mappings = List.sortBy (\(x,_) (y,_) -> compare x y) $ Map.toList heap 137 | heapRow :: (Var, Object) -> [Html] 138 | heapRow (var, obj) = [pre << var, pre << render (pretty obj)] 139 | 140 | mkHtmlFileName :: Integer -> FilePath 141 | mkHtmlFileName count = "step" ++ show count <.> "html" 142 | -------------------------------------------------------------------------------- /src/Ministg/Parser.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Ministg.Parser 4 | -- Copyright : (c) 2009-2012 Bernie Pope 5 | -- License : BSD-style 6 | -- Maintainer : florbitous@gmail.com 7 | -- Stability : experimental 8 | -- Portability : ghc 9 | -- 10 | -- Parsing for ministg programs. 11 | ----------------------------------------------------------------------------- 12 | module Ministg.Parser (parser) where 13 | 14 | import Prelude hiding (exp, subtract) 15 | import Text.ParserCombinators.Parsec hiding (Parser) 16 | import qualified Ministg.Lexer as Lex 17 | import Ministg.AST hiding (rightArrow) 18 | import Control.Applicative hiding ((<|>), many) 19 | 20 | type Parser a = GenParser Lex.Token () a 21 | 22 | tokenParser :: (Lex.Symbol -> Maybe a) -> Parser a 23 | tokenParser test 24 | = token showToken posToken testToken 25 | where 26 | showToken (Lex.Token (pos,tok)) = show tok 27 | posToken (Lex.Token (pos,tok)) = pos 28 | testToken (Lex.Token (pos,tok)) = test tok 29 | 30 | symbol :: Lex.Symbol -> Parser () 31 | symbol tok 32 | = tokenParser $ 33 | \next -> if next == tok then Just () else Nothing 34 | 35 | parser :: FilePath -> String -> Either ParseError Program 36 | parser source input 37 | = case Lex.lexer source input of 38 | Left err -> Left err 39 | Right toks -> parse program source toks 40 | 41 | program :: Parser Program 42 | program = Program <$> sepEndBy decl semiColon <* eof 43 | 44 | decl :: Parser Decl 45 | decl = Decl <$> var <*> (equals *> object) 46 | 47 | exp :: Parser Exp 48 | exp = funCallOrVar <|> 49 | expAtomLiteral <|> 50 | primApp <|> 51 | letExp <|> 52 | caseExp <|> 53 | stack 54 | 55 | stack :: Parser Exp 56 | stack = Stack <$> (symbol Lex.Stack *> quotedString) <*> exp 57 | 58 | quotedString :: Parser String 59 | quotedString = tokenParser getString 60 | where 61 | getString (Lex.QuotedString s) = Just s 62 | getString other = Nothing 63 | 64 | funCallOrVar :: Parser Exp 65 | funCallOrVar = do 66 | v <- var 67 | args <- many atom 68 | return $ if null args 69 | then Atom $ Variable v 70 | -- we don't know the arity of the function yet. 71 | else FunApp Nothing v args 72 | 73 | expAtomLiteral :: Parser Exp 74 | expAtomLiteral = Atom <$> atomLiteral 75 | 76 | expAtom :: Parser Exp 77 | expAtom = Atom <$> atom 78 | 79 | primApp :: Parser Exp 80 | primApp = PrimApp <$> primOp <*> many1 atom 81 | 82 | primOp, add, subtract, multiply, eq, lessThan, greaterThan, lessThanEquals, greaterThanEquals :: Parser Prim 83 | 84 | primOp = 85 | add <|> 86 | subtract <|> 87 | multiply <|> 88 | eq <|> 89 | lessThan <|> 90 | greaterThan <|> 91 | lessThanEquals <|> 92 | greaterThanEquals <|> 93 | intToBool 94 | 95 | add = const Add <$> symbol Lex.Plus 96 | subtract = const Subtract <$> symbol Lex.Minus 97 | multiply = const Multiply <$> symbol Lex.Times 98 | eq = const Equality <$> symbol Lex.Equality 99 | lessThan = const LessThan <$> symbol Lex.LessThan 100 | lessThanEquals = const LessThanEquals <$> symbol Lex.LessThanEquals 101 | greaterThan = const GreaterThan <$> symbol Lex.GreaterThan 102 | greaterThanEquals = const GreaterThanEquals <$> symbol Lex.GreaterThanEquals 103 | intToBool = const IntToBool <$> symbol Lex.IntToBool 104 | 105 | letExp :: Parser Exp 106 | letExp = flattenLet <$> (symbol Lex.Let *> leftBrace *> sepEndBy1 decl semiColon <* rightBrace) <*> (symbol Lex.In *> exp) 107 | 108 | flattenLet :: [Decl] -> Exp -> Exp 109 | flattenLet [Decl var obj] body = Let var obj body 110 | flattenLet (Decl var obj : decls) body = Let var obj $ flattenLet decls body 111 | 112 | caseExp :: Parser Exp 113 | caseExp = Case <$> (symbol Lex.Case *> exp) <*> (symbol Lex.Of *> leftBrace *> sepEndBy1 alt semiColon <* rightBrace) 114 | 115 | atom, atomLiteral, atomVariable :: Parser Atom 116 | atom = atomLiteral <|> atomVariable 117 | atomLiteral = Literal <$> literal 118 | atomVariable = Variable <$> var 119 | 120 | literal :: Parser Literal 121 | literal = Integer <$> natural 122 | 123 | alt :: Parser Alt 124 | alt = patAlt <|> defaultAlt 125 | 126 | patAlt :: Parser Alt 127 | patAlt = PatAlt <$> constructor <*> many var <*> (rightArrow *> exp) 128 | 129 | defaultAlt :: Parser Alt 130 | defaultAlt = DefaultAlt <$> var <*> (rightArrow *> exp) 131 | 132 | object :: Parser Object 133 | object = fun <|> pap <|> con <|> thunk <|> errorObj 134 | 135 | fun, pap, con, thunk, errorObj :: Parser Object 136 | fun = Fun <$> (symbol Lex.Fun *> leftParen *> many1 var) <*> (rightArrow *> exp <* rightParen) 137 | pap = Pap <$> (symbol Lex.Pap *> leftParen *> var) <*> (many1 atom <* rightParen) 138 | con = Con <$> (symbol Lex.Con *> leftParen *> constructor) <*> (many atom <* rightParen) 139 | thunk = Thunk <$> (symbol Lex.Thunk *> leftParen *> exp <* rightParen) <*> pure [] 140 | errorObj = const Error <$> symbol Lex.Error 141 | 142 | var :: Parser Var 143 | var = tokenParser getIdent 144 | where 145 | getIdent (Lex.Variable s) = Just s 146 | getIdent other = Nothing 147 | 148 | constructor :: Parser Constructor 149 | constructor = tokenParser getIdent 150 | where 151 | getIdent (Lex.Constructor s) = Just s 152 | getIdent other = Nothing 153 | 154 | equals :: Parser () 155 | equals = symbol Lex.Equals 156 | 157 | semiColon :: Parser () 158 | semiColon = symbol Lex.SemiColon 159 | 160 | rightArrow :: Parser () 161 | rightArrow = symbol Lex.RightArrow 162 | 163 | leftParen, rightParen :: Parser () 164 | leftParen = symbol Lex.LeftParen 165 | rightParen = symbol Lex.RightParen 166 | 167 | leftBrace, rightBrace :: Parser () 168 | leftBrace = symbol Lex.LeftBrace 169 | rightBrace = symbol Lex.RightBrace 170 | 171 | natural :: Parser Integer 172 | natural = 173 | tokenParser getNat 174 | where 175 | getNat :: Lex.Symbol -> Maybe Integer 176 | getNat (Lex.Natural n) = Just n 177 | getNat other = Nothing 178 | -------------------------------------------------------------------------------- /src/Ministg/Options.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Ministg.Options 4 | -- Copyright : (c) 2009-2012 Bernie Pope 5 | -- License : BSD-style 6 | -- Maintainer : florbitous@gmail.com 7 | -- Stability : experimental 8 | -- Portability : ghc 9 | -- 10 | -- Command line option processing. 11 | ----------------------------------------------------------------------------- 12 | module Ministg.Options 13 | ( processOptions 14 | , programName 15 | , defaultMaxSteps 16 | , defaultEvalStyle 17 | , defaultTraceDir 18 | , Flag (..) 19 | , EvalStyle (..) 20 | , Dumped (..) 21 | , probeFlags 22 | , probeFlagsFirst 23 | , existsFlag 24 | , getTraceDir 25 | , getMaxSteps 26 | , getEvalStyle 27 | ) 28 | where 29 | 30 | import System.Console.GetOpt 31 | import Data.Maybe (fromMaybe, mapMaybe) 32 | import Data.Char (toLower, isDigit) 33 | import System.IO (stderr, hPutStrLn) 34 | import System.Exit (exitFailure, exitSuccess) 35 | 36 | programName :: String 37 | programName = "ministg" 38 | 39 | -- This should really come from the cabal file somehow. 40 | versionNumber :: String 41 | versionNumber = "0.3" 42 | 43 | versionInfo :: String 44 | versionInfo = unwords [programName, "version", versionNumber] 45 | 46 | processOptions :: [String] -> IO ([Flag], [String]) 47 | processOptions argv = 48 | case getOpt RequireOrder options argv of 49 | (_, [], []) -> do 50 | putStrLn $ usageInfo header options 51 | exitSuccess 52 | (flags, nonOpts, []) 53 | | existsFlag flags Help -> do 54 | putStrLn $ usageInfo header options 55 | exitSuccess 56 | | existsFlag flags Version -> do 57 | putStrLn versionInfo 58 | exitSuccess 59 | | otherwise -> return (flags, nonOpts) 60 | (_, _, errs) -> raiseError errs 61 | where 62 | header = "Usage: " ++ programName ++ " [OPTION...] file" 63 | failureMsg = programName ++ ": command line error.\n" 64 | raiseError errs = do 65 | hPutStrLn stderr $ failureMsg ++ concat errs ++ usageInfo header options 66 | exitFailure 67 | 68 | probeFlags :: [Flag] -> (Flag -> Maybe a) -> [a] 69 | probeFlags flags probe = mapMaybe probe flags 70 | 71 | probeFlagsFirst :: [Flag] -> (Flag -> Maybe a) -> a -> a 72 | probeFlagsFirst flags probe defaultValue 73 | | null probed = defaultValue 74 | | otherwise = head probed 75 | where 76 | probed = probeFlags flags probe 77 | 78 | existsFlag :: [Flag] -> Flag -> Bool 79 | existsFlag flags f 80 | = probeFlagsFirst flags probe False 81 | where 82 | probe someFlag = if f == someFlag then Just True else Nothing 83 | 84 | data Flag 85 | = Style EvalStyle -- ^ Which evaluation rules to use (eval/apply or push enter) 86 | | Trace -- ^ Turn tracing on. 87 | | TraceDir String -- ^ Directory to save trace file. 88 | | MaxSteps Integer -- ^ Maximum reduction steps to perform. 89 | | CallStack -- ^ Include call stack in trace. 90 | | Dump Dumped -- ^ Dump something out to debug the interpreter. 91 | | NoPrelude -- ^ Do not automatically include the Prelude. 92 | | NoGC -- ^ Disable garbage collection. 93 | | Help -- ^ Print a help message and exit. 94 | | Version -- ^ Print the version number. 95 | | Annotate -- ^ Auto annotate the program with stack markers. 96 | deriving (Eq, Ord, Show) 97 | 98 | data EvalStyle 99 | = EvalApply 100 | | PushEnter 101 | deriving (Eq, Ord, Show) 102 | 103 | data Dumped 104 | = DumpAST 105 | | DumpParsed 106 | | DumpArity 107 | | DumpNothing 108 | deriving (Eq, Ord, Show) 109 | 110 | options :: [OptDescr Flag] 111 | options = 112 | [ Option ['s'] ["style"] (ReqArg mkStyle "STYLE") "evaluation STYLE to use (EA = eval apply, PE = push enter)" 113 | , Option ['t'] ["trace"] (NoArg Trace) "record a trace of program evaluation" 114 | , Option [] ["tracedir"] (ReqArg TraceDir "DIR") "directory (DIR) to store trace files" 115 | , Option ['m'] ["maxsteps"] (ReqArg mkMaxSteps "STEPS") "maximum number of reduction STEPS to perform" 116 | , Option ['c'] ["callstack"] (NoArg CallStack) "enable call stack tracing" 117 | , Option [] ["nogc"] (NoArg NoGC) "disable garbage collector" 118 | , Option ['d'] ["dump"] (ReqArg mkDumped "DUMPED") "output DUMPED for debugging purposes (ast, parsed, arity)" 119 | , Option ['v'] ["version"] (NoArg Version) "show version number" 120 | , Option ['h'] ["help"] (NoArg Help) "get help about using this program" 121 | , Option ['a'] ["annotate"] (NoArg Annotate) "automatically annotate the program with stack markers" 122 | ] 123 | 124 | defaultTraceDir :: String 125 | defaultTraceDir = "trace" 126 | 127 | defaultEvalStyle :: EvalStyle 128 | defaultEvalStyle = PushEnter 129 | 130 | mkStyle :: String -> Flag 131 | mkStyle = normalMkStyle . map toLower 132 | where 133 | normalMkStyle "ea" = Style EvalApply 134 | normalMkStyle "pe" = Style PushEnter 135 | normalMkStyle other = Style defaultEvalStyle 136 | 137 | mkDumped :: String -> Flag 138 | mkDumped = normalMkDumped . map toLower 139 | where 140 | normalMkDumped "ast" = Dump DumpAST 141 | normalMkDumped "parsed" = Dump DumpParsed 142 | normalMkDumped "arity" = Dump DumpArity 143 | normalMkDumped other = Dump DumpNothing 144 | 145 | defaultMaxSteps :: Integer 146 | defaultMaxSteps = 1000 147 | 148 | mkMaxSteps :: String -> Flag 149 | mkMaxSteps [] = MaxSteps defaultMaxSteps 150 | mkMaxSteps n 151 | | all isDigit n = MaxSteps $ read n 152 | | otherwise = MaxSteps defaultMaxSteps 153 | 154 | getMaxSteps :: [Flag] -> Integer 155 | getMaxSteps flags = 156 | probeFlagsFirst flags probe defaultMaxSteps 157 | where probe (MaxSteps i) = Just i 158 | probe other = Nothing 159 | 160 | getTraceDir :: [Flag] -> String 161 | getTraceDir flags = 162 | probeFlagsFirst flags probe defaultTraceDir 163 | where probe (TraceDir d) = Just d 164 | probe other = Nothing 165 | 166 | getEvalStyle :: [Flag] -> EvalStyle 167 | getEvalStyle flags = 168 | probeFlagsFirst flags probe defaultEvalStyle 169 | where 170 | probe :: Flag -> Maybe EvalStyle 171 | probe (Style style) = Just style 172 | probe other = Nothing 173 | -------------------------------------------------------------------------------- /src/Ministg/State.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Ministg.State 4 | -- Copyright : (c) 2009-2012 Bernie Pope 5 | -- License : BSD-style 6 | -- Maintainer : florbitous@gmail.com 7 | -- Stability : experimental 8 | -- Portability : ghc 9 | -- 10 | -- Representation of the state of the ministg evaluator. 11 | ----------------------------------------------------------------------------- 12 | 13 | module Ministg.State 14 | ( Continuation (..) 15 | , Stack 16 | , prettyStack 17 | , Heap 18 | , EvalState (..) 19 | , Eval 20 | , initStack 21 | , initHeap 22 | , initState 23 | , pushCallStack 24 | , setCallStack 25 | , lookupHeap 26 | , lookupHeapAtom 27 | , updateHeap 28 | , freshVar 29 | , incStepCount 30 | , setRule 31 | , prettyHeapObject 32 | , isArgCont 33 | ) 34 | where 35 | 36 | import Control.Monad.State 37 | import Data.Map as Map hiding (map) 38 | import Data.Set as Set hiding (map) 39 | import Ministg.AST 40 | import Ministg.CallStack (CallStack, push, prettyCallStack) 41 | import Ministg.Pretty 42 | import Ministg.Options 43 | ( Flag (..), defaultMaxSteps, defaultTraceDir 44 | , probeFlagsFirst, existsFlag, getTraceDir, getMaxSteps ) 45 | 46 | -- | Stack continuations. 47 | data Continuation 48 | = CaseCont [Alt] CallStack -- ^ The alternatives of a case expression. 49 | | UpdateCont Var CallStack -- ^ A variable which points to a thunk to be updated. 50 | | ArgCont Atom -- ^ A pending argument (used only by the push-enter model). 51 | | ApplyToArgs [Atom] -- ^ Apply the returned function to these arguments (eval-apply only). 52 | deriving (Eq, Show) 53 | 54 | instance FreeVars Continuation where 55 | freeVars (CaseCont alts _cs) = freeVars alts 56 | freeVars (UpdateCont var _cs) = Set.singleton var 57 | freeVars (ArgCont arg) = freeVars arg 58 | freeVars (ApplyToArgs args) = freeVars args 59 | 60 | instance Pretty Continuation where 61 | pretty (CaseCont alts callStack) 62 | = text "case *" <+> braces (vcat (punctuate semi (map pretty alts))) $$ 63 | nest 3 (prettyCallStack callStack) 64 | pretty (UpdateCont var callStack) 65 | = text "upd *" <+> text var $$ 66 | nest 3 (prettyCallStack callStack) 67 | pretty (ArgCont atom) = text "arg" <+> pretty atom 68 | pretty (ApplyToArgs atoms) = parens (char '*' <+> hsep (map pretty atoms)) 69 | 70 | isArgCont :: Continuation -> Bool 71 | isArgCont (ArgCont {}) = True 72 | isArgCont _other = False 73 | 74 | -- | The evaluation stack. 75 | type Stack = [Continuation] 76 | 77 | prettyStack :: Stack -> Doc 78 | prettyStack stack = (vcat $ map prettyCont stack) 79 | where 80 | prettyCont :: Continuation -> Doc 81 | prettyCont cont = text "-" <+> pretty cont 82 | 83 | -- | The heap (mapping variables to objects). 84 | type Heap = Map.Map Var Object 85 | 86 | -- | State to be threaded through evaluation. 87 | data EvalState 88 | = EvalState 89 | { state_unique :: !Int -- ^ Unique counter for generating fresh variables. 90 | , state_callStack :: CallStack -- ^ Function call stack (for debugging). 91 | , state_stepCount :: !Integer -- ^ How many steps have been executed. 92 | , state_lastRule :: !String -- ^ The most recent evaluation rule applied. 93 | , state_trace :: Bool -- ^ Do we want tracing of evaluation steps? 94 | , state_maxTraceSteps :: Integer -- ^ Maximum number of evaluation steps to trace. 95 | , state_traceDir :: String -- ^ Name of directory to store trace files. 96 | , state_gc :: Bool -- ^ Do we want garbage collection? 97 | , state_traceCallStack :: Bool -- ^ Do we want the call stack shown in the trace? 98 | } 99 | 100 | -- | Eval monad. Combines State and IO. 101 | type Eval a = StateT EvalState IO a 102 | 103 | initState :: [Flag] -> EvalState 104 | initState flags = 105 | EvalState 106 | { state_unique = 0 107 | , state_callStack = [] 108 | , state_stepCount = 0 109 | , state_lastRule = "" 110 | , state_trace = existsFlag flags Trace 111 | , state_maxTraceSteps = getMaxSteps flags 112 | , state_traceDir = getTraceDir flags 113 | , state_gc = not $ existsFlag flags NoGC 114 | , state_traceCallStack = existsFlag flags CallStack 115 | } 116 | 117 | initHeap :: Program -> Heap 118 | initHeap (Program decls) = Map.fromList $ map declToPair decls 119 | where 120 | declToPair :: Decl -> (Var, Object) 121 | declToPair (Decl var obj) = (var, obj) 122 | 123 | initStack :: Stack 124 | initStack = [] 125 | 126 | setRule :: String -> Eval () 127 | setRule str = do 128 | lr <- gets state_lastRule 129 | modify $ \s -> s { state_lastRule = str } 130 | 131 | incStepCount :: Eval () 132 | incStepCount = do 133 | sc <- gets state_stepCount 134 | modify $ \s -> s { state_stepCount = sc + 1 } 135 | 136 | pushCallStack :: String -> Eval () 137 | pushCallStack str = do 138 | cs <- gets state_callStack 139 | modify $ \s -> s { state_callStack = push str cs } 140 | 141 | setCallStack :: CallStack -> Eval () 142 | setCallStack cs = modify $ \s -> s { state_callStack = cs } 143 | 144 | -- | Lookup a variable in a heap. If found return the corresponding 145 | -- object, otherwise throw an error (it is a fatal error which can't 146 | -- be recovered from). 147 | lookupHeap :: Var -> Heap -> Object 148 | lookupHeap var heap = 149 | case Map.lookup var heap of 150 | Nothing -> error $ "undefined variable: " ++ show var 151 | Just object -> object 152 | 153 | -- | Convenience wrapper for lookupHeap, for atoms which happen to be variables. 154 | lookupHeapAtom :: Atom -> Heap -> Object 155 | lookupHeapAtom (Variable var) heap = lookupHeap var heap 156 | lookupHeapAtom other _heap = error $ "lookupHeapAtom called with non variable " ++ show other 157 | 158 | -- | Add a new mapping to a heap, or update an existing one. 159 | updateHeap :: Var -> Object -> Heap -> Heap 160 | updateHeap = Map.insert 161 | 162 | -- | Generate a new unique variable. Uniqueness is guaranteed by using a 163 | -- "$" prefix, which is not allowed in the concrete sytax of ministg programs. 164 | freshVar :: Eval Var 165 | freshVar = do 166 | u <- gets state_unique 167 | modify $ \s -> s { state_unique = u + 1 } 168 | return $ "$" ++ show u 169 | 170 | -- XXX not very good for printing large objects, nonetheless it is lazy. 171 | prettyHeapObject :: Heap -> Object -> String 172 | prettyHeapObject heap (Con constructor args) 173 | | length args == 0 = constructor 174 | | otherwise = "(" ++ unwords (constructor : map (prettyHeapAtom heap) args) ++ ")" 175 | prettyHeapObject _heap (Fun {}) = "" 176 | prettyHeapObject _heap (Pap {}) = "" 177 | prettyHeapObject _heap (Thunk {}) = "" 178 | prettyHeapObject _heap BlackHole = "" 179 | prettyHeapObject _heap Error = "" 180 | 181 | prettyHeapAtom :: Heap -> Atom -> String 182 | prettyHeapAtom heap (Literal (Integer i)) = show i 183 | prettyHeapAtom heap (Variable var) = prettyHeapObject heap $ lookupHeap var heap 184 | -------------------------------------------------------------------------------- /src/Ministg/AST.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | ----------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Ministg.AST 5 | -- Copyright : (c) 2009-2012 Bernie Pope 6 | -- License : BSD-style 7 | -- Maintainer : florbitous@gmail.com 8 | -- Stability : experimental 9 | -- Portability : ghc 10 | -- 11 | -- The representation of the abstract syntax tree for ministg programs. 12 | ----------------------------------------------------------------------------- 13 | module Ministg.AST where 14 | 15 | import qualified Data.Semigroup as Semigroup 16 | import Ministg.CallStack (CallStack, prettyCallStack) 17 | import Ministg.Pretty 18 | import Data.Set as Set hiding (map) 19 | #if MIN_VERSION_base(4,11,0) 20 | import Prelude hiding ((<>)) 21 | #endif 22 | 23 | -- | Variables (also known as identifiers). 24 | type Var = String 25 | -- | Data constructor names. 26 | type Constructor = String 27 | 28 | class FreeVars t where 29 | freeVars :: t -> Set Var 30 | 31 | instance FreeVars t => FreeVars [t] where 32 | freeVars = Set.unions . map freeVars 33 | 34 | -- | Literal integers. These correspond to unboxed integers in the semantics. 35 | newtype Literal = Integer Integer 36 | deriving (Eq, Show) 37 | 38 | instance Pretty Literal where 39 | pretty (Integer i) = pretty i 40 | 41 | -- | Atomic expressions. 42 | data Atom 43 | = Literal Literal -- ^ Literal values (unoboxed integers). 44 | | Variable Var -- ^ Variables. 45 | deriving (Eq, Show) 46 | 47 | instance Pretty Atom where 48 | pretty (Literal l) = pretty l 49 | pretty (Variable v) = text v 50 | 51 | instance FreeVars Atom where 52 | freeVars Literal {} = Set.empty 53 | freeVars (Variable v) = Set.singleton v 54 | 55 | -- | Is an atom a literal? 56 | isLiteral :: Atom -> Bool 57 | isLiteral Literal {} = True 58 | isLiteral _other = False 59 | 60 | -- | The arity (number of parameters) of a function. It is only known when the function 61 | -- being applied is statically known (not lambda bound). 62 | type FunArity = Maybe Int 63 | 64 | prettyArity :: FunArity -> Doc 65 | prettyArity Nothing = text "_?" 66 | prettyArity (Just i) = text "_" <> int i 67 | 68 | -- | Expressions. 69 | data Exp 70 | = Atom Atom -- ^ Atomic expressions (literals, variables). 71 | | FunApp FunArity Var [Atom] -- ^ Function application (f^k a_1 ... a_n, n >= 1). 72 | | PrimApp Prim [Atom] -- ^ Saturated primitive application (op a_1 ... a_n, n >= 1). 73 | | Let Var Object Exp -- ^ Let declaration. 74 | | Case Exp [Alt] -- ^ Case expression. 75 | | Stack String Exp -- ^ Like SCC, but just for stacks. (stack str (exp)) 76 | deriving (Eq, Show) 77 | 78 | instance FreeVars Exp where 79 | freeVars (Atom a) = freeVars a 80 | freeVars (FunApp _arity var args) = Set.singleton var `Set.union` freeVars args 81 | freeVars (PrimApp prim args) = freeVars args 82 | -- Treat this as a letrec, which means that the var is bound (not free) in the object 83 | freeVars (Let var object exp) 84 | = Set.delete var (freeVars exp `Set.union` freeVars object) 85 | freeVars (Case exp alts) 86 | = freeVars exp `Set.union` freeVars alts 87 | freeVars (Stack _str exp) = freeVars exp 88 | 89 | instance Pretty Exp where 90 | pretty (Atom a) = pretty a 91 | pretty (FunApp arity var atoms) = text var <> prettyArity arity <+> hsep (map pretty atoms) 92 | pretty (PrimApp prim atoms) = pretty prim <+> hsep (map pretty atoms) 93 | pretty letExp@(Let var obj exp) 94 | = maybeNest (text "let {") prettyDecls (rbrace <+> text "in" <+> pretty inExp) 95 | where 96 | (decls, inExp) = unflattenLet letExp 97 | prettyDecls = vcat (punctuate semi (map pretty decls)) 98 | maybeNest letPart declPart inPart 99 | | length decls < 2 = letPart <+> declPart <+> inPart 100 | | otherwise = letPart $$ nest 3 declPart $$ inPart 101 | pretty (Case exp alts) = 102 | text "case" <+> pretty exp <+> text "of {" $$ 103 | nest 3 (vcat (punctuate semi (map pretty alts))) $$ 104 | rbrace 105 | pretty (Stack annotation exp) = 106 | maybeNest exp (text "stack" <+> doubleQuotes (text annotation)) (pretty exp) 107 | 108 | isNestedExp :: Exp -> Bool 109 | isNestedExp Let {} = True 110 | isNestedExp Case {} = True 111 | isNestedExp Stack {} = True 112 | isNestedExp other = False 113 | 114 | unflattenLet :: Exp -> ([Decl], Exp) 115 | unflattenLet exp = unflattenLetAcc exp [] 116 | where 117 | unflattenLetAcc :: Exp -> [Decl] -> ([Decl], Exp) 118 | unflattenLetAcc (Let var obj exp) ds = unflattenLetAcc exp (Decl var obj : ds) 119 | unflattenLetAcc exp ds = (reverse ds, exp) 120 | 121 | -- | Case alternatives (the right-hand-sides of case branches). 122 | data Alt 123 | = PatAlt Constructor [Var] Exp -- ^ Constructor pattern (C x_1 ... x_n -> e, n >= 0). 124 | | DefaultAlt Var Exp -- ^ Default pattern (matches anything) (x -> e). 125 | deriving (Eq, Show) 126 | 127 | instance FreeVars Alt where 128 | freeVars (PatAlt constructor args exp) = freeVars exp \\ Set.fromList args 129 | freeVars (DefaultAlt var exp) = Set.delete var $ freeVars exp 130 | 131 | instance Pretty Alt where 132 | pretty (PatAlt con vars exp) = maybeNest exp (text con <+> hsep (map text vars) <+> rightArrow) (pretty exp) 133 | pretty (DefaultAlt var exp) = text var <+> rightArrow <+> pretty exp 134 | 135 | rightArrow :: Doc 136 | rightArrow = text "->" 137 | 138 | -- | Objects. These serve two roles in the language: 139 | -- 140 | -- (1) as part of the language syntax (except blackholes). 141 | -- (2) as things which are allocated on the heap during execution. 142 | 143 | data Object 144 | = Fun [Var] Exp -- ^ Function values (FUN (x_1 ... x_n -> e). 145 | | Pap Var [Atom] -- ^ Partial applications (PAP (f a_1 ... a_n)). 146 | | Con Constructor [Atom] -- ^ Data constructor application (CON (C a_1 ... a_n)). 147 | | Thunk Exp CallStack -- ^ THUNK (e). 148 | | BlackHole -- ^ BLACKHOLE (only during evaluation - not part of the language syntax). 149 | | Error -- ^ Raise an exception. 150 | deriving (Eq, Show) 151 | 152 | instance FreeVars Object where 153 | freeVars (Fun vars exp) = freeVars exp \\ Set.fromList vars 154 | freeVars (Pap var args) = Set.singleton var `Set.union` freeVars args 155 | freeVars (Con constructor args) = freeVars args 156 | freeVars (Thunk exp callStack) = freeVars exp 157 | freeVars BlackHole = Set.empty 158 | freeVars Error = Set.empty 159 | 160 | maybeNest :: Exp -> Doc -> Doc -> Doc 161 | maybeNest exp d1 d2 = if isNestedExp exp then d1 $$ nest 3 d2 else d1 <+> d2 162 | 163 | instance Pretty Object where 164 | pretty (Fun vars exp) 165 | = text "FUN" <> parens (maybeNest exp (hsep (map text vars) <+> rightArrow) (pretty exp)) 166 | pretty (Pap var atoms) = text "PAP" <> parens (text var <+> hsep (map pretty atoms)) 167 | pretty (Con constructor atoms) = text "CON" <> parens (text constructor <+> hsep (map pretty atoms)) 168 | pretty (Thunk exp callStack) 169 | = text "THUNK" <> parens (pretty exp) $$ nest 3 (prettyCallStack callStack) 170 | pretty BlackHole = text "BLACKHOLE" 171 | pretty Error = text "ERROR" 172 | 173 | -- | Test for "value" objects. 174 | isValue :: Object -> Bool 175 | isValue Fun {} = True 176 | isValue Pap {} = True 177 | isValue Con {} = True 178 | isValue _other = False 179 | 180 | -- | Test for FUN objects 181 | isFun :: Object -> Bool 182 | isFun Fun {} = True 183 | isFun other = False 184 | 185 | -- | Test for PAP objects 186 | isPap :: Object -> Bool 187 | isPap Pap {} = True 188 | isPap other = False 189 | 190 | -- | A top-level declaration (f = obj). 191 | data Decl = Decl Var Object 192 | deriving Show 193 | 194 | instance Pretty Decl where 195 | pretty (Decl var obj) = text var <+> equals <+> pretty obj 196 | 197 | -- | A whole program. 198 | newtype Program = Program [Decl] 199 | deriving Show 200 | 201 | instance Semigroup Program where 202 | (Program decl1) <> (Program decl2) = Program (decl1 Semigroup.<> decl2) 203 | 204 | instance Monoid Program where 205 | mempty = Program [] 206 | 207 | instance Pretty Program where 208 | pretty (Program decls) = vcat (punctuate semi (map pretty decls)) 209 | 210 | -- | Primitive operators. 211 | data Prim 212 | = Add -- ^ Unboxed integer addition (x + y). 213 | | Subtract -- ^ Unboxed integer subtraction (x - y). 214 | | Multiply -- ^ Unboxed integer multiplication (x * y). 215 | | Equality -- ^ Unboxed integer equality test (x == y). 216 | | LessThan -- ^ Unboxed integer less-than comparison (x < y). 217 | | GreaterThan -- ^ Unboxed integer greater-than comparison ( x > y). 218 | | LessThanEquals -- ^ Unboxed integer less-than-equals comparison ( x <= y). 219 | | GreaterThanEquals -- ^ Unboxed integer greater-than-equals comparison ( x >= y). 220 | | IntToBool -- ^ Convert an unboxed integer to a (boxed) boolean ( 1 = True, 0 = False). 221 | deriving (Eq, Show) 222 | 223 | instance Pretty Prim where 224 | pretty Add = text "plus#" 225 | pretty Subtract = text "sub#" 226 | pretty Multiply = text "mult#" 227 | pretty Equality = text "eq#" 228 | pretty LessThan = text "lt#" 229 | pretty GreaterThan = text "gt#" 230 | pretty LessThanEquals = text "lte#" 231 | pretty GreaterThanEquals = text "gte#" 232 | pretty IntToBool = text "intToBool#" 233 | -------------------------------------------------------------------------------- /src/Ministg/Eval.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -XPatternGuards #-} 2 | ----------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Ministg.Eval 5 | -- Copyright : (c) 2009-2012 Bernie Pope 6 | -- License : BSD-style 7 | -- Maintainer : florbitous@gmail.com 8 | -- Stability : experimental 9 | -- Portability : ghc 10 | -- 11 | -- Evaluate a ministg program using the semantics described in the 12 | -- "fast curry" paper by Simon Marlow and Simon Peyton Jones. 13 | ----------------------------------------------------------------------------- 14 | 15 | module Ministg.Eval (run) where 16 | 17 | import Control.Monad.State (evalStateT, gets) 18 | import Control.Monad.Trans (liftIO) 19 | import qualified Data.Map as Map 20 | import Data.Map (Map) 21 | import Data.List (foldl') 22 | import Ministg.AST 23 | import Ministg.CallStack (CallStack, push, showCallStack) 24 | import Ministg.Pretty 25 | import Ministg.State 26 | import Ministg.TraceEval (traceEval, traceEnd, traceMaxStepsExceeded) 27 | import Ministg.Options as Opts 28 | (Flag (..), EvalStyle (..), defaultEvalStyle, probeFlagsFirst, getEvalStyle) 29 | import Ministg.GC (garbageCollect) 30 | 31 | -- | Evaluate a ministg program and cause its effects to happen. 32 | run :: [Flag] -> Program -> IO () 33 | run flags decls = 34 | evalStateT (evalProgram style $ initHeap decls) (initState flags) 35 | where 36 | style = getEvalStyle flags 37 | 38 | evalProgram :: EvalStyle -> Heap -> Eval () 39 | evalProgram style heap = do 40 | (newExp, _newStack, newHeap) <- bigStep style (Atom (Variable "main")) initStack heap 41 | traceEnd 42 | str <- case newExp of 43 | Atom (Literal lit) -> return $ prettyText lit 44 | Atom (Variable var) -> do 45 | let object = lookupHeap var newHeap 46 | case object of 47 | Error -> do 48 | cs <- gets state_callStack 49 | return $ "Exception raised!" ++ displayCallStack cs 50 | other -> return $ prettyHeapObject newHeap $ lookupHeap var newHeap 51 | other -> return $ "Runtime error: result of bigStep is not an atom: " ++ show other 52 | liftIO $ putStrLn str 53 | where 54 | displayCallStack [] = [] 55 | displayCallStack cs = "\n\nCall stack:\n" ++ showCallStack cs 56 | 57 | -- | Reduce an exression to WHNF (a big step reduction, which may be composed 58 | -- of one or more small step reductions). 59 | bigStep :: EvalStyle -> Exp -> Stack -> Heap -> Eval (Exp, Stack, Heap) 60 | bigStep style exp stack heap = do 61 | count <- gets state_stepCount 62 | maxSteps <- gets state_maxTraceSteps 63 | if count > maxSteps 64 | then do 65 | traceMaxStepsExceeded 66 | fail ("Maximum reduction steps " ++ show maxSteps ++ " exceeded") 67 | else do 68 | gcHeap <- garbageCollect exp stack heap 69 | traceEval exp stack gcHeap 70 | result <- smallStep style exp stack gcHeap 71 | incStepCount 72 | case result of 73 | -- Nothing more to do, we have reached a WHNF value (or perhaps some error). 74 | Nothing -> return (exp, stack, gcHeap) 75 | -- There might be more to do, keep trying. 76 | Just (newExp, newStack, newHeap) -> bigStep style newExp newStack newHeap 77 | 78 | -- | Perform one step of reduction. These equations correspond to the 79 | -- rules in the operational semantics described in the "fast curry" paper. 80 | smallStep :: EvalStyle -> Exp -> Stack -> Heap -> Eval (Maybe (Exp, Stack, Heap)) 81 | -- STACK ANNOTATION 82 | smallStep style (Stack annotation exp) stack heap = do 83 | setRule "STACK" 84 | pushCallStack annotation 85 | return $ Just (exp, stack, heap) 86 | -- LET 87 | smallStep _anyStyle (Let var object exp) stack heap = do 88 | setRule "LET" 89 | newVar <- freshVar 90 | callStack <- gets state_callStack 91 | let annotatedObject = setThunkStack callStack object 92 | let newHeap = updateHeap newVar annotatedObject heap 93 | let newExp = subs (mkSub var (Variable newVar)) exp 94 | return $ Just (newExp, stack, newHeap) 95 | -- CASECON 96 | smallStep _anyStyle (Case (Atom (Variable v)) alts) stack heap 97 | | Con constructor args <- lookupHeap v heap, 98 | Just (vars, exp) <- exactPatternMatch constructor alts = do 99 | setRule "CASECON" 100 | return $ Just (subs (mkSubList $ zip vars args) exp, stack, heap) 101 | -- CASEANY 102 | smallStep _anyStyle (Case (Atom v) alts) stack heap 103 | | isLiteral v || isValue (lookupHeapAtom v heap) = 104 | case defaultPatternMatch alts of 105 | Just (x, exp) -> do 106 | setRule "CASEANY" 107 | return $ Just (subs (mkSub x v) exp, stack, heap) 108 | -- technically the compiler should insert a catch-all default alternative 109 | -- for each case expression, but if we don't check for it here we 110 | -- could have non-desirable error behaviour such as an infinite loop. 111 | Nothing -> fail "non exhaustive patterns in case expression" 112 | -- CASE 113 | smallStep _anyStyle (Case exp alts) stack heap = do 114 | setRule "CASE" 115 | callStack <- gets state_callStack 116 | return $ Just (exp, CaseCont alts callStack : stack, heap) 117 | -- RET 118 | smallStep _anyStyle exp@(Atom atom) (CaseCont alts oldCallStack : stackRest) heap 119 | | isLiteral atom || isValue (lookupHeapAtom atom heap) = do 120 | setRule "RET" 121 | setCallStack oldCallStack 122 | return $ Just (Case exp alts, stackRest, heap) 123 | -- THUNK 124 | smallStep _anyStyle (Atom (Variable x)) stack heap 125 | | Thunk exp thunkCallStack <- lookupHeap x heap = do 126 | setRule "THUNK" 127 | let newHeap = updateHeap x BlackHole heap 128 | oldCallStack <- gets state_callStack 129 | setCallStack thunkCallStack 130 | return $ Just (exp, UpdateCont x oldCallStack : stack, newHeap) 131 | -- UPDATE 132 | smallStep _anyStyle atom@(Atom (Variable y)) (UpdateCont x oldCallStack : stackRest) heap 133 | | object <- lookupHeap y heap, isValue object = do 134 | setRule "UPDATE" 135 | setCallStack oldCallStack 136 | return $ Just (atom, stackRest, updateHeap x object heap) 137 | -- KNOWNCALL 138 | smallStep _anyStyle (FunApp (Just arity) var args) stack heap 139 | | arity == length args = 140 | case lookupHeap var heap of 141 | Fun params body -> do 142 | setRule "KNOWNCALL" 143 | let newBody = subs (mkSubList $ zip params args) body 144 | return $ Just (newBody, stack, heap) 145 | other -> fail $ "known function " ++ var ++ " bound to non function object: " ++ show other 146 | -- PRIMOP 147 | smallStep _anyStyle (PrimApp prim args) stack heap = do 148 | setRule "PRIMOP" 149 | (result, newStack, newHeap) <- evalPrim prim args stack heap 150 | return $ Just (Atom result, newStack, newHeap) 151 | 152 | -- The push enter specific rules. 153 | 154 | -- PUSH 155 | smallStep PushEnter (FunApp _arity f args) stack heap = do 156 | setRule "PUSH" 157 | return $ Just (Atom (Variable f), map ArgCont args ++ stack, heap) 158 | -- FENTER 159 | smallStep PushEnter (Atom (Variable f)) stack heap 160 | | Fun vars exp <- lookupHeap f heap, 161 | (argConts, restStack) <- span isArgCont stack, 162 | length vars <= length argConts = do 163 | setRule "FENTER" 164 | let (enoughArgs, restArgs) = splitAt (length vars) argConts 165 | let argAtoms = [atom | ArgCont atom <- enoughArgs] 166 | let newStack = restArgs ++ restStack 167 | return $ Just (subs (mkSubList $ zip vars argAtoms) exp, newStack, heap) 168 | -- PAP1 169 | smallStep PushEnter (Atom (Variable f)) stack heap 170 | | Fun vars exp <- lookupHeap f heap, 171 | argConts <- takeWhile isArgCont stack, 172 | length argConts >= 1, 173 | length vars > length argConts = do 174 | setRule "PAP1" 175 | let argAtoms = [atom | ArgCont atom <- argConts] 176 | p <- freshVar 177 | return $ Just (Atom (Variable p), drop (length argConts) stack, updateHeap p (Pap f argAtoms) heap) 178 | -- PENTER 179 | smallStep PushEnter (Atom (Variable f)) stack@(ArgCont _ : stackRest) heap 180 | | Pap g args <- lookupHeap f heap = do 181 | setRule "PENTER" 182 | return $ Just (Atom (Variable g), map ArgCont args ++ stack, heap) 183 | 184 | -- The eval apply rules 185 | 186 | -- EXACT 187 | smallStep EvalApply (FunApp Nothing f args) stack heap 188 | | Fun vars exp <- lookupHeap f heap, length args == length vars = do 189 | setRule "EXACT" 190 | let newExp = subs (mkSubList $ zip vars args) exp 191 | return $ Just (newExp, stack, heap) 192 | -- CALLK 193 | smallStep EvalApply (FunApp _anyArity f args) stack heap 194 | | Fun vars exp <- lookupHeap f heap, length args > length vars = do 195 | setRule "CALLK" 196 | let (enoughArgs, restArgs) = splitAt (length vars) args 197 | newExp = subs (mkSubList $ zip vars enoughArgs) exp 198 | return $ Just (newExp, (ApplyToArgs restArgs) : stack, heap) 199 | -- PAP2 200 | smallStep EvalApply (FunApp _anyArity f args) stack heap 201 | | Fun vars exp <- lookupHeap f heap, length args < length vars = do 202 | setRule "PAP2" 203 | p <- freshVar 204 | let newHeap = updateHeap p (Pap f args) heap 205 | return $ Just (Atom (Variable p), stack, newHeap) 206 | -- TCALL 207 | -- XXX fix up call stack? 208 | smallStep EvalApply (FunApp Nothing f args) stack heap 209 | | Thunk exp thunkCallStack <- lookupHeap f heap = do 210 | setRule "TCALL" 211 | return $ Just (Atom (Variable f), (ApplyToArgs args) : stack, heap) 212 | -- PCALL 213 | smallStep EvalApply (FunApp _anyArity f args) stack heap 214 | | Pap g papArgs <- lookupHeap f heap = do 215 | setRule "PCALL" 216 | return $ Just (FunApp Nothing g (papArgs ++ args), stack, heap) 217 | -- RETFUN 218 | smallStep EvalApply (Atom (Variable f)) (ApplyToArgs args : stack) heap 219 | | object <- lookupHeap f heap, isFun object || isPap object = do 220 | setRule "RETFUN" 221 | return $ Just (FunApp Nothing f args, stack, heap) 222 | 223 | -- NOTHING MORE TO DO 224 | smallStep _anyStyle _other _stack _heap = do 225 | setRule "None" 226 | return Nothing 227 | 228 | -- | Evaluate the application of a primitive function. It is assumed that the 229 | -- arguments of the primitive are already evaluated. Note: we allow primitives 230 | -- to manipulate the heap and stack, but the semantics in the "fast curry" paper 231 | -- do not. 232 | evalPrim :: Prim -> [Atom] -> Stack -> Heap -> Eval (Atom, Stack, Heap) 233 | evalPrim Add args stack heap = mkIntPrim (+) args stack heap 234 | evalPrim Subtract args stack heap = mkIntPrim (-) args stack heap 235 | evalPrim Multiply args stack heap = mkIntPrim (*) args stack heap 236 | evalPrim Equality args stack heap = mkIntComparePrim (==) args stack heap 237 | evalPrim LessThan args stack heap = mkIntComparePrim (<) args stack heap 238 | evalPrim LessThanEquals args stack heap = mkIntComparePrim (<=) args stack heap 239 | evalPrim GreaterThan args stack heap = mkIntComparePrim (>) args stack heap 240 | evalPrim GreaterThanEquals args stack heap = mkIntComparePrim (>=) args stack heap 241 | evalPrim IntToBool [Literal (Integer i)] stack heap = do 242 | var <- freshVar 243 | let newHeap = updateHeap var (Con (if i == 1 then "True" else "False") []) heap 244 | return (Variable var, stack, newHeap) 245 | evalPrim prim args stack heap = error $ show (prim,args) 246 | 247 | -- | Check for an exact pattern match for a data constructor in a list of case alternatives. 248 | exactPatternMatch :: Constructor -> [Alt] -> Maybe ([Var], Exp) 249 | exactPatternMatch con1 (PatAlt con2 vars exp : alts) 250 | | con1 == con2 = Just (vars, exp) 251 | | otherwise = exactPatternMatch con1 alts 252 | exactPatternMatch con (DefaultAlt {} : _) = Nothing 253 | exactPatternMatch _con [] = Nothing 254 | 255 | -- | Check for a default pattern match (x -> e) in a list of case alternatives. 256 | defaultPatternMatch :: [Alt] -> Maybe (Var, Exp) 257 | defaultPatternMatch [] = Nothing 258 | defaultPatternMatch (PatAlt {} : alts) = defaultPatternMatch alts 259 | defaultPatternMatch (DefaultAlt var exp : _alts) = Just (var, exp) 260 | 261 | -- | Convenience function for making integer primitives. 262 | mkIntPrim :: (Integer -> Integer -> Integer) -> [Atom] -> Stack -> Heap -> Eval (Atom, Stack, Heap) 263 | mkIntPrim op [Literal (Integer i), Literal (Integer j)] stack heap 264 | = return (Literal $ Integer (i `op` j), stack, heap) 265 | 266 | -- | Convenience function for making integer comparison primitives. 267 | mkIntComparePrim :: (Integer -> Integer -> Bool) -> [Atom] -> Stack -> Heap -> Eval (Atom, Stack, Heap) 268 | mkIntComparePrim op args stack heap = mkIntPrim (\i j -> if i `op` j then 1 else 0) args stack heap 269 | 270 | setThunkStack :: CallStack -> Object -> Object 271 | setThunkStack cs (Thunk e _oldCS) = Thunk e cs 272 | setThunkStack cs other = other 273 | 274 | type Substitution = Map.Map Var Atom 275 | 276 | mkSub :: Var -> Atom -> Substitution 277 | mkSub = Map.singleton 278 | 279 | mkSubList :: [(Var, Atom)] -> Substitution 280 | mkSubList = Map.fromList 281 | 282 | removeVars :: [Var] -> Substitution -> Substitution 283 | removeVars vars sub = foldl' (flip Map.delete) sub vars 284 | 285 | class Substitute a where 286 | subs :: Substitution -> a -> a 287 | 288 | instance Substitute a => Substitute [a] where 289 | subs s = map (subs s) 290 | 291 | subsVar :: Substitution -> Var -> Var 292 | subsVar s var = 293 | case Map.lookup var s of 294 | Nothing -> var 295 | Just (Variable newVar) -> newVar 296 | Just (Literal lit) -> error $ "attempt to substitute variable " ++ var ++ " with literal " ++ show lit 297 | 298 | instance Substitute Atom where 299 | subs s v@(Variable var) = 300 | case Map.lookup var s of 301 | Nothing -> v 302 | Just atom -> atom 303 | subs _s l@(Literal {}) = l 304 | 305 | instance Substitute Exp where 306 | subs s (Atom a) = Atom $ subs s a 307 | subs s exp@(FunApp arity var atoms) 308 | = FunApp arity (subsVar s var) (subs s atoms) 309 | subs s (PrimApp prim args) = PrimApp prim $ subs s args 310 | -- lets are not recursive so we don't really need to removeVars from s 311 | -- in the subs of obj, but it is safe to do so, and we might use it 312 | -- if lets become recursive. 313 | subs s exp@(Let var obj body) 314 | = Let var (subs newSub obj) (subs newSub body) 315 | where 316 | newSub = removeVars [var] s 317 | subs s (Case exp alts) = Case (subs s exp) (subs s alts) 318 | subs s (Stack str e) = Stack str $ subs s e 319 | 320 | instance Substitute Alt where 321 | subs s p@(PatAlt cons vars exp) 322 | = PatAlt cons vars $ subs (removeVars vars s) exp 323 | subs s p@(DefaultAlt var exp) 324 | = DefaultAlt var $ subs (removeVars [var] s) exp 325 | 326 | instance Substitute Object where 327 | subs s f@(Fun args exp) 328 | = Fun args $ subs (removeVars args s) exp 329 | subs s (Pap var atoms) 330 | = Pap (subsVar s var) (subs s atoms) 331 | subs s (Con constructor atoms) = Con constructor $ subs s atoms 332 | subs s (Thunk exp cs) = Thunk (subs s exp) cs 333 | subs _s BlackHole = BlackHole 334 | subs _s Error = Error 335 | --------------------------------------------------------------------------------