diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,19 @@ +Copyright David Anekstein here (c) 2016 + +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: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/Lexer.x b/app/Lexer.x new file mode 100644 --- /dev/null +++ b/app/Lexer.x @@ -0,0 +1,133 @@ +{ +module Lexer where +} + +%wrapper "posn" + +$digit = 0-9 +$alpha = [a-zA-Z] +$special = [\.\;\,\$\|\*\+\?\#\~\-\{\}\(\)\[\]\^\/] +$graphic = $printable # $white +$eol = [\n] + +@string = \" ($graphic # \")* \" +@escape = ’\\’ ($printable | $digit+) +@char = \' ($graphic # $special) \' | \' @escape \' +@id = [A-Za-z][A-Z0-9a-z_]* +@double = [0-9]+[\.][0-9]+ + + +tokens :- + + $white+ ; + $eol ; + "--".* ; + $digit+ { tok (\p s -> T (TokenInt) p s) } + [\+] { tok (\p s -> T (TokenAdd) p s) } + [\-] { tok (\p s -> T (TokenMin) p s) } + [\*] { tok (\p s -> T (TokenMul) p s) } + [\/] { tok (\p s -> T (TokenDiv) p s) } + [\=] { tok (\p s -> T (TokenAssign) p s) } + [\\] { tok (\p s -> T (TokenLamVars) p s) } + "." { tok (\p s -> T (TokenLamExpr) p s) } + "<" { tok (\p s -> T (TokenLT) p s) } + "<=" { tok (\p s -> T (TokenLTE) p s) } + "==" { tok (\p s -> T (TokenEQ) p s) } + "/=" { tok (\p s -> T (TokenNEQ) p s) } + ">=" { tok (\p s -> T (TokenGTE) p s) } + ">" { tok (\p s -> T (TokenGT) p s) } + "&" { tok (\p s -> T (TokenAnd) p s) } + "|" { tok (\p s -> T (TokenOr) p s) } + let { tok (\p s -> T (TokenLet) p s) } + letrec { tok (\p s -> T (TokenLetRec) p s) } + in { tok (\p s -> T (TokenIn) p s) } + case { tok (\p s -> T (TokenCase) p s) } + of { tok (\p s -> T (TokenOf) p s) } + "->" { tok (\p s -> T (TokenArrow) p s) } + Pack { tok (\p s -> T (TokenPack) p s) } + "{" { tok (\p s -> T (TokenLBrace) p s) } + "}" { tok (\p s -> T (TokenRBrace) p s) } + "(" { tok (\p s -> T (TokenLParen) p s) } + ")" { tok (\p s -> T (TokenRParen) p s) } + ";" { tok (\p s -> T (TokenSemiColon) p s) } + "," { tok (\p s -> T (TokenComma) p s) } + @id { tok (\p s -> T (TokenSym) p s) } + +{ + +tok f p s = f p s + +data Token = T TokenClass AlexPosn String + +data TokenClass = TokenInt + | TokenSym + | TokenAdd + | TokenMin + | TokenMul + | TokenDiv + | TokenAssign + | TokenLamVars + | TokenLamExpr + | TokenLT + | TokenLTE + | TokenEQ + | TokenNEQ + | TokenGTE + | TokenGT + | TokenAnd + | TokenOr + | TokenLet + | TokenLetRec + | TokenIn + | TokenCase + | TokenOf + | TokenArrow + | TokenPack + | TokenLBrace + | TokenRBrace + | TokenLParen + | TokenRParen + | TokenSemiColon + | TokenComma + | TokenEOF + deriving (Eq, Show) + +showPos :: AlexPosn -> String +showPos (AlexPn _ l c) = "line " ++ show l ++ ":" ++ show c + +scanTokens :: String -> [Token] +scanTokens = alexScanTokens + +instance Show Token where + show (T TokenSym _ s) = s + show (T TokenInt _ i) = show i + show (T TokenAdd _ _) = "+" + show (T TokenMin _ _) = "-" + show (T TokenMul _ _) = "*" + show (T TokenDiv _ _) = "/" + show (T TokenAssign _ _) = "=" + show (T TokenLamVars _ _) = "\\" + show (T TokenLamExpr _ _) = "." + show (T TokenLT _ _) = "<" + show (T TokenLTE _ _) = "<=" + show (T TokenEQ _ _) = "==" + show (T TokenNEQ _ _) = "/=" + show (T TokenGTE _ _) = ">=" + show (T TokenGT _ _) = ">" + show (T TokenAnd _ _) = "&" + show (T TokenOr _ _) = "|" + show (T TokenLet _ _) = "let" + show (T TokenLetRec _ _) = "letrec" + show (T TokenIn _ _) = "in" + show (T TokenCase _ _) = "case" + show (T TokenOf _ _) = "of" + show (T TokenArrow _ _) = "->" + show (T TokenPack _ _) = "Pack" + show (T TokenLBrace _ _) = "{" + show (T TokenRBrace _ _) = "}" + show (T TokenLParen _ _) = "(" + show (T TokenRParen _ _) = ")" + show (T TokenSemiColon _ _) = ";" + show (T TokenComma _ _) = "," + show (T TokenEOF _ _) = "EOF" +} diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,26 @@ +module Main where + +import Lexer +import Parser +import Core.Pretty +import Core.Grammar +import Core.GMachine +import Core.Compiler +import Core.Prelude +import System.Environment + +main :: IO () +main = do + args <- getArgs + case args of + ("run-steps":file:_) -> run showResults file + (file:_) -> run showFinalResult file + _ -> error "incorrect arguments" + +run :: Printer -> String -> IO () +run printer file = do + contents <- readFile file + runH printer contents + +runH printer = putStrLn . printer . eval . compile + . parseTokens . scanTokens diff --git a/app/Parser.y b/app/Parser.y new file mode 100644 --- /dev/null +++ b/app/Parser.y @@ -0,0 +1,117 @@ +{ +module Parser where +import Lexer +import Core.Grammar +} + +%name parseTokens +%tokentype { Token } +%error { parseError } + +%token + int { T TokenInt p $$ } + var { T TokenSym p $$ } + '+' { T TokenAdd p _ } + '-' { T TokenMin p _ } + '*' { T TokenMul p _ } + '/' { T TokenDiv p _ } + '=' { T TokenAssign p _ } + lambda { T TokenLamVars p _ } + '.' { T TokenLamExpr p _ } + lt { T TokenLT p _ } + lte { T TokenLTE p _ } + eq { T TokenEQ p _ } + neq { T TokenNEQ p _ } + gte { T TokenGTE p _ } + gt { T TokenGT p _ } + and { T TokenAnd p _ } + or { T TokenOr p _ } + let { T TokenLet p _ } + letrec { T TokenLetRec p _ } + in { T TokenIn p _ } + case { T TokenCase p _ } + of { T TokenOf p _ } + arrow { T TokenArrow p _ } + Pack { T TokenPack p _ } + '{' { T TokenLBrace p _ } + '}' { T TokenRBrace p _ } + '(' { T TokenLParen p _ } + ')' { T TokenRParen p _ } + ';' { T TokenSemiColon p _ } + ',' { T TokenComma p _ } + + + +%right ';' in +%nonassoc gt lt gte lte eq neq '.' Pack int var arrow '}' '{' '(' ')' +%left '+' '-' +%left '*' '/' and or + +%% + +program : sc { [$1] } + | sc ';' program { $1 : $3 } + +sc : var vars '=' expr { ($1, $2, $4) } + +vars : { [] } + | var vars { $1 : $2 } + +expr : expr aexpr { EAp $1 $2 } + | expr '+' expr { EAp (EAp (EVar "+") $1) $3 } + | expr '-' expr { EAp (EAp (EVar "-") $1) $3 } + | expr '*' expr { EAp (EAp (EVar "*") $1) $3 } + | expr '/' expr { EAp (EAp (EVar "/") $1) $3 } + | expr and expr { EAp (EAp (EVar "and") $1) $3 } + | expr or expr { EAp (EAp (EVar "or") $1) $3 } + | expr lt expr { EAp (EAp (EVar "<") $1) $3 } + | expr lte expr { EAp (EAp (EVar "<=") $1) $3 } + | expr eq expr { EAp (EAp (EVar "==") $1) $3 } + | expr neq expr { EAp (EAp (EVar "/=") $1) $3 } + | expr gte expr { EAp (EAp (EVar ">=") $1) $3 } + | expr gt expr { EAp (EAp (EVar ">") $1) $3 } + | let defns in expr { ELet nonRecursive $2 $4 } + | letrec defns in expr { ELet recursive $2 $4 } + | case expr of alts { ECase $2 $4 } + | lambda var vars '.' expr { ELam ($2 : $3) $5 } + | aexpr { $1 } + +aexpr : var { EVar $1 } + | int { ENum (read $1 :: Int) } + | Pack '{' int ',' int '}' '('exprs')' { EConstr (read $3 :: Int) (read $5 :: Int) $8} + | '('expr')' { $2 } + +exprs : { [] } + | exprsH { $1 } + +exprsH : expr { [$1] } + | expr ',' exprsH { $1 : $3 } + +defns : defn { [$1] } + | defn ';' defns { $1 : $3 } + +defn : var '=' expr { ($1, $3) } + +alts : alt ';' { [$1] } + | alt ';' alts { $1 : $3 } + +alt : lt int gt vars arrow expr { ((read $2 :: Int), $4, $6) } + +{ + +type IsRec = Bool + +recursive :: IsRec +recursive = True + +nonRecursive :: IsRec +nonRecursive = False + +parseError :: [Token] -> a +parseError ts = + case ts of + [] -> error "unexpected end of file" + token@(T t p s):_ -> + error $ "parse error " ++ showPos p ++ " - unexpected '" ++ show token ++ "'" + +} diff --git a/core-compiler.cabal b/core-compiler.cabal new file mode 100644 --- /dev/null +++ b/core-compiler.cabal @@ -0,0 +1,44 @@ +name: core-compiler +version: 0.1.0.0 +synopsis: compile your own mini functional language with Core +stability: functional +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 +homepage: https://github.com/aneksteind/Core#readme +license: MIT +license-file: LICENSE +author: David Anekstein +maintainer: aneksteind@gmail.com +copyright: 2016 David Anekstein +category: Compiler, Language +build-type: Simple +-- extra-source-files: +cabal-version: >=1.10 + +library + hs-source-dirs: src + exposed-modules: Core.Compiler, + Core.GMachine, + Core.Grammar, + Core.Prelude, + Core.Pretty + other-modules: Core.G + build-depends: base >= 4.7 && < 5, + unordered-containers, + containers, + text + default-language: Haskell2010 + +executable core-compiler-exe + main-is: Main.hs + hs-source-dirs: app + build-depends: base >=4.7, + core-compiler, + array + other-modules: Lexer, + Parser + build-tools: happy, alex + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/aneksteind/Core diff --git a/src/Core/Compiler.hs b/src/Core/Compiler.hs new file mode 100644 --- /dev/null +++ b/src/Core/Compiler.hs @@ -0,0 +1,187 @@ +module Core.Compiler (compile) where + +import Core.Grammar +import Core.G +import Core.Prelude +import Data.List +import qualified Data.Map as M (Map, keys, fromList, map, mapAccum, member, lookup, toList) + +type GmCompiledSC = (Name, Int, GmCode) + +type GmCompiler = CoreExpr -> GmEnvironment -> GmCode + +type GmEnvironment = M.Map Name Int + +-- | sets initial state, +-- binds the supercombinators to the environment, +-- and generates the initial G code +compile :: CoreProgram -> GmState +compile program = ([], initialCode, [], [], [], heap, globals, statInitial) where + (heap,globals) = buildInitialHeap program + +-- start with the main function and unwind from there +initialCode :: GmCode +initialCode = [Pushglobal "main", Eval, Print] + +statInitial :: GmStats +statInitial = 0 + +-- bind sc's, allocate corresponding nodes in heap +buildInitialHeap :: CoreProgram -> (GmHeap, GmGlobals) +buildInitialHeap program = (heap, M.fromList globals) where + (heap, globals) = mapAccumL allocateSc hInitial compiled + compiled = map compileSc (preludeDefs ++ program ++ primitives) + +-- allocate node in heap for supercombinator +allocateSc :: GmHeap -> GmCompiledSC -> (GmHeap, (Name, Addr)) +allocateSc heap (name, nargs, instructions) = (newHeap, (name, addr)) where + (newHeap, addr) = hAlloc heap (NGlobal nargs instructions) + +hInitial :: Heap a +hInitial = (0, 1, []) + +-- compile super combinator +compileSc :: (Name, [Name], CoreExpr) -> GmCompiledSC +compileSc (name, env, body) = + let d = length env in + (name, d, compileR d body $ M.fromList $ zip env [0..]) + +-- compile body (Expr) of super combinator, top level +compileR :: Int -> GmCompiler +compileR d (ELet recursive defs e) env + | recursive = compileLetrec (compileR (d + length defs)) Null defs e env + | otherwise = compileLet (compileR (d + length defs)) Null defs e env +compileR d (EAp (EAp (EAp (EVar "if") predicate) e1) e2) env = + compileB predicate env ++ [Cond (compileR d e1 env) (compileR d e2 env)] +compileR d (ECase e alts) env = compileE e env ++ + [Casejump $ compileD (compileAR d) alts env] +compileR d e env = + compileE e env ++ [Update d, Pop d, Unwind] + +-- strictly compile expression to WHNF +-- leaves a pointer to the expression on top of stack +compileE :: GmCompiler +compileE (ENum i) env = [Pushint i] +compileE (ELet recursive defs e) args + | recursive = compileLetrec compileE (Final Slide) defs e args + | otherwise = compileLet compileE (Final Slide) defs e args +compileE (ECase e alts) env = compileE e env ++ + [Casejump $ compileD compileAE alts env] +compileE (EConstr t n es) env | length es == n = + compileConstrArgs n es env ++ [Pack t n] + | otherwise = + error $ "too many or too little arguments in constructor " ++ show t +compileE e@(EAp (EAp (EVar op) e1) e2) env = + let maybeBinop = M.lookup op builtInDyadic + mkCode Arith = [Mkint] + mkCode Comp = [Mkbool] in + case maybeBinop of + Just (binop, dyad) -> compileB e env ++ mkCode dyad + Nothing -> compileC e env ++ [Eval] +compileE b@(EAp (EVar "negate") e1) env = compileB b env ++ [Mkint] +compileE (EAp (EAp (EAp (EVar "if") predicate) e1) e2) env = + compileB predicate env ++ [Cond (compileE e1 env) (compileE e2 env)] +compileE e env = compileC e env ++ [Eval] + +-- compiles expression that needs evaluation to WHNF +-- also must be of type Int or Bool +-- leaves the result on top of the V stack +compileB :: GmCompiler +compileB (ENum i) env = [Pushbasic i] +compileB (ELet recursive defs e) args + | recursive = compileLetrec compileB (Final Pop) defs e args + | otherwise = compileLet compileB (Final Pop) defs e args +compileB e@(EAp (EAp (EVar op) e1) e2) env = + let maybeBinop = M.lookup op builtInDyadic in + case maybeBinop of + Just (binop,_) -> compileB e2 env ++ compileB e1 env ++ [binop] + _ -> compileE e env +compileB (EAp (EVar "negate") e1) env = compileB e1 env ++ [Neg] +compileB (EAp (EAp (EAp (EVar "if") predicate) e1) e2) env = + compileB predicate env ++ [Cond (compileB e1 env) (compileB e2 env)] +compileB e env = compileE e env ++ [Get] + +-- lazily compile expression +compileC :: GmCompiler +compileC (EVar v) env | elem v (M.keys env) = + let n = M.lookup v env in case n of Just num -> [Push num] + Nothing -> error "compileC: variable not in environment" + | otherwise = [Pushglobal v] +compileC (ENum nm) env = [Pushint nm] +compileC (EAp e1 e2) env = + compileC e2 env ++ compileC e1 (argOffset 1 env) ++ [Mkap] +compileC (EConstr t n es) env | length es == n = compileConstrArgs n es env ++ [Pack t n] + | otherwise = error $ "too many or too little arguments in constructor " ++ show t +compileC (ECase e alts) env = compileE e env ++ + [Casejump $ compileD compileAE alts env] +compileC (ELet recursive defs e) args + | recursive = compileLetrec compileC (Final Slide) defs e args + | otherwise = compileLet compileC (Final Slide) defs e args + +-- compile cases for case expressions +compileD :: (Int -> GmCompiler) -> [CoreAlt] -> GmEnvironment -> [(Int, GmCode)] +compileD comp alts env = + [(tag, comp (length names) body (M.fromList (zip names [0..] ++ (M.toList $ argOffset (length names) env)))) + | (tag, names, body) <- alts] + +-- compiles the code for an alternative for E context +compileAE :: Int -> GmCompiler +compileAE offset expr env = [Split offset] ++ compileE expr env ++ [Slide offset] + +-- compiles the code for an alternative for R context +compileAR :: Int -> Int -> GmCompiler +compileAR d offset expr env = [Split offset] ++ compileR (offset + d) expr env + +-- compiles let expression, last instruction depends on context +compileLet :: GmCompiler -> FinalInstruction -> [(Name, CoreExpr)] -> GmCompiler +compileLet comp (Final inst) defs expr env = + compileLetH2 comp defs expr env ++ [inst (length defs)] +compileLet comp Null defs expr env = + compileLetH2 comp defs expr env + +compileLetH :: [(Name, CoreExpr)] -> GmEnvironment -> GmCode +compileLetH [] env = [] +compileLetH ((name, expr):defs) env = + compileC expr env ++ compileLetH defs (argOffset 1 env) + +compileLetH2 :: GmCompiler -> [(Name, CoreExpr)] -> GmCompiler +compileLetH2 comp defs expr env = compileLetH defs env ++ comp expr newEnv where + newEnv = compileArgs defs env + +-- compiles recursive let expression, last instruction depends on context +compileLetrec :: GmCompiler -> FinalInstruction -> [(Name, CoreExpr)] -> GmCompiler +compileLetrec comp (Final inst) defs expr env = + compileLetrecH2 comp defs expr env ++ [inst (length defs)] +compileLetrec comp Null defs expr env = + compileLetrecH2 comp defs expr env + +compileLetrecH :: [(Name, CoreExpr)] -> GmEnvironment -> Int -> GmCode +compileLetrecH [] env n = [] +compileLetrecH ((name, expr):defs) env n = + compileC expr env ++ [Update n] ++ (compileLetrecH defs env (n-1)) + +compileLetrecH2 :: GmCompiler -> [(Name, CoreExpr)] -> GmCompiler +compileLetrecH2 comp defs expr env = + [Alloc n] ++ compileLetrecH defs newEnv (n-1) ++ + comp expr newEnv where + newEnv = compileArgs defs env + n = (length defs) + +-- compile the arguments of a let expression +compileArgs :: [(Name, CoreExpr)] -> GmEnvironment -> GmEnvironment +compileArgs defs env = + M.fromList $ zip (map fst defs) [n-1, n-2 .. 0] ++ (M.toList $ argOffset n env) where + n = length defs + +-- compile the arguments of a data type +compileConstrArgs :: Int -> [CoreExpr] -> GmEnvironment -> GmCode +compileConstrArgs numArgs (e:es) env = + let compiled = foldl iterCode base es + iterCode = (\(code, n) x -> ((compileC x (argOffset n env))++code, n+1)) + base = ((compileC e env),1) + in fst compiled +compileConstrArgs numArgs [] env = [] + +-- offsets env bindings by n +argOffset :: Int -> GmEnvironment -> GmEnvironment +argOffset n env = M.map (\v -> v + n) env diff --git a/src/Core/G.hs b/src/Core/G.hs new file mode 100644 --- /dev/null +++ b/src/Core/G.hs @@ -0,0 +1,198 @@ +module Core.G where + +import qualified Data.Map as M +import Core.Grammar + +type GmState = (GmOutput, -- ^ current output + GmCode, -- ^ current instruction stream + GmStack, -- ^ current stack + GmDump, -- ^ a stack for WHNF reductions + GmVStack, -- ^ current v-stack + GmHeap, -- ^ heap of nodes + GmGlobals, -- ^ global addresses in heap + GmStats) -- ^ statistics + +type GmOutput = [Char] + +type GmCode = [Instruction] + +type GmStack = [Addr] + +type GmDump = [GmDumpItem] +type GmDumpItem = (GmCode, GmStack) + +type GmVStack = [Int] + +type GmHeap = Heap Node + +type GmGlobals = M.Map Name Addr + +type GmStats = Int + +-- | G code instructions +data Instruction = Unwind + | Pushbasic Int + | Pushglobal Name + | Pushint Int + | Push Int + | Get + | Mkap + | Mkint + | Mkbool + | Update Int + | Pop Int + | Slide Int + | Alloc Int + | Eval + | Add | Sub | Mul | Div | Neg + | Eq | Ne | Lt | Le | Gt | Ge + | Cond GmCode GmCode + | Pack Int Int + | Casejump [(Int, GmCode)] -- TODO: map + | Split Int + | Print deriving (Show) + +instance Eq Instruction where + Unwind == Unwind = True + Pushglobal a == Pushglobal b = a == b + Pushint a == Pushint b = a == b + Push a == Push b = a == b + Mkap == Mkap = True + Update a == Update b = a == b + _ == _ = False + +-- | represents a node that is put into the heap +data Node = NNum Int -- ^ Numbers + | NAp Addr Addr -- ^ Applications + | NGlobal Int GmCode -- ^ Globals + | NInd Addr -- ^ Indirections + | NConstr Int [Addr] -- ^ Constructing a data type + deriving (Show) + +instance Eq Node where + NNum a == NNum b = a == b -- needed to check conditions + NAp a b == NAp c d = False -- not needed + NGlobal a b == NGlobal c d = False -- not needed + NInd a == NInd b = False -- not needed + NConstr a b == NConstr c d = False -- not needed + + +type Heap a = (Int, Addr, [(Int, a)]) -- TODO: map + +type Addr = Int + +-- the final instruction of a given code sequence +data FinalInstruction = Final (Int -> Instruction) | Null + +type Boxer b = (b -> GmState -> GmState) +type Unboxer a = (Addr -> GmState -> a) +type MOperator a b = (a -> b) +type DOperator a b = (a -> a -> b) +type StateTran = (GmState -> GmState) + +data Dyad = Arith | Comp + +isAtomicExpr :: Expr a -> Bool +isAtomicExpr (EVar v) = True +isAtomicExpr (ENum n) = True +isAtomicExpr e = False + +builtInDyadic :: M.Map Name (Instruction, Dyad) +builtInDyadic = + M.fromList [("+", (Add, Arith)), ("-", (Sub, Arith)), ("*", (Mul, Arith)), ("/", (Div, Arith)), + ("==", (Eq, Comp)), ("/=", (Ne, Comp)), (">=", (Ge, Comp)), + (">", (Gt, Comp)), ("<=", (Le, Comp)), ("<", (Lt, Comp))] + +--------------------------- GMSTATE FUNCTIONS --------------------------- + +getOutput :: GmState -> GmOutput +getOutput (o,i ,stack, dump, vstack, heap, globals, stats) = o + +putOutput :: GmOutput -> GmState -> GmState +putOutput newO (output, code, stack, dump, vstack, heap, globals, stats) = + (newO, code, stack, dump, vstack, heap, globals, stats) + +getCode :: GmState -> GmCode +getCode (output, code, stack, dump, vstack, heap, globals, stats) = code + +putCode :: GmCode -> GmState -> GmState +putCode newCode (output, oldCode, stack, dump, vstack, heap, globals, stats) = + (output, newCode, stack, dump, vstack, heap, globals, stats) + +getStack :: GmState -> GmStack +getStack (output, i, stack, dump, vstack, heap, globals, stats) = stack + +putStack :: GmStack -> GmState -> GmState +putStack newStack (output, i, oldStack, dump, vstack, heap, globals, stats) = + (output, i, newStack, dump, vstack, heap, globals, stats) + +getDump :: GmState -> GmDump +getDump (output, i, stack, dump, vstack, heap, globals, stats) = dump + +putDump :: GmDump -> GmState -> GmState +putDump newDump (output, i, stack, dump, vstack, heap, globals, stats) = + (output, i, stack, newDump, vstack, heap, globals, stats) + +getVStack :: GmState -> GmVStack +getVStack (o, i, stack, dump, vstack, heap, globals, stats) = vstack + +putVStack :: GmVStack -> GmState -> GmState +putVStack newVstack (o, i, stack, dump, vstack, heap, globals, stats) = + (o, i, stack, dump, newVstack, heap, globals, stats) + +getHeap :: GmState -> GmHeap +getHeap (output, i, stack, dump, vstack, heap, globals, stats) = heap + +putHeap :: GmHeap -> GmState -> GmState +putHeap newHeap (output, i, stack, dump, vstack, oldHeap, globals, stats) = + (output, i, stack, dump, vstack, newHeap, globals, stats) + +getGlobals :: GmState -> GmGlobals +getGlobals (output, i, stack, dump, vstack, heap, globals, stats) = globals + +putGlobals :: Name -> Addr -> GmState -> GmState +putGlobals name addr (output, code, stack, dump, vstack, heap, globals, stats) = + let newGlobals = M.insert name addr globals + in (output, code, stack, dump, vstack, heap, newGlobals, stats) + +getStats :: GmState -> GmStats +getStats (output, i, stack, dump, vstack, heap, globals, stats) = stats + +putStats :: GmStats -> GmState -> GmState +putStats newStats (output, i, stack, dump, vstack, heap, globals, oldStats) = + (output, i, stack, dump, vstack, heap, globals, newStats) + +statIncSteps :: GmStats -> GmStats +statIncSteps s = s+1 + + +-- adds a node the heap, a new address is created +hAlloc :: Heap a -> a -> (Heap a, Addr) +hAlloc (size, address, cts) n = ((size+1, address+1, (address,n) : cts),address) + +-- replaces a the node at address "a" with a new node "n" +-- TODO: see remove function +hUpdate :: Heap a -> Addr -> a -> Heap a +hUpdate (size, free, cts) a n = (size, free, (a,n) : remove cts a) + +-- looks up a node in a heap +hLookup :: Heap Node -> Addr -> Maybe Node +hLookup (size,free,cts) a = lookup a cts + +-- returns the addresses from the paired (Name, Address) list +hAddresses :: Heap a -> [Addr] +hAddresses (size, free, cts) = [addr | (addr, node) <- cts] + +hSize :: Heap a -> Int +hSize (size, free, cts) = size + +hNull :: Addr +hNull = 0 + +hIsnull :: Addr -> Bool +hIsnull a = a == 0 + +remove :: [(Int,a)] -> Int -> [(Int,a)] +remove [] a = error "hUpdate: nothing in the heap matches the given address" +remove ((val,n):cts) match | match == val = cts + | match /= val = (val,n) : remove cts match diff --git a/src/Core/GMachine.hs b/src/Core/GMachine.hs new file mode 100644 --- /dev/null +++ b/src/Core/GMachine.hs @@ -0,0 +1,334 @@ +module Core.GMachine (eval) where + +import Core.Grammar +import Core.G +import qualified Data.Map as M (Map, lookup, insert, fromList) + + + +--------------------------- EVALUATOR --------------------------- + +-- | executes the g-machine by executing each instruction +-- each execution of an instruction is cons'ed to the list +-- the last state in the list is the final instruction +eval :: GmState -> [GmState] +eval state = state : restStates where + restStates | gmFinal state = [] + | otherwise = eval nextState + nextState = doAdmin (step state) + +-- checks to see if the current state is the final one +-- the state is final if all of the code has been executed +gmFinal :: GmState -> Bool +gmFinal s = case (getCode s) of [] -> True + otherwise -> False + +-- increases the statistics, puts the new value into the state +doAdmin :: GmState -> GmState +doAdmin s = putStats (statIncSteps (getStats s)) s + +-- makes a state transistion based on the instruction +-- takes out the current instruction from the instruction list +step :: GmState -> GmState +step state = dispatch i (putCode is state) where + (i:is) = getCode state + +-- executes the current instruction +-- moves the machine to the next state +dispatch :: Instruction -> GmState -> GmState +dispatch (Pushglobal f) = pushglobal f +dispatch (Pushint n) = pushint n +dispatch (Pushbasic n) = pushbasic n +dispatch Mkap = mkap +dispatch Mkint = mkInt +dispatch Mkbool = mkBool +dispatch (Push n) = push n +dispatch (Pop n) = pop n +dispatch (Update n) = update n +dispatch Unwind = unwind +dispatch (Slide n) = slide n +dispatch (Alloc n) = alloc n +dispatch Eval = evalI +dispatch Add = add +dispatch Sub = sub +dispatch Mul = mul +dispatch Div = divide +dispatch Neg = neg +dispatch Eq = eq +dispatch Ne = ne +dispatch Lt = lt +dispatch Le = le +dispatch Gt = gt +dispatch Ge = ge +dispatch (Cond c1 c2) = cond c1 c2 +dispatch (Pack t n) = pack t n +dispatch (Casejump cases) = casejump cases +dispatch (Split n) = split n +dispatch Print = printt +dispatch Get = get + +-- finds the global node in the heap +-- pushes the address of the global node onto the stack +pushglobal :: Name -> GmState -> GmState +pushglobal f state = let a = M.lookup f (getGlobals state) in + case a of Just add -> putStack (add: getStack state) state + Nothing -> error ("pushglobal: global " ++ f ++ " not found in globals") + +-- adds an integer node onto the heap +-- pushes the new address onto the stack +pushint :: Int -> GmState -> GmState +pushint n state = + let maybeAddr = M.lookup (show n) (getGlobals state) + pushintHelper s = putHeap newHeap (putStack (a: getStack s) s) + (newHeap, a) = hAlloc (getHeap state) (NNum n) in + case maybeAddr of Just addr -> (putStack (addr: getStack state) state) where + Nothing -> pushintHelper $ putGlobals (show n) a state + +-- pushes an int ont the V stack +pushbasic :: Int -> GmState -> GmState +pushbasic n state = + let vstack = getVStack state in putVStack (n:vstack) state + +-- takes the 2 addresses at the top of the address stack +-- and combines them into one address +-- also constructs an application node and puts it in the heap +mkap :: GmState -> GmState +mkap state = + putHeap newHeap (putStack (newAddress:addresses) state) where + (newHeap, newAddress) = hAlloc (getHeap state) (NAp a1 a2) + (a1:a2:addresses) = getStack state + +-- moves an int value from the V stack to the heap +mkInt :: GmState -> GmState +mkInt state = + let stack = getStack state + heap = getHeap state + (n:v) = getVStack state + (newHeap, add) = hAlloc heap (NNum n) + in putVStack v $ putStack (add:stack) $ putHeap newHeap state + +-- moves a bool value from the V stack to the heap +mkBool :: GmState -> GmState +mkBool state = + let stack = getStack state + heap = getHeap state + (t:v) = getVStack state + (newHeap, add) = hAlloc heap (NConstr t []) + in putVStack v $ putStack (add:stack) $ putHeap newHeap state + +-- gets the current address stack +-- pushes the A(nth) address on top of the stack +push :: Int -> GmState -> GmState +push n state = + let as = getStack state + a = (as !! n) in putStack (a:as) state + +-- drops the top n addresses from the stack +pop :: Int -> GmState -> GmState +pop n state = putStack (drop n stack) state where + stack = getStack state + +-- updates the nth address in the stack with an indirection node +update :: Int -> GmState -> GmState +update n state = + let (a:as) = getStack state + in putHeap (hUpdate (getHeap state) (as !! n) (NInd a)) (putStack as state) + + +------------------------------------------------------------ +-- unravels the spine of the graph +unwind :: GmState -> GmState +unwind state = + let stack@(a:as) = getStack state + dump = getDump state + heap = getHeap state + replaceAddrs name = putStack (rearrange name heap stack) + n = (hLookup heap a) + newState (NNum num) = updateFromDump a dump state + newState (NConstr t s) = updateFromDump a dump state + newState (NAp a1 a2) = putCode [Unwind] (putStack (a1:a:as) state) + newState (NInd ia) = putCode [Unwind] (putStack (ia:as) state) + newState (NGlobal na c) | length as < na = + case dump of ((i,s):d) -> putCode i $ + putStack ((last stack):s) $ + putDump d state + [] -> error "unwind: dump should not be empty" + | otherwise = + replaceAddrs na $ putCode c state in + case n of Just node -> newState node + Nothing -> error "unwind: address not found in heap" + +-- takes the code and address from the dump and returns them +updateFromDump :: Addr -> GmDump -> GmState -> GmState +updateFromDump address dump state = + case dump of [] -> state + ((i,s):d) -> putDump d $ + putCode i $ + putStack (address:s) state + +-- replaces the application node addresses in the stack with +-- the addresses of the value being applied to +rearrange :: Int -> GmHeap -> GmStack -> GmStack +rearrange n heap as = + let newAs = mapM ((getArg =<<) . hLookup heap) (tail as) in + case newAs of Just addrs -> take n addrs ++ drop n as + Nothing -> error "rearrange: address not found in heap" + +getArg :: Node -> Maybe Addr +getArg (NAp a1 a2) = return a2 + +------------------------------------------------------------ + +-- takes the address at the top of the stack +-- drops the next n addresses from the stack +-- reattaches the address to the stack +slide :: Int -> GmState -> GmState +slide n state = putStack (a : drop n as) state where + (a:as) = getStack state + +-- puts empty indirection nodes in the heap for updating later +alloc :: Int -> GmState -> GmState +alloc n state = let (newHeap, addrs) = allocNodes n (getHeap state) + stack = getStack state in + putHeap newHeap $ putStack (addrs ++ stack) state + +-- allocates an empty indirection node in the heap +allocNodes :: Int -> GmHeap -> (GmHeap, [Addr]) +allocNodes 0 heap = (heap, []) +allocNodes n heap = (heap2, a:as) where + (heap1, as) = allocNodes (n-1) heap + (heap2, a) = hAlloc heap1 (NInd hNull) + +-- unwinds top address node, +-- puts the rest of code and addresses in the dump +evalI :: GmState -> GmState +evalI state = + let code = getCode state + (a:as) = getStack state + dump = getDump state in + putCode [Unwind] $ putStack [a] $ putDump ((code, as):dump) state + +------------------------------------------------------------ + +add :: GmState -> GmState +add state = arithmetic2 (+) state + +sub :: GmState -> GmState +sub state = arithmetic2 (-) state + +divide :: GmState -> GmState +divide state = arithmetic2 (div) state + +mul :: GmState -> GmState +mul state = arithmetic2 (*) state + +neg :: GmState -> GmState +neg state = arithmetic1 (* (-1)) state + +eq :: GmState -> GmState +eq state = comparison (==) state + +ne :: GmState -> GmState +ne state = comparison (/=) state + +le :: GmState -> GmState +le state = comparison (<=) state + +lt :: GmState -> GmState +lt state = comparison (<) state + +gt :: GmState -> GmState +gt state = comparison (>) state + +ge :: GmState -> GmState +ge state = comparison (>=) state + +-- compares the top two numbers on the V stack +comparison :: (Int -> Int -> Bool) -> StateTran +comparison op state = + let (a0:a1:as) = getVStack state + bool = (a0 `op` a1) + vBool n = putVStack (n:as) state in + if bool then vBool 2 else vBool 1 + +-- applies the monadic operation to the top V stack number +arithmetic1 :: MOperator Int Int -> StateTran +arithmetic1 op state = putVStack (op a : v) state where + (a:v) = getVStack state + +-- applies the dyadic operator to the top two V stack numbers +arithmetic2 :: DOperator Int Int -> StateTran +arithmetic2 op state = putVStack ((a0 `op` a1):as) state where + (a0:a1:as) = getVStack state + +------------------------------------------------------------ + +-- gets the top value of V stack, +-- if 2 (True), evaluate the t code +-- if 1 (False), evaluate the f code +cond :: GmCode -> GmCode -> GmState -> GmState +cond t f state = + let (n:v) = getVStack state + i = getCode state in + case n of 2 -> putCode (t++i) $ putVStack v state + 1 -> putCode (f++i) $ putVStack v state + _ -> error $ "cond: the number " ++ show n ++ " is not valid" + +-- creates a new data type, adds it to heap +-- adds address of new datatype to stack +pack :: Int -> Int -> GmState -> GmState +pack t n state = + let stack = getStack state + heap = getHeap state + (newHeap, a) = hAlloc heap (NConstr t (take n stack)) in + putStack (a:(drop n stack)) $ putHeap newHeap state + +-- adds the code of the matching case expression to the code +casejump :: [(Int, GmCode)] -> GmState -> GmState +casejump cases state = + let (a:s) = getStack state + i = getCode state + heap = getHeap state + maybeNode = hLookup heap a + maybeCode typ = lookup typ cases + message t = "code for <" ++ show t ++ "> not found in cases" + typeCode t = case (maybeCode t) of Just code -> code + _ -> error (message t) in + case maybeNode of Just (NConstr t ss) -> putCode ((typeCode t)++i) state + _ -> error "casejump: node not found in heap" + +-- adds the addresses referenced by the data type to the stack +split :: Int -> GmState -> GmState +split n state = + let (a:as) = getStack state + heap = getHeap state + maybeNC = hLookup heap a in + case maybeNC of Just (NConstr t s) -> putStack (s++as) state + _ -> error "split: node not found in heap" + +-- puts the output of the program into the output +printt :: GmState -> GmState +printt state = + let (a:as) = getStack state + heap = getHeap state + output = getOutput state + i = getCode state + appP xs = take (2 * (length xs)) $ cycle [Eval, Print] + maybeNode = hLookup heap a in + case maybeNode of + Just (NNum n) -> putStack as $ putOutput (output ++ " " ++ (show n)) state + Just (NConstr t s) -> putOutput ("<" ++ show t ++ ">") $ putCode ((appP s)++i) $ putStack (s++as) state + _ -> error $ "address " ++ show a ++ " not found in heap" + +-- gets a number or a data type's #args from the heap +-- adds it to the V stack +get :: GmState -> GmState +get state = + let (a:as) = getStack state + heap = getHeap state + maybeNode = hLookup heap a + v = getVStack state + getH val = putStack as $ putVStack (val:v) state + in case maybeNode of Just (NConstr t _) -> getH t + Just (NNum n) -> getH n + _ -> error "get: node not found in heap" diff --git a/src/Core/Grammar.hs b/src/Core/Grammar.hs new file mode 100644 --- /dev/null +++ b/src/Core/Grammar.hs @@ -0,0 +1,48 @@ +module Core.Grammar (CoreExpr(..), + Expr(..), + Name, + CoreAlt(..), + Alter(..), + CoreProgram(..), + Program(..), + CoreScDefn(..), + ScDefn(..)) where + +-- | AST of the Core language +data Expr a = EVar Name -- ^ a variable + | ENum Int -- ^ an Int + | EConstr Int Int [Expr a] -- ^ a type declaration + | EAp (Expr a) (Expr a) -- ^ function application + | ELet Bool [(a, Expr a)] (Expr a) -- ^ let/letrec expression + | ECase (Expr a) [Alter a] -- ^ case expression + | ELam [a] (Expr a) -- ^ lambda expression (not yet implemented) + deriving (Show, Eq) + +-- | A Core expression +type CoreExpr = Expr Name + +type Name = String + + + +-- | a case alternative for a given datatype +type Alter a = (Int -- ^ the datatype number + ,[a] -- ^ a list of local variable names + , Expr a -- ^ the expression that the case evaluates to + ) + +-- | a case alternative +type CoreAlt = Alter Name + +type Program a = [ScDefn a] + +-- | A list of super combinator definitions +type CoreProgram = Program Name + +type ScDefn a = (Name -- ^ the name of the function/global + ,[a] -- ^ the list of local variable names + , Expr a -- ^ the expression the supercombinator evaluates to + ) + +-- | A supercombinator definition +type CoreScDefn = ScDefn Name diff --git a/src/Core/Prelude.hs b/src/Core/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/Core/Prelude.hs @@ -0,0 +1,33 @@ +module Core.Prelude where + +import Core.Grammar + +-- | simple but important functions in Core +preludeDefs :: CoreProgram +preludeDefs = [ ("I", ["x"], EVar "x"), + ("K", ["x","y"], EVar "x"), + ("K1",["x","y"], EVar "y"), + ("S", ["f","g","x"], EAp (EAp (EVar "f") (EVar "x")) + (EAp (EVar "g") (EVar "x"))), + ("compose", ["f","g","x"], EAp (EVar "f") + (EAp (EVar "g") (EVar "x"))), + ("twice", ["f"], EAp (EAp (EVar "compose") (EVar "f")) (EVar "f"))] + +-- | primitive operations +primitives :: CoreProgram +primitives = + [("+", ["x","y"], (EAp (EAp (EVar "+") (EVar "x")) (EVar "y"))), + ("-", ["x","y"], (EAp (EAp (EVar "-") (EVar "x")) (EVar "y"))), + ("*", ["x","y"], (EAp (EAp (EVar "*") (EVar "x")) (EVar "y"))), + ("/", ["x","y"], (EAp (EAp (EVar "/") (EVar "x")) (EVar "y"))), + ("negate", ["x"], (EAp (EVar "negate") (EVar "x"))), + ("==", ["x","y"], (EAp (EAp (EVar "==") (EVar "x")) (EVar "y"))), + ("˜=", ["x","y"], (EAp (EAp (EVar "˜=") (EVar "x")) (EVar "y"))), + (">=", ["x","y"], (EAp (EAp (EVar ">=") (EVar "x")) (EVar "y"))), + (">", ["x","y"], (EAp (EAp (EVar ">") (EVar "x")) (EVar "y"))), + ("<=", ["x","y"], (EAp (EAp (EVar "<=") (EVar "x")) (EVar "y"))), + ("<", ["x","y"], (EAp (EAp (EVar "<") (EVar "x")) (EVar "y"))), + ("if", ["c","t","f"], + (EAp (EAp (EAp (EVar "if") (EVar "c")) (EVar "t")) (EVar "f"))), + ("True", [], (EConstr 2 0 [])), + ("False", [], (EConstr 1 0 []))] diff --git a/src/Core/Pretty.hs b/src/Core/Pretty.hs new file mode 100644 --- /dev/null +++ b/src/Core/Pretty.hs @@ -0,0 +1,278 @@ +module Core.Pretty (pprint, + showResults, + showFinalResult, + Printer(..)) where + + +import Core.Grammar +import Core.G +import qualified Data.Map as M (toList, member, fromList, Map) + +data Iseq = INil + | IStr String + | IAppend Iseq Iseq + | IIndent Iseq + | INewline + deriving (Show, Eq) + +type Printer = [GmState] -> [Char] + +-- | pretty prints a core program +pprint :: CoreProgram -> String +pprint prog = iDisplay (pprProgram prog) + +pprProgram :: CoreProgram -> Iseq +pprProgram scdefns = + flip iAppend iNewline (iInterleave (iStr ";" `iAppend` iNewline) $ map pprScDefn scdefns) + +-- pretty prints a supercombinator definition +pprScDefn :: CoreScDefn -> Iseq +pprScDefn (name, vars, expr) = + (iStr name) `iAppend` iStr " " `iAppend` (iInterleave (iStr " ") (map iStr vars)) + `iAppend` maybeSpace `iAppend` (pprExpr expr) + where maybeSpace = case vars of [] -> iStr "= " + _ -> iStr " = " + +-- pretty prints expressions +pprExpr :: CoreExpr -> Iseq +pprExpr (ENum n) = iNum n +pprExpr (EVar v) = iStr v +pprExpr (EAp (EAp (EVar op) e1) e2) | M.member op builtInDyadic = + iConcat [ pprAExpr e1,iStr " ", iStr op,iStr " ", pprAExpr e2 ] + | otherwise = + (pprExpr e1) `iAppend` (iStr " ") `iAppend` (pprAExpr e2) +pprExpr (EAp e1 e2) = (pprExpr e1) `iAppend` (iStr " ") `iAppend` (pprAExpr e2) +pprExpr (ELet isrec defns expr) = + iConcat [ iStr keyword, iIndent (pprDefns defns), iStr " in " `iAppend` pprExpr expr ] + where keyword | not isrec = "let" + | isrec = "letrec" +pprExpr (ECase e1 patterns) = + iConcat [ iStr "case ", (pprExpr e1), iStr " of ", iIndent $ pprPatterns patterns ] +pprExpr (ELam vars expr) = + iConcat [ iStr "(lambda (", iInterleave (iStr " ") (map iStr vars), + iStr ") ", pprExpr expr, iStr ")"] +pprExpr (EConstr i1 i2 es) = + iConcat [ iStr "Pack {", iStr $ show i1, + iStr ", ", iStr $ show i2, iStr "}"] `iAppend` + (iConcat $ map pprExpr es) + +-- pretty prints case alts +pprPatterns :: [CoreAlt] -> Iseq +pprPatterns patterns = + iNewline `iAppend` iInterleave (iStr "; " `iAppend` iNewline) (map pprPattern patterns) + +pprPattern :: CoreAlt -> Iseq +pprPattern (int, vars@(v:vs), result) = iConcat $ + [iStr "<", iStr $ show int, iStr "> ", + iInterleave (iStr " ") (map iStr vars), + iStr " -> ", pprExpr result] +pprPattern (int, [], result) = iConcat $ + [iStr "<", iStr $ show int, iStr ">", + iStr " -> ", pprExpr result] + +-- pretty prints let definitions +pprDefns :: [(Name, CoreExpr)] -> Iseq +pprDefns defns = iNewline `iAppend` iInterleave sep (map pprDefn defns) + where sep = iConcat [ iStr ";", iNewline ] + +pprDefn :: (Name, CoreExpr) -> Iseq +pprDefn (name, expr) = iConcat [ iStr name, iStr " = ", pprExpr expr ] + +-- pretty prints a single expression +pprAExpr :: CoreExpr -> Iseq +pprAExpr e | isAtomicExpr e = pprExpr e + | otherwise = (iStr "(") `iAppend` (pprExpr e) `iAppend` (iStr ")") + +iNil :: Iseq +iNil = INil + +-- pretty prints a string +iStr :: String -> Iseq +iStr str = IStr str + +-- pretty prints an int +iNum :: Int -> Iseq +iNum n = IStr $ show n + +-- pretty prints digits with proper spacing +iFWNum :: Int -> Int -> Iseq +iFWNum width n = iStr (space (width - length digits) ++ digits) + where digits = show n + +-- prints out a numbered list of other sequences +iLayn :: [Iseq] -> Iseq +iLayn seqs = iConcat (map lay_item (zip [1..] seqs)) + where lay_item (n, seq) = iConcat [ iFWNum 4 n, iStr ") ", iIndent seq, iNewline ] + +-- append two iseqs +iAppend :: Iseq -> Iseq -> Iseq +iAppend seq1 seq2 | seq2 == INil = seq1 + | seq1 == INil = seq1 + | otherwise = IAppend seq1 seq2 + +iNewline :: Iseq +iNewline = INewline + +iIndent :: Iseq -> Iseq +iIndent s = IIndent s + +iDisplay :: Iseq -> String +iDisplay s = flatten 0 [(s,0)] + +-- keeps track of the current column as well as +-- a work list that includes the current iseq and +-- the indentation for it +flatten :: Int -> [(Iseq,Int)] -> String +flatten col [] = "" +flatten col (((INil), indent):seqs) = flatten col seqs +flatten col (((IStr s), indent):seqs) = s ++ (flatten col seqs) +flatten col (((IAppend seq1 seq2), indent):seqs) = flatten col ((seq1,indent) : (seq2,indent) : seqs) +flatten col ((INewline, indent):seqs) = '\n' : (space indent) ++ (flatten indent seqs) +flatten col ((IIndent s, indent):seqs) = (flatten col ((s, col+4):seqs)) + +space :: Int -> String +space n = take n $ repeat ' ' + +-- appends a list of iseqs +iConcat :: [Iseq] -> Iseq +iConcat iseqs = foldr (\iseq acc -> iseq `iAppend` acc) iNil iseqs + +iInterleave :: Iseq -> [Iseq] -> Iseq +iInterleave sep (i:is) = iConcat $ i : prependToAll sep is +iInterleave sep [] = iNil + +-- puts a character before each element in a list +prependToAll sep (i:is) = sep : (i : prependToAll sep is) +prependToAll sep [] = [] + +--builds sample expressions of n size +mkMultiAp :: Int -> CoreExpr -> CoreExpr -> CoreExpr +mkMultiAp n e1 e2 = foldl EAp e1 (take n e2s) + where e2s = e2 : e2s + +--------------------------- SHOW COMPILATION --------------------------- + +-- | outputs the final result of evaluating a program with the G machine +showFinalResult :: Printer +showFinalResult states = iDisplay $ showOutput (last states) + +-- | outputs each step the GMachine makes in compiling a program +showResults :: Printer +showResults states = iDisplay (iConcat [ + iNewline, iStr "-----Supercombinator definitions-----", iNewline, iNewline, + iInterleave iNewline (map (showSC s) (M.toList $ getGlobals s)), + iNewline, iNewline, iStr "-----State transitions-----", iNewline, iNewline, + iLayn (map showState states), iNewline, + showStats (last states)]) where (s:ss) = states + +showSC :: GmState -> (Name, Addr) -> Iseq +showSC s (name, addr) = + let maybeAdd = (hLookup (getHeap s) addr) + in case maybeAdd of Just (NGlobal arity code) -> showSCresult name code + Nothing -> error "global not found in heap" + +showSCresult :: Name -> GmCode -> Iseq +showSCresult name code = iConcat [ iStr "Code for ", + iStr name, iNewline, showInstructions code, iNewline, iNewline] + +showInstructions :: GmCode -> Iseq +showInstructions is = iConcat [iStr " Code:{", + iIndent (iInterleave iNewline (map showInstruction is)), + iStr "}", iNewline] + +showInstruction :: Instruction -> Iseq +showInstruction (Pushglobal f) = (iStr "Pushglobal ") `iAppend` (iStr f) +showInstruction (Push n) = (iStr "Push ") `iAppend` (iNum n) +showInstruction (Pushint n) = (iStr "Pushint ") `iAppend` (iNum n) +showInstruction (Update n) = (iStr "Update ") `iAppend` (iNum n) +showInstruction (Pop n) = (iStr "Pop ") `iAppend` (iNum n) +showInstruction (Slide n) = (iStr "Slide ") `iAppend` (iNum n) +showInstruction (Alloc n) = (iStr "Alloc ") `iAppend` (iNum n) +showInstruction (Cond cond1 cond2) = + (iStr "Cond {") `iAppend` showInstructions cond1 `iAppend` showInstructions cond2 +showInstruction (Pack n1 n2) = + (iStr "Pack{") `iAppend` (iNum n1) `iAppend` (iStr ",") `iAppend` + (iNum n2) `iAppend` (iStr "}") +showInstruction (Casejump cases) = (iStr "Casejump [") `iAppend` showCases cases +showInstruction (Split n) = (iStr "Split ") `iAppend` (iNum n) +showInstruction inst = iStr $ show inst + +showCases :: [(Int, GmCode)] -> Iseq +showCases cases = iInterleave iNewline $ map showCase cases + +showCase :: (Int, GmCode) -> Iseq +showCase (i, code) = + (iNum i) `iAppend` (iStr " -> [") `iAppend` + showInstructions code `iAppend` (iStr "]") + +showState :: GmState -> Iseq +showState s = iConcat [showOutput s, iNewline, + showStack s, iNewline, + showVStack s, iNewline, + showDump s, iNewline, + showInstructions (getCode s), iNewline] + +showOutput :: GmState -> Iseq +showOutput s = iConcat [iStr "Output:\"", iStr (getOutput s), iStr "\""] + +showStack :: GmState -> Iseq +showStack s = iConcat [iStr " Stack:[", + iIndent (iInterleave iNewline + (map (showStackItem s) (reverse (getStack s)))), + iStr "]"] + +showStackItem :: GmState -> Addr -> Iseq +showStackItem s a = + let maybeAddress = (hLookup (getHeap s) a) in + case maybeAddress of Just address -> iConcat [iStr (showaddr a), iStr ": ", showNode s a address] + Nothing -> error "showStackItem: node not found in heap" + +statGetSteps :: GmStats -> Int +statGetSteps s = s + +showaddr :: Addr -> [Char] +showaddr a = "#" ++ show a + +showVStack :: GmState -> Iseq +showVStack s = iConcat [iStr "Vstack:[", + iInterleave (iStr ", ") (map iNum (getVStack s))] `iAppend` iStr "]" + +showDump :: GmState -> Iseq +showDump s = iConcat [iStr " Dump:[", + iIndent (iInterleave iNewline + (map showDumpItem (reverse (getDump s)))), + iStr "]"] + +showDumpItem :: GmDumpItem -> Iseq +showDumpItem (code, stack) = + iConcat [iStr "<", + shortShowInstructions 3 code, iStr ", ", + shortShowStack stack, iStr ">"] + +shortShowInstructions :: Int -> GmCode -> Iseq +shortShowInstructions number code = + iConcat [iStr "{", iInterleave (iStr "; ") dotcodes, iStr "}"] where + codes = map showInstruction (take number code) + dotcodes | length code > number = codes ++ [iStr "..."] + | otherwise = codes + +shortShowStack :: GmStack -> Iseq +shortShowStack stack = + iConcat [iStr "[", + iInterleave (iStr ", ") (map (iStr . showaddr) stack), + iStr "]"] + +showNode :: GmState -> Addr -> Node -> Iseq +showNode s a (NNum n) = iNum n +showNode s a (NGlobal n g) = iConcat [iStr "Global ", iStr v] + where v = head [n | (n,b) <- M.toList $ getGlobals s, a==b] +showNode s a (NAp a1 a2) = iConcat [iStr "Ap ", iStr (showaddr a1), + iStr " ", iStr (showaddr a2)] +showNode s a (NInd ia) = iConcat [iStr "Ind ", iStr (showaddr ia)] +showNode s a (NConstr t as) = + iConcat [iStr "Cons ", iNum t, iStr " [", + iInterleave (iStr ", ") (map (iStr.showaddr) as), + iStr "]"] + +showStats :: GmState -> Iseq +showStats s = iConcat [ iStr "Steps taken = ", iNum (statGetSteps (getStats s))]