ministg (empty) → 0.1

raw patch · 35 files changed

+2014/−0 lines, 35 filesdep +basedep +containersdep +directorysetup-changed

Dependencies added: base, containers, directory, filepath, haskell98, monads-tf, parsec, pretty, transformers, xhtml

Files

• LICENSE +27/−0
• README.txt +13/−0
• Setup.lhs +3/−0
• ministg.cabal +40/−0
• src/Main.hs +80/−0
• src/Ministg/AST.hs +222/−0
• src/Ministg/Annotate.hs +34/−0
• src/Ministg/Arity.hs +78/−0
• src/Ministg/CallStack.hs +27/−0
• src/Ministg/Eval.hs +321/−0
• src/Ministg/GC.hs +47/−0
• src/Ministg/Lexer.hs +173/−0
• src/Ministg/Options.hs +173/−0
• src/Ministg/Parser.hs +177/−0
• src/Ministg/Pretty.hs +47/−0
• src/Ministg/State.hs +183/−0
• src/Ministg/TraceEval.hs +140/−0
• src/Ministg/Utils.hs +22/−0
• test/Prelude.stg +100/−0
• test/append.stg +6/−0
• test/apply.stg +2/−0
• test/docs.stg +26/−0
• test/empty.stg +0/−0
• test/error.stg +1/−0
• test/fac.stg +9/−0
• test/fac_stack.stg +9/−0
• test/fibs.stg +11/−0
• test/loop.stg +2/−0
• test/map.stg +10/−0
• test/map_pap.stg +8/−0
• test/ones.stg +2/−0
• test/seq.stg +10/−0
• test/sum.stg +4/−0
• test/sum_error.stg +4/−0
• test/take.stg +3/−0

@@ -0,0 +1,27 @@+Copyright (c) 2009 Bernard James Pope ++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.+2. Redistributions in binary form must reproduce the above copyright+   notice, this list of conditions and the following disclaimer in the+   documentation and/or other materials provided with the distribution.+3. Neither the name of the author nor the names of his contributors+   may be used to endorse or promote products derived from this software+   without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT OWNER OR+CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,+EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,+PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR+PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING+NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,13 @@+Thank you for trying Ministg.++For documentation on using Ministg please consult the web page:++   http://www.haskell.org/haskellwiki/Ministg++For building and installing please consult the web page:++   http://www.haskell.org/haskellwiki/Cabal/How_to_install_a_Cabal_package++Feedback, feature requests, bug reports:++  Bernie Pope: http://www.cs.mu.oz.au/~bjpop/

@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain

@@ -0,0 +1,40 @@+name:                ministg+version:             0.1+cabal-version:       >= 1.6+synopsis:            an interpreter for an operational semantics for the STG machine. +description:         ministg is an interpreter for a simple high-level operational semantics for the STG machine. The+                     semantics is taken from the research paper "Making a fast curry: push/enter vs. eval/apply+                     for higher-order languages", by Simon Marlow and Simon Peyton Jones. It provides the option+                     to trace the execution of the interpreter, rendering each step in a HTML file. This is useful+                     for understanding the behaviour of the STG machine, and also useful for experimenting with +                     changes to the machine. It also supports an experimental call stack tracing facility.+category:            Language+license:             BSD3+license-file:        LICENSE+copyright:           (c) 2009 Bernard James Pope+author:              Bernard James Pope +maintainer:          bjpop@csse.unimelb.edu.au+homepage:            http://www.haskell.org/haskellwiki/Ministg +build-type:          Simple+stability:           experimental+tested-with:         GHC==6.10.4+extra-source-files:  README.txt test/*.stg ++Executable ministg +  main-is:         Main.hs+  hs-source-dirs:  src+  build-depends:   base >= 3 && < 5, monads-tf, transformers, containers, parsec >= 3, pretty, haskell98, xhtml, directory, filepath+  other-modules:+      Ministg.AST+      Ministg.Lexer+      Ministg.Parser+      Ministg.Utils+      Ministg.Eval+      Ministg.Arity+      Ministg.Pretty+      Ministg.State+      Ministg.TraceEval+      Ministg.CallStack+      Ministg.Options+      Ministg.GC+      Ministg.Annotate

@@ -0,0 +1,80 @@+-----------------------------------------------------------------------------+-- |+-- Module      : Main +-- Copyright   : (c) 2009 Bernie Pope +-- License     : BSD-style+-- Maintainer  : bjpop@csse.unimelb.edu.au+-- Stability   : experimental+-- Portability : ghc+--+-- The main module of ministg. An interpreter for the operational semantics+-- of the STG machine, as set out in the "How to make a fast curry" paper+-- by Simon Marlow and Simon Peyton Jones.+-----------------------------------------------------------------------------++module Main where++import System (exitFailure)+import Ministg.AST (Program (Program))+import Ministg.Parser (parser)+import Ministg.Lexer (lexer, Token)+import Control.Monad (when, unless)+import System (getArgs, exitFailure)+import System.Directory (doesDirectoryExist, createDirectory)+import Ministg.Utils (safeReadFile)+import Ministg.Arity (runArity)+import Ministg.Eval (run)+import Ministg.Pretty (prettyText)+import Ministg.Options (processOptions, Flag (..), Dumped (..), existsFlag, getTraceDir)+import Ministg.Annotate++-- | The main driver of the program.+main :: IO ()+main = do+   args <- getArgs+   (flags, file) <- processOptions args+   -- create trace directory if necessary+   when (existsFlag flags Trace) $ do+      let traceDir = getTraceDir flags+      dirExist <- doesDirectoryExist traceDir+      unless dirExist $ createDirectory traceDir +   -- parse the file+   Program userProgram <- parseFile flags file+   -- optionally include the Prelude+   fullProgram +      <- if existsFlag flags NoPrelude+            then return (Program userProgram)+            else do Program preludeProgram <- parseFile flags "Prelude.stg"+                    return $ Program (preludeProgram ++ userProgram)+   -- possibly annotate the program with stack markers+   let annotated = if existsFlag flags Annotate +                      then annotate fullProgram else fullProgram +   -- compute arities of known functions+   let arityProgram = runArity annotated +   dump flags DumpArity (prettyText arityProgram) $+      "The program after arity analysis:\n"+   -- interpret the program+   run flags arityProgram++parseFile :: [Flag] -> FilePath -> IO Program+parseFile flags file = do+   tryContents <- safeReadFile file+   case tryContents of+      Left error -> putStrLn error >> exitFailure+      Right contents -> do+         -- parse the program+         case parser file contents of+            Left e -> (putStrLn $ "Parse error: " ++ show e) >> exitFailure+            Right program -> do +               dump flags DumpAST (show program) $ "The AST of the program from " ++ file ++ ":\n"+               dump flags DumpParsed (prettyText program) $+                    "The parsed program from " ++ file ++ ":\n"+               return program ++dump :: [Flag] -> Dumped -> String -> String -> IO () +dump flags dumped str msg = +   when (existsFlag flags $ Dump dumped) $ do+      putStrLn msg +      putStrLn str +      putStr "\n"+

@@ -0,0 +1,222 @@+-----------------------------------------------------------------------------+-- |+-- Module      : Ministg.AST +-- Copyright   : (c) 2009 Bernie Pope +-- License     : BSD-style+-- Maintainer  : bjpop@csse.unimelb.edu.au+-- Stability   : experimental+-- Portability : ghc+--+-- The representation of the abstract syntax tree for ministg programs. +-----------------------------------------------------------------------------+module Ministg.AST where++import Prelude +import Ministg.CallStack (CallStack, prettyCallStack)+import Ministg.Pretty+import Data.Set as Set hiding (map)++-- | Variables (also known as identifiers).+type Var = String+-- | Data constructor names.+type Constructor = String++class FreeVars t where+   freeVars :: t -> Set Var++instance FreeVars t => FreeVars [t] where+   freeVars = Set.unions . map freeVars++-- | Literal integers. These correspond to unboxed integers in the semantics.+data Literal = Integer Integer +   deriving (Eq, Show)++instance Pretty Literal where+   pretty (Integer i) = pretty i++-- | Atomic expressions.+data Atom+   = Literal Literal    -- ^ Literal values (unoboxed integers).+   | Variable Var       -- ^ Variables.+   deriving (Eq, Show)++instance Pretty Atom where+   pretty (Literal l) = pretty l+   pretty (Variable v) = text v++instance FreeVars Atom where+   freeVars (Literal {}) = Set.empty+   freeVars (Variable v) = Set.singleton v++-- | Is an atom a literal?+isLiteral :: Atom -> Bool+isLiteral (Literal {}) = True+isLiteral _other = False++-- | The arity (number of parameters) of a function. It is only known when the function +-- being applied is statically known (not lambda bound).+type FunArity = Maybe Int++prettyArity :: FunArity -> Doc+prettyArity Nothing = text "_?" +prettyArity (Just i) = text "_" <> int i++-- | Expressions.+data Exp +   = Atom Atom                  -- ^ Atomic expressions (literals, variables).+   | FunApp FunArity Var [Atom] -- ^ Function application (f^k a_1 ... a_n, n >= 1).+   | PrimApp Prim [Atom]        -- ^ Saturated primitive application (op a_1 ... a_n, n >= 1).+   | Let Var Object Exp         -- ^ Let declaration. +   | Case Exp [Alt]             -- ^ Case expression.+   | Stack String Exp           -- ^ Like SCC, but just for stacks. (stack str (exp))+   deriving (Eq, Show)++instance FreeVars Exp where+   freeVars (Atom a) = freeVars a+   freeVars (FunApp _arity var args) = Set.singleton var `Set.union` freeVars args+   freeVars (PrimApp prim args) = freeVars args+   -- Treat this as a letrec, which means that the var is bound (not free) in the object+   freeVars (Let var object exp) +      = Set.delete var (freeVars exp `Set.union` freeVars object) +   freeVars (Case exp alts)+      = freeVars exp `Set.union` freeVars alts+   freeVars (Stack _str exp) = freeVars exp++instance Pretty Exp where+   pretty (Atom a) = pretty a+   pretty (FunApp arity var atoms) = text var <> prettyArity arity <+> hsep (map pretty atoms)+   pretty (PrimApp prim atoms) = pretty prim <+> hsep (map pretty atoms)+   pretty letExp@(Let var obj exp) +      = maybeNest (text "let {") prettyDecls (rbrace <+> text "in" <+> pretty inExp)+      where+      (decls, inExp) = unflattenLet letExp+      prettyDecls = vcat (punctuate semi (map pretty decls))+      maybeNest letPart declPart inPart+         | length decls < 2 = letPart <+> declPart <+> inPart+         | otherwise = letPart $$ (nest 3 declPart) $$ inPart+   pretty (Case exp alts) = +      text "case" <+> pretty exp <+> text "of {" $$ +      nest 3 (vcat (punctuate semi (map pretty alts))) $$+      rbrace+   pretty (Stack annotation exp) = +      maybeNest exp (text "stack" <+> doubleQuotes (text annotation)) (pretty exp)++isNestedExp :: Exp -> Bool+isNestedExp (Let {}) = True+isNestedExp (Case {}) = True+isNestedExp (Stack {}) = True+isNestedExp other = False ++unflattenLet :: Exp -> ([Decl], Exp)+unflattenLet exp = unflattenLetAcc exp []+   where+   unflattenLetAcc :: Exp -> [Decl] -> ([Decl], Exp)+   unflattenLetAcc (Let var obj exp) ds = unflattenLetAcc exp (Decl var obj : ds) +   unflattenLetAcc exp ds = (reverse ds, exp) ++-- | Case alternatives (the right-hand-sides of case branches).+data Alt+   = PatAlt Constructor [Var] Exp  -- ^ Constructor pattern (C x_1 ... x_n -> e, n >= 0).+   | DefaultAlt Var Exp            -- ^ Default pattern (matches anything) (x -> e).+   deriving (Eq, Show)++instance FreeVars Alt where+   freeVars (PatAlt constructor args exp) = freeVars exp \\ Set.fromList args+   freeVars (DefaultAlt var exp) = Set.delete var $ freeVars exp ++instance Pretty Alt where+   pretty (PatAlt con vars exp) = maybeNest exp (text con <+> hsep (map text vars) <+> rightArrow) (pretty exp)+   pretty (DefaultAlt var exp) = text var <+> rightArrow <+> pretty exp++rightArrow :: Doc+rightArrow = text "->" ++-- | Objects. These serve two roles in the language: +-- +-- (1) as part of the language syntax (except blackholes).+-- (2) as things which are allocated on the heap during execution.++data Object+   = Fun [Var] Exp                 -- ^ Function values (FUN (x_1 ... x_n -> e).+   | Pap Var [Atom]                -- ^ Partial applications (PAP (f a_1 ... a_n)).+   | Con Constructor [Atom]        -- ^ Data constructor application (CON (C a_1 ... a_n)).+   | Thunk Exp CallStack           -- ^ THUNK (e).+   | BlackHole                     -- ^ BLACKHOLE (only during evaluation - not part of the language syntax).+   | Error                         -- ^ Raise an exception.+   deriving (Eq, Show)++instance FreeVars Object where+   freeVars (Fun vars exp) = freeVars exp \\ Set.fromList vars+   freeVars (Pap var args) = Set.singleton var `Set.union` freeVars args+   freeVars (Con constructor args) = freeVars args+   freeVars (Thunk exp callStack) = freeVars exp +   freeVars BlackHole = Set.empty+   freeVars Error = Set.empty++maybeNest :: Exp -> Doc -> Doc -> Doc+maybeNest exp d1 d2 = if isNestedExp exp then d1 $$ (nest 3 d2) else d1 <+> d2++instance Pretty Object where+   pretty (Fun vars exp) +      = text "FUN" <> parens (maybeNest exp (hsep (map text vars) <+> rightArrow) (pretty exp))+   pretty (Pap var atoms) = text "PAP" <> parens (text var <+> hsep (map pretty atoms))+   pretty (Con constructor atoms) = text "CON" <> parens (text constructor <+> hsep (map pretty atoms))+   pretty (Thunk exp callStack) +      = text "THUNK" <> parens (pretty exp) $$ (nest 3 (prettyCallStack callStack))+   pretty BlackHole = text "BLACKHOLE"+   pretty Error = text "ERROR"++-- | Test for "value" objects.+isValue :: Object -> Bool+isValue (Fun {}) = True+isValue (Pap {}) = True+isValue (Con {}) = True+isValue _other = False++-- | Test for FUN objects+isFun :: Object -> Bool+isFun (Fun {}) = True+isFun other = False++-- | Test for PAP objects+isPap :: Object -> Bool+isPap (Pap {}) = True+isPap other = False++-- | A top-level declaration (f = obj).+data Decl = Decl Var Object+   deriving Show++instance Pretty Decl where+   pretty (Decl var obj) = text var <+> equals <+> pretty obj++-- | A whole program.+newtype Program = Program [Decl]+   deriving Show++instance Pretty Program where+   pretty (Program decls) = vcat (punctuate semi (map pretty decls))++-- | Primitive operators.+data Prim+   = Add                        -- ^ Unboxed integer addition (x + y).+   | Subtract                   -- ^ Unboxed integer subtraction (x - y).+   | Multiply                   -- ^ Unboxed integer multiplication (x * y).+   | Equality                   -- ^ Unboxed integer equality test (x == y).+   | LessThan                   -- ^ Unboxed integer less-than comparison (x < y).+   | GreaterThan                -- ^ Unboxed integer greater-than comparison ( x > y). +   | LessThanEquals             -- ^ Unboxed integer less-than-equals comparison ( x <= y).+   | GreaterThanEquals          -- ^ Unboxed integer greater-than-equals comparison ( x >= y).+   | IntToBool                  -- ^ Convert an unboxed integer to a (boxed) boolean ( 1 = True, 0 = False).+   deriving (Eq, Show)++instance Pretty Prim where+   pretty Add = text "plus#"+   pretty Subtract = text "sub#"+   pretty Multiply = text "mult#"+   pretty Equality = text "eq#"+   pretty LessThan = text "lt#"+   pretty GreaterThan = text "gt#"+   pretty LessThanEquals = text "lte#"+   pretty GreaterThanEquals = text "gte#" +   pretty IntToBool = text "intToBool#"

@@ -0,0 +1,34 @@+-----------------------------------------------------------------------------+-- |+-- Module      : Ministg.Annotate+-- Copyright   : (c) 2009 Bernie Pope +-- License     : BSD-style+-- Maintainer  : bjpop@csse.unimelb.edu.au+-- Stability   : experimental+-- Portability : ghc+--+-- Add stack annotations to top-level functions in ministg programs. +-----------------------------------------------------------------------------+module Ministg.Annotate where++import Ministg.AST++class Annotate t where+   annotate :: t -> t++instance Annotate a => Annotate [a] where+   annotate = map annotate++instance Annotate Program where+   annotate (Program decls) = Program $ annotate decls++instance Annotate Decl where+   -- don't annotate functions which are already annotated (by the user)+   annotate decl@(Decl _ (Fun _ (Stack {}))) = decl+   annotate (Decl var (Fun args body))+      = Decl var (Fun args (Stack var body))+   -- don't annotate thunks which are already annotated (by the user)+   annotate decl@(Decl _ (Thunk (Stack {}) _)) = decl+   annotate decl@(Decl var (Thunk body callStack)) +      = Decl var (Thunk (Stack var body) callStack) +   annotate other = other

@@ -0,0 +1,78 @@+{-# OPTIONS_GHC -XTypeSynonymInstances #-}+-----------------------------------------------------------------------------+-- |+-- Module      : Ministg.Arity+-- Copyright   : (c) 2009 Bernie Pope +-- License     : BSD-style+-- Maintainer  : bjpop@csse.unimelb.edu.au+-- Stability   : experimental+-- Portability : ghc+--+-- Arity analysis of ministg programs: compute how many arguments each+-- top-level and let-bound function has, and annotate the application sites+-- of those functions.+-----------------------------------------------------------------------------++module Ministg.Arity (runArity, Arity) where++import Data.Map as Map+import Control.Monad.Reader+import Control.Applicative+import Ministg.AST+import Data.List (foldl')++-- | A mapping from variable names (names of functions) to their respective+-- arities.+type ArityMap = Map Var Int+-- | A monad for pushing arity information down the AST, taking care of +-- variable scope. +type A a = Reader ArityMap a++-- | Arity analysis of a program fragment.+runArity :: Arity a => a -> a+runArity x = runReader (arity x) Map.empty ++-- | Overloaded arity function.+class Arity a where+   arity :: a -> A a ++instance Arity Alt where+   arity (PatAlt con args body) = +      PatAlt con args <$> local (clearVars args) (arity body)+   arity (DefaultAlt var body) = +      DefaultAlt var <$> local (clearVars [var]) (arity body)++instance Arity Object where+   arity (Fun args body) = Fun args <$> local (clearVars args) (arity body)+   arity (Thunk exp cs) = Thunk <$> arity exp <*> pure cs+   arity other = return other++instance Arity Program where+   arity (Program decls) = Program <$> (local (Map.union as) $ mapM arity decls)+      where+      as :: ArityMap+      as = Map.fromList [ (var, countArgs obj) | Decl var obj <- decls, isFun obj]++-- | Count the number of arguments (really parameters) of a function object).+countArgs :: Object -> Int+countArgs (Fun args _) = length args+countArgs other = error $ "countArgs called on non function: " ++ show other++instance Arity Decl where+   arity (Decl var object) = Decl var <$> arity object++instance Arity Exp where+   arity (FunApp _oldArity var args) = +      FunApp <$> asks (Map.lookup var) <*> pure var <*> pure args+   arity (Let var object exp)+      | isFun object = +           Let var <$> arity object <*> local (Map.insert var $ countArgs object) (arity exp)+      | otherwise = Let var <$> arity object <*> local (clearVars [var]) (arity exp)+   arity (Case exp alts) = Case <$> arity exp <*> mapM arity alts +   arity (Stack annotation exp) = Stack annotation <$> arity exp+   arity exp@(Atom {}) = return exp+   arity exp@(PrimApp {}) = return exp++-- | Remove a list of variables from an ArityMap.+clearVars :: [Var] -> ArityMap -> ArityMap+clearVars vars map = foldl' (flip Map.delete) map vars

@@ -0,0 +1,27 @@+-----------------------------------------------------------------------------+-- |+-- Module      : Ministg.CallStack+-- Copyright   : (c) 2009 Bernie Pope +-- License     : BSD-style+-- Maintainer  : bjpop@csse.unimelb.edu.au+-- Stability   : experimental+-- Portability : ghc+--+-- Stack of program annotations. Simulate a call stack.+-----------------------------------------------------------------------------++module Ministg.CallStack (CallStack, push, showCallStack, prettyCallStack) where++import Ministg.Pretty++type CallStack = [String]++push :: String -> CallStack -> CallStack+push = (:)++showCallStack :: CallStack -> String+showCallStack = unlines++prettyCallStack :: CallStack -> Doc+prettyCallStack [] = empty+prettyCallStack stack = char '<' <> hcat (punctuate (text "|") (map text stack)) <> char '>'

@@ -0,0 +1,321 @@+{-# OPTIONS_GHC -XPatternGuards #-}+-----------------------------------------------------------------------------+-- |+-- Module      : Ministg.Eval+-- Copyright   : (c) 2009 Bernie Pope +-- License     : BSD-style+-- Maintainer  : bjpop@csse.unimelb.edu.au+-- Stability   : experimental+-- Portability : ghc+--+-- Evaluate a ministg program using the semantics described in the +-- "fast curry" paper by Simon Marlow and Simon Peyton Jones.+-----------------------------------------------------------------------------++module Ministg.Eval (run) where++import Control.Monad.State (evalStateT, gets)+import Control.Monad.Trans (liftIO)+import Data.Map as Map hiding (map)+import Data.List (foldl')+import Ministg.AST+import Ministg.CallStack (CallStack, push, showCallStack)+import Ministg.Pretty+import Ministg.State+import Ministg.TraceEval (traceEval, traceEnd)+import Ministg.Options as Opts +       (Flag (..), EvalStyle (..), defaultEvalStyle, probeFlagsFirst, getEvalStyle)+import Ministg.GC (garbageCollect)++-- | Evaluate a ministg program and cause its effects to happen.+run :: [Flag] -> Program -> IO ()+run flags decls = +   evalStateT (evalProgram style $ initHeap decls) (initState flags)+   where+   style = getEvalStyle flags++evalProgram :: EvalStyle -> Heap -> Eval ()+evalProgram style heap = do+   (newExp, _newStack, newHeap) <- bigStep style (Atom (Variable "main")) initStack heap+   traceEnd+   str <- case newExp of+             Atom (Literal lit) -> return $ prettyText lit +             Atom (Variable var) -> do+                let object = lookupHeap var newHeap+                case object of+                   Error -> do+                      cs <- gets state_callStack+                      return $ "Exception raised!" ++ displayCallStack cs+                   other -> return $ prettyHeapObject newHeap $ lookupHeap var newHeap+             other -> return $ "Runtime error: result of bigStep is not an atom: " ++ show other +   liftIO $ putStrLn str+   where+   displayCallStack [] = []+   displayCallStack cs = "\n\nCall stack:\n" ++ showCallStack cs+        +-- | Reduce an exression to WHNF (a big step reduction, which may be composed+-- of one or more small step reductions).+bigStep :: EvalStyle -> Exp -> Stack -> Heap -> Eval (Exp, Stack, Heap) +bigStep style exp stack heap = do+   gcHeap <- garbageCollect exp stack heap+   traceEval exp stack gcHeap +   result <- smallStep style exp stack gcHeap+   incStepCount+   case result of+      -- Nothing more to do, we have reached a WHNF value (or perhaps some error).+      Nothing -> return (exp, stack, gcHeap)+      -- There might be more to do, keep trying.+      Just (newExp, newStack, newHeap) -> bigStep style newExp newStack newHeap++-- | Perform one step of reduction. These equations correspond to the+-- rules in the operational semantics described in the "fast curry" paper.+smallStep :: EvalStyle -> Exp -> Stack -> Heap -> Eval (Maybe (Exp, Stack, Heap))+-- STACK ANNOTATION+smallStep style (Stack annotation exp) stack heap = do+   setRule "STACK"+   pushCallStack annotation+   return $ Just (exp, stack, heap)+-- LET+smallStep _anyStyle (Let var object exp) stack heap = do+   setRule "LET"+   newVar <- freshVar+   callStack <- gets state_callStack+   let annotatedObject = setThunkStack callStack object+   let newHeap = updateHeap newVar annotatedObject heap+   let newExp = subs (mkSub var (Variable newVar)) exp +   return $ Just (newExp, stack, newHeap)+-- CASECON+smallStep _anyStyle (Case (Atom (Variable v)) alts) stack heap+   | Con constructor args <- lookupHeap v heap, +     Just (vars, exp) <- exactPatternMatch constructor alts = do+        setRule "CASECON"+        return $ Just (subs (mkSubList $ zip vars args) exp, stack, heap)+-- CASEANY+smallStep _anyStyle (Case (Atom v) alts) stack heap+   | isLiteral v || isValue (lookupHeapAtom v heap), +     Just (x, exp) <- defaultPatternMatch alts = do+        setRule "CASEANY"+        return $ Just (subs (mkSub x v) exp, stack, heap)+-- CASE+smallStep _anyStyle (Case exp alts) stack heap = do+   setRule "CASE"+   callStack <- gets state_callStack+   return $ Just (exp, CaseCont alts callStack : stack, heap)+-- RET +smallStep _anyStyle exp@(Atom atom) (CaseCont alts oldCallStack : stackRest) heap+   | isLiteral atom || isValue (lookupHeapAtom atom heap) = do+        setRule "RET"+        setCallStack oldCallStack+        return $ Just (Case exp alts, stackRest, heap)+-- THUNK +smallStep _anyStyle (Atom (Variable x)) stack heap+   | Thunk exp thunkCallStack <- lookupHeap x heap = do+        setRule "THUNK"+        let newHeap = updateHeap x BlackHole heap+        oldCallStack <- gets state_callStack+        setCallStack thunkCallStack +        return $ Just (exp, UpdateCont x oldCallStack : stack, newHeap)+-- UPDATE+smallStep _anyStyle atom@(Atom (Variable y)) (UpdateCont x oldCallStack : stackRest) heap+   | object <- lookupHeap y heap, isValue object = do+        setRule "UPDATE"+        setCallStack oldCallStack+        return $ Just (atom, stackRest, updateHeap x object heap)+-- KNOWNCALL+smallStep _anyStyle (FunApp (Just arity) var args) stack heap+   | arity == length args = +        case lookupHeap var heap of+           Fun params body -> do+              setRule "KNOWNCALL"+              let newBody = subs (mkSubList $ zip params args) body+              return $ Just (newBody, stack, heap) +           other -> fail $ "known function " ++ var ++ " bound to non function object: " ++ show other+-- PRIMOP+smallStep _anyStyle (PrimApp prim args) stack heap = do+   setRule "PRIMOP"+   (result, newStack, newHeap) <- evalPrim prim args stack heap+   return $ Just (Atom result, newStack, newHeap)++-- The push enter specific rules.++-- PUSH+smallStep PushEnter (FunApp _arity f args) stack heap = do+   setRule "PUSH"+   return $ Just (Atom (Variable f), map ArgCont args ++ stack, heap)+-- FENTER+smallStep PushEnter (Atom (Variable f)) stack heap+   | Fun vars exp <- lookupHeap f heap,+     (argConts, restStack) <- span isArgCont stack,+     length vars <= length argConts = do+        setRule "FENTER"+        let (enoughArgs, restArgs) = splitAt (length vars) argConts+        let argAtoms = [atom | ArgCont atom <- enoughArgs]+        let newStack = restArgs ++ restStack +        return $ Just (subs (mkSubList $ zip vars argAtoms) exp, newStack, heap) +-- PAP1+smallStep PushEnter (Atom (Variable f)) stack heap+   | Fun vars exp <- lookupHeap f heap,+     argConts <- takeWhile isArgCont stack,+     length argConts >= 1,+     length vars > length argConts = do+        setRule "PAP1"+        let argAtoms = [atom | ArgCont atom <- argConts]+        p <- freshVar+        return $ Just (Atom (Variable p), drop (length argConts) stack, updateHeap p (Pap f argAtoms) heap)+-- PENTER+smallStep PushEnter (Atom (Variable f)) stack@(ArgCont _ : stackRest) heap+   | Pap g args <- lookupHeap f heap = do+        setRule "PENTER"+        return $ Just (Atom (Variable g), map ArgCont args ++ stack, heap) ++-- The eval apply rules++-- EXACT+smallStep EvalApply (FunApp Nothing f args) stack heap+   | Fun vars exp <- lookupHeap f heap, length args == length vars = do+        setRule "EXACT"+        let newExp = subs (mkSubList $ zip vars args) exp+        return $ Just (newExp, stack, heap)+-- CALLK+smallStep EvalApply (FunApp _anyArity f args) stack heap+   | Fun vars exp <- lookupHeap f heap, length args > length vars = do+        setRule "CALLK"+        let (enoughArgs, restArgs) = splitAt (length vars) args+            newExp = subs (mkSubList $ zip vars enoughArgs) exp+        return $ Just (newExp, (ApplyToArgs restArgs) : stack, heap)+-- PAP2+smallStep EvalApply (FunApp _anyArity f args) stack heap+   | Fun vars exp <- lookupHeap f heap, length args < length vars = do+        setRule "PAP2"+        p <- freshVar+        let newHeap = updateHeap p (Pap f args) heap+        return $ Just (Atom (Variable p), stack, newHeap)+-- TCALL+-- XXX fix up call stack?+smallStep EvalApply (FunApp Nothing f args) stack heap+   | Thunk exp thunkCallStack <- lookupHeap f heap = do+        setRule "TCALL"+        return $ Just (Atom (Variable f), (ApplyToArgs args) : stack, heap)+-- PCALL+smallStep EvalApply (FunApp _anyArity f args) stack heap+   | Pap g papArgs <- lookupHeap f heap = do+        setRule "PCALL"+        return $ Just (FunApp Nothing g (papArgs ++ args), stack, heap)+-- RETFUN+smallStep EvalApply (Atom (Variable f)) (ApplyToArgs args : stack) heap+   | object <- lookupHeap f heap, isFun object || isPap object = do+        setRule "RETFUN"+        return $ Just (FunApp Nothing f args, stack, heap)++-- NOTHING MORE TO DO+smallStep _anyStyle _other _stack _heap = do+   setRule "None"+   return Nothing++-- | Evaluate the application of a primitive function. It is assumed that the+-- arguments of the primitive are already evaluated. Note: we allow primitives+-- to manipulate the heap and stack, but the semantics in the "fast curry" paper+-- do not.+evalPrim :: Prim -> [Atom] -> Stack -> Heap -> Eval (Atom, Stack, Heap)+evalPrim Add args stack heap = mkIntPrim (+) args stack heap+evalPrim Subtract args stack heap = mkIntPrim (-) args stack heap+evalPrim Multiply args stack heap = mkIntPrim (*) args stack heap+evalPrim Equality args stack heap = mkIntComparePrim (==) args stack heap+evalPrim LessThan args stack heap = mkIntComparePrim (<) args stack heap+evalPrim LessThanEquals args stack heap = mkIntComparePrim (<=) args stack heap+evalPrim GreaterThan args stack heap = mkIntComparePrim (>) args stack heap+evalPrim GreaterThanEquals args stack heap = mkIntComparePrim (>=) args stack heap+evalPrim IntToBool [Literal (Integer i)] stack heap = do+   var <- freshVar+   let newHeap = updateHeap var (Con (if i == 1 then "True" else "False") []) heap+   return (Variable var, stack, newHeap)+evalPrim prim args stack heap = error $ show (prim,args)++-- | Check for an exact pattern match for a data constructor in a list of case alternatives.+exactPatternMatch :: Constructor -> [Alt] -> Maybe ([Var], Exp)+exactPatternMatch con1 (PatAlt con2 vars exp : alts)+   | con1 == con2 = Just (vars, exp)+   | otherwise = exactPatternMatch con1 alts+exactPatternMatch con (DefaultAlt {} : _) = Nothing+exactPatternMatch _con [] = Nothing++-- | Check for a default pattern match (x -> e) in a list of case alternatives.+defaultPatternMatch :: [Alt] -> Maybe (Var, Exp)+defaultPatternMatch [] = Nothing+defaultPatternMatch (PatAlt {} : alts) = defaultPatternMatch alts+defaultPatternMatch (DefaultAlt var exp : _alts) = Just (var, exp) ++-- | Convenience function for making integer primitives. +mkIntPrim :: (Integer -> Integer -> Integer) -> [Atom] -> Stack -> Heap -> Eval (Atom, Stack, Heap)+mkIntPrim op [Literal (Integer i), Literal (Integer j)] stack heap+   = return (Literal $ Integer (i `op` j), stack, heap)++-- | Convenience function for making integer comparison primitives. +mkIntComparePrim :: (Integer -> Integer -> Bool) -> [Atom] -> Stack -> Heap -> Eval (Atom, Stack, Heap)+mkIntComparePrim op args stack heap = mkIntPrim (\i j -> if i `op` j then 1 else 0) args stack heap++setThunkStack :: CallStack -> Object -> Object+setThunkStack cs (Thunk e _oldCS) = Thunk e cs+setThunkStack cs other = other++type Substitution = Map.Map Var Atom++mkSub :: Var -> Atom -> Substitution +mkSub = Map.singleton++mkSubList :: [(Var, Atom)] -> Substitution+mkSubList = Map.fromList++removeVars :: [Var] -> Substitution -> Substitution +removeVars vars sub = foldl' (flip Map.delete) sub vars++class Substitute a where+   subs :: Substitution -> a -> a ++instance Substitute a => Substitute [a] where+   subs s = map (subs s)++subsVar :: Substitution -> Var -> Var +subsVar s var = +   case Map.lookup var s of+      Nothing -> var+      Just (Variable newVar) -> newVar+      Just (Literal lit) -> error $ "attempt to substitute variable " ++ var ++ " with literal " ++ show lit++instance Substitute Atom where+   subs s v@(Variable var) = +      case Map.lookup var s of+         Nothing -> v+         Just atom -> atom +   subs _s l@(Literal {}) = l++instance Substitute Exp where+   subs s (Atom a) = Atom $ subs s a+   subs s exp@(FunApp arity var atoms)+      = FunApp arity (subsVar s var) (subs s atoms)+   subs s (PrimApp prim args) = PrimApp prim $ subs s args+   -- lets are not recursive so we don't really need to removeVars from s+   -- in the subs of obj, but it is safe to do so, and we might use it+   -- if lets become recursive.+   subs s exp@(Let var obj body)+      = Let var (subs newSub obj) (subs newSub body)+      where+      newSub = removeVars [var] s+   subs s (Case exp alts) = Case (subs s exp) (subs s alts)+   subs s (Stack str e) = Stack str $ subs s e++instance Substitute Alt where+   subs s p@(PatAlt cons vars exp)+      = PatAlt cons vars $ subs (removeVars vars s) exp+   subs s p@(DefaultAlt var exp)+      = DefaultAlt var $ subs (removeVars [var] s) exp++instance Substitute Object where+   subs s f@(Fun args exp)+      = Fun args $ subs (removeVars args s) exp+   subs s (Pap var atoms)+      = Pap (subsVar s var) (subs s atoms)+   subs s (Con constructor atoms) = Con constructor $ subs s atoms+   subs s (Thunk exp cs) = Thunk (subs s exp) cs+   subs _s BlackHole = BlackHole+   subs _s Error = Error

@@ -0,0 +1,47 @@+-----------------------------------------------------------------------------+-- |+-- Module      : Ministg.GC+-- Copyright   : (c) 2009 Bernie Pope +-- License     : BSD-style+-- Maintainer  : bjpop@csse.unimelb.edu.au+-- Stability   : experimental+-- Portability : ghc+--+-- Garbage collection for ministg.+-----------------------------------------------------------------------------+module Ministg.GC where++import Data.Set as Set hiding (map)+import Data.Map as Map hiding (map, fold)+import Control.Monad.Trans (liftIO)+import Control.Monad.State (gets)+import Ministg.Pretty+import Ministg.State+import Ministg.AST++garbageCollect :: Exp -> Stack -> Heap -> Eval Heap+garbageCollect exp stack heap = do+   wantGC <- gets state_gc +   if wantGC +      then return $ collect roots heap Map.empty +      else return heap+   where+   roots = freeVars exp `Set.union` freeVars stack++collect :: Set Var -> Heap -> Heap -> Heap+collect vars oldHeap newHeap+   = collector vars newHeap+   where+   collector vars newHeap +      | Set.null vars = newHeap+      | otherwise = collector newVars nextHeap +      where+      (newVars, nextHeap) = fold collectVar (Set.empty, newHeap) vars +      collectVar :: Var -> (Set Var, Heap) -> (Set Var, Heap)+      collectVar var (vars, heap)+         | Map.member var heap = (vars, heap)+         | otherwise = (newVars, newHeap)+         where+         object = lookupHeap var oldHeap +         newVars = freeVars object `Set.union` vars+         newHeap = updateHeap var object heap

@@ -0,0 +1,173 @@+-----------------------------------------------------------------------------+-- |+-- Module      : Ministg.Lexer+-- Copyright   : (c) 2009 Bernie Pope +-- License     : BSD-style+-- Maintainer  : bjpop@csse.unimelb.edu.au+-- Stability   : experimental+-- Portability : ghc+--+-- Lexical analysis for ministg programs.+-----------------------------------------------------------------------------++module Ministg.Lexer +   ( Token (..)+   , Symbol (..)+   , Ident+   , lexer+   )+where++import Data.Char +   ( isDigit+   , isAlpha+   , isPrint+   , isLower+   )++import Text.ParserCombinators.Parsec hiding (token)+import Control.Applicative hiding ((<|>), many)++newtype Token = Token (SourcePos, Symbol)++instance Show Token where+   show (Token (pos, symbol)) = show symbol++type Ident = String++data Symbol+   = Variable Ident +   | Constructor Ident+   | Natural Integer+   | QuotedString String+   | Equals+   | BackSlash +   | RightArrow+   | Let+   | In +   | Case+   | Of+   | LeftParen+   | RightParen+   | LeftBrace+   | RightBrace+   | SemiColon+   | Fun+   | Con+   | Pap+   | Thunk +   | Plus+   | Minus+   | Times+   | Equality+   | GreaterThan+   | LessThan+   | GreaterThanEquals+   | LessThanEquals+   | IntToBool+   | Stack+   | Error+   deriving (Eq, Show)++lexer :: String -> String -> Either ParseError [Token] +lexer = parse tokenise ++tokenise :: Parser [Token]+tokenise = skip *> sepEndBy token skip <* eof++skip :: Parser ()+skip = skipMany (comment <|> whiteSpace)++whiteSpace :: Parser ()+whiteSpace = space >> return ()++comment :: Parser () +comment = singleLineComment++singleLineComment :: Parser ()+singleLineComment = string  "#" >> manyTill anyChar eol >> return ()++eol :: Parser ()+eol = newline >> return ()++-- XXX Perhaps it is not sensible to divide the tokens based on their+-- syntactic role. Sometimes tokens from different syntactic classes can have+-- the same prefix.+token :: Parser Token+token = +   punctuation <|>+   keyword     <|> +   variable    <|> +   constructor <|>+   parenthesis <|> +   number <|>+   quotedString++number :: Parser Token+number = tokenPos parseNum Natural+   where+   parseNum :: Parser Integer+   parseNum = read <$> many1 digit++quotedString :: Parser Token+quotedString = tokenPos parseString QuotedString+   where+   parseString :: Parser String+   parseString = char '"' *> manyTill anyChar (char '"')++variable :: Parser Token+variable = tokenPos (parseIdent lower) Variable ++constructor :: Parser Token+constructor = tokenPos (parseIdent upper) Constructor++parseIdent :: Parser Char -> Parser String+parseIdent firstChar = (:) <$> firstChar <*> many (char '_' <|> alphaNum) ++keyword :: Parser Token+keyword =+   key "let"   Let   <|>+   key "in"    In    <|>+   key "case"  Case  <|>+   key "of"    Of    <|>+   key "FUN"   Fun   <|>+   key "CON"   Con   <|>+   key "PAP"   Pap   <|>+   key "THUNK" Thunk <|>+   key "plus#" Plus  <|>+   key "sub#"  Minus <|>+   key "mult#" Times <|>+   key "eq#"   Equality <|>+   key "lt#"   LessThan <|>+   key "lte#"  LessThanEquals <|>+   key "gt#"   GreaterThan <|>+   key "gte#"  GreaterThanEquals <|>+   key "intToBool#" IntToBool <|>+   key "ERROR" Error <|>+   key "stack" Stack+   where+   key :: String -> Symbol -> Parser Token+   key str keyWord = tokenPos (try kwParser) (const keyWord)+      where+      kwParser = string str >> notFollowedBy alphaNum++parenthesis :: Parser Token+parenthesis = +   simpleTok "(" LeftParen  <|> +   simpleTok ")" RightParen <|>+   simpleTok "{" LeftBrace  <|>+   simpleTok "}" RightBrace  ++punctuation :: Parser Token+punctuation = +   simpleTok "=" Equals +   <|> simpleTok ";" SemiColon +   <|> simpleTok "\\" BackSlash +   <|> simpleTok "->" RightArrow++simpleTok :: String -> Symbol -> Parser Token+simpleTok str token = tokenPos (string str) (const token) ++tokenPos :: Parser a -> (a -> Symbol) -> Parser Token+tokenPos parser mkToken = +  Token <$> ((,) <$> getPosition <*> (mkToken <$> parser))

@@ -0,0 +1,173 @@+-----------------------------------------------------------------------------+-- |+-- Module      : Ministg.Options+-- Copyright   : (c) 2009 Bernie Pope +-- License     : BSD-style+-- Maintainer  : bjpop@csse.unimelb.edu.au+-- Stability   : experimental+-- Portability : ghc+--+-- Command line option processing. +-----------------------------------------------------------------------------+module Ministg.Options +   ( processOptions+   , programName+   , defaultMaxSteps+   , defaultEvalStyle+   , defaultTraceDir+   , Flag (..)+   , EvalStyle (..)+   , Dumped (..)+   , probeFlags+   , probeFlagsFirst+   , existsFlag+   , getTraceDir+   , getMaxTraceSteps+   , getEvalStyle+   )+   where++import System.Console.GetOpt +import Data.Maybe (fromMaybe)+import Data.Char (toLower, isDigit)+import Data.Maybe (catMaybes)+import IO (stderr, hPutStrLn)+import System++programName :: String+programName = "ministg"++-- This should really come from the cabal file somehow.+versionNumber :: String+versionNumber = "0.1"++versionInfo :: String+versionInfo = unwords [programName, "version", versionNumber]++processOptions :: [String] -> IO ([Flag], String)+processOptions argv = +   case getOpt RequireOrder options argv of+      (flags, nonOpts, []) +         | existsFlag flags Help -> do +              putStrLn $ usageInfo header options+              exitWith ExitSuccess+         | existsFlag flags Version -> do +              putStrLn versionInfo +              exitWith ExitSuccess+         | length nonOpts /= 1 ->+              raiseError ["You must specify a single input stg file.\n"]  +         | otherwise -> return (flags, head nonOpts)+      (_, _, errs) -> raiseError errs+      where +      header = "Usage: " ++ programName ++ " [OPTION...] file"+      failureMsg = programName ++ ": command line error.\n"+      raiseError errs = do+         hPutStrLn stderr $ failureMsg ++ concat errs ++ usageInfo header options+         exitFailure++probeFlags :: [Flag] -> (Flag -> Maybe a) -> [a]+probeFlags flags probe = catMaybes (map probe flags)++probeFlagsFirst :: [Flag] -> (Flag -> Maybe a) -> a -> a+probeFlagsFirst flags probe defaultValue+   | null probed = defaultValue +   | otherwise = head probed+   where+   probed = probeFlags flags probe++existsFlag :: [Flag] -> Flag -> Bool+existsFlag flags f+   = probeFlagsFirst flags probe False +   where+   probe someFlag = if f == someFlag then Just True else Nothing +    +data Flag +  = Style EvalStyle        -- ^ Which evaluation rules to use (eval/apply or push enter)+  | Trace                  -- ^ Turn tracing on.+  | TraceDir String        -- ^ Directory to save trace file.+  | MaxTraceSteps Integer  -- ^ Maximum trace steps to record.+  | CallStack              -- ^ Include call stack in trace.+  | Dump Dumped            -- ^ Dump something out to debug the interpreter.+  | NoPrelude              -- ^ Do not automatically include the Prelude.+  | NoGC                   -- ^ Disable garbage collection.+  | Help                   -- ^ Print a help message and exit.+  | Version                -- ^ Print the version number. +  | Annotate               -- ^ Auto annotate the program with stack markers.+  deriving (Eq, Ord, Show)++data EvalStyle+   = EvalApply+   | PushEnter+   deriving (Eq, Ord, Show)++data Dumped+  = DumpAST+  | DumpParsed+  | DumpArity+  | DumpNothing+  deriving (Eq, Ord, Show)++options :: [OptDescr Flag]+options =+ [ Option ['s']     ["style"]     (ReqArg mkStyle "STYLE")   "evaluation STYLE to use (EA = eval apply, PE = push enter)"+ , Option ['t']     ["trace"]     (NoArg Trace)              "record a trace of program evaluation"+ , Option []        ["tracedir"]  (ReqArg TraceDir "DIR")    "directory (DIR) to store trace files"+ , Option ['m']     ["maxsteps"]  (ReqArg mkMaxSteps "STEPS")  "maximum number of evaluation STEPS to record in trace"+ , Option ['c']     ["callstack"] (NoArg CallStack)          "enable call stack tracing"+ , Option []        ["noprelude"] (NoArg NoPrelude)          "do not import the Prelude"+ , Option []        ["nogc"]      (NoArg NoGC)               "disable garbage collector"+ , Option ['d']     ["dump"]      (ReqArg mkDumped "DUMPED") "output DUMPED for debugging purposes (ast, parsed, arity)"+ , Option ['v']     ["version"]   (NoArg Version)            "show version number"+ , Option ['h']     ["help"]      (NoArg Help)               "get help about using this program"+ , Option ['a']     ["annotate"]  (NoArg Annotate)           "automatically annotate the program with stack markers"+ ]++defaultTraceDir :: String+defaultTraceDir = "trace"++defaultEvalStyle :: EvalStyle +defaultEvalStyle = PushEnter++mkStyle :: String -> Flag+mkStyle = normalMkStyle . map toLower+   where+   normalMkStyle "ea" = Style EvalApply+   normalMkStyle "pe" = Style PushEnter+   normalMkStyle other = Style defaultEvalStyle++mkDumped :: String -> Flag+mkDumped = normalMkDumped . map toLower+   where+   normalMkDumped "ast"    = Dump DumpAST+   normalMkDumped "parsed" = Dump DumpParsed+   normalMkDumped "arity"  = Dump DumpArity+   normalMkDumped other    = Dump DumpNothing++defaultMaxSteps :: Integer +defaultMaxSteps = 1000++mkMaxSteps :: String -> Flag +mkMaxSteps [] = MaxTraceSteps defaultMaxSteps +mkMaxSteps n+   | all isDigit n = MaxTraceSteps $ read n+   | otherwise = MaxTraceSteps defaultMaxSteps++getMaxTraceSteps :: [Flag] -> Integer +getMaxTraceSteps flags =+      probeFlagsFirst flags probe defaultMaxSteps+      where probe (MaxTraceSteps i) = Just i+            probe other = Nothing++getTraceDir :: [Flag] -> String+getTraceDir flags =+   probeFlagsFirst flags probe defaultTraceDir+      where probe (TraceDir d) = Just d+            probe other = Nothing++getEvalStyle :: [Flag] -> EvalStyle+getEvalStyle flags =+   probeFlagsFirst flags probe defaultEvalStyle+   where+   probe :: Flag -> Maybe EvalStyle+   probe (Style style) = Just style+   probe other = Nothing

@@ -0,0 +1,177 @@+-----------------------------------------------------------------------------+-- |+-- Module      : Ministg.Parser+-- Copyright   : (c) 2009 Bernie Pope +-- License     : BSD-style+-- Maintainer  : bjpop@csse.unimelb.edu.au+-- Stability   : experimental+-- Portability : ghc+--+-- Parsing for ministg programs.+-----------------------------------------------------------------------------+module Ministg.Parser (parser) where++import Prelude hiding (exp, subtract)+import Text.ParserCombinators.Parsec hiding (Parser)+import qualified Ministg.Lexer as Lex+import Ministg.AST hiding (rightArrow)+import Control.Applicative hiding ((<|>), many)++type Parser a = GenParser Lex.Token () a++tokenParser :: (Lex.Symbol -> Maybe a) -> Parser a+tokenParser test+   = token showToken posToken testToken+   where+   showToken (Lex.Token (pos,tok)) = show tok+   posToken  (Lex.Token (pos,tok)) = pos+   testToken (Lex.Token (pos,tok)) = test tok++symbol :: Lex.Symbol -> Parser ()+symbol tok+   = tokenParser $ +        \next -> if next == tok then Just () else Nothing++parser :: FilePath -> String -> Either ParseError Program +parser source input+   = case Lex.lexer source input of+        Left err -> Left err+        Right toks -> parse program source toks ++program :: Parser Program+program = Program <$> sepEndBy decl semiColon <* eof++decl :: Parser Decl+decl = Decl <$> var <*> (equals *> object)++exp :: Parser Exp+exp = funCallOrVar <|> +      expAtomLiteral <|> +      primApp <|> +      letExp <|> +      caseExp <|>+      stack++stack :: Parser Exp+stack = Stack <$> (symbol Lex.Stack *> quotedString) <*> exp++quotedString :: Parser String +quotedString = tokenParser getString+   where+   getString (Lex.QuotedString s) = Just s+   getString other = Nothing ++funCallOrVar :: Parser Exp+funCallOrVar = do+   v <- var+   args <- many atom+   return $ if null args+      then Atom $ Variable v+      -- we don't know the arity of the function yet.+      else FunApp Nothing v args ++expAtomLiteral :: Parser Exp+expAtomLiteral = Atom <$> atomLiteral ++expAtom :: Parser Exp+expAtom = Atom <$> atom++primApp :: Parser Exp+primApp = PrimApp <$> primOp <*> many1 atom ++primOp, add, subtract, multiply, eq, lessThan, greaterThan, lessThanEquals, greaterThanEquals :: Parser Prim++primOp = +   add <|> +   subtract <|> +   multiply <|> +   eq <|> +   lessThan <|> +   greaterThan <|> +   lessThanEquals <|> +   greaterThanEquals <|> +   intToBool++add = const Add <$> symbol Lex.Plus+subtract = const Subtract <$> symbol Lex.Minus+multiply = const Multiply <$> symbol Lex.Times+eq = const Equality <$> symbol Lex.Equality+lessThan = const LessThan <$> symbol Lex.LessThan+lessThanEquals = const LessThanEquals <$> symbol Lex.LessThanEquals+greaterThan = const GreaterThan <$> symbol Lex.GreaterThan+greaterThanEquals = const GreaterThanEquals <$> symbol Lex.GreaterThanEquals+intToBool = const IntToBool <$> symbol Lex.IntToBool++letExp :: Parser Exp+letExp = flattenLet <$> (symbol Lex.Let *> leftBrace *> sepEndBy1 decl semiColon <* rightBrace) <*> (symbol Lex.In *> exp)++flattenLet :: [Decl] -> Exp -> Exp+flattenLet [Decl var obj] body = Let var obj body+flattenLet (Decl var obj : decls) body = Let var obj $ flattenLet decls body ++caseExp :: Parser Exp+caseExp = Case <$> (symbol Lex.Case *> exp) <*> (symbol Lex.Of *> leftBrace *> sepEndBy1 alt semiColon <* rightBrace)++atom, atomLiteral, atomVariable :: Parser Atom+atom = atomLiteral <|> atomVariable+atomLiteral = Literal <$> literal+atomVariable = Variable <$> var++literal :: Parser Literal+literal = Integer <$> natural ++alt :: Parser Alt+alt = patAlt <|> defaultAlt++patAlt :: Parser Alt+patAlt = PatAlt <$> constructor <*> many var <*> (rightArrow *> exp)++defaultAlt :: Parser Alt+defaultAlt = DefaultAlt <$> var <*> (rightArrow *> exp)++object :: Parser Object+object = fun <|> pap <|> con <|> thunk <|> errorObj++fun, pap, con, thunk, errorObj  :: Parser Object+fun = Fun <$> (symbol Lex.Fun *> leftParen *> many1 var) <*> (rightArrow *> exp <* rightParen)+pap = Pap <$> (symbol Lex.Pap *> leftParen *> var) <*> (many1 atom <* rightParen)+con = Con <$> (symbol Lex.Con *> leftParen *> constructor) <*> (many atom <* rightParen)+thunk = Thunk <$> (symbol Lex.Thunk *> leftParen *> exp <* rightParen) <*> pure []+errorObj = const Error <$> symbol Lex.Error++var :: Parser Var +var = tokenParser getIdent+   where+   getIdent (Lex.Variable s) = Just s+   getIdent other = Nothing ++constructor :: Parser Constructor +constructor = tokenParser getIdent+   where+   getIdent (Lex.Constructor s) = Just s+   getIdent other = Nothing ++equals :: Parser ()+equals = symbol Lex.Equals ++semiColon :: Parser ()+semiColon = symbol Lex.SemiColon ++rightArrow :: Parser ()+rightArrow = symbol Lex.RightArrow++leftParen, rightParen :: Parser ()+leftParen = symbol Lex.LeftParen+rightParen = symbol Lex.RightParen++leftBrace, rightBrace :: Parser ()+leftBrace = symbol Lex.LeftBrace+rightBrace = symbol Lex.RightBrace++natural :: Parser Integer +natural = +   tokenParser getNat+   where+   getNat :: Lex.Symbol -> Maybe Integer +   getNat (Lex.Natural n) = Just n +   getNat other = Nothing 

@@ -0,0 +1,47 @@+-----------------------------------------------------------------------------+-- |+-- Module      : Ministg.Pretty+-- Copyright   : (c) 2009 Bernie Pope +-- License     : BSD-style+-- Maintainer  : bjpop@csse.unimelb.edu.au+-- Stability   : experimental+-- Portability : ghc+--+-- Convenient class wrapper for pretty printing. +-----------------------------------------------------------------------------++module Ministg.Pretty (module Ministg.Pretty, module HPJ) where++import Text.PrettyPrint.HughesPJ as HPJ++class Pretty a where+   pretty :: a -> Doc++prettyText :: Pretty a => a -> String+prettyText = render . pretty++parensIf :: Pretty a => (a -> Bool) -> a -> Doc+parensIf test x = if test x then parens $ pretty x else pretty x ++tuple :: Pretty a => [a] -> Doc+tuple = parens . hsep . punctuate comma . map pretty ++instance Pretty Int where+  pretty = int++instance Pretty Integer where+  pretty = integer++instance Pretty Char where+  pretty = char++instance Pretty Double where+   pretty = double++instance Pretty Bool where+  pretty True = text "True"+  pretty False = text "False"++instance Pretty a => Pretty (Maybe a) where+   pretty Nothing = empty+   pretty (Just x) = pretty x

@@ -0,0 +1,183 @@+-----------------------------------------------------------------------------+-- |+-- Module      : Ministg.State+-- Copyright   : (c) 2009 Bernie Pope +-- License     : BSD-style+-- Maintainer  : bjpop@csse.unimelb.edu.au+-- Stability   : experimental+-- Portability : ghc+--+-- Representation of the state of the ministg evaluator.+-----------------------------------------------------------------------------++module Ministg.State +   ( Continuation (..)+   , Stack+   , prettyStack +   , Heap +   , EvalState (..)+   , Eval+   , initStack+   , initHeap+   , initState+   , pushCallStack+   , setCallStack+   , lookupHeap+   , lookupHeapAtom+   , updateHeap+   , freshVar+   , incStepCount+   , setRule+   , prettyHeapObject+   , isArgCont+   )+   where++import Control.Monad.State +import Data.Map as Map hiding (map)+import Data.Set as Set hiding (map)+import Ministg.AST+import Ministg.CallStack (CallStack, push, prettyCallStack)+import Ministg.Pretty +import Ministg.Options +   ( Flag (..), defaultMaxSteps, defaultTraceDir+   , probeFlagsFirst, existsFlag, getTraceDir, getMaxTraceSteps )++-- | Stack continuations.+data Continuation+   = CaseCont [Alt] CallStack -- ^ The alternatives of a case expression.+   | UpdateCont Var CallStack -- ^ A variable which points to a thunk to be updated.+   | ArgCont Atom             -- ^ A pending argument (used only by the push-enter model).+   | ApplyToArgs [Atom]       -- ^ Apply the returned function to these arguments (eval-apply only).+   deriving (Eq, Show)++instance FreeVars Continuation where+   freeVars (CaseCont alts _cs) = freeVars alts+   freeVars (UpdateCont var _cs) = Set.singleton var+   freeVars (ArgCont arg) = freeVars arg+   freeVars (ApplyToArgs args) = freeVars args++instance Pretty Continuation where+   pretty (CaseCont alts callStack) +      = text "case *" <+> braces (vcat (punctuate semi (map pretty alts))) $$+        nest 3 (prettyCallStack callStack)+   pretty (UpdateCont var callStack) +      = text "upd *" <+> text var $$+        nest 3 (prettyCallStack callStack)+   pretty (ArgCont atom) = text "arg" <+> pretty atom +   pretty (ApplyToArgs atoms) = parens (char '*' <+> hsep (map pretty atoms))++isArgCont :: Continuation -> Bool+isArgCont (ArgCont {}) = True+isArgCont _other = False++-- | The evaluation stack. +type Stack = [Continuation]++prettyStack :: Stack -> Doc+prettyStack stack = (vcat $ map prettyCont stack)+   where+   prettyCont :: Continuation -> Doc+   prettyCont cont = text "-" <+> pretty cont++-- | The heap (mapping variables to objects).+type Heap = Map.Map Var Object++-- | State to be threaded through evaluation.+data EvalState +   = EvalState +     { state_unique :: !Int           -- ^ Unique counter for generating fresh variables.+     , state_callStack :: CallStack   -- ^ Function call stack (for debugging).+     , state_stepCount :: !Integer    -- ^ How many steps have been executed.+     , state_lastRule :: !String      -- ^ The most recent evaluation rule applied.+     , state_trace :: Bool            -- ^ Do we want tracing of evaluation steps? +     , state_maxTraceSteps :: Integer -- ^ Maximum number of evaluation steps to trace.+     , state_traceDir :: String       -- ^ Name of directory to store trace files.+     , state_gc :: Bool               -- ^ Do we want garbage collection?+     , state_traceCallStack :: Bool   -- ^ Do we want the call stack shown in the trace?+     }++-- | Eval monad. Combines State and IO.+type Eval a = StateT EvalState IO a++initState :: [Flag] -> EvalState+initState flags = +   EvalState +   { state_unique = 0+   , state_callStack = []+   , state_stepCount = 0 +   , state_lastRule = ""+   , state_trace = existsFlag flags Trace +   , state_maxTraceSteps = getMaxTraceSteps flags+   , state_traceDir = getTraceDir flags+   , state_gc = not $ existsFlag flags NoGC +   , state_traceCallStack = existsFlag flags CallStack+   }++initHeap :: Program -> Heap+initHeap (Program decls) = Map.fromList $ map declToPair decls+   where+   declToPair :: Decl -> (Var, Object)+   declToPair (Decl var obj) = (var, obj)++initStack :: Stack+initStack = []++setRule :: String -> Eval ()+setRule str = do+   lr <- gets state_lastRule+   modify $ \s -> s { state_lastRule = str } ++incStepCount :: Eval ()+incStepCount = do+   sc <- gets state_stepCount+   modify $ \s -> s { state_stepCount = sc + 1 } ++pushCallStack :: String -> Eval ()+pushCallStack str = do+   cs <- gets state_callStack+   modify $ \s -> s { state_callStack = push str cs }++setCallStack :: CallStack -> Eval ()+setCallStack cs = modify $ \s -> s { state_callStack = cs }++-- | Lookup a variable in a heap. If found return the corresponding+-- object, otherwise throw an error (it is a fatal error which can't+-- be recovered from).+lookupHeap :: Var -> Heap -> Object +lookupHeap var heap = +   case Map.lookup var heap of+      Nothing -> error $ "undefined variable: " ++ show var+      Just object -> object++-- | Convenience wrapper for lookupHeap, for atoms which happen to be variables.+lookupHeapAtom :: Atom -> Heap -> Object+lookupHeapAtom (Variable var) heap = lookupHeap var heap+lookupHeapAtom other _heap = error $ "lookupHeapAtom called with non variable " ++ show other++-- | Add a new mapping to a heap, or update an existing one.+updateHeap :: Var -> Object -> Heap -> Heap +updateHeap = Map.insert ++-- | Generate a new unique variable. Uniqueness is guaranteed by using a+-- "$" prefix, which is not allowed in the concrete sytax of ministg programs.+freshVar :: Eval Var+freshVar = do+   u <- gets state_unique+   modify $ \s -> s { state_unique = u + 1 }+   return $ "$" ++ show u++-- XXX not very good for printing large objects, nonetheless it is lazy.+prettyHeapObject :: Heap -> Object -> String +prettyHeapObject heap (Con constructor args)+   | length args == 0 = constructor+   | otherwise = "(" ++ unwords (constructor : map (prettyHeapAtom heap) args) ++ ")"+prettyHeapObject _heap (Fun {}) = "<function>"+prettyHeapObject _heap (Pap {}) = "<pap>"+prettyHeapObject _heap (Thunk {}) = "<thunk>"+prettyHeapObject _heap BlackHole = "<blackhole>"+prettyHeapObject _heap Error = "<error>"++prettyHeapAtom :: Heap -> Atom -> String +prettyHeapAtom heap (Literal (Integer i)) = show i+prettyHeapAtom heap (Variable var) = prettyHeapObject heap $ lookupHeap var heap

@@ -0,0 +1,140 @@+{-# OPTIONS_GHC -XPatternGuards #-}+-----------------------------------------------------------------------------+-- |+-- Module      : Ministg.TraceEval+-- Copyright   : (c) 2009 Bernie Pope +-- License     : BSD-style+-- Maintainer  : bjpop@csse.unimelb.edu.au+-- Stability   : experimental+-- Portability : ghc+--+-- Trace the evaluation steps of the interpreter and generate HTML output. +-----------------------------------------------------------------------------++module Ministg.TraceEval (traceEval, traceEnd) where++import System.FilePath ((<.>), (</>))+import Control.Monad (when, join)+import Control.Monad.Trans (liftIO)+import Control.Monad.State (gets)+import Control.Applicative ((<$>))+import Text.XHtml.Transitional as Html+import Text.XHtml.Table hiding ((</>))+import Data.Map as Map (toList)+import Ministg.AST+import Ministg.CallStack (CallStack, push, showCallStack)+import Ministg.Pretty as Pretty (pretty, Doc, ($$), nest, render, text)+import Ministg.State+import Data.List as List (sortBy)++traceEval :: Exp -> Stack -> Heap -> Eval ()+traceEval exp stack heap = do+   traceOn <- gets state_trace+   when traceOn $ do +      count <- gets state_stepCount+      maxSteps <- gets state_maxTraceSteps+      when (count <= maxSteps) $ do+         join (writeTraceFile <$> makeHtml exp stack heap)+      when (count == maxSteps + 1) $ lastTracePage "Maximum trace steps exceeded"++traceEnd :: Eval ()+traceEnd = do+   traceOn <- gets state_trace+   when traceOn $ lastTracePage "The computation has completed"+   +lastTracePage :: String -> Eval ()+lastTracePage msg = join (writeTraceFile <$> lastPage msg) ++writeTraceFile :: Html -> Eval ()+writeTraceFile html = do+   traceFile <- nextTraceFileName+   liftIO $ writeFile traceFile $ renderHtml html ++nextTraceFileName :: Eval FilePath+nextTraceFileName = do+   traceDir <- gets state_traceDir+   count <- gets state_stepCount+   return $ traceDir </> mkHtmlFileName count ++lastPage :: String -> Eval Html+lastPage msg = do+   count <- gets state_stepCount+   return (theHead +++ theBody count)+   where+   theHead = header << thetitle << msg +   theBody count +      = body << (mainHeading +++ navigation)+      where+      mainHeading = h1 << msg +      navigation = paragraph ((anchor << "previous") ! [href $ mkHtmlFileName (count - 1)])++makeHtml :: Exp -> Stack -> Heap -> Eval Html +makeHtml exp stack heap = do+   count <- gets state_stepCount+   rule <- gets state_lastRule+   callStack <- gets state_callStack+   wantCallStack <- gets state_traceCallStack+   return $ headAndBody count rule +               (if wantCallStack then Just callStack else Nothing) +   where+   headAndBody count rule maybeCallStack = theHead +++ theBody+      where+      stepStr = "Step " ++ show count+      theHead = header << thetitle << stepStr +      theBody = +         body << (mainHeading +++ navigation +++ ruleSection +++ expStackSection +++ heapSection)+         where+         mainHeading = h1 << stepStr +         navigation = paragraph (previous +++ " " +++ next)+         previous = if count == 0 then noHtml +                       else (anchor << "previous") ! [href $ mkHtmlFileName (count - 1)]+         next = (anchor << "next") ! [href $ mkHtmlFileName (count + 1)]+         ruleSection = if null rule then noHtml +                          else (h3 << "Most recent rule applied") +++ (paragraph << rule)+         expStackSection = (h3 << "Stack and Code") +++ expStackCallTable exp stack maybeCallStack +         heapSection = (h3 << "Heap") +++ heapTable heap ++expStackCallTable :: Exp -> Stack -> Maybe CallStack -> Html+expStackCallTable exp stack maybeCallStack +   = simpleTable [border 3, cellpadding 10] [thestyle "vertical-align:top"] rows +   where+   rows | Just callStack <- maybeCallStack =+             [stackExprHeading ++ callStackHeading, stackExprData ++ callStackData callStack]+        | otherwise = [stackExprHeading, stackExprData] +        where+        stackExprHeading = [stringToHtml "Stack", stringToHtml "Expression"]+        stackExprData = [stackTable stack, pre << expStr]+        callStackHeading = [stringToHtml "Call Stack"]+        callStackData callStack = [callStackTable callStack]+        expStr = render $ pretty exp++stackTable :: Stack -> Html+stackTable [] = noHtml+stackTable stack+   = simpleTable [border 1, cellpadding 5, cellspacing 0] +                 [] (map stackRow stack)+   where+   stackRow :: Continuation -> [Html]+   stackRow cont = [ pre << (render $ pretty cont) ]++callStackTable :: CallStack -> Html+callStackTable [] = noHtml+callStackTable stack+   = simpleTable [border 1, cellpadding 5, cellspacing 0] +                 [] (map stackRow stack)+   where+   stackRow :: String -> [Html]+   stackRow str = [ pre << str ]++heapTable :: Heap -> Html+heapTable heap+   = simpleTable [border 3, cellpadding 5, cellspacing 0] +                 [] (headingRow : map heapRow mappings)+   where+   headingRow = [stringToHtml "Variable", stringToHtml "Object"]+   mappings = List.sortBy (\(x,_) (y,_) -> compare x y) $ Map.toList heap+   heapRow :: (Var, Object) -> [Html]+   heapRow (var, obj) = [pre << var, pre << render (pretty obj)]++mkHtmlFileName :: Integer -> FilePath+mkHtmlFileName count = "step" ++ show count <.> "html"

@@ -0,0 +1,22 @@+-----------------------------------------------------------------------------+-- |+-- Module      : Ministg.Utils+-- Copyright   : (c) 2009 Bernie Pope +-- License     : BSD-style+-- Maintainer  : bjpop@csse.unimelb.edu.au+-- Stability   : experimental+-- Portability : ghc+--+-- Some handy utilities. +-----------------------------------------------------------------------------+module Ministg.Utils where++import Control.Monad +   ( liftM )++safeReadFile :: FilePath -> IO (Either String String) +safeReadFile file+   = catch (rightReadFile file) $ \error -> return $ Left $ show error +   where+   rightReadFile :: FilePath -> IO (Either String String)+   rightReadFile file = liftM Right $ readFile file

@@ -0,0 +1,100 @@+error = ERROR;+unit = CON(Unit);+true = CON(True);+false = CON(False);+nil = CON(Nil);+zero = CON(I 0);+one = CON(I 1);+two = CON(I 2);+three = CON(I 3);+four = CON(I 4);+five = CON(I 5);+six = CON(I 6);+seven = CON(I 7);+eight = CON(I 8);+nine = CON(I 9);+ten = CON(I 10);++multInt = FUN(x y ->+   case x of { +      I i -> case y of { +               I j -> case mult# i j of { +                         x -> let { result = CON (I x) } in result }}});++plusInt = FUN(x y ->+   case x of { +      I i -> case y of { +               I j -> case plus# i j of { +                         x -> let { result = CON (I x) } in result }}});++subInt = FUN(x y ->+           case x of+              { I i ->+                  case y of+                     { I j -> case sub# i j of+                                 { x -> let { result = CON (I x) } in result }}});++eqInt = FUN(x y ->+           case x of+              { I i ->+                  case y of+                     { I j -> case eq# i j of+                                 { x -> intToBool# x }}});++append = FUN(l1 l2 ->+            case l1 of+               { Nil -> l2;+                 Cons hd tl -> let { rec = THUNK(append tl l2);+                                     result = CON(Cons hd rec) }+                               in result });++const = FUN(x y -> x);+apply = FUN(f x -> f x);++map = FUN(f list ->+   case list of {+      Nil -> nil;+      Cons h t -> let { x = THUNK(f h); rec = THUNK(map f t); res = CON(Cons x rec) } in res+   });++take = FUN(n xs ->+   case eqInt n zero of+      { True -> nil;+        False -> case xs of+                 { Nil -> nil;+                   Cons hd tl -> let { m = THUNK(subInt n one);+                                       rec = THUNK(take m tl);+                                       result = CON(Cons hd rec) } in result }});++head = FUN(xs -> case xs of { Cons hd tl -> hd });+tail = FUN(xs -> case xs of { Cons hd tl -> tl });++foldl = FUN(f acc list ->+   case list of {+      Nil -> acc;+      Cons h t -> let { newAcc = THUNK(f acc h) } in foldl f newAcc t +   });++# lazy sum with a well-known space leak+sum = FUN(list -> foldl plusInt zero list);++zipWith = FUN(f list1 list2 ->+   case list1 of {+      Nil -> nil;+      Cons h1 t1 -> +         case list2 of {+            Nil -> nil;+            Cons h2 t2 ->+               let { newHead = THUNK(f h1 h2); +                     newTail = THUNK(zipWith f t1 t2);+                     result = CON(Cons newHead newTail)+               } in result+         }+   });++seq = FUN(x y -> case x of { z -> y });++forcelist = FUN(list ->+   case list of {+      Nil -> unit;+      Cons h t -> let { rec = THUNK(forcelist t) } in seq h rec });

@@ -0,0 +1,6 @@+list1 = CON(Cons one nil);+list2 = CON(Cons one list1);+list3 = CON(Cons zero list2);+list4 = THUNK(append list3 list3);+list5 = THUNK(append list4 list4);+main = THUNK(let { f = THUNK(forcelist list5)} in seq f list5)

@@ -0,0 +1,2 @@+twentytwo = CON(I 22);+main = THUNK(apply const true twentytwo)

@@ -0,0 +1,26 @@+nil = CON(Nil);+zero = CON(I 0);+one = CON(I 1);+two = CON(I 2);+three = CON(I 3);+ +plusInt = FUN(x y ->+   case x of {+      I i -> case y of {+               I j -> case plus# i j of {+                         x -> let { result = CON (I x) } in result }}});+ +foldl = FUN(f acc list ->+   case list of {+      Nil -> acc;+      Cons h t -> let { newAcc = THUNK(f acc h) } in foldl f newAcc t+   });+ +# lazy sum with a well-known space leak+sum = FUN(list -> foldl plusInt zero list);+ +list1 = CON(Cons one nil);+list2 = CON(Cons two list1);+list3 = CON(Cons three list2);+ +main = THUNK(sum list3);

@@ -0,0 +1,1 @@+main = ERROR;

@@ -0,0 +1,9 @@+fac = FUN (x -> +         case eqInt x zero of {+            True -> one;+            False -> let { s = THUNK(subInt x one);+                           rec = THUNK(fac s) }+                     in multInt x rec+         });++main = THUNK (fac seven) 

@@ -0,0 +1,9 @@+fac = FUN (x -> stack "fac"+         case eqInt x zero of {+            True -> one;+            False -> let { s = THUNK(subInt x one);+                           rec = THUNK(fac s) }+                     in multInt x rec+         });++main = THUNK (stack "main" fac seven) 

@@ -0,0 +1,11 @@+# fibs = 1 : 1 : zipWith (+) fibs (tail fibs)++fibs = THUNK(let { tailFibs = THUNK(tail fibs);+                   zippedList = THUNK(zipWith plusInt fibs tailFibs);+                   tailList = CON(Cons one zippedList);+                   list = CON(Cons one tailList)+             } in list);++main = THUNK( let { result = THUNK(take five fibs);+                    f = THUNK(forcelist result)+                  } in seq f result)

@@ -0,0 +1,2 @@+# this should crash with a blackhole.+main = THUNK(main);

@@ -0,0 +1,10 @@+pzero = CON(Z);+pone = CON(S pzero);+list1 = CON(Cons pone nil);+list2 = CON(Cons pone list1);+list3 = CON(Cons pone list2);+list4 = CON(Cons pone list3); +consttrue = PAP(const true);+main = THUNK( let { result = THUNK(map const list4);+                    f = THUNK(forcelist result) +                  } in seq f result )

@@ -0,0 +1,8 @@+# in Haskell: main = head (map const [7,2,1]) 10 ++list1 = CON(Cons one nil);+list2 = CON(Cons two list1);+list3 = CON(Cons seven list2);+main = THUNK(let { mc = THUNK(map const list3);+                   constSeven = THUNK(head mc);+                 } in constSeven ten);

@@ -0,0 +1,2 @@+ones = CON(Cons one ones);+main = THUNK(ones)

@@ -0,0 +1,10 @@+# haskell: main = let x = 1 + 2 in seq x (foo x)+main = THUNK(let {x = THUNK(plusInt one two);+                  res = THUNK(foo x)} in seq x res);++# compare with+# haskell: main = foo (1 + 2)+# main = THUNK(let {x = THUNK(plusInt one two) } in foo x);+                  ++foo = FUN(x -> three)

@@ -0,0 +1,4 @@+list1 = CON(Cons one nil);+list2 = CON(Cons two list1);+list3 = CON(Cons three list2);+main = THUNK(sum list3)

@@ -0,0 +1,4 @@+list1 = CON(Cons one nil);+list2 = CON(Cons error list1);+list3 = CON(Cons three list2);+main = THUNK(sum list3);

@@ -0,0 +1,3 @@+ones = CON(Cons one ones);+main = THUNK(let { result = THUNK(take three ones);+                   f = THUNK(forcelist result)} in seq f result )