packages feed

core-compiler (empty) → 0.1.0.0

raw patch · 12 files changed

+1419/−0 lines, 12 filesdep +arraydep +basedep +containerssetup-changed

Dependencies added: array, base, containers, core-compiler, text, unordered-containers

Files

+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Lexer.x view
@@ -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"+}
+ app/Main.hs view
@@ -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
+ app/Parser.y view
@@ -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 ++ "'"++}
+ core-compiler.cabal view
@@ -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
+ src/Core/Compiler.hs view
@@ -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
+ src/Core/G.hs view
@@ -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
+ src/Core/GMachine.hs view
@@ -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"
+ src/Core/Grammar.hs view
@@ -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
+ src/Core/Prelude.hs view
@@ -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 []))]
+ src/Core/Pretty.hs view
@@ -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))]