├── LICENSE ├── README.md ├── Setup.hs ├── app ├── .DS_Store ├── Lexer.x ├── Parser.y └── main.hs ├── core-compiler.cabal ├── src ├── Core │ ├── Compiler.hs │ ├── G.hs │ ├── GMachine.hs │ ├── Grammar.hs │ ├── Prelude.hs │ └── Pretty.hs └── SamplePrograms │ ├── tp1.cor │ ├── tp10.cor │ ├── tp11(nested addition).cor │ ├── tp12(simple addition).cor │ ├── tp13(packing).cor │ ├── tp14(conditional packing).cor │ ├── tp15(nested case).cor │ ├── tp2.cor │ ├── tp3.cor │ ├── tp4.cor │ ├── tp5.cor │ ├── tp6.cor │ ├── tp7.cor │ ├── tp8.cor │ └── tp9.cor └── stack.yaml /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright David Anekstein here (c) 2016 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining a copy 4 | of this software and associated documentation files (the "Software"), to 5 | deal in the Software without restriction, including without limitation the 6 | rights to use, copy, modify, merge, publish, distribute, sublicense, and/or 7 | sell copies of the Software, and to permit persons to whom the Software is 8 | furnished to do so, subject to the following conditions: 9 | 10 | The above copyright notice and this permission notice shall be included in 11 | all copies or substantial portions of the Software. 12 | 13 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 14 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 15 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 16 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 17 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 18 | FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS 19 | IN THE SOFTWARE. -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Core 2 | 3 | *This compiler is based on the book [Implementing Functional Languages: A Tutorial](http://research.microsoft.com/en-us/um/people/simonpj/Papers/pj-lester-book/) by Simon Peyton Jones and David Lester.* 4 | 5 | ## [Documentation](http://hackage.haskell.org/package/core-compiler-0.1.0.2) 6 | 7 | To download: 8 | ``` 9 | stack install core-compiler 10 | ``` 11 | To run the example: 12 | ``` 13 | stack build 14 | stack exec core-compiler-exe [file] 15 | ``` 16 | OR 17 | ``` 18 | stack exec core-compiler-exe run-steps [file] 19 | ``` 20 | The option ```run-steps``` will print out each step the G-Machine makes in evaluating the program, to help the user learn how it works. There are example Core programs in the ```SamplePrograms``` folder 21 | 22 | As the project currently stands, anyone who wants to create a very simple functional language can do so by parsing it into the Core Expression AST found in this project. 23 | 24 | ## About the Project 25 | 26 | The Core language is a simple functional language that other functional languages (such as Haskell) can be compiled to. In the book, as well as in this implementation, Core is compiled to G-Code (which can be further compiled to C or machine code) or later interpreted by the G-Machine. The grammar of Core in this implementation is ever so slightly different than what is in the book (for readability), but this change had no affects on the compiler itself. 27 | 28 | 29 | This implementation leaves a lot to be desired, but was successful as an introduction to the world of compilers as well as state transition and stack machines. I believe that it was a great next step following the Write Yourself a Scheme tutorial. 30 | 31 | The project itself is broken into the following series of steps: 32 | - Lexing (using Alex) 33 | - Parsing (using Happy) 34 | - Compilation to initial G-Code 35 | - Evaluation by the G-Machine 36 | 37 | ## To Do 38 | - implement lambda expressions and lambda lifting 39 | - possibly implement GmState as a State monad 40 | - consider Reader for the environment during evalutation in the G machine 41 | - fix odd syntax such as double semi-colons 42 | - better error handling 43 | - replace `String` with `Text` 44 | 45 | ## Contributing 46 | I encourage contribution in the form of pull requests. The todo list is a good place to start; the lambda lifting for example is a well documented addition in the book mentioned above, and the error handling would be relatively simple. 47 | 48 | 49 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /app/.DS_Store: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/aneksteind/Core/416f53bc25a697dc6f0e40e43f0222c61f69d16b/app/.DS_Store -------------------------------------------------------------------------------- /app/Lexer.x: -------------------------------------------------------------------------------- 1 | { 2 | module Lexer where 3 | } 4 | 5 | %wrapper "posn" 6 | 7 | $digit = 0-9 8 | $alpha = [a-zA-Z] 9 | $special = [\.\;\,\$\|\*\+\?\#\~\-\{\}\(\)\[\]\^\/] 10 | $graphic = $printable # $white 11 | $eol = [\n] 12 | 13 | @string = \" ($graphic # \")* \" 14 | @escape = ’\\’ ($printable | $digit+) 15 | @char = \' ($graphic # $special) \' | \' @escape \' 16 | @id = [A-Za-z][A-Z0-9a-z_]* 17 | @double = [0-9]+[\.][0-9]+ 18 | 19 | 20 | tokens :- 21 | 22 | $white+ ; 23 | $eol ; 24 | "--".* ; 25 | $digit+ { tok (\p s -> T (TokenInt) p s) } 26 | [\+] { tok (\p s -> T (TokenAdd) p s) } 27 | [\-] { tok (\p s -> T (TokenMin) p s) } 28 | [\*] { tok (\p s -> T (TokenMul) p s) } 29 | [\/] { tok (\p s -> T (TokenDiv) p s) } 30 | [\=] { tok (\p s -> T (TokenAssign) p s) } 31 | [\\] { tok (\p s -> T (TokenLamVars) p s) } 32 | "." { tok (\p s -> T (TokenLamExpr) p s) } 33 | "<" { tok (\p s -> T (TokenLT) p s) } 34 | "<=" { tok (\p s -> T (TokenLTE) p s) } 35 | "==" { tok (\p s -> T (TokenEQ) p s) } 36 | "/=" { tok (\p s -> T (TokenNEQ) p s) } 37 | ">=" { tok (\p s -> T (TokenGTE) p s) } 38 | ">" { tok (\p s -> T (TokenGT) p s) } 39 | "&" { tok (\p s -> T (TokenAnd) p s) } 40 | "|" { tok (\p s -> T (TokenOr) p s) } 41 | let { tok (\p s -> T (TokenLet) p s) } 42 | letrec { tok (\p s -> T (TokenLetRec) p s) } 43 | in { tok (\p s -> T (TokenIn) p s) } 44 | case { tok (\p s -> T (TokenCase) p s) } 45 | of { tok (\p s -> T (TokenOf) p s) } 46 | "->" { tok (\p s -> T (TokenArrow) p s) } 47 | Pack { tok (\p s -> T (TokenPack) p s) } 48 | "{" { tok (\p s -> T (TokenLBrace) p s) } 49 | "}" { tok (\p s -> T (TokenRBrace) p s) } 50 | "(" { tok (\p s -> T (TokenLParen) p s) } 51 | ")" { tok (\p s -> T (TokenRParen) p s) } 52 | ";" { tok (\p s -> T (TokenSemiColon) p s) } 53 | "," { tok (\p s -> T (TokenComma) p s) } 54 | @id { tok (\p s -> T (TokenSym) p s) } 55 | 56 | { 57 | 58 | tok f p s = f p s 59 | 60 | data Token = T TokenClass AlexPosn String 61 | 62 | data TokenClass = TokenInt 63 | | TokenSym 64 | | TokenAdd 65 | | TokenMin 66 | | TokenMul 67 | | TokenDiv 68 | | TokenAssign 69 | | TokenLamVars 70 | | TokenLamExpr 71 | | TokenLT 72 | | TokenLTE 73 | | TokenEQ 74 | | TokenNEQ 75 | | TokenGTE 76 | | TokenGT 77 | | TokenAnd 78 | | TokenOr 79 | | TokenLet 80 | | TokenLetRec 81 | | TokenIn 82 | | TokenCase 83 | | TokenOf 84 | | TokenArrow 85 | | TokenPack 86 | | TokenLBrace 87 | | TokenRBrace 88 | | TokenLParen 89 | | TokenRParen 90 | | TokenSemiColon 91 | | TokenComma 92 | | TokenEOF 93 | deriving (Eq, Show) 94 | 95 | showPos :: AlexPosn -> String 96 | showPos (AlexPn _ l c) = "line " ++ show l ++ ":" ++ show c 97 | 98 | scanTokens :: String -> [Token] 99 | scanTokens = alexScanTokens 100 | 101 | instance Show Token where 102 | show (T TokenSym _ s) = s 103 | show (T TokenInt _ i) = show i 104 | show (T TokenAdd _ _) = "+" 105 | show (T TokenMin _ _) = "-" 106 | show (T TokenMul _ _) = "*" 107 | show (T TokenDiv _ _) = "/" 108 | show (T TokenAssign _ _) = "=" 109 | show (T TokenLamVars _ _) = "\\" 110 | show (T TokenLamExpr _ _) = "." 111 | show (T TokenLT _ _) = "<" 112 | show (T TokenLTE _ _) = "<=" 113 | show (T TokenEQ _ _) = "==" 114 | show (T TokenNEQ _ _) = "/=" 115 | show (T TokenGTE _ _) = ">=" 116 | show (T TokenGT _ _) = ">" 117 | show (T TokenAnd _ _) = "&" 118 | show (T TokenOr _ _) = "|" 119 | show (T TokenLet _ _) = "let" 120 | show (T TokenLetRec _ _) = "letrec" 121 | show (T TokenIn _ _) = "in" 122 | show (T TokenCase _ _) = "case" 123 | show (T TokenOf _ _) = "of" 124 | show (T TokenArrow _ _) = "->" 125 | show (T TokenPack _ _) = "Pack" 126 | show (T TokenLBrace _ _) = "{" 127 | show (T TokenRBrace _ _) = "}" 128 | show (T TokenLParen _ _) = "(" 129 | show (T TokenRParen _ _) = ")" 130 | show (T TokenSemiColon _ _) = ";" 131 | show (T TokenComma _ _) = "," 132 | show (T TokenEOF _ _) = "EOF" 133 | } -------------------------------------------------------------------------------- /app/Parser.y: -------------------------------------------------------------------------------- 1 | { 2 | module Parser where 3 | import Lexer 4 | import Core.Grammar 5 | } 6 | 7 | %name parseTokens 8 | %tokentype { Token } 9 | %error { parseError } 10 | 11 | %token 12 | int { T TokenInt p $$ } 13 | var { T TokenSym p $$ } 14 | '+' { T TokenAdd p _ } 15 | '-' { T TokenMin p _ } 16 | '*' { T TokenMul p _ } 17 | '/' { T TokenDiv p _ } 18 | '=' { T TokenAssign p _ } 19 | lambda { T TokenLamVars p _ } 20 | '.' { T TokenLamExpr p _ } 21 | lt { T TokenLT p _ } 22 | lte { T TokenLTE p _ } 23 | eq { T TokenEQ p _ } 24 | neq { T TokenNEQ p _ } 25 | gte { T TokenGTE p _ } 26 | gt { T TokenGT p _ } 27 | and { T TokenAnd p _ } 28 | or { T TokenOr p _ } 29 | let { T TokenLet p _ } 30 | letrec { T TokenLetRec p _ } 31 | in { T TokenIn p _ } 32 | case { T TokenCase p _ } 33 | of { T TokenOf p _ } 34 | arrow { T TokenArrow p _ } 35 | Pack { T TokenPack p _ } 36 | '{' { T TokenLBrace p _ } 37 | '}' { T TokenRBrace p _ } 38 | '(' { T TokenLParen p _ } 39 | ')' { T TokenRParen p _ } 40 | ';' { T TokenSemiColon p _ } 41 | ',' { T TokenComma p _ } 42 | 43 | 44 | 45 | %right ';' in 46 | %nonassoc gt lt gte lte eq neq '.' Pack int var arrow '}' '{' '(' ')' 47 | %left '+' '-' 48 | %left '*' '/' and or 49 | 50 | %% 51 | 52 | program : sc { [$1] } 53 | | sc ';' program { $1 : $3 } 54 | 55 | sc : var vars '=' expr { ($1, $2, $4) } 56 | 57 | vars : { [] } 58 | | var vars { $1 : $2 } 59 | 60 | expr : expr aexpr { EAp $1 $2 } 61 | | expr '+' expr { EAp (EAp (EVar "+") $1) $3 } 62 | | expr '-' expr { EAp (EAp (EVar "-") $1) $3 } 63 | | expr '*' expr { EAp (EAp (EVar "*") $1) $3 } 64 | | expr '/' expr { EAp (EAp (EVar "/") $1) $3 } 65 | | expr and expr { EAp (EAp (EVar "and") $1) $3 } 66 | | expr or expr { EAp (EAp (EVar "or") $1) $3 } 67 | | expr lt expr { EAp (EAp (EVar "<") $1) $3 } 68 | | expr lte expr { EAp (EAp (EVar "<=") $1) $3 } 69 | | expr eq expr { EAp (EAp (EVar "==") $1) $3 } 70 | | expr neq expr { EAp (EAp (EVar "/=") $1) $3 } 71 | | expr gte expr { EAp (EAp (EVar ">=") $1) $3 } 72 | | expr gt expr { EAp (EAp (EVar ">") $1) $3 } 73 | | let defns in expr { ELet nonRecursive $2 $4 } 74 | | letrec defns in expr { ELet recursive $2 $4 } 75 | | case expr of alts { ECase $2 $4 } 76 | | lambda var vars '.' expr { ELam ($2 : $3) $5 } 77 | | aexpr { $1 } 78 | 79 | aexpr : var { EVar $1 } 80 | | int { ENum (read $1 :: Int) } 81 | | Pack '{' int ',' int '}' '('exprs')' { EConstr (read $3 :: Int) (read $5 :: Int) $8} 82 | | '('expr')' { $2 } 83 | 84 | exprs : { [] } 85 | | exprsH { $1 } 86 | 87 | exprsH : expr { [$1] } 88 | | expr ',' exprsH { $1 : $3 } 89 | 90 | defns : defn { [$1] } 91 | | defn ';' defns { $1 : $3 } 92 | 93 | defn : var '=' expr { ($1, $3) } 94 | 95 | alts : alt ';' { [$1] } 96 | | alt ';' alts { $1 : $3 } 97 | 98 | alt : lt int gt vars arrow expr { ((read $2 :: Int), $4, $6) } 99 | 100 | { 101 | 102 | type IsRec = Bool 103 | 104 | recursive :: IsRec 105 | recursive = True 106 | 107 | nonRecursive :: IsRec 108 | nonRecursive = False 109 | 110 | parseError :: [Token] -> a 111 | parseError ts = 112 | case ts of 113 | [] -> error "unexpected end of file" 114 | token@(T t p s):_ -> 115 | error $ "parse error " ++ showPos p ++ " - unexpected '" ++ show token ++ "'" 116 | 117 | } -------------------------------------------------------------------------------- /app/main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Lexer 4 | import Parser 5 | import Core.Pretty 6 | import Core.Grammar 7 | import Core.GMachine 8 | import Core.Compiler 9 | import Core.Prelude 10 | import System.Environment 11 | 12 | main :: IO () 13 | main = do 14 | args <- getArgs 15 | case args of 16 | ("run-steps":file:_) -> run showResults file 17 | (file:_) -> run showFinalResult file 18 | _ -> error "incorrect arguments" 19 | 20 | run :: Printer -> String -> IO () 21 | run printer file = do 22 | contents <- readFile file 23 | runH printer contents 24 | 25 | runH printer = putStrLn . printer . eval . compile 26 | . parseTokens . scanTokens -------------------------------------------------------------------------------- /core-compiler.cabal: -------------------------------------------------------------------------------- 1 | name: core-compiler 2 | version: 0.1.0.1 3 | synopsis: compile your own mini functional language with Core 4 | stability: functional 5 | description: This package doubles as a compiler and as a module with which anyone can compile their own functional programming language by parsing into the 'CoreExpr' datatype 6 | homepage: https://github.com/aneksteind/Core#readme 7 | license: MIT 8 | license-file: LICENSE 9 | author: David Anekstein 10 | maintainer: aneksteind@gmail.com 11 | copyright: 2016 David Anekstein 12 | category: Compiler, Language 13 | build-type: Simple 14 | -- extra-source-files: 15 | cabal-version: >=1.10 16 | 17 | library 18 | hs-source-dirs: src 19 | exposed-modules: Core.Compiler, 20 | Core.GMachine, 21 | Core.Grammar, 22 | Core.Prelude, 23 | Core.Pretty 24 | other-modules: Core.G 25 | build-depends: base >= 4.7 && < 5, 26 | unordered-containers, 27 | containers, 28 | text 29 | default-language: Haskell2010 30 | 31 | executable core-compiler-exe 32 | main-is: Main.hs 33 | hs-source-dirs: app 34 | build-depends: base >=4.7, 35 | core-compiler, 36 | array 37 | other-modules: Lexer, 38 | Parser 39 | build-tools: happy, alex 40 | default-language: Haskell2010 41 | 42 | source-repository head 43 | type: git 44 | location: https://github.com/aneksteind/Core 45 | -------------------------------------------------------------------------------- /src/Core/Compiler.hs: -------------------------------------------------------------------------------- 1 | module Core.Compiler (compile) where 2 | 3 | import Core.Grammar 4 | import Core.G 5 | import Core.Prelude 6 | import Data.List 7 | import qualified Data.Map as M (Map, keys, fromList, map, mapAccum, member, lookup, toList) 8 | 9 | type GmCompiledSC = (Name, Int, GmCode) 10 | 11 | type GmCompiler = CoreExpr -> GmEnvironment -> GmCode 12 | 13 | type GmEnvironment = M.Map Name Int 14 | 15 | -- | sets initial state, 16 | -- binds the supercombinators to the environment, 17 | -- and generates the initial G code 18 | compile :: CoreProgram -> GmState 19 | compile program = ([], initialCode, [], [], [], heap, globals, statInitial) where 20 | (heap,globals) = buildInitialHeap program 21 | 22 | -- start with the main function and unwind from there 23 | initialCode :: GmCode 24 | initialCode = [Pushglobal "main", Eval, Print] 25 | 26 | statInitial :: GmStats 27 | statInitial = 0 28 | 29 | -- bind sc's, allocate corresponding nodes in heap 30 | buildInitialHeap :: CoreProgram -> (GmHeap, GmGlobals) 31 | buildInitialHeap program = (heap, M.fromList globals) where 32 | (heap, globals) = mapAccumL allocateSc hInitial compiled 33 | compiled = map compileSc (preludeDefs ++ program ++ primitives) 34 | 35 | -- allocate node in heap for supercombinator 36 | allocateSc :: GmHeap -> GmCompiledSC -> (GmHeap, (Name, Addr)) 37 | allocateSc heap (name, nargs, instructions) = (newHeap, (name, addr)) where 38 | (newHeap, addr) = hAlloc heap (NGlobal nargs instructions) 39 | 40 | hInitial :: Heap a 41 | hInitial = (0, 1, []) 42 | 43 | -- compile super combinator 44 | compileSc :: (Name, [Name], CoreExpr) -> GmCompiledSC 45 | compileSc (name, env, body) = 46 | let d = length env in 47 | (name, d, compileR d body $ M.fromList $ zip env [0..]) 48 | 49 | -- compile body (Expr) of super combinator, top level 50 | compileR :: Int -> GmCompiler 51 | compileR d (ELet recursive defs e) env 52 | | recursive = compileLetrec (compileR (d + length defs)) Null defs e env 53 | | otherwise = compileLet (compileR (d + length defs)) Null defs e env 54 | compileR d (EAp (EAp (EAp (EVar "if") predicate) e1) e2) env = 55 | compileB predicate env ++ [Cond (compileR d e1 env) (compileR d e2 env)] 56 | compileR d (ECase e alts) env = compileE e env ++ 57 | [Casejump $ compileD (compileAR d) alts env] 58 | compileR d e env = 59 | compileE e env ++ [Update d, Pop d, Unwind] 60 | 61 | -- strictly compile expression to WHNF 62 | -- leaves a pointer to the expression on top of stack 63 | compileE :: GmCompiler 64 | compileE (ENum i) env = [Pushint i] 65 | compileE (ELet recursive defs e) args 66 | | recursive = compileLetrec compileE (Final Slide) defs e args 67 | | otherwise = compileLet compileE (Final Slide) defs e args 68 | compileE (ECase e alts) env = compileE e env ++ 69 | [Casejump $ compileD compileAE alts env] 70 | compileE (EConstr t n es) env | length es == n = 71 | compileConstrArgs n es env ++ [Pack t n] 72 | | otherwise = 73 | error $ "too many or too little arguments in constructor " ++ show t 74 | compileE e@(EAp (EAp (EVar op) e1) e2) env = 75 | let maybeBinop = M.lookup op builtInDyadic 76 | mkCode Arith = [Mkint] 77 | mkCode Comp = [Mkbool] in 78 | case maybeBinop of 79 | Just (binop, dyad) -> compileB e env ++ mkCode dyad 80 | Nothing -> compileC e env ++ [Eval] 81 | compileE b@(EAp (EVar "negate") e1) env = compileB b env ++ [Mkint] 82 | compileE (EAp (EAp (EAp (EVar "if") predicate) e1) e2) env = 83 | compileB predicate env ++ [Cond (compileE e1 env) (compileE e2 env)] 84 | compileE e env = compileC e env ++ [Eval] 85 | 86 | -- compiles expression that needs evaluation to WHNF 87 | -- also must be of type Int or Bool 88 | -- leaves the result on top of the V stack 89 | compileB :: GmCompiler 90 | compileB (ENum i) env = [Pushbasic i] 91 | compileB (ELet recursive defs e) args 92 | | recursive = compileLetrec compileB (Final Pop) defs e args 93 | | otherwise = compileLet compileB (Final Pop) defs e args 94 | compileB e@(EAp (EAp (EVar op) e1) e2) env = 95 | let maybeBinop = M.lookup op builtInDyadic in 96 | case maybeBinop of 97 | Just (binop,_) -> compileB e2 env ++ compileB e1 env ++ [binop] 98 | _ -> compileE e env 99 | compileB (EAp (EVar "negate") e1) env = compileB e1 env ++ [Neg] 100 | compileB (EAp (EAp (EAp (EVar "if") predicate) e1) e2) env = 101 | compileB predicate env ++ [Cond (compileB e1 env) (compileB e2 env)] 102 | compileB e env = compileE e env ++ [Get] 103 | 104 | -- lazily compile expression 105 | compileC :: GmCompiler 106 | compileC (EVar v) env | elem v (M.keys env) = 107 | let n = M.lookup v env in case n of Just num -> [Push num] 108 | Nothing -> error "compileC: variable not in environment" 109 | | otherwise = [Pushglobal v] 110 | compileC (ENum nm) env = [Pushint nm] 111 | compileC (EAp e1 e2) env = 112 | compileC e2 env ++ compileC e1 (argOffset 1 env) ++ [Mkap] 113 | compileC (EConstr t n es) env | length es == n = compileConstrArgs n es env ++ [Pack t n] 114 | | otherwise = error $ "too many or too little arguments in constructor " ++ show t 115 | compileC (ECase e alts) env = compileE e env ++ 116 | [Casejump $ compileD compileAE alts env] 117 | compileC (ELet recursive defs e) args 118 | | recursive = compileLetrec compileC (Final Slide) defs e args 119 | | otherwise = compileLet compileC (Final Slide) defs e args 120 | 121 | -- compile cases for case expressions 122 | compileD :: (Int -> GmCompiler) -> [CoreAlt] -> GmEnvironment -> [(Int, GmCode)] 123 | compileD comp alts env = 124 | [(tag, comp (length names) body (M.fromList (zip names [0..] ++ (M.toList $ argOffset (length names) env)))) 125 | | (tag, names, body) <- alts] 126 | 127 | -- compiles the code for an alternative for E context 128 | compileAE :: Int -> GmCompiler 129 | compileAE offset expr env = [Split offset] ++ compileE expr env ++ [Slide offset] 130 | 131 | -- compiles the code for an alternative for R context 132 | compileAR :: Int -> Int -> GmCompiler 133 | compileAR d offset expr env = [Split offset] ++ compileR (offset + d) expr env 134 | 135 | -- compiles let expression, last instruction depends on context 136 | compileLet :: GmCompiler -> FinalInstruction -> [(Name, CoreExpr)] -> GmCompiler 137 | compileLet comp (Final inst) defs expr env = 138 | compileLetH2 comp defs expr env ++ [inst (length defs)] 139 | compileLet comp Null defs expr env = 140 | compileLetH2 comp defs expr env 141 | 142 | compileLetH :: [(Name, CoreExpr)] -> GmEnvironment -> GmCode 143 | compileLetH [] env = [] 144 | compileLetH ((name, expr):defs) env = 145 | compileC expr env ++ compileLetH defs (argOffset 1 env) 146 | 147 | compileLetH2 :: GmCompiler -> [(Name, CoreExpr)] -> GmCompiler 148 | compileLetH2 comp defs expr env = compileLetH defs env ++ comp expr newEnv where 149 | newEnv = compileArgs defs env 150 | 151 | -- compiles recursive let expression, last instruction depends on context 152 | compileLetrec :: GmCompiler -> FinalInstruction -> [(Name, CoreExpr)] -> GmCompiler 153 | compileLetrec comp (Final inst) defs expr env = 154 | compileLetrecH2 comp defs expr env ++ [inst (length defs)] 155 | compileLetrec comp Null defs expr env = 156 | compileLetrecH2 comp defs expr env 157 | 158 | compileLetrecH :: [(Name, CoreExpr)] -> GmEnvironment -> Int -> GmCode 159 | compileLetrecH [] env n = [] 160 | compileLetrecH ((name, expr):defs) env n = 161 | compileC expr env ++ [Update n] ++ (compileLetrecH defs env (n-1)) 162 | 163 | compileLetrecH2 :: GmCompiler -> [(Name, CoreExpr)] -> GmCompiler 164 | compileLetrecH2 comp defs expr env = 165 | [Alloc n] ++ compileLetrecH defs newEnv (n-1) ++ 166 | comp expr newEnv where 167 | newEnv = compileArgs defs env 168 | n = (length defs) 169 | 170 | -- compile the arguments of a let expression 171 | compileArgs :: [(Name, CoreExpr)] -> GmEnvironment -> GmEnvironment 172 | compileArgs defs env = 173 | M.fromList $ zip (map fst defs) [n-1, n-2 .. 0] ++ (M.toList $ argOffset n env) where 174 | n = length defs 175 | 176 | -- compile the arguments of a data type 177 | compileConstrArgs :: Int -> [CoreExpr] -> GmEnvironment -> GmCode 178 | compileConstrArgs numArgs (e:es) env = 179 | let compiled = foldl iterCode base es 180 | iterCode = (\(code, n) x -> ((compileC x (argOffset n env))++code, n+1)) 181 | base = ((compileC e env),1) 182 | in fst compiled 183 | compileConstrArgs numArgs [] env = [] 184 | 185 | -- offsets env bindings by n 186 | argOffset :: Int -> GmEnvironment -> GmEnvironment 187 | argOffset n env = M.map (\v -> v + n) env -------------------------------------------------------------------------------- /src/Core/G.hs: -------------------------------------------------------------------------------- 1 | module Core.G where 2 | 3 | import qualified Data.Map as M 4 | import Core.Grammar 5 | 6 | type GmState = (GmOutput, -- ^ current output 7 | GmCode, -- ^ current instruction stream 8 | GmStack, -- ^ current stack 9 | GmDump, -- ^ a stack for WHNF reductions 10 | GmVStack, -- ^ current v-stack 11 | GmHeap, -- ^ heap of nodes 12 | GmGlobals, -- ^ global addresses in heap 13 | GmStats) -- ^ statistics 14 | 15 | type GmOutput = [Char] 16 | 17 | type GmCode = [Instruction] 18 | 19 | type GmStack = [Addr] 20 | 21 | type GmDump = [GmDumpItem] 22 | type GmDumpItem = (GmCode, GmStack) 23 | 24 | type GmVStack = [Int] 25 | 26 | type GmHeap = Heap Node 27 | 28 | type GmGlobals = M.Map Name Addr 29 | 30 | type GmStats = Int 31 | 32 | -- | G code instructions 33 | data Instruction = Unwind 34 | | Pushbasic Int 35 | | Pushglobal Name 36 | | Pushint Int 37 | | Push Int 38 | | Get 39 | | Mkap 40 | | Mkint 41 | | Mkbool 42 | | Update Int 43 | | Pop Int 44 | | Slide Int 45 | | Alloc Int 46 | | Eval 47 | | Add | Sub | Mul | Div | Neg 48 | | Eq | Ne | Lt | Le | Gt | Ge 49 | | Cond GmCode GmCode 50 | | Pack Int Int 51 | | Casejump [(Int, GmCode)] -- TODO: map 52 | | Split Int 53 | | Print deriving (Show) 54 | 55 | instance Eq Instruction where 56 | Unwind == Unwind = True 57 | Pushglobal a == Pushglobal b = a == b 58 | Pushint a == Pushint b = a == b 59 | Push a == Push b = a == b 60 | Mkap == Mkap = True 61 | Update a == Update b = a == b 62 | _ == _ = False 63 | 64 | -- | represents a node that is put into the heap 65 | data Node = NNum Int -- ^ Numbers 66 | | NAp Addr Addr -- ^ Applications 67 | | NGlobal Int GmCode -- ^ Globals 68 | | NInd Addr -- ^ Indirections 69 | | NConstr Int [Addr] -- ^ Constructing a data type 70 | deriving (Show) 71 | 72 | instance Eq Node where 73 | NNum a == NNum b = a == b -- needed to check conditions 74 | NAp a b == NAp c d = False -- not needed 75 | NGlobal a b == NGlobal c d = False -- not needed 76 | NInd a == NInd b = False -- not needed 77 | NConstr a b == NConstr c d = False -- not needed 78 | 79 | 80 | type Heap a = (Int, Addr, [(Int, a)]) -- TODO: map 81 | 82 | type Addr = Int 83 | 84 | -- the final instruction of a given code sequence 85 | data FinalInstruction = Final (Int -> Instruction) | Null 86 | 87 | type Boxer b = (b -> GmState -> GmState) 88 | type Unboxer a = (Addr -> GmState -> a) 89 | type MOperator a b = (a -> b) 90 | type DOperator a b = (a -> a -> b) 91 | type StateTran = (GmState -> GmState) 92 | 93 | data Dyad = Arith | Comp 94 | 95 | isAtomicExpr :: Expr a -> Bool 96 | isAtomicExpr (EVar v) = True 97 | isAtomicExpr (ENum n) = True 98 | isAtomicExpr e = False 99 | 100 | builtInDyadic :: M.Map Name (Instruction, Dyad) 101 | builtInDyadic = 102 | M.fromList [("+", (Add, Arith)), ("-", (Sub, Arith)), ("*", (Mul, Arith)), ("/", (Div, Arith)), 103 | ("==", (Eq, Comp)), ("/=", (Ne, Comp)), (">=", (Ge, Comp)), 104 | (">", (Gt, Comp)), ("<=", (Le, Comp)), ("<", (Lt, Comp))] 105 | 106 | --------------------------- GMSTATE FUNCTIONS --------------------------- 107 | 108 | getOutput :: GmState -> GmOutput 109 | getOutput (o,i ,stack, dump, vstack, heap, globals, stats) = o 110 | 111 | putOutput :: GmOutput -> GmState -> GmState 112 | putOutput newO (output, code, stack, dump, vstack, heap, globals, stats) = 113 | (newO, code, stack, dump, vstack, heap, globals, stats) 114 | 115 | getCode :: GmState -> GmCode 116 | getCode (output, code, stack, dump, vstack, heap, globals, stats) = code 117 | 118 | putCode :: GmCode -> GmState -> GmState 119 | putCode newCode (output, oldCode, stack, dump, vstack, heap, globals, stats) = 120 | (output, newCode, stack, dump, vstack, heap, globals, stats) 121 | 122 | getStack :: GmState -> GmStack 123 | getStack (output, i, stack, dump, vstack, heap, globals, stats) = stack 124 | 125 | putStack :: GmStack -> GmState -> GmState 126 | putStack newStack (output, i, oldStack, dump, vstack, heap, globals, stats) = 127 | (output, i, newStack, dump, vstack, heap, globals, stats) 128 | 129 | getDump :: GmState -> GmDump 130 | getDump (output, i, stack, dump, vstack, heap, globals, stats) = dump 131 | 132 | putDump :: GmDump -> GmState -> GmState 133 | putDump newDump (output, i, stack, dump, vstack, heap, globals, stats) = 134 | (output, i, stack, newDump, vstack, heap, globals, stats) 135 | 136 | getVStack :: GmState -> GmVStack 137 | getVStack (o, i, stack, dump, vstack, heap, globals, stats) = vstack 138 | 139 | putVStack :: GmVStack -> GmState -> GmState 140 | putVStack newVstack (o, i, stack, dump, vstack, heap, globals, stats) = 141 | (o, i, stack, dump, newVstack, heap, globals, stats) 142 | 143 | getHeap :: GmState -> GmHeap 144 | getHeap (output, i, stack, dump, vstack, heap, globals, stats) = heap 145 | 146 | putHeap :: GmHeap -> GmState -> GmState 147 | putHeap newHeap (output, i, stack, dump, vstack, oldHeap, globals, stats) = 148 | (output, i, stack, dump, vstack, newHeap, globals, stats) 149 | 150 | getGlobals :: GmState -> GmGlobals 151 | getGlobals (output, i, stack, dump, vstack, heap, globals, stats) = globals 152 | 153 | putGlobals :: Name -> Addr -> GmState -> GmState 154 | putGlobals name addr (output, code, stack, dump, vstack, heap, globals, stats) = 155 | let newGlobals = M.insert name addr globals 156 | in (output, code, stack, dump, vstack, heap, newGlobals, stats) 157 | 158 | getStats :: GmState -> GmStats 159 | getStats (output, i, stack, dump, vstack, heap, globals, stats) = stats 160 | 161 | putStats :: GmStats -> GmState -> GmState 162 | putStats newStats (output, i, stack, dump, vstack, heap, globals, oldStats) = 163 | (output, i, stack, dump, vstack, heap, globals, newStats) 164 | 165 | statIncSteps :: GmStats -> GmStats 166 | statIncSteps s = s+1 167 | 168 | 169 | -- adds a node the heap, a new address is created 170 | hAlloc :: Heap a -> a -> (Heap a, Addr) 171 | hAlloc (size, address, cts) n = ((size+1, address+1, (address,n) : cts),address) 172 | 173 | -- replaces a the node at address "a" with a new node "n" 174 | -- TODO: see remove function 175 | hUpdate :: Heap a -> Addr -> a -> Heap a 176 | hUpdate (size, free, cts) a n = (size, free, (a,n) : remove cts a) 177 | 178 | -- looks up a node in a heap 179 | hLookup :: Heap Node -> Addr -> Maybe Node 180 | hLookup (size,free,cts) a = lookup a cts 181 | 182 | -- returns the addresses from the paired (Name, Address) list 183 | hAddresses :: Heap a -> [Addr] 184 | hAddresses (size, free, cts) = [addr | (addr, node) <- cts] 185 | 186 | hSize :: Heap a -> Int 187 | hSize (size, free, cts) = size 188 | 189 | hNull :: Addr 190 | hNull = 0 191 | 192 | hIsnull :: Addr -> Bool 193 | hIsnull a = a == 0 194 | 195 | remove :: [(Int,a)] -> Int -> [(Int,a)] 196 | remove [] a = error "hUpdate: nothing in the heap matches the given address" 197 | remove ((val,n):cts) match | match == val = cts 198 | | match /= val = (val,n) : remove cts match -------------------------------------------------------------------------------- /src/Core/GMachine.hs: -------------------------------------------------------------------------------- 1 | module Core.GMachine (eval) where 2 | 3 | import Core.Grammar 4 | import Core.G 5 | import qualified Data.Map as M (Map, lookup, insert, fromList) 6 | 7 | 8 | 9 | --------------------------- EVALUATOR --------------------------- 10 | 11 | -- | executes the g-machine by executing each instruction 12 | -- each execution of an instruction is cons'ed to the list 13 | -- the last state in the list is the final instruction 14 | eval :: GmState -> [GmState] 15 | eval state = state : restStates where 16 | restStates | gmFinal state = [] 17 | | otherwise = eval nextState 18 | nextState = doAdmin (step state) 19 | 20 | -- checks to see if the current state is the final one 21 | -- the state is final if all of the code has been executed 22 | gmFinal :: GmState -> Bool 23 | gmFinal s = case (getCode s) of [] -> True 24 | otherwise -> False 25 | 26 | -- increases the statistics, puts the new value into the state 27 | doAdmin :: GmState -> GmState 28 | doAdmin s = putStats (statIncSteps (getStats s)) s 29 | 30 | -- makes a state transistion based on the instruction 31 | -- takes out the current instruction from the instruction list 32 | step :: GmState -> GmState 33 | step state = dispatch i (putCode is state) where 34 | (i:is) = getCode state 35 | 36 | -- executes the current instruction 37 | -- moves the machine to the next state 38 | dispatch :: Instruction -> GmState -> GmState 39 | dispatch (Pushglobal f) = pushglobal f 40 | dispatch (Pushint n) = pushint n 41 | dispatch (Pushbasic n) = pushbasic n 42 | dispatch Mkap = mkap 43 | dispatch Mkint = mkInt 44 | dispatch Mkbool = mkBool 45 | dispatch (Push n) = push n 46 | dispatch (Pop n) = pop n 47 | dispatch (Update n) = update n 48 | dispatch Unwind = unwind 49 | dispatch (Slide n) = slide n 50 | dispatch (Alloc n) = alloc n 51 | dispatch Eval = evalI 52 | dispatch Add = add 53 | dispatch Sub = sub 54 | dispatch Mul = mul 55 | dispatch Div = divide 56 | dispatch Neg = neg 57 | dispatch Eq = eq 58 | dispatch Ne = ne 59 | dispatch Lt = lt 60 | dispatch Le = le 61 | dispatch Gt = gt 62 | dispatch Ge = ge 63 | dispatch (Cond c1 c2) = cond c1 c2 64 | dispatch (Pack t n) = pack t n 65 | dispatch (Casejump cases) = casejump cases 66 | dispatch (Split n) = split n 67 | dispatch Print = printt 68 | dispatch Get = get 69 | 70 | -- finds the global node in the heap 71 | -- pushes the address of the global node onto the stack 72 | pushglobal :: Name -> GmState -> GmState 73 | pushglobal f state = let a = M.lookup f (getGlobals state) in 74 | case a of Just add -> putStack (add: getStack state) state 75 | Nothing -> error ("pushglobal: global " ++ f ++ " not found in globals") 76 | 77 | -- adds an integer node onto the heap 78 | -- pushes the new address onto the stack 79 | pushint :: Int -> GmState -> GmState 80 | pushint n state = 81 | let maybeAddr = M.lookup (show n) (getGlobals state) 82 | pushintHelper s = putHeap newHeap (putStack (a: getStack s) s) 83 | (newHeap, a) = hAlloc (getHeap state) (NNum n) in 84 | case maybeAddr of Just addr -> (putStack (addr: getStack state) state) where 85 | Nothing -> pushintHelper $ putGlobals (show n) a state 86 | 87 | -- pushes an int ont the V stack 88 | pushbasic :: Int -> GmState -> GmState 89 | pushbasic n state = 90 | let vstack = getVStack state in putVStack (n:vstack) state 91 | 92 | -- takes the 2 addresses at the top of the address stack 93 | -- and combines them into one address 94 | -- also constructs an application node and puts it in the heap 95 | mkap :: GmState -> GmState 96 | mkap state = 97 | putHeap newHeap (putStack (newAddress:addresses) state) where 98 | (newHeap, newAddress) = hAlloc (getHeap state) (NAp a1 a2) 99 | (a1:a2:addresses) = getStack state 100 | 101 | -- moves an int value from the V stack to the heap 102 | mkInt :: GmState -> GmState 103 | mkInt state = 104 | let stack = getStack state 105 | heap = getHeap state 106 | (n:v) = getVStack state 107 | (newHeap, add) = hAlloc heap (NNum n) 108 | in putVStack v $ putStack (add:stack) $ putHeap newHeap state 109 | 110 | -- moves a bool value from the V stack to the heap 111 | mkBool :: GmState -> GmState 112 | mkBool state = 113 | let stack = getStack state 114 | heap = getHeap state 115 | (t:v) = getVStack state 116 | (newHeap, add) = hAlloc heap (NConstr t []) 117 | in putVStack v $ putStack (add:stack) $ putHeap newHeap state 118 | 119 | -- gets the current address stack 120 | -- pushes the A(nth) address on top of the stack 121 | push :: Int -> GmState -> GmState 122 | push n state = 123 | let as = getStack state 124 | a = (as !! n) in putStack (a:as) state 125 | 126 | -- drops the top n addresses from the stack 127 | pop :: Int -> GmState -> GmState 128 | pop n state = putStack (drop n stack) state where 129 | stack = getStack state 130 | 131 | -- updates the nth address in the stack with an indirection node 132 | update :: Int -> GmState -> GmState 133 | update n state = 134 | let (a:as) = getStack state 135 | in putHeap (hUpdate (getHeap state) (as !! n) (NInd a)) (putStack as state) 136 | 137 | 138 | ------------------------------------------------------------ 139 | -- unravels the spine of the graph 140 | unwind :: GmState -> GmState 141 | unwind state = 142 | let stack@(a:as) = getStack state 143 | dump = getDump state 144 | heap = getHeap state 145 | replaceAddrs name = putStack (rearrange name heap stack) 146 | n = (hLookup heap a) 147 | newState (NNum num) = updateFromDump a dump state 148 | newState (NConstr t s) = updateFromDump a dump state 149 | newState (NAp a1 a2) = putCode [Unwind] (putStack (a1:a:as) state) 150 | newState (NInd ia) = putCode [Unwind] (putStack (ia:as) state) 151 | newState (NGlobal na c) | length as < na = 152 | case dump of ((i,s):d) -> putCode i $ 153 | putStack ((last stack):s) $ 154 | putDump d state 155 | [] -> error "unwind: dump should not be empty" 156 | | otherwise = 157 | replaceAddrs na $ putCode c state in 158 | case n of Just node -> newState node 159 | Nothing -> error "unwind: address not found in heap" 160 | 161 | -- takes the code and address from the dump and returns them 162 | updateFromDump :: Addr -> GmDump -> GmState -> GmState 163 | updateFromDump address dump state = 164 | case dump of [] -> state 165 | ((i,s):d) -> putDump d $ 166 | putCode i $ 167 | putStack (address:s) state 168 | 169 | -- replaces the application node addresses in the stack with 170 | -- the addresses of the value being applied to 171 | rearrange :: Int -> GmHeap -> GmStack -> GmStack 172 | rearrange n heap as = 173 | let newAs = mapM ((getArg =<<) . hLookup heap) (tail as) in 174 | case newAs of Just addrs -> take n addrs ++ drop n as 175 | Nothing -> error "rearrange: address not found in heap" 176 | 177 | getArg :: Node -> Maybe Addr 178 | getArg (NAp a1 a2) = return a2 179 | 180 | ------------------------------------------------------------ 181 | 182 | -- takes the address at the top of the stack 183 | -- drops the next n addresses from the stack 184 | -- reattaches the address to the stack 185 | slide :: Int -> GmState -> GmState 186 | slide n state = putStack (a : drop n as) state where 187 | (a:as) = getStack state 188 | 189 | -- puts empty indirection nodes in the heap for updating later 190 | alloc :: Int -> GmState -> GmState 191 | alloc n state = let (newHeap, addrs) = allocNodes n (getHeap state) 192 | stack = getStack state in 193 | putHeap newHeap $ putStack (addrs ++ stack) state 194 | 195 | -- allocates an empty indirection node in the heap 196 | allocNodes :: Int -> GmHeap -> (GmHeap, [Addr]) 197 | allocNodes 0 heap = (heap, []) 198 | allocNodes n heap = (heap2, a:as) where 199 | (heap1, as) = allocNodes (n-1) heap 200 | (heap2, a) = hAlloc heap1 (NInd hNull) 201 | 202 | -- unwinds top address node, 203 | -- puts the rest of code and addresses in the dump 204 | evalI :: GmState -> GmState 205 | evalI state = 206 | let code = getCode state 207 | (a:as) = getStack state 208 | dump = getDump state in 209 | putCode [Unwind] $ putStack [a] $ putDump ((code, as):dump) state 210 | 211 | ------------------------------------------------------------ 212 | 213 | add :: GmState -> GmState 214 | add state = arithmetic2 (+) state 215 | 216 | sub :: GmState -> GmState 217 | sub state = arithmetic2 (-) state 218 | 219 | divide :: GmState -> GmState 220 | divide state = arithmetic2 (div) state 221 | 222 | mul :: GmState -> GmState 223 | mul state = arithmetic2 (*) state 224 | 225 | neg :: GmState -> GmState 226 | neg state = arithmetic1 (* (-1)) state 227 | 228 | eq :: GmState -> GmState 229 | eq state = comparison (==) state 230 | 231 | ne :: GmState -> GmState 232 | ne state = comparison (/=) state 233 | 234 | le :: GmState -> GmState 235 | le state = comparison (<=) state 236 | 237 | lt :: GmState -> GmState 238 | lt state = comparison (<) state 239 | 240 | gt :: GmState -> GmState 241 | gt state = comparison (>) state 242 | 243 | ge :: GmState -> GmState 244 | ge state = comparison (>=) state 245 | 246 | -- compares the top two numbers on the V stack 247 | comparison :: (Int -> Int -> Bool) -> StateTran 248 | comparison op state = 249 | let (a0:a1:as) = getVStack state 250 | bool = (a0 `op` a1) 251 | vBool n = putVStack (n:as) state in 252 | if bool then vBool 2 else vBool 1 253 | 254 | -- applies the monadic operation to the top V stack number 255 | arithmetic1 :: MOperator Int Int -> StateTran 256 | arithmetic1 op state = putVStack (op a : v) state where 257 | (a:v) = getVStack state 258 | 259 | -- applies the dyadic operator to the top two V stack numbers 260 | arithmetic2 :: DOperator Int Int -> StateTran 261 | arithmetic2 op state = putVStack ((a0 `op` a1):as) state where 262 | (a0:a1:as) = getVStack state 263 | 264 | ------------------------------------------------------------ 265 | 266 | -- gets the top value of V stack, 267 | -- if 2 (True), evaluate the t code 268 | -- if 1 (False), evaluate the f code 269 | cond :: GmCode -> GmCode -> GmState -> GmState 270 | cond t f state = 271 | let (n:v) = getVStack state 272 | i = getCode state in 273 | case n of 2 -> putCode (t++i) $ putVStack v state 274 | 1 -> putCode (f++i) $ putVStack v state 275 | _ -> error $ "cond: the number " ++ show n ++ " is not valid" 276 | 277 | -- creates a new data type, adds it to heap 278 | -- adds address of new datatype to stack 279 | pack :: Int -> Int -> GmState -> GmState 280 | pack t n state = 281 | let stack = getStack state 282 | heap = getHeap state 283 | (newHeap, a) = hAlloc heap (NConstr t (take n stack)) in 284 | putStack (a:(drop n stack)) $ putHeap newHeap state 285 | 286 | -- adds the code of the matching case expression to the code 287 | casejump :: [(Int, GmCode)] -> GmState -> GmState 288 | casejump cases state = 289 | let (a:s) = getStack state 290 | i = getCode state 291 | heap = getHeap state 292 | maybeNode = hLookup heap a 293 | maybeCode typ = lookup typ cases 294 | message t = "code for <" ++ show t ++ "> not found in cases" 295 | typeCode t = case (maybeCode t) of Just code -> code 296 | _ -> error (message t) in 297 | case maybeNode of Just (NConstr t ss) -> putCode ((typeCode t)++i) state 298 | _ -> error "casejump: node not found in heap" 299 | 300 | -- adds the addresses referenced by the data type to the stack 301 | split :: Int -> GmState -> GmState 302 | split n state = 303 | let (a:as) = getStack state 304 | heap = getHeap state 305 | maybeNC = hLookup heap a in 306 | case maybeNC of Just (NConstr t s) -> putStack (s++as) state 307 | _ -> error "split: node not found in heap" 308 | 309 | -- puts the output of the program into the output 310 | printt :: GmState -> GmState 311 | printt state = 312 | let (a:as) = getStack state 313 | heap = getHeap state 314 | output = getOutput state 315 | i = getCode state 316 | appP xs = take (2 * (length xs)) $ cycle [Eval, Print] 317 | maybeNode = hLookup heap a in 318 | case maybeNode of 319 | Just (NNum n) -> putStack as $ putOutput (output ++ " " ++ (show n)) state 320 | Just (NConstr t s) -> putOutput ("<" ++ show t ++ ">") $ putCode ((appP s)++i) $ putStack (s++as) state 321 | _ -> error $ "address " ++ show a ++ " not found in heap" 322 | 323 | -- gets a number or a data type's #args from the heap 324 | -- adds it to the V stack 325 | get :: GmState -> GmState 326 | get state = 327 | let (a:as) = getStack state 328 | heap = getHeap state 329 | maybeNode = hLookup heap a 330 | v = getVStack state 331 | getH val = putStack as $ putVStack (val:v) state 332 | in case maybeNode of Just (NConstr t _) -> getH t 333 | Just (NNum n) -> getH n 334 | _ -> error "get: node not found in heap" -------------------------------------------------------------------------------- /src/Core/Grammar.hs: -------------------------------------------------------------------------------- 1 | module Core.Grammar (CoreExpr(..), 2 | Expr(..), 3 | Name, 4 | CoreAlt(..), 5 | Alter(..), 6 | CoreProgram(..), 7 | Program(..), 8 | CoreScDefn(..), 9 | ScDefn(..)) where 10 | 11 | -- | AST of the Core language 12 | data Expr a = EVar Name -- ^ a variable 13 | | ENum Int -- ^ an Int 14 | | EConstr Int Int [Expr a] -- ^ a type declaration 15 | | EAp (Expr a) (Expr a) -- ^ function application 16 | | ELet Bool [(a, Expr a)] (Expr a) -- ^ let/letrec expression 17 | | ECase (Expr a) [Alter a] -- ^ case expression 18 | | ELam [a] (Expr a) -- ^ lambda expression (not yet implemented) 19 | deriving (Show, Eq) 20 | 21 | -- | A Core expression 22 | type CoreExpr = Expr Name 23 | 24 | type Name = String 25 | 26 | 27 | 28 | -- | a case alternative for a given datatype 29 | type Alter a = (Int -- ^ the datatype number 30 | ,[a] -- ^ a list of local variable names 31 | , Expr a -- ^ the expression that the case evaluates to 32 | ) 33 | 34 | -- | a case alternative 35 | type CoreAlt = Alter Name 36 | 37 | type Program a = [ScDefn a] 38 | 39 | -- | A list of super combinator definitions 40 | type CoreProgram = Program Name 41 | 42 | type ScDefn a = (Name -- ^ the name of the function/global 43 | ,[a] -- ^ the list of local variable names 44 | , Expr a -- ^ the expression the supercombinator evaluates to 45 | ) 46 | 47 | -- | A supercombinator definition 48 | type CoreScDefn = ScDefn Name -------------------------------------------------------------------------------- /src/Core/Prelude.hs: -------------------------------------------------------------------------------- 1 | module Core.Prelude where 2 | 3 | import Core.Grammar 4 | 5 | -- | simple but important functions in Core 6 | preludeDefs :: CoreProgram 7 | preludeDefs = [ ("I", ["x"], EVar "x"), 8 | ("K", ["x","y"], EVar "x"), 9 | ("K1",["x","y"], EVar "y"), 10 | ("S", ["f","g","x"], EAp (EAp (EVar "f") (EVar "x")) 11 | (EAp (EVar "g") (EVar "x"))), 12 | ("compose", ["f","g","x"], EAp (EVar "f") 13 | (EAp (EVar "g") (EVar "x"))), 14 | ("twice", ["f"], EAp (EAp (EVar "compose") (EVar "f")) (EVar "f"))] 15 | 16 | -- | primitive operations 17 | primitives :: CoreProgram 18 | primitives = 19 | [("+", ["x","y"], (EAp (EAp (EVar "+") (EVar "x")) (EVar "y"))), 20 | ("-", ["x","y"], (EAp (EAp (EVar "-") (EVar "x")) (EVar "y"))), 21 | ("*", ["x","y"], (EAp (EAp (EVar "*") (EVar "x")) (EVar "y"))), 22 | ("/", ["x","y"], (EAp (EAp (EVar "/") (EVar "x")) (EVar "y"))), 23 | ("negate", ["x"], (EAp (EVar "negate") (EVar "x"))), 24 | ("==", ["x","y"], (EAp (EAp (EVar "==") (EVar "x")) (EVar "y"))), 25 | ("˜=", ["x","y"], (EAp (EAp (EVar "˜=") (EVar "x")) (EVar "y"))), 26 | (">=", ["x","y"], (EAp (EAp (EVar ">=") (EVar "x")) (EVar "y"))), 27 | (">", ["x","y"], (EAp (EAp (EVar ">") (EVar "x")) (EVar "y"))), 28 | ("<=", ["x","y"], (EAp (EAp (EVar "<=") (EVar "x")) (EVar "y"))), 29 | ("<", ["x","y"], (EAp (EAp (EVar "<") (EVar "x")) (EVar "y"))), 30 | ("if", ["c","t","f"], 31 | (EAp (EAp (EAp (EVar "if") (EVar "c")) (EVar "t")) (EVar "f"))), 32 | ("True", [], (EConstr 2 0 [])), 33 | ("False", [], (EConstr 1 0 []))] -------------------------------------------------------------------------------- /src/Core/Pretty.hs: -------------------------------------------------------------------------------- 1 | module Core.Pretty (pprint, 2 | showResults, 3 | showFinalResult, 4 | Printer(..)) where 5 | 6 | 7 | import Core.Grammar 8 | import Core.G 9 | import qualified Data.Map as M (toList, member, fromList, Map) 10 | 11 | data Iseq = INil 12 | | IStr String 13 | | IAppend Iseq Iseq 14 | | IIndent Iseq 15 | | INewline 16 | deriving (Show, Eq) 17 | 18 | type Printer = [GmState] -> [Char] 19 | 20 | -- | pretty prints a core program 21 | pprint :: CoreProgram -> String 22 | pprint prog = iDisplay (pprProgram prog) 23 | 24 | pprProgram :: CoreProgram -> Iseq 25 | pprProgram scdefns = 26 | flip iAppend iNewline (iInterleave (iStr ";" `iAppend` iNewline) $ map pprScDefn scdefns) 27 | 28 | -- pretty prints a supercombinator definition 29 | pprScDefn :: CoreScDefn -> Iseq 30 | pprScDefn (name, vars, expr) = 31 | (iStr name) `iAppend` iStr " " `iAppend` (iInterleave (iStr " ") (map iStr vars)) 32 | `iAppend` maybeSpace `iAppend` (pprExpr expr) 33 | where maybeSpace = case vars of [] -> iStr "= " 34 | _ -> iStr " = " 35 | 36 | -- pretty prints expressions 37 | pprExpr :: CoreExpr -> Iseq 38 | pprExpr (ENum n) = iNum n 39 | pprExpr (EVar v) = iStr v 40 | pprExpr (EAp (EAp (EVar op) e1) e2) | M.member op builtInDyadic = 41 | iConcat [ pprAExpr e1,iStr " ", iStr op,iStr " ", pprAExpr e2 ] 42 | | otherwise = 43 | (pprExpr e1) `iAppend` (iStr " ") `iAppend` (pprAExpr e2) 44 | pprExpr (EAp e1 e2) = (pprExpr e1) `iAppend` (iStr " ") `iAppend` (pprAExpr e2) 45 | pprExpr (ELet isrec defns expr) = 46 | iConcat [ iStr keyword, iIndent (pprDefns defns), iStr " in " `iAppend` pprExpr expr ] 47 | where keyword | not isrec = "let" 48 | | isrec = "letrec" 49 | pprExpr (ECase e1 patterns) = 50 | iConcat [ iStr "case ", (pprExpr e1), iStr " of ", iIndent $ pprPatterns patterns ] 51 | pprExpr (ELam vars expr) = 52 | iConcat [ iStr "(lambda (", iInterleave (iStr " ") (map iStr vars), 53 | iStr ") ", pprExpr expr, iStr ")"] 54 | pprExpr (EConstr i1 i2 es) = 55 | iConcat [ iStr "Pack {", iStr $ show i1, 56 | iStr ", ", iStr $ show i2, iStr "}"] `iAppend` 57 | (iConcat $ map pprExpr es) 58 | 59 | -- pretty prints case alts 60 | pprPatterns :: [CoreAlt] -> Iseq 61 | pprPatterns patterns = 62 | iNewline `iAppend` iInterleave (iStr "; " `iAppend` iNewline) (map pprPattern patterns) 63 | 64 | pprPattern :: CoreAlt -> Iseq 65 | pprPattern (int, vars@(v:vs), result) = iConcat $ 66 | [iStr "<", iStr $ show int, iStr "> ", 67 | iInterleave (iStr " ") (map iStr vars), 68 | iStr " -> ", pprExpr result] 69 | pprPattern (int, [], result) = iConcat $ 70 | [iStr "<", iStr $ show int, iStr ">", 71 | iStr " -> ", pprExpr result] 72 | 73 | -- pretty prints let definitions 74 | pprDefns :: [(Name, CoreExpr)] -> Iseq 75 | pprDefns defns = iNewline `iAppend` iInterleave sep (map pprDefn defns) 76 | where sep = iConcat [ iStr ";", iNewline ] 77 | 78 | pprDefn :: (Name, CoreExpr) -> Iseq 79 | pprDefn (name, expr) = iConcat [ iStr name, iStr " = ", pprExpr expr ] 80 | 81 | -- pretty prints a single expression 82 | pprAExpr :: CoreExpr -> Iseq 83 | pprAExpr e | isAtomicExpr e = pprExpr e 84 | | otherwise = (iStr "(") `iAppend` (pprExpr e) `iAppend` (iStr ")") 85 | 86 | iNil :: Iseq 87 | iNil = INil 88 | 89 | -- pretty prints a string 90 | iStr :: String -> Iseq 91 | iStr str = IStr str 92 | 93 | -- pretty prints an int 94 | iNum :: Int -> Iseq 95 | iNum n = IStr $ show n 96 | 97 | -- pretty prints digits with proper spacing 98 | iFWNum :: Int -> Int -> Iseq 99 | iFWNum width n = iStr (space (width - length digits) ++ digits) 100 | where digits = show n 101 | 102 | -- prints out a numbered list of other sequences 103 | iLayn :: [Iseq] -> Iseq 104 | iLayn seqs = iConcat (map lay_item (zip [1..] seqs)) 105 | where lay_item (n, seq) = iConcat [ iFWNum 4 n, iStr ") ", iIndent seq, iNewline ] 106 | 107 | -- append two iseqs 108 | iAppend :: Iseq -> Iseq -> Iseq 109 | iAppend seq1 seq2 | seq2 == INil = seq1 110 | | seq1 == INil = seq1 111 | | otherwise = IAppend seq1 seq2 112 | 113 | iNewline :: Iseq 114 | iNewline = INewline 115 | 116 | iIndent :: Iseq -> Iseq 117 | iIndent s = IIndent s 118 | 119 | iDisplay :: Iseq -> String 120 | iDisplay s = flatten 0 [(s,0)] 121 | 122 | -- keeps track of the current column as well as 123 | -- a work list that includes the current iseq and 124 | -- the indentation for it 125 | flatten :: Int -> [(Iseq,Int)] -> String 126 | flatten col [] = "" 127 | flatten col (((INil), indent):seqs) = flatten col seqs 128 | flatten col (((IStr s), indent):seqs) = s ++ (flatten col seqs) 129 | flatten col (((IAppend seq1 seq2), indent):seqs) = flatten col ((seq1,indent) : (seq2,indent) : seqs) 130 | flatten col ((INewline, indent):seqs) = '\n' : (space indent) ++ (flatten indent seqs) 131 | flatten col ((IIndent s, indent):seqs) = (flatten col ((s, col+4):seqs)) 132 | 133 | space :: Int -> String 134 | space n = take n $ repeat ' ' 135 | 136 | -- appends a list of iseqs 137 | iConcat :: [Iseq] -> Iseq 138 | iConcat iseqs = foldr (\iseq acc -> iseq `iAppend` acc) iNil iseqs 139 | 140 | iInterleave :: Iseq -> [Iseq] -> Iseq 141 | iInterleave sep (i:is) = iConcat $ i : prependToAll sep is 142 | iInterleave sep [] = iNil 143 | 144 | -- puts a character before each element in a list 145 | prependToAll sep (i:is) = sep : (i : prependToAll sep is) 146 | prependToAll sep [] = [] 147 | 148 | --builds sample expressions of n size 149 | mkMultiAp :: Int -> CoreExpr -> CoreExpr -> CoreExpr 150 | mkMultiAp n e1 e2 = foldl EAp e1 (take n e2s) 151 | where e2s = e2 : e2s 152 | 153 | --------------------------- SHOW COMPILATION --------------------------- 154 | 155 | -- | outputs the final result of evaluating a program with the G machine 156 | showFinalResult :: Printer 157 | showFinalResult states = iDisplay $ showOutput (last states) 158 | 159 | -- | outputs each step the GMachine makes in compiling a program 160 | showResults :: Printer 161 | showResults states = iDisplay (iConcat [ 162 | iNewline, iStr "-----Supercombinator definitions-----", iNewline, iNewline, 163 | iInterleave iNewline (map (showSC s) (M.toList $ getGlobals s)), 164 | iNewline, iNewline, iStr "-----State transitions-----", iNewline, iNewline, 165 | iLayn (map showState states), iNewline, 166 | showStats (last states)]) where (s:ss) = states 167 | 168 | showSC :: GmState -> (Name, Addr) -> Iseq 169 | showSC s (name, addr) = 170 | let maybeAdd = (hLookup (getHeap s) addr) 171 | in case maybeAdd of Just (NGlobal arity code) -> showSCresult name code 172 | Nothing -> error "global not found in heap" 173 | 174 | showSCresult :: Name -> GmCode -> Iseq 175 | showSCresult name code = iConcat [ iStr "Code for ", 176 | iStr name, iNewline, showInstructions code, iNewline, iNewline] 177 | 178 | showInstructions :: GmCode -> Iseq 179 | showInstructions is = iConcat [iStr " Code:{", 180 | iIndent (iInterleave iNewline (map showInstruction is)), 181 | iStr "}", iNewline] 182 | 183 | showInstruction :: Instruction -> Iseq 184 | showInstruction (Pushglobal f) = (iStr "Pushglobal ") `iAppend` (iStr f) 185 | showInstruction (Push n) = (iStr "Push ") `iAppend` (iNum n) 186 | showInstruction (Pushint n) = (iStr "Pushint ") `iAppend` (iNum n) 187 | showInstruction (Update n) = (iStr "Update ") `iAppend` (iNum n) 188 | showInstruction (Pop n) = (iStr "Pop ") `iAppend` (iNum n) 189 | showInstruction (Slide n) = (iStr "Slide ") `iAppend` (iNum n) 190 | showInstruction (Alloc n) = (iStr "Alloc ") `iAppend` (iNum n) 191 | showInstruction (Cond cond1 cond2) = 192 | (iStr "Cond {") `iAppend` showInstructions cond1 `iAppend` showInstructions cond2 193 | showInstruction (Pack n1 n2) = 194 | (iStr "Pack{") `iAppend` (iNum n1) `iAppend` (iStr ",") `iAppend` 195 | (iNum n2) `iAppend` (iStr "}") 196 | showInstruction (Casejump cases) = (iStr "Casejump [") `iAppend` showCases cases 197 | showInstruction (Split n) = (iStr "Split ") `iAppend` (iNum n) 198 | showInstruction inst = iStr $ show inst 199 | 200 | showCases :: [(Int, GmCode)] -> Iseq 201 | showCases cases = iInterleave iNewline $ map showCase cases 202 | 203 | showCase :: (Int, GmCode) -> Iseq 204 | showCase (i, code) = 205 | (iNum i) `iAppend` (iStr " -> [") `iAppend` 206 | showInstructions code `iAppend` (iStr "]") 207 | 208 | showState :: GmState -> Iseq 209 | showState s = iConcat [showOutput s, iNewline, 210 | showStack s, iNewline, 211 | showVStack s, iNewline, 212 | showDump s, iNewline, 213 | showInstructions (getCode s), iNewline] 214 | 215 | showOutput :: GmState -> Iseq 216 | showOutput s = iConcat [iStr "Output:\"", iStr (getOutput s), iStr "\""] 217 | 218 | showStack :: GmState -> Iseq 219 | showStack s = iConcat [iStr " Stack:[", 220 | iIndent (iInterleave iNewline 221 | (map (showStackItem s) (reverse (getStack s)))), 222 | iStr "]"] 223 | 224 | showStackItem :: GmState -> Addr -> Iseq 225 | showStackItem s a = 226 | let maybeAddress = (hLookup (getHeap s) a) in 227 | case maybeAddress of Just address -> iConcat [iStr (showaddr a), iStr ": ", showNode s a address] 228 | Nothing -> error "showStackItem: node not found in heap" 229 | 230 | statGetSteps :: GmStats -> Int 231 | statGetSteps s = s 232 | 233 | showaddr :: Addr -> [Char] 234 | showaddr a = "#" ++ show a 235 | 236 | showVStack :: GmState -> Iseq 237 | showVStack s = iConcat [iStr "Vstack:[", 238 | iInterleave (iStr ", ") (map iNum (getVStack s))] `iAppend` iStr "]" 239 | 240 | showDump :: GmState -> Iseq 241 | showDump s = iConcat [iStr " Dump:[", 242 | iIndent (iInterleave iNewline 243 | (map showDumpItem (reverse (getDump s)))), 244 | iStr "]"] 245 | 246 | showDumpItem :: GmDumpItem -> Iseq 247 | showDumpItem (code, stack) = 248 | iConcat [iStr "<", 249 | shortShowInstructions 3 code, iStr ", ", 250 | shortShowStack stack, iStr ">"] 251 | 252 | shortShowInstructions :: Int -> GmCode -> Iseq 253 | shortShowInstructions number code = 254 | iConcat [iStr "{", iInterleave (iStr "; ") dotcodes, iStr "}"] where 255 | codes = map showInstruction (take number code) 256 | dotcodes | length code > number = codes ++ [iStr "..."] 257 | | otherwise = codes 258 | 259 | shortShowStack :: GmStack -> Iseq 260 | shortShowStack stack = 261 | iConcat [iStr "[", 262 | iInterleave (iStr ", ") (map (iStr . showaddr) stack), 263 | iStr "]"] 264 | 265 | showNode :: GmState -> Addr -> Node -> Iseq 266 | showNode s a (NNum n) = iNum n 267 | showNode s a (NGlobal n g) = iConcat [iStr "Global ", iStr v] 268 | where v = head [n | (n,b) <- M.toList $ getGlobals s, a==b] 269 | showNode s a (NAp a1 a2) = iConcat [iStr "Ap ", iStr (showaddr a1), 270 | iStr " ", iStr (showaddr a2)] 271 | showNode s a (NInd ia) = iConcat [iStr "Ind ", iStr (showaddr ia)] 272 | showNode s a (NConstr t as) = 273 | iConcat [iStr "Cons ", iNum t, iStr " [", 274 | iInterleave (iStr ", ") (map (iStr.showaddr) as), 275 | iStr "]"] 276 | 277 | showStats :: GmState -> Iseq 278 | showStats s = iConcat [ iStr "Steps taken = ", iNum (statGetSteps (getStats s))] -------------------------------------------------------------------------------- /src/SamplePrograms/tp1.cor: -------------------------------------------------------------------------------- 1 | main = 3 + 4 * 5 -------------------------------------------------------------------------------- /src/SamplePrograms/tp10.cor: -------------------------------------------------------------------------------- 1 | nfib n = if (n<=0) 0 (1 + (nfib (n-1)) + (nfib (n-2))) ; 2 | 3 | nfib2 n = fib n 1 1; 4 | fib n acc1 acc2 = if (n<=2) (acc2) (fib (n-1) (acc2) (acc1 + acc2)); 5 | 6 | main = nfib2 6 7 | 8 | -- works mark 5 9 | 10 | -------------------------------------------------------------------------------- /src/SamplePrograms/tp11(nested addition).cor: -------------------------------------------------------------------------------- 1 | f x = x + 2; 2 | main = f (n - 1); 3 | n = 2 4 | 5 | -- works mark 5 -------------------------------------------------------------------------------- /src/SamplePrograms/tp12(simple addition).cor: -------------------------------------------------------------------------------- 1 | main = 7 - (1 - y); 2 | x = 7; 3 | y = 4 4 | 5 | -- works mark 5 -------------------------------------------------------------------------------- /src/SamplePrograms/tp13(packing).cor: -------------------------------------------------------------------------------- 1 | f x = Pack{2,2}((case x of <1> -> 1; <2> -> 2;), Pack{1,0}()); 2 | main = f 2 -------------------------------------------------------------------------------- /src/SamplePrograms/tp14(conditional packing).cor: -------------------------------------------------------------------------------- 1 | if3 c t f = case c of 2 | <3> -> t > 1; 3 | <1> -> f > 1;; 4 | 5 | blub = Pack{3,0}(); 6 | 7 | main = if3 blub 5 4 -------------------------------------------------------------------------------- /src/SamplePrograms/tp15(nested case).cor: -------------------------------------------------------------------------------- 1 | x = Pack{3,2}(2 + z, 8); 2 | y = False; 3 | z = 4; 4 | 5 | and x y = case x of 6 | <3> a b -> case y of 7 | <2> -> x; 8 | <1> -> x;; 9 | <1> -> y;; 10 | 11 | main = and x y 12 | -------------------------------------------------------------------------------- /src/SamplePrograms/tp2.cor: -------------------------------------------------------------------------------- 1 | cons a b cc cn = cc a b ; 2 | nil cc cn = cn ; 3 | hd list = list K abort ; 4 | tl list = list K1 abort ; 5 | abort = abort ; 6 | infinite x = cons x (infinite x) ; 7 | main = hd (tl (infinite 4)) 8 | 9 | -- broken mark 5 -------------------------------------------------------------------------------- /src/SamplePrograms/tp3.cor: -------------------------------------------------------------------------------- 1 | oct g x = let h = twice g 2 | in let k = twice h 3 | in k (k x) ; 4 | main = oct I 4 5 | 6 | -- works mark 5 -------------------------------------------------------------------------------- /src/SamplePrograms/tp4.cor: -------------------------------------------------------------------------------- 1 | cons a b cc cn = cc a b ; 2 | nil cc cn = cn ; 3 | tl list = list K1 abort ; 4 | hd list = list K abort ; 5 | abort = abort ; 6 | infinite x = letrec xs = cons x xs 7 | in xs ; 8 | 9 | main = hd (tl (tl (infinite 4))) 10 | 11 | -- broken mark 5 -------------------------------------------------------------------------------- /src/SamplePrograms/tp5.cor: -------------------------------------------------------------------------------- 1 | main = 4*5+(2-5) 2 | 3 | -- works mark 5 -------------------------------------------------------------------------------- /src/SamplePrograms/tp6.cor: -------------------------------------------------------------------------------- 1 | inc x = x+1; 2 | main = twice (twice (twice inc)) 0 3 | 4 | -- works mark 5 -------------------------------------------------------------------------------- /src/SamplePrograms/tp7.cor: -------------------------------------------------------------------------------- 1 | cons a b cc cn = cc a b ; 2 | nil cc cn = cn ; 3 | length xs = xs length1 0 ; 4 | length1 x xs = 1 + (length xs) ; 5 | main = length (cons 3 (cons 3 (cons 3 nil))) 6 | 7 | -- works mark 5 -------------------------------------------------------------------------------- /src/SamplePrograms/tp8.cor: -------------------------------------------------------------------------------- 1 | fac n = if (n==0) 1 (n * (fac (n-1))) ; 2 | main = fac 5 3 | 4 | -- works mark 5 -------------------------------------------------------------------------------- /src/SamplePrograms/tp9.cor: -------------------------------------------------------------------------------- 1 | gcd a b = if (a==b) a (if (a=1.1" 56 | # 57 | # Override the architecture used by stack, especially useful on Windows 58 | # arch: i386 59 | # arch: x86_64 60 | # 61 | # Extra directories used by stack for building 62 | # extra-include-dirs: [/path/to/dir] 63 | # extra-lib-dirs: [/path/to/dir] 64 | # 65 | # Allow a newer minor version of GHC than the snapshot specifies 66 | # compiler-check: newer-minor --------------------------------------------------------------------------------