├── LICENSE ├── Makefile ├── README.md ├── Setup.hs ├── examples ├── arithmetic.core ├── badcase.core ├── badpoly.core ├── badscrut.core ├── factorial.core ├── fibonacci.core ├── fixedpoint.core ├── fold.core ├── freevar.core ├── infinite.core ├── map.core └── polymorphic.core ├── mini-core.cabal ├── reference ├── DerivationPatternMatchingCompiler.pdf ├── ImplementingFunctionalLanguages.pdf └── TheChalmersLazyMLCompiler.pdf ├── src ├── Main.hs └── MiniCore │ ├── Format.hs │ ├── GCompiler.hs │ ├── GMachine.hs │ ├── Heap.hs │ ├── Inference.hs │ ├── Parse.hs │ ├── Template.hs │ ├── Transforms.hs │ ├── Transforms │ ├── BinOps.hs │ ├── Constructors.hs │ ├── Lambdas.hs │ ├── StronglyConnectedComponents.hs │ └── Utils.hs │ └── Types.hs ├── stack.yaml └── tests ├── arithmetic.out ├── badcase.out ├── badpoly.out ├── badscrut.out ├── factorial.out ├── fibonacci.out ├── fixedpoint.out ├── fold.out ├── freevar.out ├── infinite.out ├── map.out └── polymorphic.out /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2013 Christopher D. Parks 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: 4 | 5 | The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. 6 | 7 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 8 | 9 | 10 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | MINI-CORE = stack exec mini-core 2 | 3 | test: mini-core 4 | $(MINI-CORE) -- examples/arithmetic.core | diff tests/arithmetic.out - 5 | $(MINI-CORE) -- examples/factorial.core | diff tests/factorial.out - 6 | $(MINI-CORE) -- examples/fibonacci.core | diff tests/fibonacci.out - 7 | $(MINI-CORE) -- examples/infinite.core | diff tests/infinite.out - 8 | $(MINI-CORE) -- examples/fixedpoint.core | diff tests/fixedpoint.out - 9 | $(MINI-CORE) -- examples/map.core | diff tests/map.out - 10 | $(MINI-CORE) -- examples/fold.core | diff tests/fold.out - 11 | $(MINI-CORE) -- examples/freevar.core | diff tests/freevar.out - 12 | $(MINI-CORE) -- examples/polymorphic.core | diff tests/polymorphic.out - 13 | $(MINI-CORE) -- examples/badcase.core | diff tests/badcase.out - 14 | $(MINI-CORE) -- examples/badscrut.core | diff tests/badscrut.out - 15 | $(MINI-CORE) -- examples/badpoly.core | diff tests/badpoly.out - 16 | 17 | mini-core: src/*.hs 18 | stack build 19 | 20 | update: mini-core 21 | $(MINI-CORE) -- examples/arithmetic.core > tests/arithmetic.out 22 | $(MINI-CORE) -- examples/factorial.core > tests/factorial.out 23 | $(MINI-CORE) -- examples/fibonacci.core > tests/fibonacci.out 24 | $(MINI-CORE) -- examples/infinite.core > tests/infinite.out 25 | $(MINI-CORE) -- examples/fixedpoint.core > tests/fixedpoint.out 26 | $(MINI-CORE) -- examples/map.core > tests/map.out 27 | $(MINI-CORE) -- examples/fold.core > tests/fold.out 28 | $(MINI-CORE) -- examples/freevar.core > tests/freevar.out 29 | $(MINI-CORE) -- examples/polymorphic.core > tests/polymorphic.out 30 | $(MINI-CORE) -- examples/badcase.core > tests/badcase.out 31 | $(MINI-CORE) -- examples/badscrut.core > tests/badscrut.out 32 | $(MINI-CORE) -- examples/badpoly.core > tests/badpoly.out 33 | 34 | loud: mini-core 35 | $(MINI-CORE) -- examples/arithmetic.core 36 | $(MINI-CORE) -- examples/factorial.core 37 | $(MINI-CORE) -- examples/fibonacci.core 38 | $(MINI-CORE) -- examples/infinite.core 39 | $(MINI-CORE) -- examples/fixedpoint.core 40 | $(MINI-CORE) -- examples/map.core 41 | $(MINI-CORE) -- examples/fold.core 42 | $(MINI-CORE) -- examples/freevar.core 43 | $(MINI-CORE) -- examples/polymorphic.core 44 | $(MINI-CORE) -- examples/badcase.core 45 | $(MINI-CORE) -- examples/badscrut.core 46 | $(MINI-CORE) -- examples/badpoly.core 47 | 48 | pretty: mini-core 49 | $(MINI-CORE) -- --show-parse examples/arithmetic.core 50 | $(MINI-CORE) -- --show-parse examples/factorial.core 51 | $(MINI-CORE) -- --show-parse examples/fibonacci.core 52 | $(MINI-CORE) -- --show-parse examples/infinite.core 53 | $(MINI-CORE) -- --show-parse examples/fixedpoint.core 54 | $(MINI-CORE) -- --show-parse examples/map.core 55 | $(MINI-CORE) -- --show-parse examples/fold.core 56 | $(MINI-CORE) -- --show-parse examples/freevar.core 57 | $(MINI-CORE) -- --show-parse examples/polymorphic.core 58 | $(MINI-CORE) -- --show-parse examples/badcase.core 59 | $(MINI-CORE) -- --show-parse examples/badscrut.core 60 | $(MINI-CORE) -- --show-parse examples/badpoly.core 61 | 62 | typecheck: mini-core 63 | $(MINI-CORE) -- --show-types examples/arithmetic.core 64 | $(MINI-CORE) -- --show-types examples/factorial.core 65 | $(MINI-CORE) -- --show-types examples/fibonacci.core 66 | $(MINI-CORE) -- --show-types examples/infinite.core 67 | $(MINI-CORE) -- --show-types examples/fixedpoint.core 68 | $(MINI-CORE) -- --show-types examples/map.core 69 | $(MINI-CORE) -- --show-types examples/fold.core 70 | $(MINI-CORE) -- --show-types examples/freevar.core 71 | $(MINI-CORE) -- --show-types examples/polymorphic.core 72 | $(MINI-CORE) -- --show-types examples/badcase.core 73 | $(MINI-CORE) -- --show-types examples/badscrut.core 74 | $(MINI-CORE) -- --show-types examples/badpoly.core 75 | 76 | transform: mini-core 77 | $(MINI-CORE) -- --show-simple examples/arithmetic.core 78 | $(MINI-CORE) -- --show-simple examples/factorial.core 79 | $(MINI-CORE) -- --show-simple examples/fibonacci.core 80 | $(MINI-CORE) -- --show-simple examples/infinite.core 81 | $(MINI-CORE) -- --show-simple examples/fixedpoint.core 82 | $(MINI-CORE) -- --show-simple examples/map.core 83 | $(MINI-CORE) -- --show-simple examples/fold.core 84 | $(MINI-CORE) -- --show-simple examples/freevar.core 85 | $(MINI-CORE) -- --show-simple examples/polymorphic.core 86 | 87 | clean: 88 | stack clean 89 | 90 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Mini-Core 2 | ## Overview 3 | Mini-Core started as an implementation of the Core language described in [Implementing Functional Languages: A Tutorial](http://research.microsoft.com/en-us/um/people/simonpj/papers/pj-lester-book/) by Simon Peyton Jones & David Lester. I've diverged slightly by adding let-polymorphic type inference and some concrete syntax for specifying and matching on data constructors. 4 | 5 | ## Usage 6 | mini-core compiles a file to G-code and executes it in a virtual G-Machine. 7 | 8 | Usage: mini-core [OPTION...] file 9 | -h --help Print usage and exit 10 | --show-parse Show program after parsing 11 | --show-types Show types after type-checking 12 | --show-simple Show program after constructor generation and lambda lifting 13 | --show-g-code Show G-code after compilation 14 | --show-states Dump all machine states 15 | --interactive Print each machine state one at a time as program executes 16 | 17 | ## Example Program 18 | A program is just a sequence of supercombinators. Execution proceeds by reducing the supercombinator `main`. Simple algebraic data types are supported using tagged constructors. 19 | 20 | ```haskell 21 | -- A list is either empty or a pair containing a value and another list 22 | data List a = Nil | Cons a (List a); 23 | 24 | -- mini-core is non-strict; we can construct infinite data structures 25 | infinite x = Cons x (infinite (x + 1)); 26 | 27 | -- Case expressions make a multi-way branch based on the scrutinee's 28 | -- tag and bind its components to the names preceding the arrow 29 | 30 | -- take yields the first n elements of a (possibly infinite) list 31 | take n ls = if (n <= 0) 32 | Nil 33 | (case ls of { 34 | Cons x xs -> Cons x (take (n - 1) xs); 35 | Nil -> Nil; 36 | }); 37 | 38 | -- map applys a function f to each element in a list yielding a list of the 39 | -- same size 40 | map f ls = case ls of { 41 | Cons x xs -> Cons (f x) (map f xs); 42 | Nil -> Nil; 43 | }; 44 | 45 | -- Print the squares of the first 5 natural numbers 46 | -- As in Haskell, we use \ to introduce an anonymous function 47 | main = map (\x -> x * x) (take 5 (infinite 1)) 48 | ``` 49 | 50 | Running the compiler on this program produces the following output: 51 | 52 | (Cons 0 (Cons 1 (Cons 4 (Cons 9 (Cons 16 Nil))))) 53 | 54 | With `--show-types` we also get the following output: 55 | 56 | ==================== Type Inference ==================== 57 | Cons :: forall a. a -> List a -> List a 58 | False :: Bool 59 | Nil :: forall a. List a 60 | True :: Bool 61 | infinite :: Int -> List Int 62 | main :: List Int 63 | map :: forall a b. (a -> b) -> List a -> List b 64 | take :: forall a. Int -> List a -> List a 65 | 66 | ## References 67 | * [Implementing Functional Languages: A Tutorial](http://research.microsoft.com/en-us/um/people/simonpj/papers/pj-lester-book/) by Simon Peyton Jones & David Lester 68 | * [The Implementation of Functional Programming Languages](http://research.microsoft.com/en-us/um/people/simonpj/papers/slpj-book-1987/index.htm) by Simon Peyton Jones 69 | * [Algorithm W Step By Step](http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.65.7733) by Martin Grabmuller 70 | * [Typing Haskell in Haskell](http://web.cecs.pdx.edu/~mpj/thih/) by Mark P. Jones 71 | 72 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /examples/arithmetic.core: -------------------------------------------------------------------------------- 1 | -- Simple arithmetic example 2 | 3 | compose f g x = f (g x); 4 | double x = 2 * x; 5 | square x = x * x; 6 | 7 | main = compose double square 10; 8 | 9 | -------------------------------------------------------------------------------- /examples/badcase.core: -------------------------------------------------------------------------------- 1 | data A = B | C; 2 | data X = Y | Z; 3 | 4 | f m = case m of { 5 | B -> 1; 6 | Y -> 2; 7 | }; 8 | 9 | main = f C; 10 | 11 | -------------------------------------------------------------------------------- /examples/badpoly.core: -------------------------------------------------------------------------------- 1 | data Pair a b = Pair a b; 2 | 3 | id x = x; 4 | 5 | f g p = case p of { Pair a b -> Pair (g a) (g b); }; 6 | 7 | -- Should not type check 8 | main = f id (Pair 1 True) 9 | 10 | -------------------------------------------------------------------------------- /examples/badscrut.core: -------------------------------------------------------------------------------- 1 | data List a = Cons a (List a) | Nil; 2 | 3 | f m = case m of { 4 | Cons x xs -> 1; 5 | Nil -> 2; 6 | }; 7 | 8 | main = f True; 9 | 10 | -------------------------------------------------------------------------------- /examples/factorial.core: -------------------------------------------------------------------------------- 1 | -- Factorial function 2 | 3 | factorial n = loop 1 n; 4 | 5 | loop acc x = if (x < 2) 6 | acc 7 | (loop (x * acc) (x - 1)); 8 | 9 | main = factorial 10; 10 | 11 | -------------------------------------------------------------------------------- /examples/fibonacci.core: -------------------------------------------------------------------------------- 1 | -- Fibonacci function 2 | 3 | fibonacci n = loop 0 1 n; 4 | 5 | loop a b n = if (n < 1) 6 | a 7 | (loop b (a + b) (n - 1)); 8 | 9 | main = fibonacci 10; 10 | 11 | -------------------------------------------------------------------------------- /examples/fixedpoint.core: -------------------------------------------------------------------------------- 1 | -- Factorial function defined in terms of fixed point combinator 2 | 3 | fix f = f (fix f); 4 | 5 | factorial f n = if (n < 2) 1 (n * f (n - 1)); 6 | 7 | main = fix factorial 10; 8 | 9 | -------------------------------------------------------------------------------- /examples/fold.core: -------------------------------------------------------------------------------- 1 | -- Compute sum of list 2 | 3 | data List a = Cons a (List a) | Nil; 4 | 5 | foldr op last ls = case ls of { 6 | Cons x xs -> op x (foldr op last xs); 7 | Nil -> last; 8 | }; 9 | 10 | list = Cons 1 (Cons 3 (Cons 5 (Cons 7 Nil))); 11 | 12 | main = foldr (\x y -> x + y) 0 list; 13 | 14 | -------------------------------------------------------------------------------- /examples/freevar.core: -------------------------------------------------------------------------------- 1 | f x = let { 2 | g = \y -> \z -> x + y + z; 3 | m = 9; 4 | } in g m; 5 | 6 | main = f 12 4; 7 | 8 | -------------------------------------------------------------------------------- /examples/infinite.core: -------------------------------------------------------------------------------- 1 | -- Take 10 elements from the front of an infinite list 2 | 3 | data List a = Cons a (List a) | Nil; 4 | 5 | infinite x = Cons x (infinite (x + 1)); 6 | 7 | take n ls = if (n <= 0) 8 | Nil 9 | (case ls of { 10 | Cons x xs -> Cons x (take (n - 1) xs); 11 | Nil -> Nil; 12 | }); 13 | 14 | main = take 10 (infinite 0); 15 | 16 | -------------------------------------------------------------------------------- /examples/map.core: -------------------------------------------------------------------------------- 1 | -- Map cube across list of numbers 2 | data List a = Cons a (List a) | Nil; 3 | 4 | map f ls = case ls of { 5 | Cons x xs -> Cons (f x) (map f xs); 6 | Nil -> Nil; 7 | }; 8 | 9 | list = Cons 1 (Cons 3 (Cons 5 (Cons 7 Nil))); 10 | 11 | main = map (\x -> x * x * x) list; 12 | 13 | -------------------------------------------------------------------------------- /examples/polymorphic.core: -------------------------------------------------------------------------------- 1 | data List a = Cons a (List a) | Nil; 2 | 3 | data Pair a b = Pair a b; 4 | 5 | length ls = case ls of { 6 | Cons x xs -> 1 + length xs; 7 | Nil -> 0; 8 | }; 9 | 10 | ls1 = Cons 1 (Cons 2 (Cons 5 (Cons 12 Nil))); 11 | 12 | ls2 = Cons (Pair 1 True) (Cons (Pair 4 False) Nil); 13 | 14 | fst x = case x of { 15 | Pair a _ -> a; 16 | }; 17 | 18 | snd x = case x of { 19 | Pair _ b -> b; 20 | }; 21 | 22 | square x = x * x; 23 | 24 | map f ls = case ls of { 25 | Nil -> Nil; 26 | Cons x xs -> Cons (f x) (map f xs); 27 | }; 28 | 29 | main = length (map snd ls2) + length (map square ls1); 30 | 31 | -------------------------------------------------------------------------------- /mini-core.cabal: -------------------------------------------------------------------------------- 1 | -- Initial mini-core.cabal generated by cabal init. For further 2 | -- documentation, see http://haskell.org/cabal/users-guide/ 3 | 4 | name: mini-core 5 | version: 0.1.0.0 6 | synopsis: An implementation of the core language described in "Implementing Functional Languages: A Tutorial" by Simon Peyton Jones and David Lester 7 | -- description: 8 | license: MIT 9 | license-file: LICENSE 10 | author: Christopher D. Parks 11 | maintainer: christopher.daniel.parks@gmail.com 12 | -- copyright: 13 | category: Language 14 | build-type: Simple 15 | cabal-version: >=1.8 16 | 17 | executable mini-core 18 | build-depends: base 19 | , pretty 20 | , parsec 21 | , containers 22 | , mtl 23 | hs-source-dirs: src 24 | main-is: Main.hs 25 | other-modules: MiniCore.Format 26 | MiniCore.GCompiler 27 | MiniCore.GMachine 28 | MiniCore.Heap 29 | MiniCore.Inference 30 | MiniCore.Parse 31 | MiniCore.Transforms 32 | MiniCore.Transforms.BinOps 33 | MiniCore.Transforms.Constructors 34 | MiniCore.Transforms.Lambdas 35 | MiniCore.Transforms.StronglyConnectedComponents 36 | MiniCore.Transforms.Utils 37 | MiniCore.Types 38 | 39 | -------------------------------------------------------------------------------- /reference/DerivationPatternMatchingCompiler.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cdparks/mini-core/ea9b32fab20d1a0224de9f2a848f7110ecef8459/reference/DerivationPatternMatchingCompiler.pdf -------------------------------------------------------------------------------- /reference/ImplementingFunctionalLanguages.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cdparks/mini-core/ea9b32fab20d1a0224de9f2a848f7110ecef8459/reference/ImplementingFunctionalLanguages.pdf -------------------------------------------------------------------------------- /reference/TheChalmersLazyMLCompiler.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cdparks/mini-core/ea9b32fab20d1a0224de9f2a848f7110ecef8459/reference/TheChalmersLazyMLCompiler.pdf -------------------------------------------------------------------------------- /src/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import MiniCore.Types 4 | import MiniCore.Parse 5 | import MiniCore.Inference 6 | import MiniCore.Transforms 7 | import MiniCore.GCompiler 8 | import MiniCore.GMachine 9 | import MiniCore.Format 10 | 11 | import System.IO 12 | import System.Console.GetOpt 13 | import System.Environment 14 | import System.Exit 15 | import Control.Monad 16 | import Data.List 17 | 18 | -- Compile and run program 19 | run :: Flags -> String -> Stage Doc 20 | run flags program = do 21 | parsed <- parseCore program 22 | traceStage "Parsing" (traceParse flags) (format parsed) 23 | 24 | (types, checked) <- typecheck parsed 25 | traceStage "Type Inference" (traceCheck flags) (format types) 26 | 27 | (cons, transformed) <- transform checked 28 | traceStage "Transforms" (traceTrans flags) (format transformed) 29 | 30 | state <- compile (cons, transformed) 31 | traceStage "Compilation" (traceComp flags) (formatDefs state) 32 | 33 | state' <- execute (traceExec flags) (traceNext flags) state 34 | return (formatStateOutput state') 35 | 36 | -- Which stages should print debug information? 37 | data Flags = Flags 38 | { traceParse :: Bool 39 | , traceCheck :: Bool 40 | , traceTrans :: Bool 41 | , traceComp :: Bool 42 | , traceExec :: Bool 43 | , traceNext :: Bool 44 | } deriving Show 45 | 46 | -- By default, just run the program 47 | defaultFlags :: Flags 48 | defaultFlags = Flags 49 | { traceParse = False 50 | , traceCheck = False 51 | , traceTrans = False 52 | , traceComp = False 53 | , traceExec = False 54 | , traceNext = False 55 | } 56 | 57 | -- Context is file to execute and execution flag 58 | data Context = Context 59 | { sFlags :: Flags 60 | , sFile :: String 61 | } deriving Show 62 | 63 | -- Specify action for each option 64 | options :: [OptDescr (Flags -> IO Flags)] 65 | options = 66 | [ Option ['h'] ["help"] 67 | (NoArg (const (usage []))) 68 | "Print usage and exit" 69 | , Option [] ["show-parse"] 70 | (NoArg (\f -> return f { traceParse = True })) 71 | "Show program after parsing" 72 | , Option [] ["show-types"] 73 | (NoArg (\f -> return f { traceCheck = True })) 74 | "Show types after type-checking" 75 | , Option [] ["show-simple"] 76 | (NoArg (\f -> return f { traceTrans = True })) 77 | "Show program after constructor generation and lambda lifting" 78 | , Option [] ["show-g-code"] 79 | (NoArg (\f -> return f { traceComp = True })) 80 | "Show G-code after compilation" 81 | , Option [] ["show-states"] 82 | (NoArg (\f -> return f { traceExec = True })) 83 | "Dump all machine states" 84 | , Option [] ["interactive"] 85 | (NoArg (\f -> return f { traceNext = True })) 86 | "Print each machine state one at a time as program executes" 87 | ] 88 | 89 | -- Parse options and generate execution context 90 | getContext :: IO Context 91 | getContext = do 92 | argv <- getArgs 93 | case getOpt Permute options argv of 94 | (actions, files, []) -> 95 | configure files actions 96 | (_, _, errors) -> 97 | usage errors 98 | 99 | -- Generate context from parsed arguments 100 | configure :: [String] -> [Flags -> IO Flags] -> IO Context 101 | configure files actions = do 102 | flags <- foldl' (>>=) (return defaultFlags) actions 103 | file <- case files of 104 | [] -> 105 | usage ["Must specify at least one file"] 106 | file:_ -> 107 | return file 108 | return Context { sFlags = flags, sFile = file } 109 | 110 | -- Print usage and exit 111 | usage :: [String] -> IO a 112 | usage errors = do 113 | let header = "Usage: mini-core [OPTION...] file" 114 | message = usageInfo header options 115 | hPutStrLn stderr (intercalate "\n" [concat errors, message]) 116 | exitWith ExitSuccess 117 | 118 | main :: IO () 119 | main = do 120 | Context { sFlags = flags, sFile = file } <- getContext 121 | program <- readFile file 122 | runStageIO (run flags program) 123 | 124 | -------------------------------------------------------------------------------- /src/MiniCore/Format.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeSynonymInstances #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | 4 | module MiniCore.Format 5 | ( format 6 | , formatStateOutput 7 | , formatState 8 | , formatDefs 9 | , precByOp 10 | , Doc (..) 11 | ) where 12 | 13 | import MiniCore.Types 14 | import MiniCore.Heap 15 | 16 | import Text.PrettyPrint 17 | import Data.List 18 | 19 | -- Function application has the highest precedence 20 | applyPrec = 10 21 | 22 | -- Reset precedence in unambiguous constructions 23 | lowestPrec = 0 24 | 25 | -- Join a list of strings together 26 | combine :: [String] -> Doc 27 | combine = sep . map text 28 | 29 | {- Pretty-print program source -} 30 | 31 | -- Format typeclass defines how a value should be pretty-printed 32 | class Format a where 33 | format :: a -> Doc 34 | format = formatPrec lowestPrec 35 | 36 | formatPrec :: Int -> a -> Doc 37 | formatPrec = const format 38 | 39 | -- Pretty-print list of declarations 40 | instance Format Program where 41 | format = sep . punctuate semi . map format 42 | 43 | -- Pretty-print a declaration (data or combinator) 44 | instance Format Declaration where 45 | format (Combinator name args expr) = 46 | text name <+> combine args <+> text "=" <+> format expr 47 | 48 | format (Data name vars constructors) = 49 | text "data" <+> text name <+> 50 | combine vars <+> text "=" <+> 51 | sep (punctuate (text " |") (map format constructors)) 52 | 53 | -- Pretty-print a constructor 54 | instance Format Constructor where 55 | format (Constructor name components) = 56 | text name <+> sep (map format components) 57 | 58 | {- Pretty-printing types -} 59 | 60 | -- Infinite list of prettier type-variables 61 | prettyVars :: [String] 62 | prettyVars = alphas ++ alphaNums 63 | where 64 | alphas = do 65 | char <- ['a'..'z'] 66 | return [char] 67 | alphaNums = do 68 | num <- [1..] 69 | char <- ['a'..'z'] 70 | return (char:show num) 71 | 72 | -- Find name in env (or just use name if not found) and convert to text 73 | lookupText :: [(Name, Name)] -> Name -> Doc 74 | lookupText env n = maybe (text n) text (lookup n env) 75 | 76 | -- Print a type using a mapping from the actual 77 | -- type-variables to pretty type-variables 78 | prettyType :: [(Name, Name)] -> Type -> Doc 79 | prettyType env t = loop False False t 80 | where 81 | loop _ _ (TVar n) = 82 | lookupText env n 83 | 84 | loop _ _ (TCon n []) = 85 | text n 86 | 87 | -- If first parameter is True, parent was (->), and current node 88 | -- is the left-hand side of (->) and may need to be parenthesized 89 | loop parent _ (TCon "(->)" [a, b]) = 90 | parensIf parent (loop True False a <+> text "->" <+> loop False False b) 91 | 92 | -- If second parameter is True, parent was a non-unary constructor 93 | -- and current node may need to be parameterized 94 | loop _ parent (TCon n xs) = 95 | parensIf parent (text n <+> sep (map (loop False True) xs)) 96 | 97 | -- Print universally quantified type variables if there are any 98 | prettyForall :: [(Name, Name)] -> [Name] -> Doc 99 | prettyForall env [] = empty 100 | prettyForall env xs = text "forall" <+> sep (map (lookupText env) xs) <> text "." 101 | 102 | -- Pretty-print a concrete type 103 | instance Format Type where 104 | format = prettyType [] 105 | 106 | -- Pretty-print a universally quantified type 107 | instance Format Scheme where 108 | format (Scheme vars t) = 109 | let env = zip (nub (vars ++ tvarsOrdered t)) prettyVars 110 | in prettyForall env vars <+> prettyType env t 111 | 112 | -- Pretty-print a mapping of Names to Schemes 113 | instance Format [(Name, Scheme)] where 114 | format = vcat . map combine 115 | where 116 | combine (name, scheme) = text name <+> text "::" <+> format scheme 117 | 118 | -- Parenthesize if some condition is true 119 | parensIf :: Bool -> Doc -> Doc 120 | parensIf True = parens 121 | parensIf False = id 122 | 123 | -- Useful down below 124 | isApp :: Expr -> Bool 125 | isApp (App _ _) = True 126 | isApp _ = False 127 | 128 | -- Convert expression into a formatted object keeping track 129 | -- of precedence 130 | instance Format Expr where 131 | -- Variable 132 | formatPrec _ (Var v) = text v 133 | 134 | -- Number 135 | formatPrec _ (Num n) = int n 136 | 137 | -- Pack operator 138 | formatPrec _ (Cons tag arity) = text "Pack" <> braces (int tag <> comma <> int arity) 139 | 140 | -- Binary application 141 | formatPrec prec (BinOp op e1 e2) = 142 | case lookup op precByOp of 143 | Just prec' -> 144 | parensIf (prec' < prec) (formatPrec prec' e1 <+> text op <+> formatPrec prec' e2) 145 | Nothing -> 146 | error ("Unrecognized infix operator " ++ op) 147 | 148 | -- Prefix application 149 | formatPrec prec (App e1 e2) = 150 | formatPrec applyPrec e1 <+> parensIf (isApp e2) (formatPrec applyPrec e2) 151 | 152 | -- Let expression 153 | formatPrec _ (Let recursive bindings body) = 154 | text keyword <+> lbrace $$ nest 2 (format bindings) $$ 155 | rbrace <+> text "in" <+> format body 156 | where 157 | keyword 158 | | recursive = "letrec" 159 | | otherwise = "let" 160 | 161 | -- Case expression 162 | formatPrec _ (Case scrutinee alts) = 163 | text "case" <+> format scrutinee <+> 164 | text "of" <+> lbrace $$ nest 2 (format alts) $$ rbrace 165 | 166 | -- Lambda expression 167 | formatPrec prec (Lambda args body) = 168 | parensIf (prec > lowestPrec) 169 | (text "\\" <> combine args <+> text "->" <+> formatPrec lowestPrec body) 170 | 171 | -- Format name = expression pairs 172 | instance Format [(Name, Expr)] where 173 | formatPrec prec bindings = 174 | vcat (punctuate semi (map formatBinding bindings)) <> semi 175 | where 176 | formatBinding (name, expr) = text name <+> text "=" <+> formatPrec prec expr 177 | 178 | -- Format alternatives of of the form Pattern [arg ...] -> expr 179 | instance Format [Alt] where 180 | formatPrec prec alts = 181 | vcat (punctuate semi (map formatAlt alts)) <> semi 182 | where 183 | formatAlt (pattern, args, expr) = 184 | format pattern <+> combine args <+> text "->" <+> formatPrec prec expr 185 | 186 | -- Format constructor, wildcard, or internal tagged pattern 187 | instance Format Pattern where 188 | format (PCon constructor) = 189 | text constructor 190 | 191 | format (PTag tag) = 192 | text "<" <> int tag <> text ">" 193 | 194 | {- Pretty-print machine states -} 195 | 196 | -- Format output component of state 197 | formatStateOutput :: GMState -> Doc 198 | formatStateOutput = text . concat . reverse . gmOutput 199 | 200 | -- Format global definitions 201 | formatDefs :: GMState -> Doc 202 | formatDefs state = text "Definitions" <> colon $$ nest 4 defs 203 | where 204 | defs = vcat (map (formatSC state) (gmGlobals state)) 205 | 206 | -- Format a single supercombinator 207 | formatSC :: GMState -> (Name, Addr) -> Doc 208 | formatSC state (name, addr) = text name <> colon $$ nest 4 (formatCode code) 209 | where 210 | NGlobal _ code = hLoad (gmHeap state) addr 211 | 212 | -- Format stack and current code 213 | formatState :: GMState -> Doc 214 | formatState state = 215 | text "State" <+> parens (formatStats (gmStats state)) <> colon $$ nest 4 components 216 | where 217 | components = 218 | formatStack state $$ 219 | formatVStack state $$ 220 | formatCode (gmCode state) $$ 221 | formatDump state 222 | 223 | -- Format number of steps and collections 224 | formatStats :: GMStats -> Doc 225 | formatStats stats = 226 | text "step" <+> int (gmSteps stats) <> comma <+> text "gc" <+> int (gmCollections stats) 227 | 228 | -- Format nodes on stack 229 | formatStack :: GMState -> Doc 230 | formatStack state = 231 | text "Stack" <> colon $$ nest 4 (vcat (map (formatNode state) (reverse (gmStack state)))) 232 | 233 | -- Format numbers in V-stack 234 | formatVStack :: GMState -> Doc 235 | formatVStack state = 236 | text "V-Stack" <> colon $$ nest 4 (vcat (map (text . show) (reverse (gmVStack state)))) 237 | 238 | -- Format first n addresses on stack 239 | formatShortStack :: GMStack -> Int -> Doc 240 | formatShortStack stack n = 241 | text "Stack" <> colon <+> hsep (punctuate comma (shorten n (map formatAddr (reverse stack)))) 242 | 243 | -- Format list of instructions 244 | formatCode :: GMCode -> Doc 245 | formatCode code = text "Code" <> colon $$ nest 4 (formatInstructions code) 246 | where 247 | formatInstructions = vcat . map formatInstruction 248 | 249 | formatInstruction (Casejump branches) = text "Casejump" $$ nest 4 (sep (map formatBranch branches)) 250 | formatInstruction (Cond t f) = 251 | text "Cond" $$ nest 4 (vcat 252 | [ text "True" <> colon <+> formatInstructions t 253 | , text "False" <> colon <+> formatInstructions f 254 | ]) 255 | formatInstruction x = text (show x) 256 | 257 | formatBranch (tag, code) = int tag <> colon <+> formatInstructions code 258 | 259 | 260 | 261 | -- Format first n instructions 262 | formatShortCode :: GMCode -> Int -> Doc 263 | formatShortCode code n = 264 | text "Code" <> colon <+> 265 | hsep (punctuate comma (shorten n (map (text . show) code))) 266 | 267 | -- Only use first n docs in list. Append ellipsis if docs longer than n. 268 | shorten :: Int -> [Doc] -> [Doc] 269 | shorten n docs 270 | | length docs > n = take n docs ++ [text "..."] 271 | | otherwise = docs 272 | 273 | -- Format dump 274 | formatDump :: GMState -> Doc 275 | formatDump state = format (gmDump state) 276 | where 277 | format [] = 278 | empty 279 | 280 | format (([], _, _):_) = 281 | empty 282 | 283 | format ((_, [], _):_) = 284 | empty 285 | 286 | format ((code, stack, vstack):_) = 287 | text "Dump" <> colon $$ nest 4 (formatShortStack stack 3 $$ formatShortCode code 3) 288 | 289 | -- Format a single node 290 | formatNode :: GMState -> Addr -> Doc 291 | formatNode state addr = formatAddr addr <> colon <+> draw (hLoad (gmHeap state) addr) 292 | where 293 | draw (NNum n) = 294 | int n 295 | 296 | draw (NGlobal n g) = 297 | text "Global" <+> text v 298 | where 299 | (v, _) = head (filter (\(x, b) -> b == addr) (gmGlobals state)) 300 | 301 | draw (NApp a1 a2) = 302 | text "App" <+> formatAddr a1 <+> formatAddr a2 303 | 304 | draw (NPointer a) = 305 | text "Pointer to" <+> formatAddr a 306 | 307 | draw (NConstructor tag components) = 308 | text "Cons" <+> int tag <+> brackets (hsep (map formatAddr components)) 309 | 310 | -- Format an address 311 | formatAddr :: Addr -> Doc 312 | formatAddr addr = text "#" <> int addr 313 | 314 | -------------------------------------------------------------------------------- /src/MiniCore/GCompiler.hs: -------------------------------------------------------------------------------- 1 | module MiniCore.GCompiler 2 | ( compile 3 | ) where 4 | 5 | import MiniCore.Types 6 | import MiniCore.Heap 7 | 8 | import Data.List 9 | import Control.Arrow hiding ((<+>)) 10 | 11 | -- Uncompiled Primitives 12 | primitives :: Program 13 | primitives = 14 | [ Combinator "+" ["x", "y"] $ App (App (Var "+") (Var "x")) (Var "y") 15 | , Combinator "-" ["x", "y"] $ App (App (Var "-") (Var "x")) (Var "y") 16 | , Combinator "*" ["x", "y"] $ App (App (Var "*") (Var "x")) (Var "y") 17 | , Combinator "/" ["x", "y"] $ App (App (Var "/") (Var "x")) (Var "y") 18 | , Combinator "negate" ["x"] $ App (Var "negate") (Var "x") 19 | , Combinator "==" ["x", "y"] $ App (App (Var "==") (Var "x")) (Var "y") 20 | , Combinator "/=" ["x", "y"] $ App (App (Var "/=") (Var "x")) (Var "y") 21 | , Combinator "<" ["x", "y"] $ App (App (Var "<") (Var "x")) (Var "y") 22 | , Combinator "<=" ["x", "y"] $ App (App (Var "<=") (Var "x")) (Var "y") 23 | , Combinator ">" ["x", "y"] $ App (App (Var ">") (Var "x")) (Var "y") 24 | , Combinator ">=" ["x", "y"] $ App (App (Var ">=") (Var "x")) (Var "y") 25 | , Combinator "&&" ["x", "y"] $ App (App (App (Var "if") (Var "x")) (Var "y")) (Var "False") 26 | , Combinator "||" ["x", "y"] $ App (App (App (Var "if") (Var "x")) (Var "True")) (Var "y") 27 | , Combinator "not" ["x"] $ App (App (App (Var "if") (Var "x")) (Var "False")) (Var "True") 28 | , Combinator "if" ["c", "t", "f"] $ App (App (App (Var "if") (Var "c")) (Var "t")) (Var "f") 29 | , Combinator "False" [] $ Cons 1 0 30 | , Combinator "True" [] $ Cons 2 0 31 | , Combinator "$" ["f", "a"] $ App (Var "f") (Var "a") 32 | , Combinator "." ["f", "g", "x"] $ App (Var "f") (App (Var "g") (Var "x")) 33 | ] 34 | 35 | -- Instruction for each binary operator 36 | binaryOpImpl :: [(Name, Instruction)] 37 | binaryOpImpl = 38 | [ ("+", Add) 39 | , ("-", Sub) 40 | , ("*", Mul) 41 | , ("/", Div) 42 | , ("==", Eq) 43 | , ("/=", Ne) 44 | , (">=", Ge) 45 | , (">", Gt) 46 | , ("<=", Le) 47 | , ("<", Lt) 48 | ] 49 | 50 | -- Boxing instruction for each binary operator 51 | binaryOpBox :: [(Name, Instruction)] 52 | binaryOpBox = 53 | [ ("+", Mkint) 54 | , ("-", Mkint) 55 | , ("*", Mkint) 56 | , ("/", Mkint) 57 | , ("==", Mkbool) 58 | , ("/=", Mkbool) 59 | , (">=", Mkbool) 60 | , (">", Mkbool) 61 | , ("<=", Mkbool) 62 | , ("<", Mkbool) 63 | ] 64 | 65 | -- Instruction for each unary operator 66 | unaryOpImpl :: [(Name, Instruction)] 67 | unaryOpImpl = [("negate", Neg)] 68 | 69 | -- Boxing instruction for each unary operator 70 | unaryOpBox :: [(Name, Instruction)] 71 | unaryOpBox = [("negate", Mkint)] 72 | 73 | -- Used for a number of compilation schemes 74 | type GMCompiler = GMEnvironment -> Expr -> GMCode 75 | 76 | -- Turn program into initial G-Machine state 77 | -- cons is a list of Constructor names such that 78 | -- cons !! tag -> Constructor name for (Cons tag arity) 79 | compile :: ([Name], Program) -> Stage GMState 80 | compile (cons, program) = return GMState 81 | { gmCons = cons 82 | , gmOutput = [] 83 | , gmCode = codeInit 84 | , gmStack = [] 85 | , gmDump = [] 86 | , gmVStack = [] 87 | , gmHeap = heap 88 | , gmGlobals = globals 89 | , gmStats = statInit 90 | } 91 | where 92 | (heap, globals) = buildInitialHeap program 93 | 94 | -- Push main and unwind 95 | codeInit :: GMCode 96 | codeInit = [Pushglobal "main", Eval, Print] 97 | 98 | -- Start at step zero 99 | statInit :: GMStats 100 | statInit = GMStats 0 0 101 | 102 | -- Instantiate supercombinators in heap 103 | buildInitialHeap :: Program -> (GMHeap, GMGlobals) 104 | buildInitialHeap program = mapAccumL allocSC hInit compiled 105 | where 106 | compiled = map compileSC (program ++ primitives) 107 | 108 | -- Allocate a supercombinator and return the new heap 109 | allocSC :: GMHeap -> (Name, Int, GMCode) -> (GMHeap, (Name, Addr)) 110 | allocSC heap (name, arity, instructions) = (heap', (name, addr)) 111 | where 112 | (heap', addr) = hAlloc heap (NGlobal arity instructions) 113 | 114 | -- Compile supercombinator f with formal parameters x1...xn by 115 | -- compiling f's body e in the environment created by substituting 116 | -- the actual parameters for the formal parameters 117 | -- SC(f x1 ... xn = e) = R(e) [x1 -> 0, ..., xn -> n - 1] n 118 | compileSC :: Declaration -> (Name, Int, GMCode) 119 | compileSC (Combinator name args body) = (name, length args, compileR (zip args [0..]) body) 120 | 121 | -- Scheme R[e] p d generates code which instantiates the expression 122 | -- e in environment p, for a supercombinator of arity d, and then 123 | -- proceeds to unwind the resulting stack 124 | 125 | compileR :: GMCompiler 126 | compileR env (Let recursive defs body) 127 | | recursive = compileLetrec compileR env defs body 128 | | otherwise = compileLet compileR env defs body 129 | 130 | compileR env e@(App (App (App (Var "if") cond) t) f) = 131 | compileB env cond ++ [Cond (compileR env t) (compileR env f)] 132 | 133 | compileR env (Case e alts) = compileE env e ++ [Casejump (compileD env compileR alts)] 134 | 135 | compileR env e = compileE env e ++ [Update n, Pop n, Unwind] 136 | where 137 | n = length env 138 | 139 | -- Scheme E[e] p compiles code that evaluates an expression e to 140 | -- WHNF in environment p, leaving a pointer to the expression on 141 | -- top of the stack. 142 | compileE :: GMCompiler 143 | compileE env (Num n) = 144 | [Pushint n] 145 | 146 | compileE env (Let recursive defs body) 147 | | recursive = compileLetrec compileE env defs body ++ [Slide (length defs)] 148 | | otherwise = compileLet compileE env defs body ++ [Slide (length defs)] 149 | 150 | compileE env e@(App (Var op) _) = 151 | case lookup op unaryOpBox of 152 | Just instruction -> 153 | compileB env e ++ [instruction] 154 | Nothing -> 155 | compileC env e ++ [Eval] 156 | 157 | compileE env e@(App (App (Var op) _) _) = 158 | case lookup op binaryOpBox of 159 | Just instruction -> 160 | compileB env e ++ [instruction] 161 | Nothing -> 162 | compileC env e ++ [Eval] 163 | 164 | compileE env e@(App (App (App (Var "if") cond) t) f) = 165 | compileB env cond ++ [Cond (compileE env t) (compileE env f)] 166 | 167 | compileE env (Case e alts) = 168 | compileE env e ++ [Casejump (compileD env compileE alts)] 169 | 170 | compileE env e = 171 | compileC env e ++ [Eval] 172 | 173 | -- Compile code for alternatives of a case expression 174 | compileD :: GMEnvironment -> GMCompiler -> [Alt] -> [(Int, GMCode)] 175 | compileD env comp = map compileP 176 | where 177 | compileP (PTag tag, args, expr) = 178 | (tag, compileA comp (length args) (zip args [0..] ++ argOffset (length args) env) expr) 179 | 180 | -- Parameterized compilation scheme bracketed by Split and Slide 181 | compileA :: GMCompiler -> Int -> GMCompiler 182 | compileA comp offset env expr = [Split offset] ++ comp env expr ++ [Slide offset] 183 | 184 | -- Scheme B[e] p compiles code that evaluates an expression e to 185 | -- WHNF in an environment p leaving the result on the V-stack. 186 | compileB :: GMCompiler 187 | compileB env (Num n) = 188 | [Pushbasic n] 189 | 190 | compileB env (Let recursive defs body) 191 | | recursive = compileLetrec compileB env defs body ++ [Pop (length defs)] 192 | | otherwise = compileLet compileB env defs body ++ [Pop (length defs)] 193 | 194 | compileB env e@(App (Var op) e1) = 195 | case lookup op unaryOpImpl of 196 | Just instruction -> 197 | compileB env e1 ++ [instruction] 198 | Nothing -> 199 | compileE env e ++ [Get] 200 | 201 | compileB env e@(App (App (Var op) e1) e2) = 202 | case lookup op binaryOpImpl of 203 | Just instruction -> 204 | compileB env e2 ++ compileB env e1 ++ [instruction] 205 | Nothing -> 206 | compileE env e ++ [Get] 207 | 208 | compileB env e@(App (App (App (Var "if") cond) t) f) = 209 | compileB env cond ++ [Cond (compileB env t) (compileB env f)] 210 | 211 | compileB env e = 212 | compileE env e ++ [Get] 213 | 214 | -- Scheme C[e] p generates code which constructs the graph of e 215 | -- in environment p, leaving a pointer to it on top of the stack. 216 | compileC :: GMCompiler 217 | compileC env (Var v) = 218 | case lookup v env of 219 | Just n -> 220 | [Push n] 221 | Nothing -> 222 | [Pushglobal v] 223 | 224 | compileC env (Num n) = 225 | [Pushint n] 226 | 227 | compileC env (App e1 e2) = 228 | compileC env e2 ++ compileC (argOffset 1 env) e1 ++ [Mkap] 229 | 230 | compileC env (Cons tag arity) = 231 | replicate arity (Push (arity - 1)) ++ [Pack tag arity] 232 | 233 | compileC env (Case e alts) = 234 | compileE env e ++ [Casejump (compileD env compileE alts)] 235 | 236 | compileC env (Let recursive defs body) 237 | | recursive = compileLetrec compileC env defs body ++ [Slide (length defs)] 238 | | otherwise = compileLet compileC env defs body ++ [Slide (length defs)] 239 | 240 | -- Generate code to construct each let binding and the let body. 241 | -- Code must remove bindings after body is evaluated. 242 | compileLet :: GMCompiler -> GMEnvironment -> [(Name, Expr)] -> Expr -> GMCode 243 | compileLet comp env defs body = compileDefs env defs ++ comp env' body 244 | where 245 | env' = compileArgs env defs 246 | 247 | -- Generate code to construct each definition in defs 248 | compileDefs :: GMEnvironment -> [(Name, Expr)] -> GMCode 249 | compileDefs env [] = [] 250 | compileDefs env ((name, expr):defs) = compileC env expr ++ compileDefs (argOffset 1 env) defs 251 | 252 | -- Generate code to construct recursive let bindings and the let body. 253 | -- Code must remove bindings after body is evaluated. 254 | -- Bindings start as null pointers and must update themselves on evaluation. 255 | compileLetrec :: GMCompiler -> GMEnvironment -> [(Name, Expr)] -> Expr -> GMCode 256 | compileLetrec comp env defs body = [Alloc n] ++ compileRecDefs (n - 1) env' defs ++ comp env' body 257 | where 258 | env' = compileArgs env defs 259 | n = length defs 260 | 261 | -- Generate code to construct each definition in defs and 262 | -- update pointer on stack. 263 | compileRecDefs :: Int -> GMEnvironment -> [(Name, Expr)] -> GMCode 264 | compileRecDefs n env [] = [] 265 | compileRecDefs n env ((name, expr):defs) = compileC env expr ++ [Update n] ++ compileRecDefs (n - 1) env defs 266 | 267 | -- Generate stack offsets for local bindings 268 | compileArgs :: GMEnvironment -> [(Name, Expr)] -> GMEnvironment 269 | compileArgs env defs = zip (map fst defs) (reverse [0..n - 1]) ++ argOffset n env 270 | where 271 | n = length defs 272 | 273 | -- Adjust the stack offsets in the environment by n 274 | argOffset :: Int -> GMEnvironment -> GMEnvironment 275 | argOffset n = map (second (+n)) 276 | 277 | -------------------------------------------------------------------------------- /src/MiniCore/GMachine.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | 3 | module MiniCore.GMachine 4 | ( execute 5 | , isFinal 6 | ) where 7 | 8 | import MiniCore.Types 9 | import MiniCore.Format 10 | import MiniCore.Heap 11 | 12 | import Data.List 13 | import Data.Maybe 14 | import Control.Monad.Trans (liftIO) 15 | import Control.Monad.State 16 | import Control.Monad.Except 17 | import System.IO 18 | import Control.Monad 19 | import Control.Applicative 20 | 21 | -- Evaluation monad transformer 22 | type Eval a = StateT GMState Stage a 23 | 24 | -- Execute computation for its effect on GMState 25 | type Transition = Eval () 26 | 27 | -- Execute computation and yield resulting GMState 28 | type Inspect = Eval GMState 29 | 30 | -- Public interface to GMachine takes an initial state and yield 31 | -- a final state 32 | execute :: Bool -> Bool -> GMState -> Stage GMState 33 | execute loud interactive state = execStateT (evaluate loud interactive) state 34 | 35 | -- Ask if user wants to continue in interactive mode 36 | untilNext :: Eval () 37 | untilNext = do 38 | liftIO (putStr "Next/Quit? [enter/q]: ") 39 | liftIO (hFlush stdout) 40 | line <- liftIO getLine 41 | case line of 42 | "q" -> runtimeError "Halting" 43 | "" -> return () 44 | _ -> untilNext 45 | 46 | -- Move from state to state until final state is reached 47 | evaluate :: Bool -> Bool -> Inspect 48 | evaluate loud interactive = do 49 | state <- get 50 | when (loud || interactive) $ 51 | lift (trace (formatState state)) 52 | when interactive $ 53 | untilNext 54 | if isFinal state 55 | then return state 56 | else do 57 | step 58 | doAdmin 59 | evaluate loud interactive 60 | 61 | -- Update machine statistics. Collect garbage if heap has grown 62 | -- too large 63 | doAdmin :: Transition 64 | doAdmin = do 65 | incSteps 66 | heap <- gets gmHeap 67 | when (hTooLarge heap) $ do 68 | incCollections 69 | gc 70 | 71 | -- Increment number of steps 72 | incSteps :: Transition 73 | incSteps = do 74 | stats <- gets gmStats 75 | let stats' = stats { gmSteps = gmSteps stats + 1 } 76 | modify (\s -> s { gmStats = stats' }) 77 | 78 | -- Increment number of collections 79 | incCollections :: Transition 80 | incCollections = do 81 | stats <- gets gmStats 82 | let stats' = stats { gmCollections = gmCollections stats + 1 } 83 | modify (\s -> s { gmStats = stats' }) 84 | 85 | -- Finished when no more code to execute 86 | isFinal :: GMState -> Bool 87 | isFinal = null . gmCode 88 | 89 | -- Transition to next state 90 | step :: Transition 91 | step = do 92 | c:code <- gets gmCode 93 | modify (\s -> s { gmCode = code }) 94 | dispatch c 95 | 96 | -- Push an address on the stack 97 | pushStack :: Addr -> Transition 98 | pushStack addr = modify (\s -> s { gmStack = addr:gmStack s }) 99 | 100 | -- Push unboxed value on the V-stack 101 | pushVStack :: Int -> Transition 102 | pushVStack n = modify (\s -> s { gmVStack = n:gmVStack s }) 103 | 104 | -- Pop address off stack 105 | popStack :: Eval Addr 106 | popStack = do 107 | addr:stack <- gets gmStack 108 | modify (\s -> s { gmStack = stack }) 109 | return addr 110 | 111 | -- Pop unboxed value off stack 112 | popVStack :: Eval Int 113 | popVStack = do 114 | n:vstack <- gets gmVStack 115 | modify (\s -> s { gmVStack = vstack }) 116 | return n 117 | 118 | -- Allocate a node on the heap 119 | gmAlloc :: Node -> Eval Addr 120 | gmAlloc node = do 121 | heap <- gets gmHeap 122 | let (heap', addr) = hAlloc heap node 123 | modify (\s -> s { gmHeap = heap' }) 124 | return addr 125 | 126 | -- Update a node in the heap 127 | gmUpdate :: Addr -> Node -> Transition 128 | gmUpdate addr node = do 129 | heap <- gets gmHeap 130 | let heap' = hUpdate heap addr node 131 | modify (\s -> s { gmHeap = heap' }) 132 | 133 | -- Load node from heap 134 | gmLoad :: Addr -> Eval Node 135 | gmLoad addr = do 136 | heap <- gets gmHeap 137 | let node = hLoad heap addr 138 | return node 139 | 140 | 141 | -- Dispatch from instruction to implementation 142 | dispatch :: Instruction -> Transition 143 | dispatch i = case i of 144 | Pushglobal f -> pushglobal f 145 | Pushint n -> pushint n 146 | Pushbasic n -> pushbasic n 147 | Push n -> push n 148 | Pop n -> pop n 149 | Slide n -> slide n 150 | Alloc n -> alloc n 151 | Update n -> update n 152 | Pack t n -> pack t n 153 | Casejump alts -> casejump alts 154 | Cond t f -> cond t f 155 | Split n -> split n 156 | Mkap -> mkap 157 | Mkint -> mkint 158 | Mkbool -> mkbool 159 | Get -> get' 160 | Eval -> eval 161 | Unwind -> unwind 162 | Print -> print' 163 | LParen -> lparen 164 | RParen -> rparen 165 | Space -> space 166 | Add -> arithBinary (+) 167 | Sub -> arithBinary (-) 168 | Mul -> arithBinary (*) 169 | Div -> arithBinary div 170 | Neg -> arithUnary negate 171 | Eq -> compBinary (==) 172 | Ne -> compBinary (/=) 173 | Lt -> compBinary (<) 174 | Le -> compBinary (<=) 175 | Gt -> compBinary (>) 176 | Ge -> compBinary (>=) 177 | 178 | -- Find global node by name 179 | -- (o, Pushglobal f : i, s, d, v, h, m[(f, a)]) 180 | -- (o, i, a : s, d, v, h, m) 181 | pushglobal :: Name -> Transition 182 | pushglobal f = do 183 | globals <- gets gmGlobals 184 | let addr = fromJust (lookup f globals) 185 | pushStack addr 186 | 187 | -- Allocate number in heap and push on stack 188 | -- (o, Pushint n : i, s, d, v, h, m) 189 | -- (o, i, a : s, d, v, h[(a, NNum n)], m) 190 | pushint :: Int -> Transition 191 | pushint n = do 192 | addr <- gmAlloc (NNum n) 193 | pushStack addr 194 | 195 | -- Push unboxed integer onto V-stack 196 | -- (o, Pushbasic n : i, s, d, v, h, m) 197 | -- (o, i, s, d, n : v, h, m) 198 | pushbasic :: Int -> Transition 199 | pushbasic = pushVStack 200 | 201 | -- Push address of argument on stack 202 | -- (o, Push n : i, a0 : ... : an+1 : s, d, v, h[(an + 1, NApp an an')], m) 203 | -- (o, i, an' : a0 : ... : an + 1 : s, d, v, h, m) 204 | push :: Int -> Transition 205 | push n = do 206 | stack <- gets gmStack 207 | let addr = stack !! n 208 | pushStack addr 209 | 210 | -- Pop n items from the stack 211 | -- (o, Pop n : i, a1 : ... : an : s, d, v, h, m) 212 | -- (o, i, s, d, v, h, m) 213 | pop :: Int -> Transition 214 | pop n = do 215 | stack <- gets gmStack 216 | modify (\s -> s { gmStack = drop n stack }) 217 | 218 | -- Remove items from stack leaving top-of-stack 219 | -- (o, Slide n : i, a0 : ... : an : s, d, v, h, m) 220 | -- (o, i, a0 : s, d, v, h, m) 221 | slide :: Int -> Transition 222 | slide n = do 223 | top:stack <- gets gmStack 224 | modify (\s -> s { gmStack = top:drop n stack }) 225 | 226 | -- Allocate n nodes in the heap and put their addresses on the stack 227 | -- (o, Alloc n : i, s, d, v, h, m) 228 | -- (o, i, a1 : ... : an : s, d, v, h[(a1, NPointer hNull), ..., (an, NPointer hNull)], m) 229 | alloc :: Int -> Transition 230 | alloc n = 231 | when (n > 0) $ do 232 | addr <- gmAlloc (NPointer hNull) 233 | pushStack addr 234 | alloc (pred n) 235 | 236 | -- Replace root of redex with pointer to top-of-stack 237 | -- (o, Update n : i, a : a0 : ... : an : s, d, v, h, m) 238 | -- (o, i, a0 : ... : an : s, d, v, h[(an, NPointer a), m) 239 | update :: Int -> Transition 240 | update n = do 241 | addr:stack <- gets gmStack 242 | gmUpdate (stack !! n) (NPointer addr) 243 | modify (\s -> s { gmStack = stack }) 244 | 245 | -- Build constructor node in heap from stack elements 246 | -- (o, Pack t n : i, a1 : ... : an : s, d, v, h, m) 247 | -- (o, i, a : s, d, v, h[(a, NConstructor t [a1, ..., an])], m) 248 | pack :: Int -> Int -> Transition 249 | pack tag arity = do 250 | stack <- gets gmStack 251 | when (length stack < arity) $ 252 | runtimeError "Not enough arguments to saturate constructor" 253 | let (args, stack') = splitAt arity stack 254 | addr <- gmAlloc (NConstructor tag args) 255 | modify (\s -> s { gmStack = addr:stack' }) 256 | 257 | -- Evaluate top-of-stack to WHNF and use tag to jump to code 258 | -- (o, Casejump [..., t -> i', ...] : i, a : s, d, v, h[(a, NConstructor t cs)], m) 259 | -- (o, i' ++ i, a : s, d, v, h, m) 260 | casejump :: [(Int, GMCode)] -> Transition 261 | casejump alts = do 262 | addr:_ <- gets gmStack 263 | (NConstructor tag _) <- gmLoad addr 264 | cons <- gets gmCons 265 | case lookup tag alts of 266 | Just branch -> modify (\s -> s { gmCode = branch ++ gmCode s }) 267 | Nothing -> runtimeError ("No case for constructor " ++ cons !! tag) 268 | 269 | -- Simple branch using top-of-V-stack 270 | -- If top-of-V-stack is 2 (True tag): 271 | -- (o, Cond t f : i, s, d, 2 : v, h, m) 272 | -- (o, t ++ i, s, d, v, h, m) 273 | -- If top-of-V-stack is 1 (False tag): 274 | -- (o, Cond t f : i, s, d, 1 : v, h, m) 275 | -- (o, f ++ i, s, d, v, h, m) 276 | cond :: GMCode -> GMCode -> Transition 277 | cond consequent alternative = do 278 | condition:vstack <- gets gmVStack 279 | branch <- case condition of 280 | 1 -> return alternative 281 | 2 -> return consequent 282 | _ -> runtimeError ("Non-Boolean " ++ show condition ++ " used in Boolean context") 283 | modify (\s -> s { gmCode = branch ++ gmCode s, gmVStack = vstack }) 284 | 285 | -- Destructure constructor onto stack 286 | -- (o, Split n : i, a : s, d, v, h[(a, NConstructor t [a1, ..., an])], m) 287 | -- (o, i, a1 : ... : an : s, d, v, h, m) 288 | split :: Int -> Transition 289 | split n = do 290 | addr:stack <- gets gmStack 291 | (NConstructor _ args) <- gmLoad addr 292 | when (length args /= n) $ 293 | runtimeError ("Cannot destructure constructor into " ++ show n ++ " components") 294 | modify (\s -> s { gmStack = args ++ stack }) 295 | 296 | -- Print numbers and constructor components by adding values to output list 297 | -- (o, Print : i, a : s, d, v, h[(a, NNum n)], m) 298 | -- (o ++ n, i, s, d, v, h, m) 299 | -- Or 300 | -- (o, Print : i, a : s, d, v, h[(a, NConstructor t [a1, ..., an])], m) 301 | -- (o, i' ++ i, a1 : ... : an : s, d, v, h, m) 302 | -- where i' = concat (take n (repeat [Eval, Print])) 303 | print' :: Transition 304 | print' = do 305 | addr <- popStack 306 | node <- gmLoad addr 307 | doPrint node 308 | where 309 | doPrint (NNum n) = 310 | modify $ \s -> s { gmOutput = show n:gmOutput s } 311 | 312 | doPrint (NConstructor tag args) = do 313 | cons <- gets gmCons 314 | if length args > 0 315 | then modify $ \s -> s 316 | { gmOutput = (cons !! tag):"(":gmOutput s 317 | , gmCode = printN (length args) ++ [RParen] ++ gmCode s 318 | , gmStack = args ++ gmStack s 319 | } 320 | else modify (\s -> s { gmOutput = (cons !! tag):gmOutput s }) 321 | 322 | doPrint (NGlobal _ _) = 323 | modify (\s -> s { gmOutput = "":gmOutput s }) 324 | 325 | doPrint (NApp _ _) = 326 | modify (\s -> s { gmOutput = "":gmOutput s }) 327 | 328 | doPrint x = runtimeError ("tried to print " ++ show x) 329 | 330 | printN n = concat (take n (repeat [Space, Eval, Print])) 331 | 332 | -- Add punctuation to output for constructor applications 333 | lparen = modify (\s -> s { gmOutput = "(":gmOutput s }) 334 | rparen = modify (\s -> s { gmOutput = ")":gmOutput s }) 335 | space = modify (\s -> s { gmOutput = " ":gmOutput s }) 336 | 337 | -- Build application from 2 addresses on top of stack 338 | -- (o, Mkap : i, a1 : a2 : s, d, v, h, m) 339 | -- (o, i, a : s, d, v, h[(a, NApp a1 a2)], m) 340 | mkap :: Transition 341 | mkap = do 342 | a1 <- popStack 343 | a2 <- popStack 344 | addr <- gmAlloc (NApp a1 a2) 345 | pushStack addr 346 | 347 | -- Box top-of-V-stack into heap as integer, put address on top-of-stack 348 | -- (o, Mkint : i, s, d, n : v, h, m) 349 | -- (o, i, a : s, d, v, h[(a, NNum n)], m) 350 | mkint :: Transition 351 | mkint = do 352 | n <- popVStack 353 | addr <- gmAlloc (NNum n) 354 | pushStack addr 355 | 356 | -- Box top-of-V-stack into heap as Boolean, put address on top-of-stack 357 | -- (o, Mkbool : i, s, d, b : v, h, m) 358 | -- (o, i, a : s, d, v, h[(a, NConstructor b [])], m) 359 | mkbool :: Transition 360 | mkbool = do 361 | b <- popVStack 362 | addr <- gmAlloc (NConstructor b []) 363 | pushStack addr 364 | 365 | -- Unbox top-of-stack and put on V-stack 366 | -- (o, Get : i, a : s, d, v, h[(a, NNum n)], m) 367 | -- (o, i, s, d, n : v, h, m) 368 | -- or 369 | -- (o, Get : i, a : s, d, v, h[(a, NConstructor b [])], m) 370 | -- (o, i, s, d, b : v, h, m) 371 | get' :: Transition 372 | get' = do 373 | addr <- popStack 374 | node <- gmLoad addr 375 | unboxed <- case node of 376 | NNum n -> return n 377 | NConstructor b [] -> return b 378 | _ -> runtimeError ("Cannot put node " ++ show node ++ " on V-stack") 379 | pushVStack unboxed 380 | 381 | -- Put bottom of stack, V-stack, and instructions on dump. 382 | -- Leave top-of-stack as only element on stack and unwind. 383 | -- (o, Eval : i, a : s, d, v, h, m) 384 | -- (o, [Unwind], [a], (i, s, v : d, [], h, m) 385 | eval :: Transition 386 | eval = do 387 | addr:stack <- gets gmStack 388 | vstack <- gets gmVStack 389 | dump <- gets gmDump 390 | code <- gets gmCode 391 | modify $ \s -> s 392 | { gmCode = [Unwind] 393 | , gmStack = [addr] 394 | , gmVStack = [] 395 | , gmDump = (code, stack, vstack):dump 396 | } 397 | 398 | -- If dump is not empty, restore to machine state. Otherwise, 399 | -- halt execution. 400 | restoreDump :: Addr -> Transition 401 | restoreDump addr = do 402 | dump <- gets gmDump 403 | case dump of 404 | (code, stack, vstack):dump -> modify $ \s -> s 405 | { gmCode = code 406 | , gmStack = addr:stack 407 | , gmVStack = vstack 408 | , gmDump = dump 409 | } 410 | _ -> modify $ \s -> s { gmCode = [] } 411 | 412 | -- Use top of stack to build next state 413 | unwind :: Transition 414 | unwind = do 415 | addr:_ <- gets gmStack 416 | node <- gmLoad addr 417 | newState node 418 | where 419 | -- Number on stack and empty dump; G-Machine is terminating. 420 | -- (o, [Unwind], a : s, [], v, h[(a, NNum n)], m) 421 | -- (o, [], a : s, [], v, h, m) 422 | -- Or number on stack and not-empty dump; restore code and stack 423 | -- (o, [Unwind], a : s, (c, s', v') : d, v, h[(a, NNum n)], m) 424 | -- (o, c, a : s', d, v', h, m) 425 | newState (NNum _) = popStack >>= restoreDump 426 | 427 | -- Constructor on stack and empty dump; G-Machine is terminating. 428 | -- (o, [Unwind], a : s, [], v, h[(a, Constructor tar args)], m) 429 | -- (o, [], a : s, [], v, h, m) 430 | -- Or Constructor on stack and not-empty dump; restore code and stack 431 | -- (o, [Unwind], a : s, (c, s', v') : d, v, h[(a, Constructor tag args)], m) 432 | -- (o, c, a : s', d, v', h, m) 433 | newState (NConstructor _ _) = popStack >>= restoreDump 434 | 435 | -- Application; keep unwinding applications onto stack 436 | -- (o, [Unwind], a : s, d, v, h[(a, NApp a1 a2)], m) 437 | -- (o, [Unwind], a1 : a : s, d, v, h, m) 438 | newState (NApp a1 a2) = do 439 | addr:stack <- gets gmStack 440 | modify $ \s -> s 441 | { gmCode = [Unwind] 442 | , gmStack = a1:addr:stack 443 | } 444 | 445 | -- Pointer; dereference and replace top-of-stack 446 | -- (o, [Unwind], a0 : s, d, v, h[(a0, NPointer a)], m) 447 | -- (o, [Unwind], a : s, d, v, h, m) 448 | newState (NPointer a) = do 449 | _:stack <- gets gmStack 450 | modify $ \s -> s 451 | { gmCode = [Unwind] 452 | , gmStack = a:stack 453 | } 454 | 455 | -- Global; put code for global in code component of machine. 456 | -- (o, [Unwind], a0 : ... : an : s, d, v, h[(a0, NGlobal n c), (NApp a0 a1'), ..., (NApp an-1, an')], m) 457 | -- (o, c, a1' : ... : an' : s, d, v, h, m) 458 | -- If we're evaluating something to WHNF, there will be information on the 459 | -- dump. In this case, we don't need to fully apply the combinator, and if we 460 | -- can't, we should just return the root of the redex: 461 | -- (o, [Unwind], [a0, ..., ak], (i, s) : d, v, h[(a0, NGlobal n c)], m) 462 | -- (o, i, ak : s, d, v, h, m) when k < n 463 | newState (NGlobal n code) = do 464 | addr:stack <- gets gmStack 465 | if length stack < n 466 | then restoreDump (last (addr:stack)) 467 | else do 468 | stack <- rearrange n 469 | modify $ \s -> s 470 | { gmCode = code 471 | , gmStack = stack 472 | } 473 | 474 | -- Pull n arguments directly onto the stack out of NApp nodes 475 | rearrange :: Int -> Eval GMStack 476 | rearrange n = do 477 | stack <- gets gmStack 478 | args <- mapM getArg (tail stack) 479 | return (take n args ++ drop n stack) 480 | 481 | -- Get argument component from application 482 | getArg :: Addr -> Eval Addr 483 | getArg addr = do 484 | node <- gmLoad addr 485 | case node of 486 | NApp _ arg -> return arg 487 | _ -> runtimeError ("Attempted to load argument to non-application node") 488 | 489 | -- Generate a state transition from a unary arithmetic function 490 | arithUnary :: (Int -> Int) -> Transition 491 | arithUnary op = popVStack >>= pushVStack . op 492 | 493 | -- Generate a state transition from a binary arithmetic function 494 | arithBinary :: (Int -> Int -> Int) -> Transition 495 | arithBinary op = do 496 | x <- popVStack 497 | y <- popVStack 498 | pushVStack (op x y) 499 | 500 | -- Generate a state transition from a binary comparison function 501 | compBinary :: (Int -> Int -> Bool) -> Transition 502 | compBinary op = do 503 | x <- popVStack 504 | y <- popVStack 505 | case op x y of 506 | True -> pushVStack 2 -- True tag 507 | False -> pushVStack 1 -- False tag 508 | 509 | -- Simple mark and scan garbage collection 510 | gc :: Transition 511 | gc = do 512 | markFromDump 513 | markFromStack 514 | markFromGlobals 515 | scanHeap 516 | 517 | -- Mark all root addresses in dump's stack component 518 | markFromDump :: Transition 519 | markFromDump = do 520 | dump <- gets gmDump >>= mapM mark 521 | modify (\s -> s { gmDump = dump }) 522 | where 523 | mark (code, stack, vstack) = do 524 | stack' <- mapM markFrom stack 525 | return (code, stack', vstack) 526 | 527 | -- Mark all root addresses in stack 528 | markFromStack :: Transition 529 | markFromStack = do 530 | stack <- gets gmStack >>= mapM markFrom 531 | modify (\s -> s { gmStack = stack }) 532 | 533 | -- Mark all root addresses in globals 534 | markFromGlobals :: Transition 535 | markFromGlobals = do 536 | globals <- gets gmGlobals >>= mapM mark 537 | modify (\s -> s { gmGlobals = globals }) 538 | where 539 | mark (name, addr) = do 540 | addr' <- markFrom addr 541 | return (name, addr') 542 | 543 | writeHeap :: Addr -> Node -> Eval Addr 544 | writeHeap addr node = do 545 | heap <- gets gmHeap 546 | modify (\s -> s { gmHeap = hUpdate heap addr node }) 547 | return addr 548 | 549 | -- Start from address and mark all reachable addresses from it. Replace any 550 | -- pointer nodes by what they point to. 551 | markFrom :: Addr -> Eval Addr 552 | markFrom addr = do 553 | heap <- gets gmHeap 554 | case hLoad heap addr of 555 | node@(NNum _) -> 556 | writeHeap addr $ NMarked node 557 | 558 | node@(NApp a1 a2) -> do 559 | -- Visit this node to avoid looping 560 | _ <- writeHeap addr (NMarked node) 561 | a1' <- markFrom a1 562 | a2' <- markFrom a2 563 | -- Update addresses that may have changed 564 | writeHeap addr $ NMarked $ NApp a1' a2' 565 | 566 | node@(NGlobal _ _) -> 567 | writeHeap addr $ NMarked node 568 | 569 | node@(NPointer a) 570 | | isNullAddr a -> writeHeap addr $ NMarked node 571 | | otherwise -> markFrom a 572 | 573 | node@(NConstructor tag addrs) -> do 574 | -- Visit this node to avoid looping 575 | _ <- writeHeap addr (NMarked node) 576 | addrs' <- mapM markFrom addrs 577 | -- Update addresses that may have changed 578 | writeHeap addr (NMarked (NConstructor tag addrs')) 579 | 580 | _ -> return addr 581 | 582 | -- Scan all nodes freeing unmarked nodes and unmarking marked nodes 583 | scanHeap :: Transition 584 | scanHeap = do 585 | heap <- gets gmHeap 586 | let addresses = hAddresses heap 587 | heap' = foldr scanFrom heap addresses 588 | modify (\s -> s { gmHeap = hIncreaseMax heap' }) 589 | where 590 | scanFrom addr heap = 591 | case hLoad heap addr of 592 | NMarked node -> hUpdate heap addr node 593 | _ -> hFree heap addr 594 | 595 | -------------------------------------------------------------------------------- /src/MiniCore/Heap.hs: -------------------------------------------------------------------------------- 1 | module MiniCore.Heap 2 | ( hInit 3 | , hAlloc 4 | , hUpdate 5 | , hFree 6 | , hLoad 7 | , hTooLarge 8 | , hIncreaseMax 9 | , hAddresses 10 | , hSize 11 | , hNull 12 | , isNullAddr 13 | ) where 14 | 15 | import MiniCore.Types 16 | 17 | -- Initial heap with an unbounded free-list and empty environment 18 | hInit :: Heap a 19 | hInit = Heap 20 | { hSize = 0 21 | , hMaxSize = 100 22 | , hFreeList = [1..] 23 | , hEnvironment = [] 24 | } 25 | 26 | -- Remove address from beginning of free-list, 27 | -- attach object to live environment, and increment size 28 | hAlloc :: Heap a -> a -> (Heap a, Addr) 29 | hAlloc heap x = (heap', addr) 30 | where 31 | addr:free = hFreeList heap 32 | heap' = heap 33 | { hSize = hSize heap + 1 34 | , hFreeList = free 35 | , hEnvironment = (addr, x):hEnvironment heap 36 | } 37 | 38 | -- Replace current node at address with new object 39 | hUpdate :: Heap a -> Addr -> a -> Heap a 40 | hUpdate heap addr x = heap 41 | { hEnvironment = (addr, x):remove (hEnvironment heap) addr 42 | } 43 | 44 | -- Remove object from live environment, and return address to free-list 45 | hFree :: Heap a -> Addr -> Heap a 46 | hFree heap addr = heap 47 | { hSize = hSize heap - 1 48 | , hFreeList = addr:hFreeList heap 49 | , hEnvironment = remove (hEnvironment heap) addr 50 | } 51 | 52 | -- Dereference address and return object 53 | hLoad :: Heap a -> Addr -> a 54 | hLoad heap addr = 55 | case lookup addr (hEnvironment heap) of 56 | Just x -> x 57 | Nothing -> error ("Can't find node " ++ show addr ++ " in heap") 58 | 59 | -- Is Heap too large? Should we initiate garbage collection? 60 | hTooLarge :: Heap a -> Bool 61 | hTooLarge heap = hSize heap > hMaxSize heap 62 | 63 | -- Make max size double the current size 64 | hIncreaseMax :: Heap a -> Heap a 65 | hIncreaseMax heap = heap { hMaxSize = 2 * hSize heap } 66 | 67 | -- Get addresses of live objects 68 | hAddresses :: Heap a -> [Addr] 69 | hAddresses = map fst . hEnvironment 70 | 71 | -- Never points to anything 72 | hNull :: Addr 73 | hNull = 0 74 | 75 | -- Address is null address 76 | isNullAddr :: Addr -> Bool 77 | isNullAddr = (==hNull) 78 | 79 | -- Remove object from list by address 80 | remove :: [(Addr, a)] -> Addr -> [(Addr, a)] 81 | remove [] addr = error ("Attempt to replace free nonexistent node " ++ show addr) 82 | remove (pair@(addr, x):env) addr' 83 | | addr' == addr = env 84 | | otherwise = pair:remove env addr' 85 | 86 | -------------------------------------------------------------------------------- /src/MiniCore/Inference.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} 2 | 3 | module MiniCore.Inference 4 | ( typecheck 5 | ) where 6 | 7 | import MiniCore.Types 8 | import MiniCore.Format 9 | import MiniCore.Transforms.StronglyConnectedComponents 10 | 11 | import Data.Function 12 | import qualified Data.Map as Map 13 | import qualified Data.Set as Set 14 | import qualified Data.List as List 15 | import Control.Applicative 16 | import Control.Monad.Except 17 | import Control.Monad.State 18 | 19 | -- Public compiler stage 20 | typecheck :: Program -> Stage ([(Name, Scheme)], Program) 21 | typecheck = runTI . inferTypes 22 | 23 | -- Type schemes for builtin functions 24 | ifScheme = Scheme ["a"] (boolTy `fn` (var "a" `fn` (var "a" `fn` var "a"))) 25 | negScheme = Scheme [] (intTy `fn` intTy) 26 | appScheme = Scheme ["a", "b"] ((var "a" `fn` var "b") `fn` (var "a" `fn` var "b")) 27 | compScheme = Scheme ["a", "b", "c"] ((var "b" `fn` var "c") `fn` ((var "a" `fn` var "b") `fn` (var "a" `fn` var "c"))) 28 | boolScheme = Scheme [] boolTy 29 | binNumScheme = Scheme [] (intTy `fn` (intTy `fn` intTy)) 30 | binBoolScheme = Scheme [] (boolTy `fn` (boolTy `fn` boolTy)) 31 | binCompareScheme = Scheme [] (intTy `fn` (intTy `fn` boolTy)) 32 | 33 | {- Initial type-environment with primitive operations -} 34 | primOps = 35 | [ ("if", ifScheme) 36 | , ("$", appScheme) 37 | , (".", compScheme) 38 | , ("+", binNumScheme) 39 | , ("-", binNumScheme) 40 | , ("*", binNumScheme) 41 | , ("/", binNumScheme) 42 | , ("||", binBoolScheme) 43 | , ("&&", binBoolScheme) 44 | , ("==", binCompareScheme) 45 | , ("/=", binCompareScheme) 46 | , ("<", binCompareScheme) 47 | , (">", binCompareScheme) 48 | , ("<=", binCompareScheme) 49 | , (">=", binCompareScheme) 50 | , ("True", boolScheme) 51 | , ("False", boolScheme) 52 | , ("negate", negScheme) 53 | ] 54 | 55 | {- Internal types for type-checking -} 56 | 57 | -- Internal type-inference state 58 | data TIState = TIState 59 | { tiDecl :: Maybe Declaration -- Typechecking Context 60 | , tiNext :: Int -- Generate fresh type variables 61 | , tiCons :: TypeEnv -- Constructor for case-expressions 62 | , tiTEnv :: TypeEnv -- Named entities to show types for 63 | , tiData :: Map.Map Name Type -- Available types 64 | } 65 | 66 | -- Keep track of type-inference state and be able to throw an error 67 | --type TI a = ErrorT String (StateT TIState Identity) a 68 | --type TI a = ErrorT String (StateT TIState IO) a 69 | type TI a = StateT TIState Stage a 70 | 71 | {- Manipulating TI context -} 72 | 73 | -- Set declaration as current typechecking context 74 | setContext :: Declaration -> TI () 75 | setContext decl = modify $ \s -> s { tiDecl = Just decl } 76 | 77 | -- Make context declaration out of name and expression 78 | setNamedExpr :: Name -> Expr -> TI () 79 | setNamedExpr name expr = setContext combinator 80 | where 81 | combinator = case expr of 82 | Lambda args body -> Combinator name args body 83 | _ -> Combinator name [] expr 84 | 85 | -- Save types of named values in type environment 86 | saveEnv :: TypeEnv -> [Name] -> TI () 87 | saveEnv env' names = do 88 | env <- gets tiTEnv 89 | let specified = fromKeys env' names 90 | modify (\s -> s { tiTEnv = specified `Map.union` env }) 91 | 92 | -- Throw an error after adding context information 93 | raise :: String -> TI a 94 | raise msg = do 95 | decl <- gets tiDecl 96 | let error = case decl of 97 | Just decl -> msg ++ "\nin:\n\t" ++ show (format decl) 98 | Nothing -> msg 99 | typeError ("\n\t" ++ error) 100 | 101 | {- Utilities -} 102 | 103 | -- Used to quote entities we're printing 104 | quote :: String -> String 105 | quote s = "'" ++ s ++ "'" 106 | 107 | -- Make a new Map just using the specified keys 108 | fromKeys m [] = Map.empty 109 | fromKeys m (x:xs) = case Map.lookup x m of 110 | Just v -> Map.insert x v (fromKeys m xs) 111 | Nothing -> fromKeys m xs 112 | 113 | {- Unification -} 114 | 115 | -- Identity substition has no effect when applied 116 | idSubst :: Subst 117 | idSubst = Map.empty 118 | 119 | -- If constraint is non-trivial and passes the occurs check, 120 | -- add it to substitution 121 | extend :: Subst -> Name -> Type -> TI Subst 122 | extend s n t 123 | | t == TVar n = return s 124 | | n `Set.member` tvars t = raise "Cannot construct infinite type" 125 | | otherwise = return (Map.singleton n t `scomp` s) 126 | 127 | -- Find a substituion that unifies pair of types. 128 | unify :: Subst -> (Type, Type) -> TI Subst 129 | unify s (TVar n, t) 130 | | n' == TVar n = extend s n t' 131 | | otherwise = unify s (n', t') 132 | where 133 | n' = apply s (TVar n) 134 | t' = apply s t 135 | 136 | unify s (TCon n ts, TVar n') = 137 | unify s (TVar n', TCon n ts) 138 | 139 | unify s (TCon n ts, TCon n' ts') 140 | | n == n' = unifyAll s (ts `zip` ts') 141 | | otherwise = raise $ "Cannot unify " ++ quote n ++ " and " ++ quote n' 142 | 143 | -- Unify each pair of types propagating the substition 144 | unifyAll :: Subst -> [(Type, Type)] -> TI Subst 145 | unifyAll = foldM unify 146 | 147 | {- Generating new type variables -} 148 | 149 | -- Get a new name 150 | fresh :: TI Name 151 | fresh = do 152 | n <- gets tiNext 153 | modify (\s -> s { tiNext = n + 1 }) 154 | return ("t" ++ show n) 155 | 156 | -- Given a list of names, return a substitution that maps 157 | -- the old names to completely new ones 158 | withNames :: [Name] -> TI Subst 159 | withNames = foldM newName Map.empty 160 | where 161 | newName env name = do 162 | x <- fresh 163 | return (Map.insert name (TVar x) env) 164 | 165 | {- Type checking for data declarations -} 166 | 167 | -- Add a new data type to the tiData mapping 168 | newDataType :: Name -> Type -> TI () 169 | newDataType name t = do 170 | types <- gets tiData 171 | when (name `Map.member` types) $ 172 | raise $ "Redeclaration of data type " ++ quote name 173 | modify (\s -> s { tiData = Map.insert name t types }) 174 | 175 | -- Ensure each data declaration is well-formed: 176 | -- * Must not be redeclaration 177 | -- * Each constructor must be well-formed 178 | -- * Type variables are replaced with fresh type variables 179 | checkDataTypes :: TypeEnv -> [Declaration] -> TI TypeEnv 180 | checkDataTypes = foldM checkDataType 181 | where 182 | checkDataType env decl@(Data name vars constructors) = do 183 | setContext decl 184 | s <- withNames vars 185 | let ty = apply s (TCon name (map TVar vars)) 186 | vars' = tvars ty 187 | mkScheme = Scheme (Set.toList vars') . foldr fn ty . apply s 188 | newDataType name ty 189 | checkConstructors mkScheme (Set.fromList vars) env constructors 190 | 191 | -- Ensure each constructor for a data type is well-formed 192 | -- * Must not be a redeclaration 193 | -- * Type-variables must be in scope 194 | -- * Composite constructors must use already-defined types 195 | checkConstructors :: ([Type] -> Scheme) -> Set.Set Name -> TypeEnv -> [Constructor] -> TI TypeEnv 196 | checkConstructors mkScheme vars = foldM checkConstructor 197 | where 198 | checkConstructor env (Constructor name args) = do 199 | when (not (tvars args `Set.isSubsetOf` vars)) $ 200 | raise ("Unbound type variable in constructor " ++ quote name) 201 | cons <- gets tiCons 202 | when (name `Map.member` cons) $ 203 | raise ("Redeclaration of constructor " ++ quote name) 204 | mapM_ validType args 205 | let scheme = mkScheme args 206 | modify (\s -> s { tiCons = Map.insert name scheme cons }) 207 | return (Map.insert name scheme env) 208 | 209 | validType (TVar _) = return () 210 | validType (TCon n ts) = do 211 | mapM_ validType ts 212 | types <- gets tiData 213 | when (n `Map.notMember` types) $ 214 | raise ("Use of undeclared type " ++ quote n) 215 | return () 216 | 217 | {- Type checking for bindings and expressions -} 218 | 219 | -- Type check a list of expressions producing a composite substition 220 | -- and a list of types 221 | tcAll :: TypeEnv -> [(Name, Expr)] -> TI (Subst, [Type]) 222 | tcAll env [] = return (idSubst, []) 223 | tcAll env ((name, expr):es) = do 224 | setNamedExpr name expr 225 | (s, t) <- tcExpr env expr 226 | (s', ts) <- tcAll (apply s env) es 227 | return (s' `scomp` s, apply s' t : ts) 228 | 229 | -- Type-check an expression in the current type-environment producing 230 | -- a substitution and a concrete type 231 | tcExpr :: TypeEnv -> Expr -> TI (Subst, Type) 232 | 233 | -- Literal integer 234 | tcExpr env (Num _) = return (idSubst, intTy) 235 | 236 | -- Variable 237 | tcExpr env (Var x) = do 238 | scheme <- case Map.lookup x env of 239 | Nothing -> raise $ "Unbound variable " ++ quote x 240 | Just scheme -> return scheme 241 | t <- newInstance scheme 242 | return (idSubst, t) 243 | 244 | -- Application 245 | tcExpr env (App e1 e2) = do 246 | (s1, t1) <- tcExpr env e1 247 | (s2, t2) <- tcExpr (apply s1 env) e2 248 | let t1' = apply s2 t1 249 | s = s2 `scomp` s1 250 | n <- fresh 251 | s' <- unify s (t1', t2 `fn` TVar n) 252 | return (s', apply s' (TVar n)) 253 | 254 | -- Binary application 255 | tcExpr env (BinOp op lhs rhs) = tcExpr env (App (App (Var op) lhs) rhs) 256 | 257 | -- Lambda 258 | tcExpr env (Lambda args e) = do 259 | schemes <- toSchemes args 260 | (s, t) <- tcExpr (schemes `Map.union` env) e 261 | let schemes' = apply s schemes 262 | args' = fromSchemes schemes' args 263 | return (s, foldr fn t args') 264 | 265 | -- Case 266 | tcExpr env (Case scrutinee alts) = do 267 | (s, t) <- tcExpr env scrutinee 268 | (s', (scrut', t')) <- tcAlts env (apply s t) alts 269 | s'' <- unify s' (t, apply s' scrut') 270 | return (s'' `scomp` s' `scomp` s, t') 271 | 272 | -- Non-recursive Let 273 | tcExpr env (Let False bindings expr) = do 274 | let (names, exprs) = unzip bindings 275 | 276 | -- Infer monomorphic types for definitions 277 | (s, ts) <- tcAll env bindings 278 | 279 | -- Generalize types and add to type-environment 280 | env'' <- addDecls (apply s env) names ts 281 | 282 | -- Save types of named values 283 | saveEnv env'' names 284 | 285 | -- Infer type for body 286 | (s', t) <- tcExpr env'' expr 287 | return (s' `scomp` s, t) 288 | 289 | -- Recursive Let 290 | tcExpr env (Let True bindings expr) = do 291 | let (names, exprs) = unzip bindings 292 | 293 | -- Add new type-variables for definitions 294 | schemes <- toSchemes names 295 | 296 | -- Infer monomorphic types for definitions 297 | (s, ts) <- tcAll (schemes `Map.union` env) bindings 298 | 299 | -- Apply substition to type-variables and unify 300 | -- with inferred types 301 | let schemes' = apply s schemes 302 | env' = apply s env 303 | ts' = fromSchemes schemes' names 304 | s' <- unifyAll s (zip ts ts') 305 | let ts'' = fromSchemes (apply s' schemes') names 306 | 307 | -- Generalize types and add to environment 308 | env'' <- addDecls (apply s' env') names ts'' 309 | 310 | -- Save types of named values 311 | saveEnv env'' names 312 | 313 | --Infer type for body 314 | (s'', t) <- tcExpr env'' expr 315 | return (s'' `scomp` s', t) 316 | 317 | -- Type-check each alternative in a case-expression 318 | tcAlts :: TypeEnv -> Type -> [Alt] -> TI (Subst, (Type, Type)) 319 | tcAlts env scrut alts = do 320 | t <- fresh 321 | foldM combine (idSubst, (scrut, TVar t)) alts 322 | where 323 | combine (s, (scrut, t)) alt = do 324 | (s', (scrut', t')) <- tcAlt env alt 325 | s'' <- unifyAll s' [(scrut, scrut'), (t, t')] 326 | return (s'' `scomp` s' `scomp` s, (scrut', t')) 327 | 328 | -- Type-check a single alternative. The first type in the return pair is of 329 | -- the scrutinee and the second is the type of the alternative. 330 | tcAlt :: TypeEnv -> Alt -> TI (Subst, (Type, Type)) 331 | tcAlt env (PCon name, names, body) = do 332 | cons <- gets tiCons 333 | scheme <- case Map.lookup name cons of 334 | Just x -> return x 335 | Nothing -> raise $ "Undeclared constructor " ++ quote name 336 | t <- newInstance scheme 337 | let (types, rtype) = components t 338 | when (length types /= length names) $ 339 | raise ("Wrong number of components for " ++ quote name) 340 | let schemes = map (Scheme []) types 341 | bindings = zip names schemes 342 | env' = Map.fromList bindings `Map.union` env 343 | (s, t') <- tcExpr env' body 344 | return (s, (rtype, apply s t')) 345 | where 346 | -- Break a constructor into its components and return type 347 | components :: Type -> ([Type], Type) 348 | components = loop [] 349 | where 350 | loop cs (TCon "(->)" [a, b]) = loop (a:cs) b 351 | loop cs last = (reverse cs, last) 352 | 353 | {- Dealing with generalization and instantiation -} 354 | 355 | -- Generate a mapping from names to new type schemes 356 | toSchemes :: [Name] -> TI TypeEnv 357 | toSchemes ns = Map.map (Scheme []) <$> withNames ns 358 | 359 | -- Get the types from a type environment 360 | -- Use name lookup to put them in order 361 | fromSchemes :: TypeEnv -> [Name] -> [Type] 362 | fromSchemes env = foldr find [] 363 | where 364 | find name ts = 365 | maybe ts 366 | ((:ts) . unScheme) 367 | (Map.lookup name env) 368 | 369 | -- Get the type from a single type scheme 370 | unScheme :: Scheme -> Type 371 | unScheme (Scheme _ t) = t 372 | 373 | -- Get all the types from a mapping of names to type schemes 374 | unSchemeAll :: TypeEnv -> [Type] 375 | unSchemeAll env = map unScheme (Map.elems env) 376 | 377 | -- Instantiate a type scheme to a new concrete type 378 | newInstance :: Scheme -> TI Type 379 | newInstance (Scheme vs t) = do 380 | s <- withNames vs 381 | return (apply s t) 382 | 383 | -- Build a polymorphic version of a monomorphic type 384 | generalize :: TypeEnv -> Type -> TI Scheme 385 | generalize env t = do 386 | let vs = tvars t `Set.difference` tvars env 387 | s <- withNames (Set.toList vs) 388 | let t' = apply s t 389 | vs' = map unTVar (Map.elems s) 390 | return $ Scheme vs' t' 391 | where 392 | unTVar (TVar n) = n 393 | 394 | -- Map each name to a generalized version of its inferred type 395 | addDecls :: TypeEnv -> [Name] -> [Type] -> TI TypeEnv 396 | addDecls env ns ts = do 397 | schemes <- mapM (generalize env) ts 398 | return (Map.fromList (zip ns schemes) `Map.union` env) 399 | 400 | {- Ensure there are no duplicate bindings in current scope -} 401 | 402 | -- Only really interesting case is Let(rec) 403 | findDups :: Expr -> TI Expr 404 | findDups (Let recursive bindings expr) = do 405 | let (names, exprs) = unzip bindings 406 | _ <- foldM scan Set.empty names 407 | exprs' <- mapM findDups exprs 408 | expr' <- findDups expr 409 | return (Let recursive (zip names exprs') expr') 410 | where 411 | scan seen name = do 412 | when (name `Set.member` seen) $ 413 | raise ("Duplicate binding for " ++ quote name) 414 | return (Set.insert name seen) 415 | 416 | findDups (Lambda args e) = 417 | Lambda args <$> findDups e 418 | 419 | findDups (App e1 e2) = 420 | App <$> findDups e1 <*> findDups e2 421 | 422 | findDups (Case scrutinee alts) = 423 | Case <$> findDups scrutinee <*> mapM findDupsAlt alts 424 | where 425 | findDupsAlt (PCon name, names, body) = do 426 | body' <- findDups body 427 | return (PCon name, names, body') 428 | 429 | findDups e = return e 430 | 431 | {- Build entry point to type inference engine -} 432 | 433 | -- Run type-inference and return either an error or some value 434 | runTI :: TI a -> Stage a 435 | runTI ti = evalStateT ti initState 436 | where 437 | initState = TIState 438 | { tiDecl = Nothing 439 | , tiNext = 0 440 | , tiTEnv = Map.empty 441 | , tiCons = Map.fromList 442 | [ ("True", Scheme [] boolTy) 443 | , ("False", Scheme [] boolTy) 444 | ] 445 | , tiData = Map.fromList 446 | [ ("Int", intTy) 447 | , ("Bool", boolTy) 448 | ] 449 | } 450 | 451 | -- Convert a list of declarations into a single letrec and return 452 | -- list of all top-level declarations 453 | -- Each non-nullary binding is turned into a lambda 454 | -- This is also where we check for the existence of main 455 | convertToExpr :: [Declaration] -> TI ([Name], Expr) 456 | convertToExpr combinators = do 457 | (bindings, main) <- foldM convert ([], Nothing) combinators 458 | let names = map fst bindings 459 | case main of 460 | Just main -> return (names, Let True bindings main) 461 | Nothing -> raise "Must specify nullary function main" 462 | where 463 | -- Redeclaring main is an error 464 | convert (xs, Just main) (Combinator "main" [] expr) = 465 | raise "Redeclaration of main" 466 | 467 | -- Initial declaration of main 468 | convert (xs, Nothing) (Combinator "main" [] expr) = 469 | return (("main", expr):xs, Just (Var "main")) 470 | 471 | -- Declaring main with arguments is an error 472 | convert (xs, Nothing) (Combinator "main" args expr) = 473 | raise "main must be a nullary declaration" 474 | 475 | -- A binding with no arguments just becomes a regular let-binding 476 | convert (xs, main) (Combinator name [] expr) = 477 | return ((name, expr):xs, main) 478 | 479 | -- A binding with arguments becomes a let-bound lambda 480 | convert (xs, main) (Combinator name args expr) = 481 | return ((name, Lambda args expr):xs, main) 482 | 483 | -- Infer types and return top-level types and untransformed program 484 | inferTypes :: Program -> TI ([(Name, Scheme)], Program) 485 | inferTypes program = do 486 | -- Break program into data declarations and supercombinators 487 | let (decls, combinators) = List.partition isData program 488 | env = Map.fromList primOps 489 | 490 | -- Check data declarations first 491 | env' <- checkDataTypes env decls 492 | 493 | -- Convert program into a single letrec and find top-level names 494 | (names, expr) <- convertToExpr combinators 495 | 496 | -- Check for duplicate bindings 497 | expr' <- findDups expr 498 | 499 | -- Turn flat letrec into a nested let(rec) where each bind-group is 500 | -- as small as possible 501 | expr'' <- lift (simplifyExpr expr') 502 | 503 | -- Type-check expression 504 | (s, t) <- tcExpr env' expr'' 505 | 506 | -- Get inferred types for constructors and top-level names and sort them 507 | env <- gets tiTEnv 508 | cons <- gets tiCons 509 | let topLevel = fromKeys env names `Map.union` cons 510 | sorted = List.sortBy (compare `on` fst) (Map.toList topLevel) 511 | 512 | -- Return types and (mostly) untransformed program 513 | return (sorted, decls ++ combinators) 514 | 515 | -------------------------------------------------------------------------------- /src/MiniCore/Parse.hs: -------------------------------------------------------------------------------- 1 | module MiniCore.Parse 2 | ( parseCore 3 | ) where 4 | 5 | import MiniCore.Types 6 | 7 | import Text.ParserCombinators.Parsec hiding ((<|>), many) 8 | import Text.ParserCombinators.Parsec.Expr 9 | import Text.ParserCombinators.Parsec.Language 10 | import qualified Text.ParserCombinators.Parsec.Token as Token 11 | import Control.Monad.Except 12 | import Control.Applicative 13 | import Data.List 14 | 15 | -- Language definition for lexer 16 | languageDef = emptyDef 17 | { Token.commentStart = "{-" 18 | , Token.commentEnd = "-}" 19 | , Token.commentLine = "--" 20 | , Token.identStart = lower <|> char '_' 21 | , Token.identLetter = alphaNum <|> char '_' <|> char '\'' 22 | , Token.reservedNames = 23 | [ "data" 24 | , "let" 25 | , "letrec" 26 | , "case" 27 | , "in" 28 | , "of" 29 | , "Pack" 30 | ] 31 | , Token.reservedOpNames = 32 | [ "|" 33 | , "\\" 34 | , "=" 35 | , "->" 36 | ] ++ map fst precByOp 37 | } 38 | 39 | -- Generate lexer and bind names that we'll use 40 | lexer = Token.makeTokenParser languageDef 41 | identifier = Token.identifier lexer 42 | reserved = Token.reserved lexer 43 | reservedOp = Token.reservedOp lexer 44 | parens = Token.parens lexer 45 | braces = Token.braces lexer 46 | angles = Token.angles lexer 47 | natural = Token.natural lexer 48 | semi = Token.semi lexer 49 | comma = Token.comma lexer 50 | symbol = Token.symbol lexer 51 | whiteSpace = Token.whiteSpace lexer 52 | 53 | -- Data specifications and constructors must start with an uppercase letter 54 | uppercased :: Parser Name 55 | uppercased = do 56 | whiteSpace 57 | first <- upper 58 | rest <- many (alphaNum <|> char '_' <|> char '\'') 59 | whiteSpace 60 | return (first:rest) 61 | 62 | -- Parser entry point 63 | parseCore :: String -> Stage Program 64 | parseCore s = case parse pCore "core" s of 65 | Left e -> parseError (show e) 66 | Right r -> return r 67 | 68 | -- Program -> Declaration* 69 | pCore :: Parser Program 70 | pCore = do 71 | whiteSpace 72 | declarations <- pDeclaration `sepEndBy1` semi 73 | eof 74 | return declarations 75 | 76 | -- Declaration -> Data | Combinator 77 | pDeclaration :: Parser Declaration 78 | pDeclaration = pData <|> pCombinator "data type or supercombinator" 79 | 80 | -- Data -> data name TyVar* = Constructor [| Constructor]*; 81 | pData :: Parser Declaration 82 | pData = do 83 | reserved "data" 84 | name <- uppercased 85 | vars <- many identifier 86 | reservedOp "=" 87 | constructors <- pConstructor `sepBy1` reservedOp "|" 88 | return (Data name vars constructors) 89 | 90 | -- Constructor -> name Type* 91 | pConstructor :: Parser Constructor 92 | pConstructor = Constructor <$> uppercased <*> many pType 93 | 94 | -- Type -> TyCon | TyVar | (TyApp) 95 | pType :: Parser Type 96 | pType = 97 | (flip TCon [] <$> uppercased) <|> (TVar <$> identifier) <|> parens pTypeApp 98 | "type variable or type constructor" 99 | 100 | -- TypeApp -> TyCon Type* 101 | pTypeApp :: Parser Type 102 | pTypeApp = TCon <$> uppercased <*> many pType 103 | 104 | -- Combinator -> var [ args]* = Expr; 105 | pCombinator :: Parser Declaration 106 | pCombinator = do 107 | name <- identifier 108 | args <- many identifier 109 | reservedOp "=" 110 | expr <- pExpr 111 | return (Combinator name args expr) 112 | 113 | -- Atom -> Let | BinOp | Case | Lambda 114 | pExpr :: Parser Expr 115 | pExpr = pLet <|> pBinOp <|> pCase <|> pLambda "expression" 116 | 117 | -- Let -> (let | letrec) Bindings in Expr 118 | pLet :: Parser Expr 119 | pLet = Let 120 | <$> (False <$ reserved "let" <|> True <$ reserved "letrec") 121 | <*> braces (pBinding `sepEndBy1` semi) 122 | <*> (reserved "in" *> pExpr) 123 | 124 | -- Binding -> var = Expr 125 | pBinding :: Parser (Name, Expr) 126 | pBinding = (,) 127 | <$> identifier 128 | <*> (reservedOp "=" *> pExpr) 129 | 130 | -- Case -> case Expr of { Alt;+ } 131 | pCase :: Parser Expr 132 | pCase = Case 133 | <$> (reserved "case" *> pExpr) 134 | <*> (reserved "of" *> braces (pAlt `sepEndBy1` semi)) 135 | 136 | -- Alt -> Constructor -> Expr 137 | --pAlt = do (name, components) <- pConstructor 138 | pAlt :: Parser Alt 139 | pAlt = (,,) 140 | <$> (PCon <$> uppercased) 141 | <*> many identifier 142 | <*> (reservedOp "->" *> pExpr) 143 | 144 | -- Lambda -> \var+ -> Expr 145 | pLambda :: Parser Expr 146 | pLambda = Lambda 147 | <$> (reservedOp "\\" *> many1 identifier) 148 | <*> (reservedOp "->" *> pExpr) 149 | 150 | -- Precedence/associativity for binary operators 151 | pBinOp :: Parser Expr 152 | pBinOp = buildExpressionParser binOpTable pApp 153 | where 154 | parseOp op = reservedOp op >> return (BinOp op) 155 | binOpTable = 156 | [ [ Infix (parseOp ".") AssocRight ] 157 | , [ Infix (parseOp "*") AssocLeft 158 | , Infix (parseOp "/") AssocLeft 159 | ] 160 | , [ Infix (parseOp "+") AssocLeft 161 | , Infix (parseOp "-") AssocLeft 162 | ] 163 | , [ Infix (parseOp "<") AssocNone 164 | , Infix (parseOp ">") AssocNone 165 | , Infix (parseOp "<=") AssocNone 166 | , Infix (parseOp ">=") AssocNone 167 | , Infix (parseOp "==") AssocNone 168 | , Infix (parseOp "/=") AssocNone 169 | ] 170 | , [ Infix (parseOp "&&") AssocLeft ] 171 | , [ Infix (parseOp "||") AssocLeft ] 172 | , [ Infix (parseOp "$") AssocRight ] 173 | ] 174 | 175 | -- Application -> Atom [Atom]* 176 | pApp :: Parser Expr 177 | pApp = makeSpine <$> many1 pAtom 178 | where 179 | makeSpine (x:xs) = foldl' App x xs 180 | 181 | -- Atom -> Constructor | var | num | ( Expr ) 182 | pAtom :: Parser Expr 183 | pAtom = 184 | (Var <$> uppercased) <|> (Var <$> identifier) <|> (Num . fromInteger <$> natural) <|> parens pExpr 185 | "constructor, identifier, number, or parenthesized expression" 186 | 187 | -------------------------------------------------------------------------------- /src/MiniCore/Template.hs: -------------------------------------------------------------------------------- 1 | module Template where 2 | 3 | -- (size, free list, environment) 4 | import Heap 5 | import Expr 6 | import Parse (parseCore) 7 | 8 | import Data.List 9 | import Text.PrettyPrint 10 | import Debug.Trace 11 | 12 | -- List of Nodes to print once execution halts 13 | type Output = [Node] 14 | 15 | -- Stack of pointers to nodes in the spine 16 | -- of the current expression 17 | type Stack = [Addr] 18 | 19 | -- Pointers to supercombinators and primitives 20 | type Globals = [(Name, Addr)] 21 | 22 | -- Stack of stacks 23 | type Dump = [Stack] 24 | initialDump = [] 25 | 26 | -- Count number of steps taken 27 | type Steps = Int 28 | 29 | -- Heap data 30 | data Node = NApp Addr Addr -- Application 31 | | NCombinator Name [Name] Expr -- Supercombinator 32 | | NNum Int -- Number 33 | | NPointer Addr -- Point to another node 34 | | NPrim Name Primitive -- Primitive operation 35 | | NData Int [Addr] -- Tag, components 36 | deriving Show 37 | 38 | -- Primitive (strict) operations 39 | data Primitive = Negate 40 | | Add 41 | | Subtract 42 | | Multiply 43 | | Divide 44 | | If 45 | | Greater 46 | | GreaterEq 47 | | Lesser 48 | | LesserEq 49 | | Eq 50 | | NotEq 51 | | Construct Int Int 52 | | CasePair 53 | | CaseList 54 | | Abort 55 | | Halt 56 | | Print 57 | deriving Show 58 | 59 | -- Count node types in heap 60 | data Usage = Usage { 61 | numCount :: Int, 62 | appCount :: Int, 63 | dataCount :: Int, 64 | pointerCount :: Int, 65 | primitiveCount :: Int, 66 | combinatorCount :: Int 67 | } 68 | 69 | -- state = (o, s, d, h, f) 70 | type TIState = (Output, Stack, Dump, Heap Node, Globals, Steps) 71 | 72 | {- 73 | Transitions from (s, d, h, f) -> (s', d', h', f'): 74 | 75 | 0. Dereference pointer arguments before unwinding 76 | (a : s, d, h[(a, NApp a1 a2), (a2, NPointer a3)], f) 77 | -> (a : s, d, h[(a, NApp a1 a3)], f) 78 | 79 | 1. Unwind a single application node onto the stack: 80 | (a : s, d, h[(a, NApp a1 a2)], f) 81 | -> (a1 : a: s, d, h, f) 82 | 83 | 2. Perform supercombinator reduction updating the root of the redex: 84 | (a0: a1 : ... : an : s, d, h [(a0, NCombinator [x1, ..., xn] body)], f) 85 | -> (ar : s, d, h'[(an, NPointer ar)], f) 86 | where (h', ar) = instantiate h f[x -> a1, ..., xn -> an] body 87 | 88 | 3. Handle indirection on the stack 89 | (a : s, d, h[(a, NPointer a1)], f) 90 | -> (a1 : s, d, h, f) 91 | 92 | 4. Handle structured data 93 | (a : a1 : ... : an : [], d, h[(a, NPrim (Construct t n)), (a1, NApp a b1) ... (an: NApp an-1, bn)], f) 94 | -> (an : [], d, h[(an, NData t [b1..bn])], f) 95 | 96 | 5. Handle unary arithmetic 97 | 98 | Already evaluated numeric argument 99 | (a : a1 : [], d, h[(a, NPrim Negate) : (a1, NApp a b) : (b, NNum n)], f) 100 | -> (a1 : [], d, h[(a1, NNum (-n))], f) 101 | 102 | Save stack above un-evaluated argument in dump and... 103 | (a : a1 : [], d, h[(a, NPrim Negate) : (a1, NApp a b)], f) 104 | -> (b : [], (a1 : []) : d, h, f) 105 | 106 | ...Evaluate argument and restore stack 107 | (a : [], s : d, h[(a, NNum n)], f) 108 | -> (s, d, h, f) 109 | 110 | 6. Handle binary arithmetic 111 | 112 | Already evaluated numeric arguments 113 | (a : b : c : [], d, h[(a, NPrim Add), (b, NApp a d), (c, NApp b e), (d, NNum n), (e, NNum m)], f) 114 | -> (c : [], d, h[(c, NNum (n + m))], f) 115 | 116 | For _ + App, save stack above un-evaluated argument in dump and... 117 | (a : b : c : [], d, h[(a, NPrim Add), (b, NApp a d), (c, NApp b e), (d, NNum n), (e, NApp 1 2)], f) 118 | -> (c : [], (b : []) : d, h, f) 119 | 120 | ...Evaluate argument and restore stack 121 | (c : [], s : d, h[(c, NNum n)], f) 122 | -> (s, d, h, f) 123 | 124 | Then, for App + Num, save stack above un-evaluated numeric argument and... 125 | (a : b : c : [], d, h[(a, NPrim Add), (b, NApp a d), (c, NApp b e), (d, NNum 23), (e, NApp 1 2)], f) 126 | -> (b : c : [], (a : []) : d, h, f) 127 | 128 | ...Evaluate argument and restore stack 129 | (b : c : [], s : d, h[(b, NNum n)], f) 130 | -> (s, d, h, f) 131 | 132 | 7. Handle if-expression 133 | If condition is True (NData 2 []), choose the first branch 134 | (w : x : y : z : [], d, h[(w, NPrim If), (x, NData 2 []), (y, NApp x j), (z, NApp y k)], f) 135 | -> (z : [], d, h[(z, NPointer j)], f) 136 | 137 | If condition is False (NData 2 []), choose the second branch 138 | (w : x : y : z : [], d, h[(w, NPrim If), (x, NData 1 []), (y, NApp x j), (z, NApp y k)], f) 139 | -> (z : [], d, h[(z, NPointer k)], f) 140 | 141 | For unevaluated condition, save stack above un-evaluated argument in dump... 142 | (w : x : y : z : [], d, h[(w, NPrim If), (x, NApp w i), (y, NApp x j), (z, NApp y k)], f) 143 | -> (x : y : z : [], (w : []) : d, h, f) 144 | 145 | ...Evaluate argument and restore stack 146 | (x : y : z : [], s : d, h[(x, NData _ [])], f) 147 | -> (s, d, h, f) 148 | 149 | -} 150 | 151 | -- Extra definitions to add to initial global environment 152 | extraDefs = [ 153 | ("and", ["x", "y"], App (App (App (Var "if") (Var "x")) (Var "y")) (Var "False")), 154 | ("or", ["x", "y"], App (App (App (Var "if") (Var "x")) (Var "True")) (Var "y")), 155 | ("not", ["x"], App (App (App (Var "if") (Var "x")) (Var "False")) (Var "True")), 156 | ("fst", ["p"], App (App (Var "casePair") (Var "p")) (Var "K")), 157 | ("snd", ["p"], App (App (Var "casePair") (Var "p")) (Var "K1")), 158 | ("head", ["ls"], App (App (App (Var "caseList") (Var "ls")) (Var "abort")) (Var "K")), 159 | ("tail", ["ls"], App (App (App (Var "caseList") (Var "ls")) (Var "abort")) (Var "K1"))] 160 | 161 | -- Generate initial state from AST 162 | compile :: Program -> TIState 163 | compile program = (output, stack, dump, heap, globals, steps) 164 | where 165 | defs = program ++ prelude ++ extraDefs 166 | (heap, globals) = buildInitialHeap defs 167 | output = [] 168 | stack = [mainAddr] 169 | steps = 0 170 | dump = initialDump 171 | mainAddr = case lookup "main" globals of 172 | Just addr -> addr 173 | Nothing -> error "main is not defined" 174 | 175 | -- Primitive data constructors 176 | tiFalse = Construct 1 0 177 | tiTrue = Construct 2 0 178 | tiCons = Construct 3 2 179 | tiNil = Construct 4 0 180 | tiPair = Construct 5 2 181 | 182 | -- Map var names to primitives 183 | primitives = [ 184 | ("negate", Negate), 185 | ("+", Add), 186 | ("-", Subtract), 187 | ("*", Multiply), 188 | ("/", Divide), 189 | ("<", Lesser), 190 | (">", Greater), 191 | ("<=", LesserEq), 192 | (">=", GreaterEq), 193 | ("==", Eq), 194 | ("/=", NotEq), 195 | ("if", If), 196 | ("casePair", CasePair), 197 | ("caseList", CaseList), 198 | ("abort", Abort), 199 | ("halt", Halt), 200 | ("print", Print), 201 | ("False", tiFalse), 202 | ("True", tiTrue), 203 | ("Cons", tiCons), 204 | ("Nil", tiNil), 205 | ("Pair", tiPair)] 206 | 207 | -- Build initial heap from list of supercombinators 208 | buildInitialHeap :: [Combinator] -> (Heap Node, Globals) 209 | buildInitialHeap combinators = (heap'', caddrs ++ paddrs) 210 | where 211 | (heap', caddrs) = mapAccumL allocCombinator hInit combinators 212 | (heap'', paddrs) = mapAccumL allocPrimitive heap' primitives 213 | 214 | -- Allocate a single combinator 215 | allocCombinator :: Heap Node -> Combinator -> (Heap Node, (Name, Addr)) 216 | allocCombinator heap (name, args, body) = (heap', (name, addr)) 217 | where 218 | (heap', addr) = hAlloc heap (NCombinator name args body) 219 | 220 | -- Allocate a single primitive 221 | allocPrimitive :: Heap Node -> (Name, Primitive) -> (Heap Node, (Name, Addr)) 222 | allocPrimitive heap (name, primitive) = (heap', (name, addr)) 223 | where 224 | (heap', addr) = hAlloc heap (NPrim name primitive) 225 | 226 | -- Increment number of steps in reduction 227 | incSteps :: TIState -> TIState 228 | incSteps (output, stack, dump, heap, globals, steps) = 229 | (output, stack, dump, heap, globals, steps + 1) 230 | 231 | -- Transition from one state to the next keeping track of all 232 | -- previous states 233 | eval :: TIState -> [TIState] 234 | eval state = state:rest 235 | where 236 | next = step (incSteps state) 237 | rest | isFinal state = [] 238 | | otherwise = eval next 239 | 240 | -- Should reduction halt? 241 | isFinal :: TIState -> Bool 242 | isFinal (_, [addr], [], heap, _, _) = isData value || isNum value 243 | where 244 | value = hLoad heap addr 245 | isFinal (_, [], _, _, _, _) = True 246 | isFinal _ = False 247 | 248 | -- Is current Node data? 249 | isData :: Node -> Bool 250 | isData (NData _ _) = True 251 | isData _ = False 252 | 253 | -- Is current Node a number? 254 | isNum :: Node -> Bool 255 | isNum (NNum _) = True 256 | isNum _ = False 257 | 258 | -- Is Node a representation of True? 259 | isTrue (NData 2 []) = True 260 | isTrue _ = False 261 | 262 | -- Is Node a representation of False? 263 | isFalse (NData 1 []) = True 264 | isFalse _ = False 265 | 266 | -- Is Node a Pair? 267 | isPair (NData 5 [_, _]) = True 268 | isPair _ = False 269 | 270 | -- Is Node a list? 271 | isList (NData 3 [_, _]) = True 272 | isList (NData 4 []) = True 273 | isList _ = False 274 | 275 | -- Is Node a Cons cell? 276 | isCons (NData 3 [_, _]) = True 277 | isCons _ = False 278 | 279 | -- Is Node Nil? 280 | isNil (NData 4 [_, _]) = True 281 | isNil _ = False 282 | 283 | -- Apply a function to the components of a pair 284 | pairApply heap (NData 5 [x, y]) f = (heap'', app) 285 | where 286 | (heap', addr) = hAlloc heap (NApp f x) 287 | (heap'', addr') = hAlloc heap' (NApp addr y) 288 | app = hLoad heap'' addr' 289 | pairApply _ _ _ = error "Function expects a pair" 290 | 291 | -- If list is nil, return (heap, nil-value). Otherwise, return 292 | -- (heap', f head tail). 293 | listApply heap (NData 3 [x, xs]) _ f = (heap'', app) 294 | where 295 | (heap', addr) = hAlloc heap (NApp f x) 296 | (heap'', addr') = hAlloc heap' (NApp addr xs) 297 | app = hLoad heap'' addr' 298 | listApply heap (NData 4 []) f _ = (heap, hLoad heap f) 299 | listApply _ _ _ _ = error "Function expects a list" 300 | 301 | -- Perform a single reduction from one state to the next 302 | step :: TIState -> TIState 303 | step state = dispatch (hLoad heap top) 304 | where 305 | (output, stack@(top:rest), dump, heap, globals, steps) = state 306 | 307 | -- If number is on top, we must have deferred some 308 | -- primitive computation. Move it from the dump to the stack 309 | dispatch (NNum _) = case dump of 310 | d:ds -> (output, d ++ rest, ds, heap, globals, steps) 311 | _ -> error "Can't apply number as function" 312 | 313 | -- If a data node is on top, we must have deferred some 314 | -- primitive computation. Move it from the dump to the stack 315 | dispatch (NData _ _) = case dump of 316 | d:ds -> (output, d ++ rest, ds, heap, globals, steps) 317 | _ -> error "Can't apply data node as function" 318 | 319 | -- Unwind spine onto stack, removing indirections from the 320 | -- argument if present. 321 | dispatch (NApp a1 a2) = case hLoad heap a2 of 322 | NPointer a3 -> (output, a1:stack, dump, hUpdate heap top (NApp a1 a3), globals, steps) 323 | _ -> (output, a1:stack, dump, heap, globals, steps) 324 | 325 | -- Dereference pointer and update with value on stack 326 | dispatch (NPointer a) = (output, a:rest, dump, heap, globals, steps) 327 | 328 | -- Apply combinator 329 | dispatch (NCombinator name args body) = (output, stack', dump, heap', globals, steps) 330 | where 331 | -- Bind arguments 332 | env = bindings ++ globals 333 | bindings = zip args (getArgs heap stack) 334 | 335 | -- Update root of redex to point to result 336 | root = stack !! (expect - 1) 337 | heap' = instantiateAndUpdate heap env body root 338 | 339 | -- Update stack 340 | expect = length args + 1 341 | stack' | expect > length stack = error ("Not enough arguments for supercombinator " ++ name) 342 | | otherwise = root:drop expect stack 343 | 344 | -- Apply primitive 345 | dispatch (NPrim name primitive) = case primitive of 346 | -- Unary arithmetic 347 | Negate -> primUnary (fromUnary negate) state 348 | 349 | -- Binary arithmetic 350 | Add -> primBinary (fromBinary (+)) state 351 | Subtract -> primBinary (fromBinary (-)) state 352 | Multiply -> primBinary (fromBinary (*)) state 353 | Divide -> primBinary (fromBinary div) state 354 | 355 | -- Binary relational 356 | Lesser -> primBinary (fromRelational (<)) state 357 | Greater -> primBinary (fromRelational (>)) state 358 | LesserEq -> primBinary (fromRelational (<=)) state 359 | GreaterEq -> primBinary (fromRelational (>=)) state 360 | Eq -> primBinary (fromRelational (==)) state 361 | NotEq -> primBinary (fromRelational (/=)) state 362 | 363 | -- Structured data 364 | Construct tag arity -> primConstruct tag arity state 365 | CasePair -> primCasePair state 366 | CaseList -> primCaseList state 367 | 368 | -- If expression 369 | If -> primIf state 370 | 371 | -- Printing 372 | Print -> primPrint state 373 | 374 | -- Early exit 375 | Halt -> (output, [], dump, heap, globals, steps) 376 | Abort -> error "Execution halted with abort" 377 | 378 | -- Convert a unary arithmetic function into a function on nodes 379 | fromUnary :: (Int -> Int) -> (Node -> Node) 380 | fromUnary f (NNum x) = NNum $ f x 381 | fromUnary _ _ = error "Expected numeric argument" 382 | 383 | -- Convert a binary arithmetic function into a function on nodes 384 | fromBinary :: (Int -> Int -> Int) -> (Node -> Node -> Node) 385 | fromBinary f (NNum x) (NNum y) = NNum $ f x y 386 | fromBinary _ _ _ = error "Expected numeric argument(s)" 387 | 388 | -- Convert a binary relational function into a function on nodes 389 | fromRelational :: (Int -> Int -> Bool) -> (Node -> Node -> Node) 390 | fromRelational pred (NNum x) (NNum y) 391 | | pred x y = NData 2 [] 392 | | otherwise = NData 1 [] 393 | fromRelational _ _ _ = error "Expected numeric argument(s)" 394 | 395 | -- Either apply unary primitive or set up evaluation of 396 | -- argument to unary primitive 397 | primUnary :: (Node -> Node) -> TIState -> TIState 398 | primUnary f (output, (_:root:stack), dump, heap, globals, steps) = state' 399 | where 400 | addr = getArg heap root 401 | arg = hLoad heap addr 402 | state' | isNum arg = (output, root:stack, dump, hUpdate heap root (f arg), globals, steps) 403 | | isData arg = error "Expected numeric argument to unary operator" 404 | | otherwise = (output, addr:stack, [root]:dump, heap, globals, steps) 405 | primUnary _ _ = error "Malformed unary primitive expression" 406 | 407 | -- Either apply binary primitive or set up evaluation of 408 | -- arguments to binary primitive 409 | primBinary :: (Node -> Node -> Node) -> TIState -> TIState 410 | primBinary f (output, (_:xRoot:yRoot:stack), dump, heap, globals, steps) = state' 411 | where 412 | (xAddr, yAddr) = (getArg heap xRoot, getArg heap yRoot) 413 | (x, y) = (hLoad heap xAddr, hLoad heap yAddr) 414 | state' 415 | | isNum x && isNum y = (output, yRoot:stack, dump, hUpdate heap yRoot (f x y), globals, steps) 416 | | isNum y && not (isData x) = (output, xAddr:yRoot:stack, [xRoot]:dump, heap, globals, steps) 417 | | isData y || isData x = error "Expected numeric arguments to binary operator" 418 | | otherwise = (output, yAddr:stack, [yRoot]:dump, heap, globals, steps) 419 | primBinary _ _ = error "Malformed binary primitive expression" 420 | 421 | -- If condition is evaluated, use it to choose the correct branch. 422 | -- Otherwise, put application on dump and evaluate condition. 423 | primIf (output, (_:c:x:y:stack), dump, heap, globals, steps) = state' 424 | where 425 | (cAddr, xAddr, yAddr) = (getArg heap c, getArg heap x, getArg heap y) 426 | cond = hLoad heap cAddr 427 | state' 428 | | isTrue cond = (output, y:stack, dump, hUpdate heap y (NPointer xAddr), globals, steps) 429 | | isFalse cond = (output, y:stack, dump, hUpdate heap y (NPointer yAddr), globals, steps) 430 | | isData cond = error "Expected a Boolean condition for if" 431 | | otherwise = (output, cAddr:x:y:stack, [c]:dump, heap, globals, steps) 432 | primIf _ = error "Malformed if-expression" 433 | 434 | -- If pair is evaluated, apply function to it. Otherwise, put application on 435 | -- dump and evaluate pair. 436 | primCasePair (output, (_:p:f:stack), dump, heap, globals, steps) = state' 437 | where 438 | (pAddr, fAddr) = (getArg heap p, getArg heap f) 439 | pair = hLoad heap pAddr 440 | (heap', app) = pairApply heap pair fAddr 441 | state' 442 | | isPair pair = (output, f:stack, dump, hUpdate heap' f app, globals, steps) 443 | | isData pair = error "Expected a pair as argument to casePair" 444 | | otherwise = (output, pAddr:f:stack, [p]:dump, heap, globals, steps) 445 | primCasePair _ = error "Malformed casePair-expression" 446 | 447 | -- If list is evaluated, check if nil and apply appropriate function to it. 448 | -- Otherwise, put application on dump and evaluate list. 449 | primCaseList (output, (_:l:n:c:stack), dump, heap, globals, steps) = state' 450 | where 451 | (lAddr, nAddr, cAddr) = (getArg heap l, getArg heap n, getArg heap c) 452 | list = hLoad heap lAddr 453 | (heap', app) = listApply heap list nAddr cAddr 454 | state' 455 | | isList list = (output, c:stack, dump, hUpdate heap' c app, globals, steps) 456 | | isData list = error "Expected a list as argument to caseList" 457 | | otherwise = (output, lAddr:n:c:stack, [l]:dump, heap, globals, steps) 458 | primCaseList _ = error "Malformed caseList-expression" 459 | 460 | -- If argument is evaluated, put it on the output stack. 461 | -- Otherwise, put application on dump and evaluate argument. 462 | primPrint (output, (_:v:n:stack), dump, heap, globals, steps) = state' 463 | where 464 | (vAddr, nAddr) = (getArg heap v, getArg heap n) 465 | value = hLoad heap vAddr 466 | state' 467 | | isNum value = (value:output, nAddr:stack, dump, heap, globals, steps) 468 | | isData value = error "Expected a numeric argument to print" 469 | | otherwise = (output, vAddr:n:stack, [v]:dump, heap, globals, steps) 470 | primPrint _ = error "Malformed print-expression" 471 | 472 | -- Generate a new data node 473 | primConstruct :: Int -> Int -> TIState -> TIState 474 | primConstruct tag arity state = (output, stack', dump, heap', globals, steps) 475 | where 476 | (output, stack, dump, heap, globals, steps) = state 477 | expect = arity + 1 478 | root = stack !! (expect - 1) 479 | args = take arity $ getArgs heap stack 480 | heap' = hUpdate heap root (NData tag args) 481 | stack' 482 | | expect > length stack = error ("Not enough arguments for constructor") 483 | | otherwise = root:drop expect stack 484 | 485 | -- Load arguments from heap 486 | getArgs :: Heap Node -> Stack -> [Addr] 487 | getArgs heap (combinator:stack) = map (getArg heap) stack 488 | 489 | -- Load a single argument from heap 490 | getArg :: Heap Node -> Addr -> Addr 491 | getArg heap addr = case hLoad heap addr of 492 | (NApp fun arg) -> arg 493 | _ -> error "Missing argument" 494 | 495 | -- Create heap node from expression and update redex root address 496 | -- to point to result 497 | instantiateAndUpdate :: Heap Node -> [(Name, Addr)] -> Expr -> Addr -> Heap Node 498 | instantiateAndUpdate heap env expr addr = build expr 499 | where 500 | -- Build number on heap 501 | build (Num n) = hUpdate heap addr (NNum n) 502 | 503 | -- Look up variable in environment 504 | build (Var v) = case lookup v env of 505 | Just value -> hUpdate heap addr (NPointer value) 506 | Nothing -> error ("Undefined name " ++ v) 507 | 508 | -- Instantiate function and argument and build application 509 | build (App e1 e2) = 510 | let (heap', a1) = instantiate heap env e1 511 | (heap'', a2) = instantiate heap' env e2 512 | in hUpdate heap'' addr (NApp a1 a2) 513 | 514 | -- Instantiate each expression, add each binding to environment, and then 515 | -- instantiate body 516 | build (Let recursive bindings body) = 517 | let (heap', letEnv') = addBindings bindings heap letEnv 518 | letEnv | recursive = env' -- letrec, bindings can refer to each other 519 | | otherwise = env -- let, bindings can refer to current environment 520 | env' = letEnv' ++ env 521 | (heap'', addr') = instantiate heap' env' body 522 | in hUpdate heap'' addr (NPointer addr') 523 | 524 | -- Convert data constructor to node 525 | build (Cons tag arity) = hUpdate heap addr (NPrim "Pack" (Construct tag arity)) 526 | 527 | -- Not supported yet 528 | build (Case _ _) = error "Can't instantiate case expressions yet" 529 | 530 | -- Create heap node from expression 531 | instantiate :: Heap Node -> [(Name, Addr)] -> Expr -> (Heap Node, Addr) 532 | instantiate heap env expr = build expr 533 | where 534 | -- Build number on heap 535 | build (Num n) = hAlloc heap (NNum n) 536 | 537 | -- Look up variable in environment 538 | build (Var v) = case lookup v env of 539 | Just value -> (heap, value) 540 | Nothing -> error ("Undefined name " ++ v) 541 | 542 | -- Instantiate function and argument and build application 543 | build (App e1 e2) = 544 | let (heap', a1) = instantiate heap env e1 545 | (heap'', a2) = instantiate heap' env e2 546 | in hAlloc heap'' (NApp a1 a2) 547 | 548 | -- Instantiate each expression, add each binding to environment, and then 549 | -- instantiate body 550 | build (Let recursive bindings body) = 551 | let (heap', letEnv') = addBindings bindings heap letEnv 552 | letEnv | recursive = env' -- letrec, bindings can refer to each other 553 | | otherwise = env -- let, bindings can refer to current environment 554 | env' = letEnv' ++ env 555 | in instantiate heap' env' body 556 | 557 | -- Convert data constructor to node 558 | build (Cons tag arity) = hAlloc heap (NPrim "Pack" (Construct tag arity)) 559 | 560 | -- Not supported yet 561 | build (Case _ _) = error "Can't instantiate case expressions yet" 562 | 563 | -- Add let bindings to new heap and environment 564 | addBindings :: [(Name, Expr)] -> Heap Node -> [(Name, Addr)] -> (Heap Node, [(Name, Addr)]) 565 | addBindings bindings heap env = foldr addBinding (heap, []) bindings 566 | where 567 | addBinding (name, expr) (heap', env') = 568 | let (heap'', addr) = instantiate heap' env expr 569 | in (heap'', (name, addr):env') 570 | 571 | -- Parse, compile, reduce program, and print states 572 | debug :: String -> String 573 | debug = show . format . eval . compile . parseCore 574 | where 575 | format states = formatStates states $$ formatOutput states 576 | 577 | -- Parse, compile, reduce program, and print output 578 | run :: String -> String 579 | run = show . formatOutput . eval . compile . parseCore 580 | 581 | -- Format elements of output stack 582 | formatOutput :: [TIState] -> Doc 583 | formatOutput states = vcat $ map formatInteger $ reverse output 584 | where 585 | (output, _, _, _, _, _) = last states 586 | formatInteger (NNum n) = int n 587 | formatInteger node = error $ "Attempted to print " ++ (show $ formatNode node) 588 | 589 | -- Format all computation states 590 | formatStates :: [TIState] -> Doc 591 | formatStates = vcat . map formatState . zip [1..] 592 | 593 | -- Format a single computation state 594 | formatState :: (Int, TIState) -> Doc 595 | formatState (num, (output, stack, _, heap, _, _)) = 596 | text "State" <+> int num <> colon $$ 597 | (nest 4 $ formatStack heap stack $$ formatHeap heap stack) 598 | 599 | -- Format the stack as a tree of applications 600 | formatStack :: Heap Node -> Stack -> Doc 601 | formatStack heap (x:xs) = text "Stack" <> colon $$ nest 4 (foldr draw (formatHeapNode heap x) (reverse xs)) 602 | where 603 | draw addr doc = text "@" <> nest 1 (text "---" <+> formatValue addr $$ text "\\" $$ nest 1 doc) 604 | formatTop addr = formatAddr addr <+> formatNode (hLoad heap addr) 605 | formatValue addr = case hLoad heap addr of 606 | NApp a1 a2 -> formatHeapNode heap a2 607 | node -> formatAddr addr <> colon <+> formatNode node 608 | formatStack heap [] = text "Stack: empty" 609 | 610 | -- Format the heap as number of Allocations 611 | formatHeap :: Heap Node -> Stack -> Doc 612 | formatHeap (size, _, env) _ = text "Heap" <> colon $$ nest 4 (formatUsage size (calculateUsage env)) 613 | 614 | calculateUsage :: [(Addr, Node)] -> Usage 615 | calculateUsage env = foldr count (Usage 0 0 0 0 0 0) (map snd env) 616 | where 617 | count (NNum _) usage = usage {numCount = numCount usage + 1} 618 | count (NApp _ _) usage = usage {appCount = appCount usage + 1} 619 | count (NData _ _) usage = usage {dataCount = dataCount usage + 1} 620 | count (NPointer _) usage = usage {pointerCount = pointerCount usage + 1} 621 | count (NPrim _ _) usage = usage {primitiveCount = primitiveCount usage + 1} 622 | count (NCombinator _ _ _) usage = usage {combinatorCount = combinatorCount usage + 1} 623 | 624 | formatUsage :: Int -> Usage -> Doc 625 | formatUsage total usage = vcat [ 626 | text "Numbers" <> colon <+> int (numCount usage), 627 | text "Applications" <> colon <+> int (appCount usage), 628 | text "Data" <> colon <+> int (dataCount usage), 629 | text "Pointers" <> colon <+> int (pointerCount usage), 630 | text "Primitives" <> colon <+> int (primitiveCount usage), 631 | text "Combinators" <> colon <+> int (combinatorCount usage), 632 | text "Total" <> colon <+> int total] 633 | 634 | -- Load a value from the heap. Format its address and value. 635 | formatHeapNode :: Heap Node -> Addr -> Doc 636 | formatHeapNode heap addr = formatAddr addr <> colon <+> formatNode (hLoad heap addr) 637 | 638 | -- Format a heap node 639 | formatNode :: Node -> Doc 640 | formatNode (NApp a1 a2) = text "NApp" <+> formatAddr a1 <+> formatAddr a2 641 | formatNode (NCombinator name args body) = text "NCombinator" <+> text name 642 | formatNode (NNum n) = text "NNum" <+> int n 643 | formatNode (NPointer a) = text "NPointer" <+> formatAddr a 644 | formatNode (NPrim name prim) = text "NPrim" <+> text name 645 | formatNode (NData tag addrs) = text "NData" <+> int tag <+> brackets (sep $ map formatAddr addrs) 646 | 647 | -- Format an address 648 | formatAddr :: Addr -> Doc 649 | formatAddr addr = text "#" <> int addr 650 | 651 | -------------------------------------------------------------------------------- /src/MiniCore/Transforms.hs: -------------------------------------------------------------------------------- 1 | module MiniCore.Transforms 2 | ( transform 3 | ) where 4 | 5 | import MiniCore.Types 6 | import MiniCore.Transforms.Constructors 7 | import MiniCore.Transforms.Lambdas 8 | import MiniCore.Transforms.BinOps 9 | 10 | -- Program to Program transformations 11 | -- Returns list of constructor names for printing 12 | -- and simplified program 13 | transform :: Program -> Stage ([Name], Program) 14 | transform program = do 15 | noBinOps <- removeBinOps program 16 | (cons, noCons) <- transformConstructors noBinOps 17 | noLambdas <- liftLambdas noCons 18 | return (cons, noLambdas) 19 | 20 | -------------------------------------------------------------------------------- /src/MiniCore/Transforms/BinOps.hs: -------------------------------------------------------------------------------- 1 | module MiniCore.Transforms.BinOps 2 | ( removeBinOps 3 | ) where 4 | 5 | import MiniCore.Types 6 | 7 | -- Build equivalent program that has no BinOp constructors 8 | -- They're only useful for pretty-printing 9 | removeBinOps :: Program -> Stage Program 10 | removeBinOps = return . map walkDecl 11 | where 12 | walkDecl (Combinator name args body) = Combinator name args (walk body) 13 | walkDecl decl = decl 14 | 15 | -- Replace all BinOps with equivalent Apps in expressions 16 | walk :: Expr -> Expr 17 | walk (BinOp op e1 e2) = 18 | App (App (Var op) (walk e1)) (walk e2) 19 | 20 | walk (App e1 e2) = 21 | App (walk e1) (walk e2) 22 | 23 | walk (Let rec bindings body) = 24 | Let rec (walkBindings bindings) (walk body) 25 | 26 | walk (Case body alts) = 27 | Case (walk body) (walkAlts alts) 28 | 29 | walk (Lambda args body) = 30 | Lambda args (walk body) 31 | 32 | walk expr = expr 33 | 34 | walkBindings :: [(Name, Expr)] -> [(Name, Expr)] 35 | walkBindings bindings = zip names exprs' 36 | where 37 | (names, exprs) = unzip bindings 38 | exprs' = map walk exprs 39 | 40 | walkAlts :: [Alt] -> [Alt] 41 | walkAlts alts = map walkAlt alts 42 | where 43 | walkAlt (PCon constructor, args, expr) = (PCon constructor, args, walk expr) 44 | 45 | -------------------------------------------------------------------------------- /src/MiniCore/Transforms/Constructors.hs: -------------------------------------------------------------------------------- 1 | module MiniCore.Transforms.Constructors 2 | ( transformConstructors 3 | ) where 4 | 5 | import MiniCore.Types 6 | 7 | import Data.List 8 | import Data.Function 9 | import qualified Data.Map as Map 10 | import Control.Monad.State 11 | import Control.Monad.Except 12 | import Control.Applicative 13 | 14 | -- Maintain mapping of constructors to arity and tag 15 | -- and allow errors to propagate 16 | type Gen a = StateT ConstructorState Stage a 17 | 18 | -- Generate constructor combinators and use tags in case-expressions 19 | transformConstructors :: Program -> Stage ([Name], Program) 20 | transformConstructors program = do 21 | (program', state) <- runStateT run initialEnv 22 | return (toCons (cEnv state), program') 23 | where 24 | run = replaceDataDecls program >>= convertCases 25 | 26 | -- Strip out Data declarations and convert their constructors into super-combinators 27 | -- Return new program and mapping from Constructor names to tags 28 | replaceDataDecls :: Program -> Gen Program 29 | replaceDataDecls program = do 30 | let (dataDecls, combinators) = partition isData program 31 | constructors = concatMap getConstructors dataDecls 32 | combinators' <- mapM newCombinator constructors 33 | return (combinators' ++ combinators) 34 | 35 | -- After all the Data declarations have been converted, use the ConstructorEnv 36 | -- to convert case expressions from constructors to tags 37 | convertCases :: Program -> Gen Program 38 | convertCases = mapM convert 39 | where 40 | convert (Combinator name args body) = Combinator name args <$> convertExpr body 41 | 42 | -- Grab all constructors out of a single Data declaration 43 | getConstructors :: Declaration -> [Constructor] 44 | getConstructors (Data _ _ constructors) = constructors 45 | getConstructors _ = [] -- Shouldn't happen 46 | 47 | -- Map constructor names to (tag, arity) 48 | type ConstructorEnv = Map.Map Name (Int, Int) 49 | type ConstructorTag = Int 50 | 51 | -- Get constructors in tag order 52 | toCons :: ConstructorEnv -> [Name] 53 | toCons = map fst . sortBy (compare `on` snd) . Map.toList 54 | 55 | -- Map constructor names to (tag, arity). Increment the tag when 56 | -- adding a new constructor. 57 | data ConstructorState = ConstructorState 58 | { cTag :: ConstructorTag 59 | , cEnv :: ConstructorEnv 60 | } deriving Show 61 | 62 | -- The default constructor _ has tag and arity 0. Additionally, True and False 63 | -- are defined in the prelude since primitives can generate them. 64 | initialEnv = ConstructorState 65 | { cTag = 3 66 | , cEnv = Map.fromList 67 | [ ("_", (0, 0)) 68 | , ("False", (1, 0)) 69 | , ("True", (2, 0)) 70 | ] 71 | } 72 | 73 | -- Generate a new constructor combinator and associate a new tag 74 | -- with the constructor name. Raise error on duplicate constructor 75 | -- names. 76 | newCombinator :: Constructor -> Gen Declaration 77 | newCombinator (Constructor name components) = do 78 | env <- gets cEnv 79 | tag <- gets cTag 80 | let arity = length components 81 | args = map (("$x"++) . show) [1..arity] 82 | when (Map.member name env) $ 83 | typeError ("Duplicate constructor " ++ name) 84 | modify $ \s -> s 85 | { cTag = tag + 1 86 | , cEnv = Map.insert name (tag, arity) env 87 | } 88 | return (Combinator name args (foldl' App (Cons tag arity) (map Var args))) 89 | 90 | -- Walk each combinator body and replace Constructor names in 91 | -- case expressions with integer tags 92 | convertExpr :: Expr -> Gen Expr 93 | convertExpr (App e1 e2) = 94 | App <$> convertExpr e1 <*> convertExpr e2 95 | 96 | convertExpr (Let recursive bindings body) = 97 | Let recursive <$> convertBindings bindings <*> convertExpr body 98 | 99 | convertExpr (Lambda args body) = 100 | Lambda args <$> convertExpr body 101 | 102 | convertExpr (Case body alts) = 103 | Case <$> convertExpr body <*> convertAlts alts 104 | 105 | convertExpr x = return x 106 | 107 | -- Replace Constructor names in let-bindings 108 | convertBindings :: [(Name, Expr)] -> Gen [(Name, Expr)] 109 | convertBindings bindings = do 110 | let (names, exprs) = unzip bindings 111 | exprs' <- mapM convertExpr exprs 112 | return (zip names exprs') 113 | 114 | -- Replace Constructor names in case alternatives 115 | convertAlts :: [Alt] -> Gen [Alt] 116 | convertAlts = mapM convertAlt 117 | where 118 | convertAlt (PCon constructor, args, expr) = do 119 | env <- gets cEnv 120 | (tag, arity) <- case Map.lookup constructor env of 121 | Just x -> return x 122 | Nothing -> typeError ("No declaration found for " ++ constructor) 123 | expr <- convertExpr expr 124 | return (PTag tag, args, expr) 125 | 126 | -------------------------------------------------------------------------------- /src/MiniCore/Transforms/Lambdas.hs: -------------------------------------------------------------------------------- 1 | module MiniCore.Transforms.Lambdas 2 | ( liftLambdas 3 | ) where 4 | 5 | import MiniCore.Types 6 | import MiniCore.Transforms.Utils 7 | 8 | import qualified Data.Set as Set 9 | import qualified Data.Map as Map 10 | import Control.Monad.State 11 | import Control.Applicative 12 | import Data.List (partition, foldl') 13 | 14 | -- Lift lambdas to top level as supercombinators and turn free variables into 15 | -- extra formal parameters 16 | liftLambdas :: Program -> Stage Program 17 | liftLambdas program = collectCombinators =<< rename =<< abstract =<< freeVars program 18 | 19 | -- Partially apply lambda expressions to pass in "free" variables 20 | abstract :: FVProgram -> Stage Program 21 | abstract = mapM abstract' 22 | where 23 | abstract' (name, args, body) = 24 | Combinator name args <$> walk body 25 | 26 | walk :: FVExpr -> Stage Expr 27 | walk (free, AVar v) = 28 | return (Var v) 29 | 30 | walk (free, ANum n) = 31 | return (Num n) 32 | 33 | walk (free, ACons tag arity) = 34 | return (Cons tag arity) 35 | 36 | walk (free, AApp e1 e2) = 37 | App <$> walk e1 <*> walk e2 38 | 39 | walk (free, ALet recursive defs body) = do 40 | let names = bindersOf defs 41 | exprs <- mapM walk (bindeesOf defs) 42 | body' <- walk body 43 | return (Let recursive (zip names exprs) body') 44 | 45 | walk (free, ACase expr alts) = 46 | let walkAlt (tag, args, rhs) = (,,) tag args <$> walk rhs 47 | in Case <$> walk expr <*> mapM walkAlt alts 48 | 49 | walk (free, ALambda args body) = do 50 | body' <- walk body 51 | let vars = Set.toList free 52 | rhs = Lambda (vars ++ args) body' 53 | sc = Let False [(lambda, rhs)] (Var lambda) 54 | return (foldl' App sc (map Var vars)) 55 | 56 | -- Wrap an integer used to generate new names 57 | data NameSupply = NameSupply { suffix :: Int } 58 | 59 | -- Keep track of name supply and be able to throw an error 60 | type Lift a = StateT NameSupply Stage a 61 | 62 | -- Generate a new name from the NameSupply 63 | fresh :: Name -> Lift Name 64 | fresh name = do 65 | n <- gets suffix 66 | modify (\s -> s { suffix = n + 1 }) 67 | return (name ++ "_$" ++ show n) 68 | 69 | -- Prefix for lifted lambdas 70 | lambda = "$lambda" 71 | 72 | -- Do we need to rename this variable? 73 | shouldReplace :: Map.Map Name Name -> Name -> Bool 74 | shouldReplace env name = name `Map.member` env || name == lambda 75 | 76 | -- Take a list of old names and return a list of new names and a mapping 77 | -- from the old names to the new names 78 | newNames :: Map.Map Name Name -> [Name] -> Lift ([Name], Map.Map Name Name) 79 | newNames env [] = return ([], env) 80 | newNames env (x:xs) = do 81 | arg <- 82 | if shouldReplace env x 83 | then fresh x 84 | else return x 85 | let env' = Map.insert x arg env 86 | (args, env') <- newNames env' xs 87 | return (arg:args, env') 88 | 89 | -- Rename variables in the program that might clash 90 | rename :: Program -> Stage Program 91 | rename program = evalStateT (mapM renameSC program) $ NameSupply 1 92 | where 93 | renameSC :: Declaration -> Lift Declaration 94 | renameSC (Combinator name args body) = do 95 | (args', env) <- newNames Map.empty args 96 | body' <- walk env body 97 | return (Combinator name args' body') 98 | 99 | walk :: Map.Map Name Name -> Expr -> Lift Expr 100 | walk env (Var v) = case Map.lookup v env of 101 | Just x -> return (Var x) 102 | Nothing -> return (Var v) 103 | 104 | walk env x@(Num _) = 105 | return x 106 | 107 | walk env x@(Cons _ _) = 108 | return x 109 | 110 | walk env (App e1 e2) = 111 | App <$> walk env e1 <*> walk env e2 112 | 113 | walk env (Lambda args body) = do 114 | (args', env') <- newNames env args 115 | body' <- walk (env' `Map.union` env) body 116 | return (Lambda args' body') 117 | 118 | walk env (Let recursive defs body) = do 119 | let binders = bindersOf defs 120 | (binders', env') <- newNames env binders 121 | let bodyEnv = env' `Map.union` env 122 | body' <- walk bodyEnv body 123 | let rhsEnv 124 | | recursive = bodyEnv 125 | | otherwise = env 126 | rhs' <- mapM (walk rhsEnv) (bindeesOf defs) 127 | return (Let recursive (zip binders' rhs') body') 128 | 129 | walk env (Case expr alts) = 130 | Case <$> walk env expr <*> mapM (walkAlt env) alts 131 | 132 | walkAlt :: Map.Map Name Name -> Alt -> Lift Alt 133 | walkAlt env (tag, args, rhs) = do 134 | (args', env') <- newNames env args 135 | rhs' <- walk (env' `Map.union` env) rhs 136 | return $ (tag, args', rhs') 137 | 138 | -- Keep track of new combinators 139 | type Collect a = StateT [Declaration] Stage a 140 | 141 | -- Find lambda expressions and promote them to supercombinators 142 | collectCombinators :: Program -> Stage Program 143 | collectCombinators = liftM concat . mapM go 144 | where 145 | go :: Declaration -> Stage Program 146 | go c = execStateT (collectCombinator c) [] 147 | 148 | collectCombinator :: Declaration -> Collect () 149 | collectCombinator (Combinator name args body) = do 150 | body' <- walk body 151 | modify (\cs -> Combinator name args body':cs) 152 | 153 | walk :: Expr -> Collect Expr 154 | walk (App e1 e2) = 155 | App <$> walk e1 <*> walk e2 156 | 157 | walk (Lambda args body) = 158 | Lambda args <$> walk body 159 | 160 | walk (Case expr alts) = 161 | Case <$> walk expr <*> mapM walkAlt alts 162 | 163 | walk (Let recursive defs body) = do 164 | defs' <- mapM walkDef defs 165 | body' <- walk body 166 | let (combinators, bindings) = partition (isLambda . snd) defs' 167 | lifted = map toCombinator combinators 168 | modify (\cs -> lifted ++ cs) 169 | case bindings of 170 | [] -> return body' 171 | _ -> return $ Let recursive bindings body' 172 | 173 | walk x = return x 174 | 175 | walkDef :: (Name, Expr) -> Collect (Name, Expr) 176 | walkDef (name, expr) = 177 | (,) name <$> walk expr 178 | 179 | walkAlt :: Alt -> Collect Alt 180 | walkAlt (tag, args, rhs) = 181 | (,,) tag args <$> walk rhs 182 | 183 | isLambda :: Expr -> Bool 184 | isLambda (Lambda _ _) = True 185 | isLambda _ = False 186 | 187 | toCombinator :: (Name, Expr) -> Declaration 188 | toCombinator (name, Lambda args body) = Combinator name args body 189 | 190 | -------------------------------------------------------------------------------- /src/MiniCore/Transforms/StronglyConnectedComponents.hs: -------------------------------------------------------------------------------- 1 | module MiniCore.Transforms.StronglyConnectedComponents 2 | ( simplifyProgram 3 | , simplifyExpr 4 | ) where 5 | 6 | import MiniCore.Types 7 | import MiniCore.Transforms.Utils 8 | import MiniCore.Format 9 | 10 | import Control.Monad.State 11 | import Control.Applicative 12 | import qualified Data.Map as Map 13 | import qualified Data.Set as Set 14 | import qualified Data.List as List 15 | import Data.Maybe 16 | import Debug.Trace 17 | import Data.Foldable (foldrM) 18 | 19 | -- Map vertex to the list of neighbor vertices 20 | type Edges a = Map.Map a [a] 21 | 22 | -- Find vertices with an edge from vertex 23 | expand :: Ord a => a -> Edges a -> [a] 24 | expand a edges = maybe [] id (Map.lookup a edges) 25 | 26 | -- Use edge map to do depth-first-search from each vertex updating 27 | -- state (visited, sequence). The output sequence should be sorted in 28 | -- topological order 29 | innerDFS :: Ord a => Edges a -> (Set.Set a, [a]) -> [a] -> (Set.Set a, [a]) 30 | innerDFS edges = List.foldl' search 31 | where 32 | search (visited, sequence) vertex 33 | | vertex `Set.member` visited = (visited, sequence) 34 | | otherwise = (visited', vertex:sequence') 35 | where 36 | (visited', sequence') = 37 | innerDFS edges (Set.insert vertex visited, sequence) (expand vertex edges) 38 | 39 | -- Public interface to depth-first-search 40 | dfs :: Ord a => Edges a -> [a] -> [a] 41 | dfs edges = snd . innerDFS edges (Set.empty, []) 42 | 43 | -- Do depth first search from each vertex producing a list of sets 44 | -- of vertices visited. 45 | spanningSearch :: Ord a => Edges a -> [a] -> [Set.Set a] 46 | spanningSearch edges = snd . List.foldl' search (Set.empty, []) 47 | where 48 | search (visited, setSequence) vertex 49 | | vertex `Set.member` visited = (visited, setSequence) 50 | | otherwise = (visited', Set.fromList (vertex:sequence):setSequence) 51 | where 52 | (visited', sequence) = 53 | innerDFS edges (Set.insert vertex visited, []) (expand vertex edges) 54 | 55 | -- Construct a topologically sorted sequence of the vertices in the graph 56 | -- and then construct the reverse of the topologically sorted sequence 57 | -- of strongly connected components 58 | scc :: Ord a => Edges a -> Edges a -> [a] -> [Set.Set a] 59 | scc ins outs = spanningSearch ins . dfs outs 60 | 61 | -- Annotate program with free-variables and then 62 | -- break up into the smallest possible lets and letrecs 63 | simplifyProgram :: Program -> Stage Program 64 | simplifyProgram program = depends =<< freeVars program 65 | 66 | -- Annotate single expression with free-variables and 67 | -- then break up into the smallest possible let or letrec 68 | simplifyExpr :: Expr -> Stage Expr 69 | simplifyExpr expr = dependsExpr =<< freeVarsExpr Set.empty expr 70 | 71 | -- Run dependency analysis on the body of each combinator 72 | depends :: FVProgram -> Stage Program 73 | depends program = mapM depends' program 74 | where 75 | depends' (name, args, body) = 76 | Combinator name args <$> dependsExpr body 77 | 78 | -- Lets are the only interesting case 79 | dependsExpr :: FVExpr -> Stage Expr 80 | dependsExpr (free, ANum n) = 81 | return (Num n) 82 | 83 | dependsExpr (free, ACons tag arity) = 84 | return (Cons tag arity) 85 | 86 | dependsExpr (free, AVar v) = 87 | return (Var v) 88 | 89 | dependsExpr (free, AApp e1 e2) = 90 | App <$> dependsExpr e1 <*> dependsExpr e2 91 | 92 | dependsExpr (free, ACase body alts) = 93 | let dependsAlt (tag, args, e) = (,,) tag args <$> dependsExpr e 94 | in Case <$> dependsExpr body <*> mapM dependsAlt alts 95 | 96 | dependsExpr (free, ALambda args body) = 97 | Lambda args <$> dependsExpr body 98 | 99 | dependsExpr (free, ALet recursive defs body) = do 100 | let binders = bindersOf defs 101 | binderSet 102 | | recursive = Set.fromList binders 103 | | otherwise = Set.empty 104 | 105 | -- Make an edge from each name to its free variables that are bound 106 | -- in this letrec 107 | edges = 108 | [ (name, freeSet) 109 | | (name, (freeVars, _)) <- defs 110 | , freeSet <- Set.toList (freeVars `Set.intersection` binderSet) 111 | ] 112 | 113 | -- If ins w = [u, ...] then w depends on each u 114 | -- If out u = [w, ...] then each w depends on u 115 | ins = Map.fromList [(w, [u | (u, w') <- edges, w == w']) | (_, w) <- edges] 116 | out = Map.fromList [(u, [w | (u', w) <- edges, u == u']) | (u, _) <- edges] 117 | 118 | -- Strongly connected components in sorted topologically 119 | components = map Set.toList (scc ins out binders) 120 | 121 | -- Break defs into strongly connected components 122 | defs' = 123 | [[(name, fromJust (lookup name defs)) | name <- names] 124 | | names <- components 125 | ] 126 | 127 | -- Build new nested let(rec) 128 | body' <- dependsExpr body 129 | defs'' <- foldrM mkLet body' defs' 130 | return defs'' 131 | 132 | -- Take a list of definitions and build a new Let out of them 133 | -- Make it recursive if any name is found in the set of all 134 | -- free variables 135 | mkLet :: [(Name, FVExpr)] -> Expr -> Stage Expr 136 | mkLet defs body = do 137 | let names = map fst defs 138 | exprs = map snd defs 139 | exprs' <- mapM dependsExpr exprs 140 | let defs' = zip names exprs' 141 | vars = foldr Set.union Set.empty (map fst exprs) 142 | recursive = any (`Set.member` vars) names 143 | return (Let recursive defs' body) 144 | 145 | -------------------------------------------------------------------------------- /src/MiniCore/Transforms/Utils.hs: -------------------------------------------------------------------------------- 1 | module MiniCore.Transforms.Utils where 2 | 3 | import MiniCore.Types 4 | import qualified Data.Set as Set 5 | import Data.List (foldl') 6 | 7 | -- Type synonyms for nodes annotated with free variables 8 | type FVProgram = AProgram Name (Set.Set Name) 9 | type FVExpr = Annotated Name (Set.Set Name) 10 | type FVAlt = AAlt Name (Set.Set Name) 11 | 12 | -- Walk program and return a new AST annotated with each node's free variables 13 | freeVars :: Program -> Stage FVProgram 14 | freeVars = mapM freeVars' 15 | where 16 | freeVars' (Combinator name args body) = do 17 | body' <- freeVarsExpr (Set.fromList args) body 18 | return (name, args, body') 19 | 20 | -- Annotate expression with free variables 21 | freeVarsExpr :: Set.Set Name -> Expr -> Stage FVExpr 22 | freeVarsExpr vars (Num n) = 23 | return (Set.empty, ANum n) 24 | 25 | freeVarsExpr vars (Cons tag arity) = 26 | return (Set.empty, ACons tag arity) 27 | 28 | freeVarsExpr vars (Var v) 29 | | v `Set.member` vars = return (Set.singleton v, AVar v) 30 | | otherwise = return (Set.empty, AVar v) 31 | 32 | freeVarsExpr vars (BinOp op e1 e2) = 33 | freeVarsExpr vars (App (App (Var op) e1) e2) 34 | 35 | freeVarsExpr vars (App e1 e2) = do 36 | e1' <- freeVarsExpr vars e1 37 | e2' <- freeVarsExpr vars e2 38 | let vars' = freeVarsOf e1' `Set.union` freeVarsOf e2' 39 | return (vars', AApp e1' e2') 40 | 41 | freeVarsExpr vars (Lambda args body) = do 42 | let argSet = Set.fromList args 43 | body' <- freeVarsExpr (vars `Set.union` argSet) body 44 | let vars' = freeVarsOf body' `Set.difference` argSet 45 | return (vars', ALambda args body') 46 | 47 | freeVarsExpr vars (Case expr alts) = do 48 | expr' <- freeVarsExpr vars expr 49 | alts' <- mapM (freeVarsAlt vars) alts 50 | let vars' = freeVarsOf expr' `Set.union` (Set.unions $ map freeVarsOfAlt alts') 51 | return (vars', ACase expr' alts') 52 | 53 | freeVarsExpr vars (Let recursive defs body) = do 54 | let binders = bindersOf defs 55 | binderSet = Set.fromList binders 56 | bodyVars = vars `Set.union` binderSet 57 | defVars 58 | | recursive = bodyVars 59 | | otherwise = vars 60 | exprs <- mapM (freeVarsExpr defVars) (bindeesOf defs) 61 | let defs' = zip binders exprs 62 | freeInValues = Set.unions (map freeVarsOf exprs) 63 | defsFree 64 | | recursive = freeInValues `Set.difference` binderSet 65 | | otherwise = freeInValues 66 | body' <- freeVarsExpr bodyVars body 67 | let bodyFree = freeVarsOf body' `Set.difference` binderSet 68 | vars' = defsFree `Set.union` bodyFree 69 | return (vars', ALet recursive defs' body') 70 | 71 | -- Annotate alternative with free vars 72 | freeVarsAlt :: Set.Set Name -> Alt -> Stage FVAlt 73 | freeVarsAlt vars (tag, args, expr) = do 74 | let argSet = Set.fromList args 75 | expr' <- freeVarsExpr (vars `Set.union` argSet) expr 76 | return (tag, args, expr') 77 | 78 | -- Just get free variables for annotated AST node 79 | freeVarsOf :: Annotated Name (Set.Set Name) -> Set.Set Name 80 | freeVarsOf (vars, _) = vars 81 | 82 | -- Just get free variables for alternative 83 | freeVarsOfAlt :: FVAlt -> Set.Set Name 84 | freeVarsOfAlt (tag, args, rhs) = freeVarsOf rhs `Set.difference` Set.fromList args 85 | 86 | -------------------------------------------------------------------------------- /src/MiniCore/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeSynonymInstances, FlexibleInstances, FlexibleContexts #-} 2 | 3 | module MiniCore.Types where 4 | 5 | import Control.Monad 6 | import Control.Applicative 7 | import Control.Monad.Trans (liftIO) 8 | import Control.Monad.Except 9 | import qualified Data.Map as Map 10 | import qualified Data.Set as Set 11 | import qualified Data.List as List 12 | 13 | data CoreError 14 | = ParseError String 15 | | TypeError String 16 | | RuntimeError String 17 | deriving (Eq) 18 | 19 | instance Show CoreError where 20 | show e = case e of 21 | ParseError message -> 22 | "Parse Error: " ++ message 23 | TypeError message -> 24 | "Type Error: " ++ message 25 | RuntimeError message -> 26 | "Runtime Error: " ++ message 27 | 28 | parseError :: (MonadError CoreError m) => String -> m a 29 | parseError = throwError . ParseError 30 | 31 | typeError :: (MonadError CoreError m) => String -> m a 32 | typeError = throwError . TypeError 33 | 34 | runtimeError :: (MonadError CoreError m) => String -> m a 35 | runtimeError = throwError . RuntimeError 36 | 37 | -- Represent a stage in the compiler as something that 38 | -- fails with an error message or produces a value 39 | type Stage = ExceptT CoreError IO 40 | 41 | -- Run compiler stage 42 | runStage :: Stage a -> IO (Either CoreError a) 43 | runStage = runExceptT 44 | 45 | -- Run compiler stage and print result 46 | runStageIO :: Show a => Stage a -> IO () 47 | runStageIO s = runStage s >>= either (putStrLn . show) (putStrLn . show) 48 | 49 | -- Print something during execution 50 | trace :: (Show a) => a -> Stage () 51 | trace = traceStr . show 52 | 53 | -- Print String during execution 54 | traceStr :: String -> Stage () 55 | traceStr = liftIO . putStrLn 56 | 57 | -- Print something for stage when prompted 58 | traceStage :: (Show a) => String -> Bool -> a -> Stage () 59 | traceStage stage cond x = do 60 | let divider = "====================" 61 | when cond $ do 62 | traceStr $ divider ++ " " ++ stage ++ " " ++ divider 63 | trace x 64 | traceStr $ "\n" 65 | 66 | {- Core Expression types -} 67 | 68 | -- A program is a list of declarations 69 | type Program = [Declaration] 70 | 71 | -- A declaration is a super-combinator or a data-type declaration 72 | data Declaration 73 | = Combinator Name [Name] Expr 74 | | Data Name [Name] [Constructor] 75 | deriving Show 76 | 77 | -- Is declaration a Data declaration or a Combinator? 78 | isData :: Declaration -> Bool 79 | isData (Data {}) = True 80 | isData _ = False 81 | 82 | -- A constructor has a name and a list of components 83 | data Constructor 84 | = Constructor Name [Type] 85 | deriving Show 86 | 87 | -- An expression is a variable, number, Cons (Pack) operation, application, 88 | -- let, case, or lambda expression. 89 | data Expr 90 | = Var Name 91 | | Num Int 92 | | Cons Int Int 93 | | BinOp Name Expr Expr 94 | | App Expr Expr 95 | | Let IsRec [(Name, Expr)] Expr 96 | | Case Expr [Alt] 97 | | Lambda [Name] Expr 98 | deriving (Show) 99 | 100 | type Name = String 101 | type IsRec = Bool 102 | 103 | -- Case alternative contains some value we can match on, 104 | -- a list of names to bind, and a body 105 | type Alt = (Pattern, [Name], Expr) 106 | 107 | -- Pattern is a constructor name or an integer tag (internal representation) 108 | data Pattern 109 | = PCon Name 110 | | PTag Int 111 | deriving Show 112 | 113 | -- Get binders and bindees 114 | bindersOf :: [(a, b)] -> [a] 115 | bindersOf = map fst 116 | 117 | bindeesOf :: [(a, b)] -> [b] 118 | bindeesOf = map snd 119 | 120 | -- Map binary ops to precedence 121 | precByOp :: [(Name, Int)] 122 | precByOp = 123 | [ ("$", 0) -- Low-precedence infix application 124 | , ("||", 2) -- Boolean OR 125 | , ("&&", 3) -- Boolean AND 126 | , ("==", 4) -- Comparators 127 | , ("/=", 4) 128 | , ("<", 4) 129 | , (">", 4) 130 | , ("<=", 4) 131 | , (">=", 4) 132 | , ("+", 6) -- Arithmetic operators 133 | , ("-", 6) 134 | , ("*", 7) 135 | , ("/", 7) 136 | , (".", 9) -- Function composition 137 | ] 138 | 139 | {- Annotated Expression types -} 140 | 141 | --An AExpr is an expression annotated with some extra useful 142 | --information. a is the type of binders in expressions, and b 143 | --is the type of annotations. 144 | data AExpr a b 145 | = AVar Name 146 | | ANum Int 147 | | ACons Int Int 148 | | AApp (Annotated a b) (Annotated a b) 149 | | ALet IsRec [ADef a b] (Annotated a b) 150 | | ACase (Annotated a b) [AAlt a b] 151 | | ALambda [a] (Annotated a b) 152 | deriving (Show) 153 | 154 | type Annotated a b = (b, AExpr a b) 155 | type ADef a b = (a, Annotated a b) 156 | type AAlt a b = (Pattern, [a], (Annotated a b)) 157 | type AProgram a b = [(Name, [a], Annotated a b)] 158 | 159 | {- Types for type checking -} 160 | 161 | -- Concrete type 162 | data Type 163 | = TVar Name 164 | | TCon Name [Type] 165 | deriving (Show, Eq) 166 | 167 | -- Universally quantified types 168 | data Scheme 169 | = Scheme [Name] Type 170 | deriving (Show, Eq) 171 | 172 | -- Constructors for built-in types 173 | intTy = TCon "Int" [] 174 | boolTy = TCon "Bool" [] 175 | 176 | -- Constructor for function types 177 | fn :: Type -> Type -> Type 178 | fn a b = TCon "(->)" [a, b] 179 | 180 | -- Constructor for type variables 181 | var = TVar 182 | 183 | -- Substitute type for name 184 | type Subst = Map.Map Name Type 185 | 186 | -- Mapping from names to schemes 187 | type TypeEnv = Map.Map Name Scheme 188 | 189 | -- If something is type-like, we can apply a substitution to it 190 | -- and get a set of its type-variables 191 | class Types a where 192 | apply :: Subst -> a -> a 193 | tvars :: a -> Set.Set Name 194 | 195 | instance Types Type where 196 | apply s t@(TVar n) = maybe t id (Map.lookup n s) 197 | apply s (TCon n ts) = TCon n $ map (apply s) ts 198 | 199 | tvars (TVar n) = Set.singleton n 200 | tvars (TCon n ts) = Set.unions (map tvars ts) 201 | 202 | -- Special case; pretty-printed types should have the type-variables in order 203 | -- which tvars won't necessarily maintain 204 | tvarsOrdered :: Type -> [Name] 205 | tvarsOrdered (TVar n) = [n] 206 | tvarsOrdered (TCon n ts) = foldr List.union [] (map tvarsOrdered ts) 207 | 208 | -- tvars doesn't return universally quantified type-variables 209 | instance Types Scheme where 210 | apply s (Scheme vs t) = 211 | let s' = foldr Map.delete s vs 212 | in Scheme vs (apply s' t) 213 | 214 | tvars (Scheme vs t) = tvars t `Set.difference` Set.fromList vs 215 | 216 | -- Extend operations to lists of things that are type-like 217 | instance Types a => Types [a] where 218 | apply s = map (apply s) 219 | tvars = Set.unions . map tvars 220 | 221 | instance Types TypeEnv where 222 | apply s env = Map.map (apply s) env 223 | tvars env = tvars (Map.elems env) 224 | 225 | -- Compose substitions by applying s1 to s2 and then 226 | -- taking their union 227 | scomp :: Subst -> Subst -> Subst 228 | scomp s1 s2 = 229 | let s2' = Map.map (apply s1) s2 230 | in s2' `Map.union` s1 231 | 232 | {- Heap types -} 233 | 234 | type Addr = Int 235 | 236 | -- (size, max-size, free-list, environment mapping addresses to live objects) 237 | data Heap a = Heap 238 | { hSize :: Int 239 | , hMaxSize :: Int 240 | , hFreeList :: [Addr] 241 | , hEnvironment :: [(Addr, a)] 242 | } 243 | 244 | {- G-Compiler/Machine types -} 245 | 246 | -- Output is just a list of Strings 247 | type GMOutput = [String] 248 | 249 | -- Code is just a list of instructions 250 | type GMCode = [Instruction] 251 | 252 | data Instruction 253 | = Pushglobal Name -- Push address of global on stack 254 | | Pushint Int -- Push address of integer on stack 255 | | Pushbasic Int -- Push unboxed integer on V-stack 256 | | Push Int -- Push address of local variable on stack 257 | | Pop Int -- Pop n items from stack 258 | | Slide Int -- Pop n items from stack leaving top-of-stack 259 | | Alloc Int -- Allocate n pointers and put addresses on stack 260 | | Mkap -- Make application node out of top two address 261 | | Mkint -- Box integer on top of V-stack into heap and onto stack 262 | | Mkbool -- Box Boolean on top of V-stack into heap and onto stack 263 | | Get -- Put top-of-stack on V-stack 264 | | Update Int -- Replace root of redex with pointer to value 265 | | Eval -- Evaluate top-of-stack to Weak Head Normal Form 266 | | Unwind -- Unwind application nodes onto stack 267 | | Add -- Arithmetic instructions 268 | | Sub 269 | | Mul 270 | | Div 271 | | Neg 272 | | Eq -- Relational instructions 273 | | Ne 274 | | Lt 275 | | Le 276 | | Gt 277 | | Ge 278 | | Pack Int Int -- Build NConstructor node 279 | | Casejump [(Int, GMCode)] -- Use tag of node on top-of-stack to jump to case-alternative 280 | | Split Int -- Destructure constructor into components for alternative-body 281 | | Cond GMCode GMCode -- Simplified case-jump. Check top-of-V-stack to branch 282 | | Print -- Add value to output 283 | | LParen -- Write open paren to output 284 | | RParen -- Write close paren to output 285 | | Space -- Write space to output 286 | deriving Show 287 | 288 | -- Execution stack 289 | type GMStack = [Addr] 290 | 291 | -- Value stack for arithmetic 292 | type GMVStack = [Int] 293 | 294 | -- Save machine's current context during 295 | -- strict evaluation 296 | type GMDump = [(GMCode, GMStack, GMVStack)] 297 | 298 | -- Heap of live objects 299 | type GMHeap = Heap Node 300 | 301 | -- Heap data 302 | data Node 303 | = NNum Int 304 | | NApp Addr Addr 305 | | NGlobal Int GMCode 306 | | NPointer Addr 307 | | NConstructor Int [Addr] 308 | | NMarked Node 309 | deriving Show 310 | 311 | -- Global environment maps names to addresses 312 | type GMGlobals = [(Name, Addr)] 313 | 314 | -- Current local environment maps names to stack offsets 315 | type GMEnvironment = [(Name, Int)] 316 | 317 | -- Tally information about machine state 318 | data GMStats = GMStats 319 | { gmSteps :: Int 320 | , gmCollections :: Int 321 | } 322 | 323 | -- Names of constructors in tag order 324 | type GMCons = [Name] 325 | 326 | -- Complete machine state 327 | data GMState = GMState 328 | { gmOutput :: GMOutput 329 | , gmCode :: GMCode 330 | , gmStack :: GMStack 331 | , gmDump :: GMDump 332 | , gmVStack :: GMVStack 333 | , gmHeap :: GMHeap 334 | , gmGlobals :: GMGlobals 335 | , gmStats :: GMStats 336 | , gmCons :: GMCons 337 | } 338 | 339 | -- Simple instance for now 340 | instance Show GMState where 341 | show _ = "GMState#" 342 | 343 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | flags: {} 2 | packages: 3 | - '.' 4 | extra-deps: [] 5 | resolver: lts-3.5 6 | -------------------------------------------------------------------------------- /tests/arithmetic.out: -------------------------------------------------------------------------------- 1 | 200 2 | -------------------------------------------------------------------------------- /tests/badcase.out: -------------------------------------------------------------------------------- 1 | Type Error: 2 | Cannot unify 'A' and 'X' 3 | in: 4 | f m = case m of { 5 | B -> 1; 6 | Y -> 2; 7 | } 8 | -------------------------------------------------------------------------------- /tests/badpoly.out: -------------------------------------------------------------------------------- 1 | Type Error: 2 | Cannot unify 'Int' and 'Bool' 3 | in: 4 | main = f id (Pair 1 True) 5 | -------------------------------------------------------------------------------- /tests/badscrut.out: -------------------------------------------------------------------------------- 1 | Type Error: 2 | Cannot unify 'List' and 'Bool' 3 | in: 4 | main = f True 5 | -------------------------------------------------------------------------------- /tests/factorial.out: -------------------------------------------------------------------------------- 1 | 3628800 2 | -------------------------------------------------------------------------------- /tests/fibonacci.out: -------------------------------------------------------------------------------- 1 | 55 2 | -------------------------------------------------------------------------------- /tests/fixedpoint.out: -------------------------------------------------------------------------------- 1 | 3628800 2 | -------------------------------------------------------------------------------- /tests/fold.out: -------------------------------------------------------------------------------- 1 | 16 2 | -------------------------------------------------------------------------------- /tests/freevar.out: -------------------------------------------------------------------------------- 1 | 25 2 | -------------------------------------------------------------------------------- /tests/infinite.out: -------------------------------------------------------------------------------- 1 | (Cons 0 (Cons 1 (Cons 2 (Cons 3 (Cons 4 (Cons 5 (Cons 6 (Cons 7 (Cons 8 (Cons 9 Nil)))))))))) 2 | -------------------------------------------------------------------------------- /tests/map.out: -------------------------------------------------------------------------------- 1 | (Cons 1 (Cons 27 (Cons 125 (Cons 343 Nil)))) 2 | -------------------------------------------------------------------------------- /tests/polymorphic.out: -------------------------------------------------------------------------------- 1 | 6 2 | --------------------------------------------------------------------------------