├── .gitignore ├── Atuin ├── LICENSE ├── Setup.hs ├── atuin.cabal ├── sdl │ ├── Makefile │ ├── sdlrun.c │ └── sdlrun.h ├── src │ ├── Lexer.lhs │ ├── Main.lhs │ ├── Makefile │ ├── MkEpic.lhs │ ├── Parser.y │ ├── SDLprims.lhs │ └── Turtle.lhs └── test.at ├── Epic ├── Bytecode.lhs ├── CodegenC.lhs ├── CodegenStack.lhs ├── Compiler.lhs ├── Epic.lhs ├── Evaluator.lhs ├── Language.lhs ├── Lexer.lhs ├── OTTLang.lhs ├── Parser.y ├── Scopecheck.lhs ├── Simplify.lhs └── Stackcode.lhs ├── FL ├── LICENSE ├── fl.cabal └── src │ ├── Lang.lhs │ └── Main.lhs ├── LICENSE ├── Main.lhs ├── Makefile ├── Papers ├── Epic-TFP │ ├── Makefile │ ├── bigexample.tex │ ├── comments.sty │ ├── conclusions.tex │ ├── dtp.bib │ ├── embounded.bib │ ├── epic.tex │ ├── example.tex │ ├── implementation.tex │ ├── intro.tex │ ├── language.tex │ ├── library.ltx │ ├── literature.bib │ ├── llncs.cls │ ├── macros.ltx │ ├── performance.tex │ └── sigplanconf.cls └── Epic │ ├── Makefile │ ├── comments.sty │ ├── conclusions.tex │ ├── dtp.bib │ ├── embounded.bib │ ├── epic.pdf │ ├── epic.tex │ ├── example.tex │ ├── implementation.tex │ ├── intro.tex │ ├── language.tex │ ├── library.ltx │ ├── literature.bib │ ├── macros.ltx │ ├── performance.tex │ └── sigplanconf.cls ├── README ├── README.Mac ├── Setup.hs ├── compiler └── Main.lhs ├── epic.cabal ├── evm ├── Makefile ├── closure.c ├── closure.h ├── emalloc.c ├── emalloc.h ├── gc_header.h ├── mainprog.c ├── sparks.c ├── sparks.h ├── stdfuns.c └── stdfuns.h ├── examples ├── Prelude.e ├── adder.e ├── bigint.e ├── hellouser.e ├── hworld.e ├── intthing.e ├── listy.e ├── tailcall.e ├── testprog.e └── testprogslow.e ├── lib ├── Makefile └── Prelude.e └── tests ├── Makefile ├── Prelude.e ├── adder.e ├── addermem.e ├── bigint.e ├── expected ├── hworld.e ├── intthing.e ├── listy.e ├── tailcall.e ├── tailfact.e └── test.pl /.gitignore: -------------------------------------------------------------------------------- 1 | dist/ 2 | evm/ 3 | tests/output 4 | output 5 | -------------------------------------------------------------------------------- /Atuin/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2010 Edwin Brady 2 | School of Computer Science, University of St Andrews 3 | All rights reserved. 4 | 5 | This code is derived from software written by Edwin Brady 6 | (eb@dcs.st-and.ac.uk). 7 | 8 | Redistribution and use in source and binary forms, with or without 9 | modification, are permitted provided that the following conditions 10 | are met: 11 | 1. Redistributions of source code must retain the above copyright 12 | notice, this list of conditions and the following disclaimer. 13 | 2. Redistributions in binary form must reproduce the above copyright 14 | notice, this list of conditions and the following disclaimer in the 15 | documentation and/or other materials provided with the distribution. 16 | 3. None of the names of the copyright holders may be used to endorse 17 | or promote products derived from this software without specific 18 | prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS ``AS IS'' AND ANY 21 | EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 22 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR 23 | PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE 24 | LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 25 | CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF 26 | SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR 27 | BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, 28 | WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE 29 | OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN 30 | IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | 32 | *** End of disclaimer. *** 33 | -------------------------------------------------------------------------------- /Atuin/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | import Distribution.Simple.InstallDirs 3 | import Distribution.Simple.LocalBuildInfo 4 | import Distribution.PackageDescription 5 | 6 | import System 7 | 8 | system' cmd = do 9 | exit <- system cmd 10 | case exit of 11 | ExitSuccess -> return () 12 | ExitFailure _ -> exitWith exit 13 | 14 | buildLib args flags desc local 15 | = system' "make -C sdl" 16 | 17 | findSDL args flags 18 | = do system' "make -C src SDLflags.hs" 19 | return emptyHookedBuildInfo 20 | 21 | -- This is a hack. I don't know how to tell cabal that a data file needs 22 | -- installing but shouldn't be in the distribution. And it won't make the 23 | -- distribution if it's not there, so instead I just delete 24 | -- the file after configure. 25 | 26 | postConfLib args flags desc local 27 | = system' "make -C sdl clean" 28 | 29 | addPrefix pfx var c = "export " ++ var ++ "=" ++ show pfx ++ "/" ++ c ++ ":$" ++ var 30 | 31 | postInstLib args flags desc local 32 | = do let pfx = prefix (installDirTemplates local) 33 | system' $ "make -C sdl install PREFIX=" ++ show pfx 34 | 35 | main = defaultMainWithHooks (simpleUserHooks { preBuild = findSDL, 36 | postBuild = buildLib, 37 | postConf = postConfLib, 38 | postInst = postInstLib }) 39 | 40 | -------------------------------------------------------------------------------- /Atuin/atuin.cabal: -------------------------------------------------------------------------------- 1 | Name: atuin 2 | Version: 0.1.2 3 | Author: Edwin Brady 4 | License: BSD3 5 | License-file: LICENSE 6 | Maintainer: eb@cs.st-andrews.ac.uk 7 | Homepage: http://www.dcs.st-and.ac.uk/~eb/epic.php 8 | Stability: experimental 9 | Category: Compilers/Interpreters 10 | Synopsis: Embedded Turtle language compiler in Haskell, with Epic output 11 | Description: This language is a demonstration of the Epic compiler API. 12 | It is a dynamically typed language with higher order 13 | functions and system interaction (specifically graphics). 14 | Requires SDL and SDL_gfx libraries, and their C headers. 15 | Data-files: sdl/sdlrun.o sdl/sdlrun.h 16 | Extra-source-files: sdl/Makefile sdl/sdlrun.c sdl/sdlrun.h src/Makefile 17 | 18 | Cabal-Version: >= 1.6 19 | Build-type: Custom 20 | 21 | Executable atuin 22 | Main-is: Main.lhs 23 | hs-source-dirs: src 24 | Other-modules: Turtle MkEpic SDLprims Lexer Parser Paths_atuin 25 | Build-depends: base >=4 && <5, haskell98, Cabal, array, 26 | directory, epic >=0.1.13 27 | -------------------------------------------------------------------------------- /Atuin/sdl/Makefile: -------------------------------------------------------------------------------- 1 | CC = gcc 2 | CFLAGS = `epic -includedirs` 3 | 4 | INSTALLDIR = ${PREFIX}/lib/elogo 5 | 6 | sdlrun.o : sdlrun.c sdlrun.h 7 | 8 | install: 9 | mkdir -p ${INSTALLDIR} 10 | install sdlrun.o sdlrun.h ${INSTALLDIR} 11 | 12 | clean: 13 | rm -f sdlrun.o 14 | 15 | .PHONY: 16 | -------------------------------------------------------------------------------- /Atuin/sdl/sdlrun.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | 5 | #include 6 | 7 | SDL_Surface* graphicsInit(int xsize, int ysize) { 8 | SDL_Surface *screen; 9 | 10 | if(SDL_Init(SDL_INIT_TIMER | SDL_INIT_VIDEO | SDL_INIT_AUDIO) <0 ) 11 | { 12 | printf("Unable to init SDL: %s\n", SDL_GetError()); 13 | return NULL; 14 | } 15 | 16 | screen = SDL_SetVideoMode(xsize, ysize, 32, 17 | SDL_HWSURFACE | SDL_DOUBLEBUF); 18 | if (screen==NULL) { 19 | printf("Unable to init SDL: %s\n", SDL_GetError()); 20 | return NULL; 21 | } 22 | 23 | return screen; 24 | } 25 | 26 | void filledRect(void *s_in, 27 | int x, int y, int w, int h, 28 | int r, int g, int b, int a) 29 | { 30 | SDL_Surface* s = (SDL_Surface*)s_in; 31 | Uint32 colour 32 | = SDL_MapRGBA(s->format, (Uint8)r, (Uint8)g, (Uint8)b, (Uint8) a); 33 | SDL_Rect rect = { x, y, w, h }; 34 | SDL_FillRect(s, &rect, colour); 35 | } 36 | 37 | void filledEllipse(void* s_in, 38 | int x, int y, int rx, int ry, 39 | int r, int g, int b, int a) 40 | { 41 | SDL_Surface* s = (SDL_Surface*)s_in; 42 | filledEllipseRGBA(s, x, y, rx, ry, r, g, b, a); 43 | } 44 | 45 | void drawLine(void* s_in, 46 | int x, int y, int ex, int ey, 47 | int r, int g, int b, int a) 48 | { 49 | SDL_Surface* s = (SDL_Surface*)s_in; 50 | lineRGBA(s, x, y, ex, ey, r, g, b, a); 51 | } 52 | 53 | 54 | void flipBuffers(void* s_in) { 55 | SDL_Surface* s = (SDL_Surface*)s_in; 56 | SDL_Flip(s); 57 | } 58 | 59 | void* startSDL(int x, int y) { 60 | SDL_Surface *s = graphicsInit(x, y); 61 | return (void*)s; 62 | } 63 | 64 | VAL KEY(int tag, SDLKey key) { 65 | VAL k; 66 | switch(key) { 67 | case SDLK_UP: 68 | k = CONSTRUCTOR(0,0,NULL); 69 | break; 70 | case SDLK_DOWN: 71 | k = CONSTRUCTOR(1,0,NULL); 72 | break; 73 | case SDLK_LEFT: 74 | k = CONSTRUCTOR(2,0,NULL); 75 | break; 76 | case SDLK_RIGHT: 77 | k = CONSTRUCTOR(3,0,NULL); 78 | break; 79 | default: 80 | k = CONSTRUCTOR1(4,MKINT((int)key)); 81 | break; 82 | } 83 | return CONSTRUCTOR1(tag, k); 84 | } 85 | 86 | void* pollEvent() 87 | { 88 | SDL_Event event; // = (SDL_Event *) GC_MALLOC(sizeof(SDL_Event)); 89 | int r = SDL_PollEvent(&event); 90 | if (r==0) { 91 | // FIXME: This will do something different depending on erasure... 92 | // Probably the only way is to generate C glue for an idris module? 93 | // Assuming erasure here. 94 | return CONSTRUCTOR(1,0,NULL); // Nothing 95 | } 96 | else { 97 | VAL ievent = NULL; 98 | switch(event.type) { 99 | case SDL_KEYDOWN: 100 | ievent = KEY(0, event.key.keysym.sym); 101 | break; 102 | case SDL_KEYUP: 103 | ievent = KEY(1, event.key.keysym.sym); 104 | break; 105 | case SDL_QUIT: 106 | ievent = CONSTRUCTOR(2,0,NULL); 107 | break; 108 | default: 109 | // FIXME: This will do something different depending on erasure... 110 | // Assuming erasure 111 | return CONSTRUCTOR(1,0,NULL); // Nothing 112 | } 113 | // FIXME: This will do something different depending on erasure... 114 | // Assuming erasure 115 | return (void*)(CONSTRUCTOR1(0, ievent)); // Just ievent 116 | } 117 | } 118 | 119 | void pressAnyKey() 120 | { 121 | while(1) { 122 | SDL_Event event; // = (SDL_Event *) GC_MALLOC(sizeof(SDL_Event)); 123 | SDL_WaitEvent(&event); 124 | if (event.type == SDL_KEYUP) { return; } 125 | } 126 | } 127 | 128 | void* waitEvent() 129 | { 130 | SDL_Event event; // = (SDL_Event *) GC_MALLOC(sizeof(SDL_Event)); 131 | SDL_WaitEvent(&event); 132 | 133 | VAL ievent = NULL; 134 | switch(event.type) { 135 | case SDL_KEYDOWN: 136 | ievent = KEY(0, event.key.keysym.sym); 137 | break; 138 | case SDL_KEYUP: 139 | ievent = KEY(1, event.key.keysym.sym); 140 | break; 141 | case SDL_QUIT: 142 | ievent = CONSTRUCTOR(2,0,NULL); 143 | break; 144 | default: 145 | // FIXME: This will do something different depending on erasure... 146 | // Assuming erasure 147 | return CONSTRUCTOR(1,0,NULL); // Nothing 148 | } 149 | return (void*)(CONSTRUCTOR1(0, ievent)); // Just ievent 150 | } 151 | 152 | -------------------------------------------------------------------------------- /Atuin/sdl/sdlrun.h: -------------------------------------------------------------------------------- 1 | #ifndef __SDLRUN_H 2 | #define __SDLRUN_H 3 | 4 | // Start SDL, open a window with dimensions (x,y) 5 | void* startSDL(int x, int y); 6 | 7 | void flipBuffers(void* s_in); 8 | 9 | // Drawing primitives 10 | 11 | void filledRect(void *s, 12 | int x, int y, int w, int h, 13 | int r, int g, int b, int a); 14 | void filledEllipse(void* s_in, 15 | int x, int y, int rx, int ry, 16 | int r, int g, int b, int a); 17 | void drawLine(void* s_in, 18 | int x, int y, int ex, int ey, 19 | int r, int g, int b, int a); 20 | 21 | // Events 22 | void* pollEvent(); // builds an Epic value 23 | void* waitEvent(); // builds an Epic value 24 | 25 | void pressAnyKey(); 26 | 27 | #endif 28 | -------------------------------------------------------------------------------- /Atuin/src/Lexer.lhs: -------------------------------------------------------------------------------- 1 | > module Lexer where 2 | 3 | > import Char 4 | 5 | > import Turtle 6 | 7 | > type Result a = Either (String, FilePath, Int) a 8 | 9 | > type LineNumber = Int 10 | > type P a = String -> String -> LineNumber -> Result a 11 | 12 | > getLineNo :: P LineNumber 13 | > getLineNo = \s fn l -> Right l 14 | 15 | > getFileName :: P String 16 | > getFileName = \s fn l -> Right fn 17 | 18 | > getContent :: P String 19 | > getContent = \s fn l -> Right s 20 | 21 | > thenP :: P a -> (a -> P b) -> P b 22 | > m `thenP` k = \s fn l -> case m s fn l of 23 | > Right a -> k a s fn l 24 | > Left (e, f, ln) -> Left (e, f, ln) 25 | 26 | > returnP :: a -> P a 27 | > returnP a = \s fn l -> Right a 28 | > 29 | > failP :: String -> P a 30 | > failP err = \s fn l -> Left (err, fn, l) 31 | 32 | > catchP :: P a -> (String -> P a) -> P a 33 | > catchP m k = \s fn l -> 34 | > case m s fn l of 35 | > Right a -> Right a 36 | > Left (e, f, ln) -> k e s fn l 37 | 38 | > happyError :: P a 39 | > happyError = reportError "Parse error" 40 | 41 | > reportError :: String -> P a 42 | > reportError err = getFileName `thenP` \fn -> 43 | > getLineNo `thenP` \line -> 44 | > getContent `thenP` \content -> 45 | > failP (fn ++ ":" ++ show line ++ ":" ++ err ++ " at " ++ take 40 content ++ " ...") 46 | 47 | > data Token 48 | > = TokenName Id 49 | > | TokenString String 50 | > | TokenInt Int 51 | > | TokenChar Char 52 | > | TokenBool Bool 53 | > | TokenOB 54 | > | TokenCB 55 | > | TokenOCB 56 | > | TokenCCB 57 | > | TokenOSB 58 | > | TokenCSB 59 | > | TokenPlus 60 | > | TokenMinus 61 | > | TokenTimes 62 | > | TokenDivide 63 | > | TokenEquals 64 | > | TokenEQ 65 | > | TokenGE 66 | > | TokenLE 67 | > | TokenGT 68 | > | TokenLT 69 | > | TokenLet 70 | > | TokenIn 71 | > | TokenIf 72 | > | TokenThen 73 | > | TokenElse 74 | > | TokenRepeat 75 | > | TokenSemi 76 | > | TokenComma 77 | > | TokenMkCol Colour 78 | > | TokenEval 79 | > | TokenFD 80 | > | TokenRight 81 | > | TokenLeft 82 | > | TokenColour 83 | > | TokenPenUp 84 | > | TokenPenDown 85 | > | TokenEOF 86 | > deriving (Show, Eq) 87 | > 88 | > 89 | > lexer :: (Token -> P a) -> P a 90 | > lexer cont [] = cont TokenEOF [] 91 | > lexer cont ('\n':cs) = \fn line -> lexer cont cs fn (line+1) 92 | > lexer cont (c:cs) 93 | > | isSpace c = \fn line -> lexer cont cs fn line 94 | > | isAlpha c = lexVar cont (c:cs) 95 | > | isDigit c = lexNum cont (c:cs) 96 | > | c == '_' = lexVar cont (c:cs) 97 | > lexer cont ('"':cs) = lexString cont cs 98 | > lexer cont ('\'':cs) = lexChar cont cs 99 | > lexer cont ('{':'-':cs) = lexerEatComment 0 cont cs 100 | > lexer cont ('-':'-':cs) = lexerEatToNewline cont cs 101 | > lexer cont ('(':cs) = cont TokenOB cs 102 | > lexer cont (')':cs) = cont TokenCB cs 103 | > lexer cont ('{':cs) = cont TokenOCB cs 104 | > lexer cont ('}':cs) = cont TokenCCB cs 105 | > lexer cont ('[':cs) = cont TokenOSB cs 106 | > lexer cont (']':cs) = cont TokenCSB cs 107 | > lexer cont ('+':cs) = cont TokenPlus cs 108 | > lexer cont ('-':cs) = cont TokenMinus cs 109 | > lexer cont ('*':cs) = cont TokenTimes cs 110 | > lexer cont ('/':cs) = cont TokenDivide cs 111 | > lexer cont ('=':'=':cs) = cont TokenEQ cs 112 | > lexer cont ('>':'=':cs) = cont TokenGE cs 113 | > lexer cont ('<':'=':cs) = cont TokenLE cs 114 | > lexer cont ('>':cs) = cont TokenGT cs 115 | > lexer cont ('<':cs) = cont TokenLT cs 116 | > lexer cont ('=':cs) = cont TokenEquals cs 117 | > lexer cont (';':cs) = cont TokenSemi cs 118 | > lexer cont (',':cs) = cont TokenComma cs 119 | > lexer cont (c:cs) = lexError c cs 120 | 121 | > lexError c s f l = failP (show l ++ ": Unrecognised token '" ++ [c] ++ "'\n") s f l 122 | 123 | > lexerEatComment nls cont ('-':'}':cs) 124 | > = \fn line -> lexer cont cs fn (line+nls) 125 | > lexerEatComment nls cont ('\n':cs) = lexerEatComment (nls+1) cont cs 126 | > lexerEatComment nls cont (c:cs) = lexerEatComment nls cont cs 127 | > 128 | > lexerEatToNewline cont ('\n':cs) 129 | > = \fn line -> lexer cont cs fn (line+1) 130 | > lexerEatToNewline cont (c:cs) = lexerEatToNewline cont cs 131 | 132 | > lexNum cont cs = case (span isDigit cs) of 133 | > (num, rest) -> 134 | > cont (TokenInt (read num)) rest 135 | 136 | > lexString cont cs = 137 | > \fn line -> 138 | > case getstr cs of 139 | > Just (str,rest,nls) -> cont (TokenString str) rest fn (nls+line) 140 | > Nothing -> failP (fn++":"++show line++":Unterminated string contant") 141 | > cs fn line 142 | 143 | > lexChar cont cs = 144 | > \fn line -> 145 | > case getchar cs of 146 | > Just (str,rest) -> cont (TokenChar str) rest fn line 147 | > Nothing -> 148 | > failP (fn++":"++show line++":Unterminated character constant") 149 | > cs fn line 150 | 151 | > isAllowed c = isAlpha c || isDigit c || c `elem` "_\'?#" 152 | 153 | > lexVar cont cs = 154 | > case span isAllowed cs of 155 | > ("true",rest) -> cont (TokenBool True) rest 156 | > ("false",rest) -> cont (TokenBool False) rest 157 | > -- expressions 158 | > ("let",rest) -> cont TokenLet rest 159 | > ("if",rest) -> cont TokenIf rest 160 | > ("then",rest) -> cont TokenThen rest 161 | > ("else",rest) -> cont TokenElse rest 162 | > ("repeat",rest) -> cont TokenRepeat rest 163 | > ("in",rest) -> cont TokenIn rest 164 | > ("eval",rest) -> cont TokenEval rest 165 | > -- commands 166 | > ("forward",rest) -> cont TokenFD rest 167 | > ("right",rest) -> cont TokenRight rest 168 | > ("left",rest) -> cont TokenLeft rest 169 | > ("colour",rest) -> cont TokenColour rest 170 | > ("penup",rest) -> cont TokenPenUp rest 171 | > ("pendown",rest) -> cont TokenPenDown rest 172 | > -- colours 173 | > ("black",rest) -> cont (TokenMkCol Black) rest 174 | > ("red",rest) -> cont (TokenMkCol Red) rest 175 | > ("green",rest) -> cont (TokenMkCol Green) rest 176 | > ("blue",rest) -> cont (TokenMkCol Blue) rest 177 | > ("yellow",rest) -> cont (TokenMkCol Yellow) rest 178 | > ("cyan",rest) -> cont (TokenMkCol Cyan) rest 179 | > ("magenta",rest) -> cont (TokenMkCol Magenta) rest 180 | > ("white",rest) -> cont (TokenMkCol White) rest 181 | > (var,rest) -> cont (mkname var) rest 182 | 183 | > mkname :: String -> Token 184 | > mkname c = TokenName (mkId c) 185 | 186 | > getstr :: String -> Maybe (String,String,Int) 187 | > getstr cs = case getstr' "" cs 0 of 188 | > Just (str,rest,nls) -> Just (reverse str,rest,nls) 189 | > _ -> Nothing 190 | > getstr' acc ('\"':xs) = \nl -> Just (acc,xs,nl) 191 | > getstr' acc ('\\':'n':xs) = getstr' ('\n':acc) xs -- Newline 192 | > getstr' acc ('\\':'r':xs) = getstr' ('\r':acc) xs -- CR 193 | > getstr' acc ('\\':'t':xs) = getstr' ('\t':acc) xs -- Tab 194 | > getstr' acc ('\\':'b':xs) = getstr' ('\b':acc) xs -- Backspace 195 | > getstr' acc ('\\':'a':xs) = getstr' ('\a':acc) xs -- Alert 196 | > getstr' acc ('\\':'f':xs) = getstr' ('\f':acc) xs -- Formfeed 197 | > getstr' acc ('\\':'0':xs) = getstr' ('\0':acc) xs -- null 198 | > getstr' acc ('\\':x:xs) = getstr' (x:acc) xs -- Literal 199 | > getstr' acc ('\n':xs) = \nl ->getstr' ('\n':acc) xs (nl+1) -- Count the newline 200 | > getstr' acc (x:xs) = getstr' (x:acc) xs 201 | > getstr' _ _ = \nl -> Nothing 202 | 203 | > getchar :: String -> Maybe (Char,String) 204 | > getchar ('\\':'n':'\'':xs) = Just ('\n',xs) -- Newline 205 | > getchar ('\\':'r':'\'':xs) = Just ('\r',xs) -- CR 206 | > getchar ('\\':'t':'\'':xs) = Just ('\t',xs) -- Tab 207 | > getchar ('\\':'b':'\'':xs) = Just ('\b',xs) -- Backspace 208 | > getchar ('\\':'a':'\'':xs) = Just ('\a',xs) -- Alert 209 | > getchar ('\\':'f':'\'':xs) = Just ('\f',xs) -- Formfeed 210 | > getchar ('\\':'0':'\'':xs) = Just ('\0',xs) -- null 211 | > getchar ('\\':x:'\'':xs) = Just (x,xs) -- Literal 212 | > getchar (x:'\'':xs) = Just (x,xs) 213 | > getchar _ = Nothing 214 | -------------------------------------------------------------------------------- /Atuin/src/Main.lhs: -------------------------------------------------------------------------------- 1 | > module Main where 2 | 3 | > import Parser 4 | > import MkEpic 5 | 6 | > import System 7 | 8 | > usage [inf, outf] = return (inf, outf) 9 | > usage _ = fail "Usage: atuin [input] [output]" 10 | 11 | > main :: IO () 12 | > main = do args <- getArgs 13 | > (inf, outf) <- usage args 14 | > putStrLn $ "Compiling " ++ inf ++ " to " ++ outf 15 | > prog <- parseFile (args!!0) 16 | > case prog of 17 | > Left (e, f, l) -> putStrLn $ f ++ ":" ++ show l ++ ":" ++ e 18 | > Right p -> output p (args !! 1) 19 | -------------------------------------------------------------------------------- /Atuin/src/Makefile: -------------------------------------------------------------------------------- 1 | SDLflags.hs: .PHONY 2 | echo "module SDLflags where\nsdlflags=\"`sdl-config --libs`\"" > SDLflags.hs 3 | 4 | .PHONY: -------------------------------------------------------------------------------- /Atuin/src/MkEpic.lhs: -------------------------------------------------------------------------------- 1 | > module MkEpic(output) where 2 | 3 | Convert a Turtle program into an Epic program 4 | 5 | > import Turtle 6 | > import SDLprims 7 | > import SDLflags 8 | > import Paths_atuin 9 | 10 | > import Epic.Epic as Epic hiding (compile) 11 | 12 | > opts = [GCCOpt (sdlflags ++ " -l SDL_gfx"), MainInc "SDL/SDL.h"] 13 | 14 | Epic takes Strings as identifiers, so we'll need to convert our identifiers 15 | to strings... 16 | 17 | > fullId :: Id -> String 18 | > fullId n = e n 19 | > where e [] = "" 20 | > e (x:xs) = "_" ++ x ++ e xs 21 | 22 | ...then to Epic identifiers. 23 | 24 | > epicId :: Id -> Name 25 | > epicId i = name (fullId i) 26 | 27 | The main compiler function, turns a logo program into an Epic 28 | term. Just traverses a Turtle and calls the appropriate Epic 29 | primitives, and the primitives we've defined in SDLprims. 30 | 31 | The compiled program maintains a turtle state, so we'll pass the 32 | state to the compiler. 33 | 34 | > class Compile a where 35 | > compile :: Expr -> a -> Term 36 | 37 | > instance Compile Turtle where 38 | 39 | When we sequence commands, we need to pass the new state from the first 40 | command as input to the second command. 41 | 42 | > compile state (Seq x y) 43 | > = let_ (compile state x) (\state' -> compile state' y) 44 | > compile state (Turtle c) = compile state c 45 | 46 | When applying a function we need to add the state as the first argument. 47 | 48 | > compile state (Call i es) 49 | > = app (fn (fullId i) @@ state) es 50 | > where app f [] = f 51 | > app f (e:es) = app (f @@ compile state e) es 52 | 53 | > compile state (If a t e) = if_ (getBool (compile state a)) 54 | > (compile state t) (compile state e) 55 | 56 | To repeat an action n times, call the "repeat" function. The action itself 57 | is parameterised over a state becaue it'll have a different state at each 58 | step of the loop. It's really handy to be able to use a Haskell function 59 | here! 60 | 61 | > compile state (Repeat n e) = fn "repeat" @@ state 62 | > @@ compile state n 63 | > @@ (\st -> compile st e) 64 | 65 | > compile state (Let i e scope) 66 | > = letN_ (epicId i) (compile state e) (compile state scope) 67 | 68 | To evaluate a delayed expression, pass it the current state. 69 | 70 | > compile state (Eval e) = effect_ (compile state e @@ state) 71 | > compile state Pass = unit_ 72 | 73 | It's a dynamically typed language, so when we compute an expression we 74 | need to check the values are the right type at each step. The primitives 75 | in SDLprims do this for us. 76 | 77 | > instance Compile Exp where 78 | > compile state (Infix op l r) 79 | > = (mkOp op) (compile state l) (compile state r) 80 | > where mkOp Plus = primPlus 81 | > mkOp Minus = primMinus 82 | > mkOp Times = primTimes 83 | > mkOp Divide = primDivide 84 | > mkOp Eq = primEq 85 | > mkOp Lt = primLT 86 | > mkOp Le = primLE 87 | > mkOp Gt = primGT 88 | > mkOp Ge = primGE 89 | > compile state (Var i) = ref (epicId i) 90 | > compile state (Const i) = compile state i 91 | 92 | Delay evaluation of a code block. When we get around to evaluating it, 93 | we'll want to use the state at that point, not the state when the block is 94 | built, so make this a function. 95 | 96 | > compile state (Block t) = lazy_ (\st -> compile st t) 97 | 98 | Values are wrapped in an ADT so we can see what type they are. 99 | i.e. data Value = MkInt Int | MkString Str | ... 100 | Primitives are defined for building these in SDLprims. 101 | 102 | > instance Compile Const where 103 | > compile state (MkInt i) = mkint (int i) 104 | > compile state (MkString s) = mkstr (str s) 105 | > compile state (MkChar c) = mkchar (char c) 106 | > compile state (MkBool b) = mkbool (bool b) 107 | > compile state (MkCol Black) = mkcol col_black 108 | > compile state (MkCol Red) = mkcol col_red 109 | > compile state (MkCol Green) = mkcol col_green 110 | > compile state (MkCol Blue) = mkcol col_blue 111 | > compile state (MkCol Yellow) = mkcol col_yellow 112 | > compile state (MkCol Cyan) = mkcol col_cyan 113 | > compile state (MkCol Magenta) = mkcol col_magenta 114 | > compile state (MkCol White) = mkcol col_white 115 | 116 | For turtle commands, we've also defined some primitives, so we just apply 117 | them to the current state and the given argument. 118 | 119 | > instance Compile Command where 120 | > compile state (Fd i) = fn "forward" @@ state @@ compile state i 121 | > compile state (RightT i) = fn "right" @@ state @@ compile state i 122 | > compile state (LeftT i) = fn "left" @@ state @@ compile state i 123 | > compile state (Colour c) = fn "colour" @@ state @@ compile state c 124 | > compile state PenUp = fn "pen" @@ state @@ bool False 125 | > compile state PenDown = fn "pen" @@ state @@ bool True 126 | 127 | Convert a function with arguments into an Epic definition. We have the 128 | arguments in the definition, plus an additional state added by the system 129 | which carries the turtle state and SDL surface. 130 | 131 | > mkEpic :: (Id, Function) -> EpicDecl 132 | > mkEpic (i, (args, p)) 133 | > = EpicFn (epicId i) (\ state -> (map epicId args, compile state p)) 134 | 135 | Epic main program - initialises SDL, sets up an initial turtle state, 136 | runs the program called "main" and waits for a key press. 137 | 138 | > runMain :: Term 139 | > runMain = 140 | > let_ (fn "initSDL" @@ int 640 @@ int 480) 141 | > (\surface -> 142 | > (fn (fullId (mkId "main")) @@ (init_turtle surface)) +> 143 | > flipBuffers surface +> 144 | > pressAnyKey) 145 | 146 | Find the support files (the SDL glue code) and compile an Epic program 147 | with the primitives (from SDLprims) and the user's program. 148 | 149 | > output :: [(Id, Function)] -> FilePath -> IO () 150 | > output prog fp = do -- TODO: run sdl-config 151 | > sdlo <- getDataFileName "sdl/sdlrun.o" 152 | > sdlh <- getDataFileName "sdl/sdlrun.h" 153 | > let eprog = map mkEpic prog 154 | > let incs = [Include sdlh, 155 | > Include "math.h"] 156 | > compileObj (mkProgram (incs ++ sdlPrims ++ 157 | > EpicFn (name "main") runMain : eprog)) 158 | > (fp++".o") 159 | > linkWith opts [fp++".o", sdlo] fp 160 | -------------------------------------------------------------------------------- /Atuin/src/Parser.y: -------------------------------------------------------------------------------- 1 | { -- -*-Haskell-*- 2 | 3 | module Parser where 4 | 5 | import Char 6 | import Turtle 7 | import Lexer 8 | 9 | } 10 | 11 | %name mkparse Program 12 | 13 | %tokentype { Token } 14 | %monad { P } { thenP } { returnP } 15 | %lexer { lexer } { TokenEOF } 16 | 17 | %token 18 | name { TokenName $$ } 19 | string { TokenString $$ } 20 | char { TokenChar $$ } 21 | int { TokenInt $$ } 22 | bool { TokenBool $$ } 23 | col { TokenMkCol $$ } 24 | let { TokenLet } 25 | in { TokenIn } 26 | if { TokenIf } 27 | then { TokenThen } 28 | else { TokenElse } 29 | repeat { TokenRepeat } 30 | '(' { TokenOB } 31 | ')' { TokenCB } 32 | '{' { TokenOCB } 33 | '}' { TokenCCB } 34 | '[' { TokenOSB } 35 | ']' { TokenCSB } 36 | '+' { TokenPlus } 37 | '-' { TokenMinus } 38 | '*' { TokenTimes } 39 | '/' { TokenDivide } 40 | '=' { TokenEquals } 41 | eq { TokenEQ } 42 | le { TokenLE } 43 | ge { TokenGE } 44 | '<' { TokenLT } 45 | '>' { TokenGT } 46 | ';' { TokenSemi } 47 | ',' { TokenComma } 48 | eval { TokenEval } 49 | forward { TokenFD } 50 | right { TokenRight } 51 | left { TokenLeft } 52 | colour { TokenColour } 53 | penup { TokenPenUp } 54 | pendown { TokenPenDown } 55 | 56 | %nonassoc NONE 57 | %left eq 58 | %left ';' 59 | %left '<' '>' le ge 60 | %left '+' '-' 61 | %left '*' '/' 62 | %left NEG 63 | 64 | %% 65 | 66 | Program :: { [(Id, Function)] } 67 | Program : Function { [$1] } 68 | | Function Program { $1:$2 } 69 | 70 | Function :: { (Id, Function) } 71 | Function : name '(' Vars ')' Block { ($1, ($3, $5)) } 72 | 73 | Vars :: { [Id] } 74 | Vars : { [] } 75 | | name { [$1] } 76 | | name ',' Vars { $1:$3 } 77 | 78 | TurtleProg :: { Turtle } 79 | TurtleProg : Turtle { $1 } 80 | | Turtle TurtleProg { Seq $1 $2 } 81 | | name '=' Expr TurtleProg { Let $1 $3 $4 } 82 | 83 | Block :: { Turtle } 84 | Block : '{' TurtleProg '}' { $2 } 85 | | Turtle { $1 } 86 | 87 | Turtle :: { Turtle } 88 | Turtle : name '(' ExprList ')' { Call $1 $3 } 89 | | if Expr Block ElseBlock 90 | { If $2 $3 $4 } 91 | | eval Expr { Eval $2 } 92 | | repeat Expr Block { Repeat $2 $3 } 93 | | forward Expr { Turtle (Fd $2) } 94 | | right Expr { Turtle (RightT $2) } 95 | | left Expr { Turtle (LeftT $2) } 96 | | colour Expr { Turtle (Colour $2) } 97 | | penup { Turtle PenUp } 98 | | pendown { Turtle PenDown } 99 | 100 | ElseBlock :: { Turtle } 101 | ElseBlock : { Pass } 102 | | else Block { $2 } 103 | 104 | ExprList :: { [Exp] } 105 | ExprList : Expr { [$1] } 106 | | Expr ',' ExprList { $1:$3 } 107 | 108 | Expr :: { Exp } 109 | Expr : name { Var $1 } 110 | | Constant { Const $1 } 111 | | '-' Expr %prec NEG { Infix Minus (Const (MkInt 0)) $2 } 112 | | Expr '+' Expr { Infix Plus $1 $3 } 113 | | Expr '-' Expr { Infix Minus $1 $3 } 114 | | Expr '*' Expr { Infix Times $1 $3 } 115 | | Expr '/' Expr { Infix Divide $1 $3 } 116 | | Expr eq Expr { Infix Eq $1 $3 } 117 | | Expr '<' Expr { Infix Lt $1 $3 } 118 | | Expr '>' Expr { Infix Gt $1 $3 } 119 | | Expr le Expr { Infix Le $1 $3 } 120 | | Expr ge Expr { Infix Ge $1 $3 } 121 | | '(' Expr ')' { $2 } 122 | | '{' TurtleProg '}' { Block $2 } 123 | 124 | Constant :: { Const } 125 | Constant : int { MkInt $1 } 126 | | string { MkString $1 } 127 | | char { MkChar $1 } 128 | | bool { MkBool $1 } 129 | | col { MkCol $1 } 130 | 131 | Line :: { LineNumber } 132 | : {- empty -} {% getLineNo } 133 | 134 | File :: { String } 135 | : {- empty -} %prec NONE {% getFileName } 136 | 137 | { 138 | 139 | parse :: String -> FilePath -> Result [(Id, Function)] 140 | parse s fn = mkparse s fn 1 141 | 142 | parseFile :: FilePath -> IO (Result [(Id, Function)]) 143 | parseFile fn = do s <- readFile fn 144 | let x = parse s fn 145 | return x 146 | 147 | } -------------------------------------------------------------------------------- /Atuin/src/SDLprims.lhs: -------------------------------------------------------------------------------- 1 | > {-# OPTIONS_GHC -XScopedTypeVariables #-} 2 | 3 | > module SDLprims where 4 | 5 | Epic primitives for calling SDL and basic operators 6 | 7 | > import Epic.Epic 8 | 9 | > initSDL :: Expr -> Expr -> Term 10 | > initSDL xsize ysize 11 | > = foreign_ tyPtr "startSDL" [(xsize, tyInt), (ysize, tyInt)] 12 | 13 | > pollEvent = foreignConst_ tyPtr "pollEvent" 14 | > pressAnyKey = foreignConst_ tyUnit "pressAnyKey" 15 | 16 | > flipBuffers :: Expr -> Term 17 | > flipBuffers s = foreign_ tyUnit "flipBuffers" [(s, tyPtr)] 18 | 19 | Define some colours, and convert a colour into a tuple of the relevant 20 | RGBA values. 21 | 22 | > col_black = con_ 0 23 | > col_red = con_ 1 24 | > col_green = con_ 2 25 | > col_blue = con_ 3 26 | > col_yellow = con_ 4 27 | > col_cyan = con_ 5 28 | > col_magenta = con_ 6 29 | > col_white = con_ 7 30 | 31 | > rgba col = case_ col 32 | > [con 0 (tuple_ @@ int 0 @@ int 0 @@ int 0 @@ int 255), 33 | > con 1 (tuple_ @@ int 255 @@ int 0 @@ int 0 @@ int 255), 34 | > con 2 (tuple_ @@ int 0 @@ int 255 @@ int 0 @@ int 255), 35 | > con 3 (tuple_ @@ int 0 @@ int 0 @@ int 255 @@ int 255), 36 | > con 4 (tuple_ @@ int 255 @@ int 255 @@ int 0 @@ int 255), 37 | > con 5 (tuple_ @@ int 0 @@ int 255 @@ int 255 @@ int 255), 38 | > con 6 (tuple_ @@ int 255 @@ int 0 @@ int 255 @@ int 255), 39 | > con 7 (tuple_ @@ int 255 @@ int 255 @@ int 255 @@ int 255)] 40 | 41 | Constants - it's a dynamically typed language so we wrap them in an ADT 42 | which says what type they are. 43 | 44 | > mkint i = con_ 0 @@ i 45 | > mkstr s = con_ 1 @@ s 46 | > mkchar c = con_ 2 @@ c 47 | > mkbool b = con_ 3 @@ b 48 | > mkcol c = con_ 4 @@ c 49 | 50 | Every time we use a constant, we'll have to extract it from the wrapper. 51 | If we're asking for the wrong type, quit with an error. 52 | 53 | ANNOYANCE: Having to add type annotations because we only have Alternative 54 | instances for (Expr -> e). Is there a way to make type inference know that 55 | it must be an Expr because that's the only instance we define? i.e. can 56 | we stop any other instances for (a -> e) being allowed somehow? 57 | 58 | > getInt x = case_ x 59 | > [con 0 (\ (x :: Expr) -> x), defaultcase (error_ "Not an Int")] 60 | 61 | > getStr x = case_ x 62 | > [con 1 (\ (x :: Expr) -> x), defaultcase (error_ "Not a String")] 63 | 64 | > getChar x = case_ x 65 | > [con 2 (\ (x :: Expr) -> x), defaultcase (error_ "Not a Char")] 66 | 67 | > getBool x = case_ x 68 | > [con 3 (\ (x :: Expr) -> x), defaultcase (error_ "Not a Bool")] 69 | 70 | > getCol x = case_ x 71 | > [con 4 (\ (x :: Expr) -> x), defaultcase (error_ "Not a Colour")] 72 | 73 | Arithmetic operations 74 | 75 | > primPlus x y = mkint $ op_ plus_ (getInt x) (getInt y) 76 | > primMinus x y = mkint $ op_ minus_ (getInt x) (getInt y) 77 | > primTimes x y = mkint $ op_ times_ (getInt x) (getInt y) 78 | > primDivide x y = mkint $ op_ divide_ (getInt x) (getInt y) 79 | 80 | Comparisons 81 | 82 | > primEq x y = mkbool $ op_ eq_ (getInt x) (getInt y) 83 | > primLT x y = mkbool $ op_ lt_ (getInt x) (getInt y) 84 | > primLE x y = mkbool $ op_ lte_ (getInt x) (getInt y) 85 | > primGT x y = mkbool $ op_ gt_ (getInt x) (getInt y) 86 | > primGE x y = mkbool $ op_ gte_ (getInt x) (getInt y) 87 | 88 | Graphics primitive, just extracts the tuple of RGBA values for the colour 89 | and calls the SDL_gfx primitive. 90 | 91 | > drawLine :: Expr -> Expr -> Expr -> Expr -> Expr -> Expr -> Term 92 | > drawLine surf x y ex ey col 93 | > = case_ (rgba col) 94 | > [tuple (\ r g b a -> 95 | > foreign_ tyUnit "drawLine" 96 | > [(surf, tyPtr), 97 | > (x, tyInt), (y, tyInt), 98 | > (ex, tyInt), (ey, tyInt), 99 | > (r, tyInt), (g, tyInt), 100 | > (b, tyInt), (a, tyInt)]) ] 101 | 102 | We have integers and degrees, but sin and cos work with floats and radians. 103 | Here's some primitives to do the necessary conversions. 104 | 105 | > intToFloat x = foreign_ tyFloat "intToFloat" [(x, tyInt)] 106 | > floatToInt x = foreign_ tyInt "floatToInt" [(x, tyFloat)] 107 | 108 | > rad x = op_ timesF_ (intToFloat x) (float (pi/180)) 109 | 110 | > esin x = foreign_ tyFloat "sin" [(rad x, tyFloat)] 111 | > ecos x = foreign_ tyFloat "cos" [(rad x, tyFloat)] 112 | 113 | Turtle functions. 114 | In these, the arguments given by the user are in the Value ADT, so we'll 115 | need to extract the integer. 116 | 117 | To move forward, create a new state with the turtle at the new position, 118 | and draw a line in the current colour between the two positions. 119 | Return the new state. 120 | 121 | > forward :: Expr -> Expr -> Term 122 | > forward st dist = case_ st 123 | > [tuple (\ (surf :: Expr) (x :: Expr) (y :: Expr) 124 | > (dir :: Expr) (col :: Expr) (pen :: Expr) -> 125 | > let_ (op_ plus_ x (floatToInt (op_ timesF_ (intToFloat (getInt dist)) 126 | > (esin dir)))) 127 | > (\ (x' :: Expr) -> let_ (op_ plus_ y (floatToInt 128 | > (op_ timesF_ (intToFloat (getInt dist)) 129 | > (ecos dir)))) 130 | > (\ (y' :: Expr) -> if_ pen (fn "drawLine" @@ surf @@ x @@ y 131 | > @@ x' @@ y' @@ col) 132 | > unit_ +> 133 | > tuple_ @@ surf @@ x' @@ y' @@ dir @@ col @@ pen)))] 134 | 135 | To turn right, create a new state with the turtle turned right. 136 | Return the new state. 137 | 138 | > right :: Expr -> Expr -> Term 139 | > right st ang = case_ st 140 | > [tuple (\ (surf :: Expr) (x :: Expr) (y :: Expr) 141 | > (dir :: Expr) (col :: Expr) (pen :: Expr) -> 142 | > (tuple_ @@ surf @@ x @@ y @@ op_ minus_ dir (getInt ang) @@ col @@ pen))] 143 | 144 | To turn left, create a new state with the turtle turned left. 145 | Return the new state. 146 | 147 | > left :: Expr -> Expr -> Term 148 | > left st ang = case_ st 149 | > [tuple (\ (surf :: Expr) (x :: Expr) (y :: Expr) 150 | > (dir :: Expr) (col :: Expr) (pen :: Expr) -> 151 | > (tuple_ @@ surf @@ x @@ y @@ op_ plus_ dir (getInt ang) @@ col @@ pen))] 152 | 153 | > colour :: Expr -> Expr -> Term 154 | > colour st col' = case_ st 155 | > [tuple (\ (surf :: Expr) (x :: Expr) (y :: Expr) 156 | > (dir :: Expr) (col :: Expr) (pen :: Expr) -> 157 | > (tuple_ @@ surf @@ x @@ y @@ dir @@ getCol col' @@ pen))] 158 | 159 | > pen :: Expr -> Expr -> Term 160 | > pen st b = case_ st 161 | > [tuple (\ (surf :: Expr) (x :: Expr) (y :: Expr) 162 | > (dir :: Expr) (col :: Expr) (pen :: Expr) -> 163 | > (tuple_ @@ surf @@ x @@ y @@ dir @@ col @@ b))] 164 | 165 | Repeat n times 166 | 167 | > primRepeat :: Expr -> Expr -> Expr -> Term 168 | > primRepeat st n e = case_ (getInt n) 169 | > [constcase 0 st, 170 | > defaultcase (let_ (e @@ st) 171 | > (\ (st' :: Expr) -> fn "repeat" @@ st' 172 | > @@ mkint (op_ minus_ (getInt n) (int 1)) 173 | > @@ e))] 174 | 175 | Turtle state consists of an SDL surface, 176 | a position, a direction, a colour, and pen up/down: 177 | (surf, x, y, dir, col, bool) 178 | 179 | Note that we use primitives here, not the Value ADT, because we don't allow 180 | the user direct access to this tuple. 181 | 182 | > init_turtle surf = tuple_ @@ surf @@ 183 | > int 320 @@ int 240 @@ int 180 @@ 184 | > col_white @@ bool True 185 | 186 | Export the primitives as Epic functions. 187 | 188 | > sdlPrims = basic_defs ++ 189 | > [EpicFn (name "initSDL") initSDL, 190 | > EpicFn (name "pollEvent") pollEvent, 191 | > EpicFn (name "flipBuffers") flipBuffers, 192 | > EpicFn (name "drawLine") drawLine, 193 | > EpicFn (name "forward") forward, 194 | > EpicFn (name "left") left, 195 | > EpicFn (name "right") right, 196 | > EpicFn (name "colour") colour, 197 | > EpicFn (name "pen") pen, 198 | > EpicFn (name "repeat") primRepeat, 199 | > EpicFn (name "pressAnyKey") pressAnyKey] 200 | -------------------------------------------------------------------------------- /Atuin/src/Turtle.lhs: -------------------------------------------------------------------------------- 1 | > module Turtle where 2 | 3 | > type Id = [String] 4 | > type Root = String 5 | 6 | > mkId :: String -> Id 7 | > mkId = (:[]) 8 | 9 | > data Exp = Infix Op Exp Exp 10 | > | Var Id 11 | > | Const Const 12 | > | Block Turtle 13 | > deriving Show 14 | 15 | > data Const = MkInt Int 16 | > | MkString String 17 | > | MkChar Char 18 | > | MkBool Bool 19 | > | MkCol Colour 20 | > deriving Show 21 | 22 | > data Colour = Black | Red | Green | Blue | Yellow | Cyan | Magenta | White 23 | > deriving (Show, Eq) 24 | 25 | > data Turtle = Call Id [Exp] 26 | > | Turtle Command 27 | > | Seq Turtle Turtle 28 | > | If Exp Turtle Turtle 29 | > | Repeat Exp Turtle 30 | > | Let Id Exp Turtle 31 | > | Eval Exp 32 | > | Pass 33 | > deriving Show 34 | 35 | > type Function = ([Id], Turtle) 36 | 37 | > data Op = Plus | Minus | Times | Divide -- int ops 38 | > | Eq | Lt | Le | Gt | Ge -- bool ops 39 | > | Car | Cdr | Append | Index -- TODO: string/char ops 40 | > deriving Show 41 | 42 | > data Command = Fd Exp 43 | > | RightT Exp 44 | > | LeftT Exp 45 | > | Colour Exp 46 | > | PenUp 47 | > | PenDown 48 | > deriving Show 49 | 50 | -------------------------------------------------------------------------------- /Atuin/test.at: -------------------------------------------------------------------------------- 1 | square(size, col) { 2 | colour col 3 | repeat 4 { 4 | forward size 5 | right 90 6 | } 7 | } 8 | 9 | myrepeat(num, block) { 10 | if num > 0 { 11 | eval block 12 | myrepeat(num-1, block) 13 | } 14 | } 15 | 16 | polygon(sides, size, col) { 17 | if sides > 2 { 18 | colour col 19 | angle = 360/sides 20 | myrepeat(sides, { 21 | forward size 22 | right angle 23 | }) 24 | } 25 | } 26 | 27 | main() { 28 | x = 100 29 | square(x, blue) 30 | penup 31 | left 90 32 | forward 200 33 | right 90 34 | pendown 35 | polygon(10, 25, red) 36 | } 37 | -------------------------------------------------------------------------------- /Epic/CodegenStack.lhs: -------------------------------------------------------------------------------- 1 | > module Epic.CodegenStack where 2 | 3 | > import Control.Monad.State 4 | 5 | > import Epic.Language 6 | > import Epic.Stackcode 7 | > import Debug.Trace 8 | 9 | > codegenC :: Context -> [Decl] -> String 10 | > codegenC ctxt decls = error $ concatMap (worker ctxt) decls 11 | 12 | > codegenH :: String -> [Decl] -> String 13 | > codegenH = undefined 14 | 15 | > writeIFace :: [Decl] -> String 16 | > writeIFace = undefined 17 | 18 | > worker :: Context -> Decl -> String 19 | > worker ctxt (Decl name ty fn exp flags) = 20 | > show (name, compile ctxt name fn) 21 | > worker _ _ = "" -------------------------------------------------------------------------------- /Epic/Compiler.lhs: -------------------------------------------------------------------------------- 1 | > -- | 2 | > -- Module : EMachine.Compiler 3 | > -- Copyright : Edwin Brady 4 | > -- Licence : BSD-style (see LICENSE in the distribution) 5 | > -- 6 | > -- Maintainer : eb@dcs.st-and.ac.uk 7 | > -- Stability : experimental 8 | > -- Portability : portable 9 | > -- 10 | > -- Public interface for Epigram Supercombinator Compiler 11 | 12 | > module Epic.Compiler(CompileOptions(..), 13 | > compile, 14 | > compileOpts, 15 | > compileDecls, 16 | > link) where 17 | 18 | Brings everything together; parsing, checking, code generation 19 | 20 | > import System.Process 21 | > import System.Exit 22 | > import System.IO 23 | > import System.Directory 24 | > import System.Environment 25 | > import Data.Char 26 | 27 | > import Epic.Language 28 | > import Epic.Parser 29 | > import Epic.Scopecheck 30 | > import Epic.CodegenC 31 | > import Epic.Simplify 32 | 33 | > import Paths_epic 34 | 35 | > addGCC :: [CompileOptions] -> String 36 | > addGCC [] = "" 37 | > addGCC ((GCCOpt s):xs) = s ++ " " ++ addGCC xs 38 | > addGCC (_:xs) = addGCC xs 39 | 40 | > linkobjs :: [CompileOptions] -> String 41 | > linkobjs [] = "" 42 | > linkobjs ((LinkObj s):xs) = s ++ " " ++ linkobjs xs 43 | > linkobjs (_:xs) = linkobjs xs 44 | 45 | > outputHeader :: [CompileOptions] -> Maybe FilePath 46 | > outputHeader [] = Nothing 47 | > outputHeader ((MakeHeader f):_) = Just f 48 | > outputHeader (_:xs) = outputHeader xs 49 | 50 | > doTrace opts | elem Trace opts = " -DTRACEON" 51 | > | otherwise = "" 52 | 53 | > -- |Compile a source file in supercombinator language to a .o 54 | > compile :: FilePath -- ^ Input file name 55 | > -> FilePath -- ^ Output file name 56 | > -> Maybe FilePath -- ^ Interface (.ei) file name, if desired 57 | > -> IO () 58 | > compile fn outf iface 59 | > = compileOpts fn outf iface [] 60 | 61 | Chop off everything after the last / - get the directory a file is in 62 | 63 | > trimLast f = case span (\x -> x /= '/') (reverse f) of 64 | > (eman, htap) -> reverse htap 65 | 66 | > compileOpts :: FilePath -- ^ Input file name 67 | > -> FilePath -- ^ Output file name 68 | > -> Maybe FilePath -- ^ Interface (.ei) file name, if desired 69 | > -> [CompileOptions] -- Keep the C file 70 | > -> IO () 71 | > compileOpts fn outf iface opts 72 | > = do input <- readFile fn 73 | > -- prelude <- readFile (libdir ++ "/Prelude.e") 74 | > let s = parse input fn 75 | > case s of 76 | > Failure err _ _ -> fail err 77 | > Success ds -> do 78 | > compileDecls outf iface ds opts 79 | 80 | > compileDecls :: FilePath -- ^ Output file name 81 | > -> Maybe FilePath -- ^ Interface (.ei) file name, if desired 82 | > -> [Decl] -- ^ Declarations 83 | > -> [CompileOptions] 84 | > -> IO () 85 | > compileDecls outf iface ds opts 86 | > = do (tmpn,tmph) <- tempfile 87 | > let hdr = outputHeader opts 88 | > scchecked <- checkAll opts ds 89 | > let simplified = simplifyAll scchecked 90 | > checked <- docompileDecls simplified tmph hdr 91 | > fp <- getDataFileName "evm/closure.h" 92 | > let libdir = trimLast fp 93 | > let dbg = if (elem Debug opts) then "-g" else "-O3" 94 | > let cmd = "gcc -DUSE_BOEHM -c -fPIC " ++ dbg ++ " -foptimize-sibling-calls -x c " ++ tmpn ++ " -I" ++ libdir ++ " -o " ++ outf ++ " " ++ addGCC opts ++ doTrace opts 95 | > -- putStrLn $ cmd 96 | > -- putStrLn $ fp 97 | > exit <- system cmd 98 | > if (elem KeepC opts) 99 | > then do system $ "cp " ++ tmpn ++ " " ++ 100 | > (getRoot outf) ++ ".c" 101 | > return () 102 | > else return () 103 | > -- removeFile tmpn 104 | > if (exit /= ExitSuccess) 105 | > then fail $ "gcc failed" 106 | > else return () 107 | > case iface of 108 | > Nothing -> return () 109 | > (Just fn) -> do writeFile fn (writeIFace checked) 110 | 111 | > getRoot fn = case span (/='.') fn of 112 | > (stem,_) -> stem 113 | 114 | 115 | > docompileDecls (ctxt, decls) outh hdr 116 | > = do hPutStr outh $ codegenC ctxt decls 117 | > case hdr of 118 | > Just fpath -> 119 | > do let hout = codegenH (filter isAlpha (map toUpper (getRoot fpath))) decls 120 | > writeFile fpath hout 121 | > Nothing -> return () 122 | > hFlush outh 123 | > hClose outh 124 | > return decls 125 | 126 | > getExtra :: [CompileOptions] -> IO [String] 127 | > getExtra ((MainInc x):xs) = do fns <- getExtra xs 128 | > return (x:fns) 129 | > getExtra (_:xs) = getExtra xs 130 | > getExtra [] = return [] 131 | 132 | > -- |Link a collection of .o files into an executable 133 | > link :: [FilePath] -- ^ Object files 134 | > -> FilePath -- ^ Executable filename 135 | > -> [CompileOptions] -- Keep the C file 136 | > -> IO () 137 | > link infs outf opts = do 138 | > extraIncs <- getExtra opts 139 | > mainprog <- if (not (elem ExternalMain opts)) then mkMain extraIncs else return "" 140 | > fp <- getDataFileName "evm/closure.h" 141 | > let libdir = trimLast fp 142 | > let dbg = if (elem Debug opts) then "-g" else "-O3" 143 | > let cmd = "gcc -DUSE_BOEHM -x c " ++ dbg ++ " -foptimize-sibling-calls " ++ mainprog ++ " -x none -L" ++ 144 | > libdir++" -I"++libdir ++ " " ++ 145 | > (concat (map (++" ") infs)) ++ 146 | > (" " ++ linkobjs opts) ++ 147 | > " -levm -lgc -lpthread -lgmp -o "++outf ++ " " ++ addGCC opts 148 | > -- putStrLn $ cmd 149 | > exit <- system cmd 150 | > if (exit /= ExitSuccess) 151 | > then fail $ "Linking failed" 152 | > else return () 153 | 154 | Output the main progam, adding any extra includes needed. 155 | (Some libraries need the extra includes, notably SDL, to compile correctly. 156 | Grr.) 157 | 158 | > mkMain :: [FilePath] -> IO FilePath 159 | > mkMain extra = 160 | > do mppath <- getDataFileName "evm/mainprog.c" 161 | > mp <- readFile mppath 162 | > (tmp, tmpH) <- tempfile 163 | > hPutStr tmpH (concat (map (\x -> "#include <" ++ x ++ ">\n") extra)) 164 | > hPutStr tmpH mp 165 | > hClose tmpH 166 | > return tmp 167 | 168 | -- |Get the path where the required C libraries and include files are stored 169 | libdir :: FilePath 170 | libdir = libprefix ++ "/lib/evm" 171 | 172 | -------------------------------------------------------------------------------- /Epic/Evaluator.lhs: -------------------------------------------------------------------------------- 1 | > {-# OPTIONS_GHC -XFlexibleInstances #-} 2 | 3 | > module Epic.Evaluator(eval) where 4 | 5 | > import Epic.Language 6 | 7 | > import Debug.Trace 8 | 9 | Assume all expressions are in HOAS form - if we see any Vs, or any Updates 10 | then we have an error. Returns expression in standard form. 11 | 12 | > eval :: [EvalDecl] -> Expr -> Expr 13 | > eval ctx e = case ev e of 14 | > Nothing -> quote 0 e 15 | > Just e' -> quote 0 e' 16 | > where 17 | > ev (R n) = case lookupD n ctx of 18 | > Just e' -> ev e' 19 | > Nothing -> return $ R n 20 | > ev (V i) = return $ V i 21 | > ev (App f xs) = do f' <- ev f 22 | > xs' <- mapM ev xs 23 | > evFn f' xs' 24 | > ev (Lazy e) = ev e 25 | > ev (Par e) = ev e 26 | > ev (Effect e) = ev e 27 | > ev (Con t es) = do es' <- mapM ev es 28 | > return $ Con t es' 29 | > ev (Proj e i) = do e' <- ev e 30 | > return $ project e' i 31 | > ev (Case e alts) = do e' <- ev e 32 | > docase e' alts 33 | > ev (If x t e) = do x' <- ev x 34 | > case x of 35 | > Const (MkInt 0) -> ev e 36 | > _ -> ev t 37 | > ev (While _ _) = fail "Can't evaluate while" 38 | > ev (WhileAcc _ _ _) = fail "Can't evaluate while" 39 | > ev (Op op x y) = do x' <- ev x 40 | > y' <- ev y 41 | > case (x', y') of 42 | > (Const xv, Const yv) -> return $ doOp op xv yv 43 | > _ -> return $ Op op x' y' 44 | > ev (Let _ _ _ _) = fail "Not in HOAS form (let)" 45 | > ev (LetM _ _ _) = fail "Can't do updates" 46 | > ev (HLet n ty val sc) = do val' <- ev val 47 | > ev (sc val') 48 | > ev (HLam n ty sc) = do let sc' = \x -> case ev (sc x) of 49 | > Nothing -> sc x 50 | > Just v -> v 51 | > return $ HLam n ty sc' 52 | > ev (WithMem a t e) = ev e 53 | > ev (ForeignCall t str args) 54 | > = do args' <- mapM ev (map fst args) 55 | > return $ ForeignCall t str (zip args' (map snd args)) 56 | > ev (LazyForeignCall t str args) 57 | > = do args' <- mapM ev (map fst args) 58 | > return $ LazyForeignCall t str (zip args' (map snd args)) 59 | > ev x = return x 60 | 61 | > evFn (HLam n t sc) (a:as) = do a' <- ev (sc a) 62 | > evFn a' as 63 | > evFn f [] = ev f 64 | > evFn f as = return $ App f as 65 | 66 | > docase c@(Con t as) alts = case fConAlt t as alts of 67 | > Just rhs -> ev rhs 68 | > Nothing -> return $ Case c alts 69 | > docase c@(Const (MkInt i)) alts 70 | > = case fConstAlt i alts of 71 | > Just rhs -> ev rhs 72 | > Nothing -> return $ Case c alts 73 | > docase c alts = return $ Case c alts 74 | 75 | > fConAlt :: Int -> [Expr] -> [CaseAlt] -> Maybe Expr 76 | > fConAlt t args (HAlt t' n rhs : _) 77 | > | t == t' && n == length args = 78 | > substRHS args rhs 79 | > where 80 | > substRHS [] (HExp rhs) = return rhs 81 | > substRHS (x:xs) (HBind n ty rhsf) = substRHS xs (rhsf x) 82 | > fConAlt t args (DefaultCase e : _) = return e 83 | > fConAlt t args (_:xs) = fConAlt t args xs 84 | > fConAlt t args _ = Nothing 85 | 86 | > fConstAlt :: Int -> [CaseAlt] -> Maybe Expr 87 | > fConstAlt t (ConstAlt t' rhs:_) 88 | > | t == t' = return rhs 89 | > fConstAlt t (DefaultCase e : _) = return e 90 | > fConstAlt t (_:xs) = fConstAlt t xs 91 | > fConstAlt t _ = Nothing 92 | 93 | > doOp Plus (MkInt x) (MkInt y) = Const $ MkInt (x+y) 94 | > doOp Minus (MkInt x) (MkInt y) = Const $ MkInt (x-y) 95 | > doOp Times (MkInt x) (MkInt y) = Const $ MkInt (x*y) 96 | > doOp Divide (MkInt x) (MkInt y) = Const $ MkInt (x `div` y) 97 | > doOp Modulo (MkInt x) (MkInt y) = Const $ MkInt (x `mod` y) 98 | > doOp OpEQ (MkInt x) (MkInt y) = bint (x==y) 99 | > doOp OpLT (MkInt x) (MkInt y) = bint (x doOp OpLE (MkInt x) (MkInt y) = bint (x<=y) 101 | > doOp OpGT (MkInt x) (MkInt y) = bint (x>y) 102 | > doOp OpGE (MkInt x) (MkInt y) = bint (x>=y) 103 | 104 | > doOp FPlus (MkFloat x) (MkFloat y) = Const $ MkFloat (x+y) 105 | > doOp FMinus (MkFloat x) (MkFloat y) = Const $ MkFloat (x-y) 106 | > doOp FTimes (MkFloat x) (MkFloat y) = Const $ MkFloat (x*y) 107 | > doOp FDivide (MkFloat x) (MkFloat y) = Const $ MkFloat (x/y) 108 | > doOp OpFEQ (MkFloat x) (MkFloat y) = bint (x==y) 109 | > doOp OpFLT (MkFloat x) (MkFloat y) = bint (x doOp OpFLE (MkFloat x) (MkFloat y) = bint (x<=y) 111 | > doOp OpFGT (MkFloat x) (MkFloat y) = bint (x>y) 112 | > doOp OpFGE (MkFloat x) (MkFloat y) = bint (x>=y) 113 | 114 | > doOp op x y = Op op (Const x) (Const y) 115 | 116 | > bint True = Const $ MkInt 1 117 | > bint False = Const $ MkInt 0 118 | 119 | > project :: Expr -> Int -> Expr 120 | > project (Con t as) i | i < length as = as!!i 121 | > project e i = Proj e i 122 | 123 | > lookupD n [] = Nothing 124 | > lookupD n (EDecl en def:xs) | n == en = Just def 125 | > lookupD n (_:xs) = lookupD n xs 126 | 127 | > class Quote a where 128 | > quote :: Int -> a -> a 129 | 130 | > instance Quote a => Quote [a] where 131 | > quote l = map (quote l) 132 | 133 | > instance Quote a => Quote (a, Type) where 134 | > quote l (x,t) = (quote l x, t) 135 | 136 | > instance Quote Expr where 137 | > quote v (App x xs) = App (quote v x) (quote v xs) 138 | > quote v (Lazy x) = Lazy (quote v x) 139 | > quote v (Par x) = Par (quote v x) 140 | > quote v (Effect x) = Effect (quote v x) 141 | > quote v (Con t xs) = Con t (quote v xs) 142 | > quote v (Proj x i) = Proj (quote v x) i 143 | > quote v (Case e as) = Case (quote v e) (quote v as) 144 | > quote v (If x y z) = If (quote v x) (quote v y) (quote v z) 145 | > quote v (While x y) = While (quote v x) (quote v y) 146 | > quote v (WhileAcc x y z) = WhileAcc (quote v x) (quote v y) (quote v z) 147 | > quote v (Op o x y) = Op o (quote v x) (quote v y) 148 | > quote v (HLam n ty fn) = Lam n ty (quote (v+1) (fn (V v))) 149 | > quote v (WithMem a x y) = WithMem a (quote v x) (quote v y) 150 | > quote v (ForeignCall t s xs) = ForeignCall t s (quote v xs) 151 | > quote v (LazyForeignCall t s xs) = LazyForeignCall t s (quote v xs) 152 | > quote v x = x 153 | 154 | > instance Quote CaseAlt where 155 | > quote v (HAlt t n rhs) = buildRHS v t [] rhs where 156 | > buildRHS v t acc (HExp e) = Alt t (reverse acc) (quote v e) 157 | > buildRHS v t acc (HBind n ty rhs) 158 | > = buildRHS (v+1) t ((n,ty):acc) (rhs (V v)) 159 | > quote v (ConstAlt c e) = ConstAlt c (quote v e) 160 | > quote v (DefaultCase e) = DefaultCase (quote v e) -------------------------------------------------------------------------------- /Epic/OTTLang.lhs: -------------------------------------------------------------------------------- 1 | > module Epic.OTTLang where 2 | 3 | > import Epic.Language 4 | 5 | Terms 6 | 7 | t = x | lam x. t | t t 8 | | i t | hd(t) | tl(t) | 9 | | switch(t) [t] 10 | | TY 11 | 12 | > data OTTerm = OTRef Name -- Global or unresolved name 13 | > | OTV Int -- Locally bound name 14 | > | OTLam Name 15 | > | OTApp OTTerm OTTerm 16 | > | OTRec Tag OTTerm 17 | > | OTHd OTTerm 18 | > | OTTl OTTerm 19 | > | OTSwitch OTTerm [OTTerm] 20 | > | OTTY -- can't look at types, so dump them all here -------------------------------------------------------------------------------- /Epic/Scopecheck.lhs: -------------------------------------------------------------------------------- 1 | > {-# LANGUAGE CPP #-} 2 | 3 | #if __GLASGOW_HASKELL__ >= 710 4 | > {-# LANGUAGE FlexibleContexts #-} 5 | #endif 6 | 7 | > {-# LANGUAGE FlexibleInstances #-} 8 | 9 | > module Epic.Scopecheck where 10 | 11 | Check that an expression has all its names in scope. This is the only 12 | checking we do (for now). 13 | 14 | > import Control.Monad.State 15 | 16 | > import Epic.Language 17 | > import Epic.Parser 18 | 19 | > import Debug.Trace 20 | 21 | > checkAll :: Monad m => [CompileOptions] -> [Decl] -> m (Context, [Decl]) 22 | > checkAll opts xs = do let ctxt = mkContext xs 23 | > ds <- ca (mkContext xs) xs 24 | > return (mkContext ds,ds) 25 | > where ca ctxt [] = return [] 26 | > ca ctxt ((Decl nm rt fn exp fl):xs) = 27 | > do (fn', newds) <- scopecheck (checkLevel opts) ctxt nm fn 28 | > xs' <- ca ctxt (newds ++ xs) 29 | > return $ (Decl nm rt fn' exp fl):xs' 30 | > ca ctxt (x:xs) = 31 | > do xs' <- ca ctxt xs 32 | > return (x:xs') 33 | 34 | > mkContext [] = [] 35 | > mkContext ((Decl nm rt (Bind args _ _ _) _ _):xs) = 36 | > (nm,(map snd args, rt)):(mkContext xs) 37 | > mkContext ((Extern nm rt args):xs) = 38 | > (nm,(args, rt)):(mkContext xs) 39 | > mkContext (_:xs) = mkContext xs 40 | 41 | Check all names are in scope in a function, and convert global 42 | references (R) to local names (V). Also, if any lazy expressions are 43 | not already applications, lift them out and make a new 44 | function. Returns the modified function, and a list of new 45 | declarations. The new declarations will *not* have been scopechecked. 46 | 47 | Do Lambda Lifting here too 48 | 49 | > scopecheck :: Monad m => Int -> Context -> Name -> Func -> m (Func, [Decl]) 50 | > scopecheck checking ctxt nm (Bind args locs exp fl) = do 51 | > (exp', (locs', _, ds)) <- runStateT (tc (v_ise args 0) exp) (length args, 0, []) 52 | > return $ (Bind args locs' exp' fl, ds) 53 | > where 54 | > getRoot (UN nm) = nm 55 | > getRoot (MN nm i) = "_" ++ nm ++ "_" ++ show i 56 | > tc env (R n) = case lookup n env of 57 | > Nothing -> case lookup n ctxt of 58 | > Nothing -> if (checking > 0) then lift $ fail $ "Unknown name " ++ showuser n 59 | > else return $ Const (MkInt 1234567890) 60 | > (Just _) -> return $ R n 61 | > (Just i) -> return $ V i 62 | > tc env (LetM n v sc) = case lookup n env of 63 | > Nothing -> lift $ fail $ "Unknown local to update" ++ showuser n 64 | > (Just i) -> do v' <- tc env v 65 | > sc' <- tc env sc 66 | > return $ Update i v' sc' 67 | > tc env (Let n ty v sc) = do 68 | > v' <- tc env v 69 | > sc' <- tc ((n,length env):env) sc 70 | > (maxlen, nextn, decls) <- get 71 | > put ((if (length env + 1)>maxlen 72 | > then (length env + 1) 73 | > else maxlen), nextn, decls) 74 | > return $ Let n ty v' sc' 75 | > tc env (Case v alts) = do 76 | > v' <- tc env v 77 | > alts' <- tcalts env alts 78 | > return $ Case v' alts' 79 | > tc env (If a t e) = do 80 | > a' <- tc env a 81 | > t' <- tc env t 82 | > e' <- tc env e 83 | > return $ If a' t' e' 84 | > tc env (While t b) = do 85 | > t' <- tc env t 86 | > b' <- tc env b 87 | > return $ While t' b' 88 | > tc env (WhileAcc t a b) = do 89 | > t' <- tc env t 90 | > a' <- tc env a 91 | > b' <- tc env b 92 | > return $ WhileAcc t' a' b' 93 | > tc env (App f as) = do 94 | > f' <- tc env f 95 | > as' <- mapM (tc env) as 96 | > return $ App f' as' 97 | > tc env (Lazy e) | appForm e = do 98 | > e' <- tc env e 99 | > return $ Lazy e' 100 | > tc env (Par e) | appForm e = do 101 | > e' <- tc env e 102 | > return $ Par e' 103 | 104 | Make a new function, with current env as arguments, and add as a decl 105 | 106 | > tc env (Lazy e) = 107 | > do (maxlen, nextn, decls) <- get 108 | > let newname = MN (getRoot nm) nextn 109 | > let newargs = zip (map fst env) (repeat TyAny) 110 | > let newfn = Bind newargs 0 e [] 111 | > let newd = Decl newname TyAny newfn Nothing [] 112 | > put (maxlen, nextn+1, newd:decls) 113 | > return $ Lazy (App (R newname) (map V (map snd env))) 114 | > tc env (Par e) = 115 | > do (maxlen, nextn, decls) <- get 116 | > let newname = MN (getRoot nm) nextn 117 | > let newargs = zip (map fst env) (repeat TyAny) 118 | > let newfn = Bind newargs 0 e [] 119 | > let newd = Decl newname TyAny newfn Nothing [] 120 | > put (maxlen, nextn+1, newd:decls) 121 | > return $ Par (App (R newname) (map V (map snd env))) 122 | 123 | > tc env (Lam n ty e) = lift e [(n,ty)] where 124 | > lift (Lam n ty e) args = lift e ((n,ty):args) 125 | > lift e args = do (maxlen, nextn, decls) <- get 126 | > let newname = MN (getRoot nm) nextn 127 | > let newargs = zip (map fst env) (repeat TyAny) 128 | > ++ reverse args 129 | > let newfn = Bind newargs 0 e [] 130 | > let newd = Decl newname TyAny newfn Nothing [] 131 | > put (maxlen, nextn+1, newd:decls) 132 | > return $ App (R newname) (map V (map snd env)) 133 | > tc env (Effect e) = do 134 | > e' <- tc env e 135 | > return $ Effect e' 136 | > tc env (Con t as) = do 137 | > as' <- mapM (tc env) as 138 | > return $ Con t as' 139 | > tc env (Proj e i) = do 140 | > e' <- tc env e 141 | > return $ Proj e' i 142 | > tc env (Op op l r) = do 143 | > l' <- tc env l 144 | > r' <- tc env r 145 | > return $ Op op l' r' 146 | > tc env (WithMem alloc s e) = do 147 | > s' <- tc env s 148 | > e' <- tc env e 149 | > return $ WithMem alloc s' e' 150 | > tc env (ForeignCall ty fn args) = do 151 | > argexps' <- mapM (tc env) (map fst args) 152 | > return $ ForeignCall ty fn (zip argexps' (map snd args)) 153 | > tc env (LazyForeignCall ty fn args) = do 154 | > argexps' <- mapM (tc env) (map fst args) 155 | > return $ LazyForeignCall ty fn (zip argexps' (map snd args)) 156 | > tc env x = return x 157 | 158 | > tcalts env [] = return [] 159 | > tcalts env ((Alt tag args expr):alts) = do 160 | > let env' = (v_ise args (length env))++env 161 | > expr' <- tc env' expr 162 | > (maxlen, nextn, decls) <- get 163 | > put ((if (length env')>maxlen 164 | > then (length env') 165 | > else maxlen), nextn, decls) 166 | > alts' <- tcalts env alts 167 | > return $ (Alt tag args expr'):alts' 168 | > tcalts env ((ConstAlt tag expr):alts) = do 169 | > expr' <- tc env expr 170 | > alts' <- tcalts env alts 171 | > return $ (ConstAlt tag expr'):alts' 172 | > tcalts env ((DefaultCase expr):alts) = do 173 | > expr' <- tc env expr 174 | > alts' <- tcalts env alts 175 | > return $ (DefaultCase expr'):alts' 176 | 177 | Turn the argument list into a mapping from names to argument position 178 | If any names appear more than once, use the last one. 179 | 180 | We're being very tolerant of input here... 181 | 182 | > v_ise [] _ = [] 183 | > v_ise ((n,ty):args) i = let rest = v_ise args (i+1) in 184 | > case lookup n rest of 185 | > Nothing -> (n,i):rest 186 | > Just i' -> (n,i'):rest 187 | 188 | where dropArg n [] = [] 189 | dropArg n ((x,i):xs) | x == n = dropArg n xs 190 | | otherwise = (x,i):(dropArg n xs) 191 | 192 | This is scope checking without the lambda lifting. Of course, it would be 193 | better to separate the two anyway... FIXME later... 194 | 195 | > class RtoV a where 196 | > rtov :: [(Name, Int)] -> a -> a 197 | > doRtoV :: a -> a 198 | > doRtoV = rtov [] 199 | 200 | > instance RtoV a => RtoV [a] where 201 | > rtov env xs = map (rtov env) xs 202 | 203 | > instance RtoV a => RtoV (a, Type) where 204 | > rtov env (x, t) = (rtov env x, t) 205 | 206 | > instance RtoV Func where 207 | > rtov env (Bind args locs def flags) 208 | > = Bind args locs (rtov (v_ise args 0) def) flags 209 | 210 | > instance RtoV Expr where 211 | > rtov v (R x) = case lookup x v of 212 | > Just i -> V i 213 | > _ -> R x 214 | > rtov v (App f xs) = App (rtov v f) (rtov v xs) 215 | > rtov v (Lazy x) = Lazy (rtov v x) 216 | > rtov v (Effect x) = Effect (rtov v x) 217 | > rtov v (Con t xs) = Con t (rtov v xs) 218 | > rtov v (Proj x i) = Proj (rtov v x) i 219 | > rtov v (Case x xs) = Case (rtov v x) (rtov v xs) 220 | > rtov v (If x t e) = If (rtov v x) (rtov v t) (rtov v e) 221 | > rtov v (While x y) = While (rtov v x) (rtov v y) 222 | > rtov v (WhileAcc x y z) = WhileAcc (rtov v x) (rtov v y) (rtov v z) 223 | > rtov v (Op o x y) = Op o (rtov v x) (rtov v y) 224 | > rtov v (Let n t val sc) 225 | > = Let n t (rtov v val) (rtov ((n,length v):v) sc) 226 | > rtov v (Lam n ty sc) 227 | > = Lam n ty (rtov ((n,length v):v) sc) 228 | > rtov v (WithMem a x y) = WithMem a (rtov v x) (rtov v y) 229 | > rtov v (ForeignCall t n xs) = ForeignCall t n (rtov v xs) 230 | > rtov v (LazyForeignCall t n xs) = LazyForeignCall t n (rtov v xs) 231 | > rtov v x = x 232 | 233 | > instance RtoV CaseAlt where 234 | > rtov v (Alt t args rhs) 235 | > = let env' = (v_ise args (length v)) ++ v in 236 | > Alt t args (rtov env' rhs) 237 | > rtov v (ConstAlt i e) = ConstAlt i (rtov v e) 238 | > rtov v (DefaultCase e) = DefaultCase (rtov v e) 239 | -------------------------------------------------------------------------------- /Epic/Simplify.lhs: -------------------------------------------------------------------------------- 1 | > module Epic.Simplify(simplifyAll) where 2 | 3 | > import Epic.Language 4 | 5 | > import Data.Maybe 6 | > import Debug.Trace 7 | 8 | > simplifyAll :: (Context, [Decl]) -> (Context, [Decl]) 9 | > simplifyAll (ctxt, xs) = let sctxt = mapMaybe mkEntry xs in 10 | > simpl sctxt ctxt xs 11 | > where mkEntry d@(Decl n _ fn _ fl) = Just (n, (d, (length (fun_args fn)), fl)) 12 | > mkEntry _ = Nothing 13 | 14 | For each supercombinator, evaluate it as far as we believe sensible - basically just inlining 15 | definitions marked as such, constant folding, case on constants, etc. 16 | 17 | Also consider creating specialised versions of functions? 18 | 19 | > type SCtxt = [(Name, (Decl, Int, [CGFlag]))] 20 | 21 | > simpl :: SCtxt -> Context -> [Decl] -> (Context, [Decl]) 22 | > simpl sctxt ctxt ds = (ctxt, map simplD ds) 23 | > where simplD (Decl fn fr fd fe fl) = let simpled = simplFun fd in 24 | > diff fn simpled fd $ 25 | > Decl fn fr (simplFun fd) fe fl 26 | > simplD d = d 27 | 28 | > simplFun (Bind args locs def fl) 29 | > = Bind args locs (simplify sctxt (map (\x -> Nothing) args) (length args) def) fl 30 | > diff fn simpled fd x | defn simpled == defn fd = x 31 | > | otherwise = {- trace (show fn ++ "\n" ++ show simpled ++ "\n" ++ 32 | > show fd) -} x 33 | 34 | > inlinable = elem Inline 35 | 36 | > simplify :: SCtxt -> [Maybe Expr] -> Int -> Expr -> Expr 37 | > simplify sctxt args arity exp = s' args arity exp 38 | > where 39 | > s' args depth (V i) = if i case args!!i of 41 | > Nothing -> V i 42 | > Just v -> v 43 | > else error "Can't happen - simplify - No such arg" -- V (i + (arity - length args)) -- adjust case/let offset 44 | > s' args d (R fn) 45 | > = case lookup fn sctxt of 46 | > Just (decl, 0, fl) -> 47 | > if (inlinable fl) then s' args d (inline d decl []) 48 | > else R fn 49 | > _ -> R fn 50 | > s' args d (App f a) = apply d (s' args d f) (map (s' args d) a) args 51 | > s' args d (Lazy e) = Lazy $ s' args d e 52 | > s' args d (Par e) = Par $ s' args d e 53 | > s' args d (Effect e) = Effect $ s' args d e 54 | > s' args d (While t e) = While (s' args d t) (s' args d e) 55 | > s' args d (WhileAcc t a e) = WhileAcc (s' args d t) (s' args d a) (s' args d e) 56 | > s' args d (Con t a) = Con t (map (s' args d) a) 57 | > s' args d (Proj e i) = project (s' args d e) i 58 | > s' args d (Case e alts) = runCase (s' args d e) (map (salt args d) alts) 59 | > s' args d (If x t e) = runIf (s' args d x) (s' args d t) (s' args d e) 60 | > s' args d (Op op l r) = runOp op (s' args d l) (s' args d r) 61 | > s' args d (Let n ty v sc) 62 | > = simplFLet $ runLet n ty (s' args d v) 63 | > (s' (args++[Just (V d)]) (d+1) sc) 64 | > s' args d (ForeignCall ty nm a) 65 | > = ForeignCall ty nm (map (\ (x,y) -> (s' args d x, y)) a) 66 | > s' args d (LazyForeignCall ty nm a) 67 | > = LazyForeignCall ty nm (map (\ (x,y) -> (s' args d x, y)) a) 68 | > s' args d x = x 69 | 70 | > salt args d (Alt t bargs e) 71 | > = Alt t bargs (s' newargs (d+length bargs) e) 72 | > where newargs = args ++ (map (Just . V) (take (length bargs) [d..])) 73 | > salt args d (ConstAlt c e) = ConstAlt c (s' args d e) 74 | > salt args d (DefaultCase e) = DefaultCase (s' args d e) 75 | 76 | > project e i = Proj e i 77 | > runCase e alts = Case e alts 78 | > runIf x t e = If x t e 79 | > runOp op l r = Op op l r 80 | > runLet n ty v sc = Let n ty v sc 81 | 82 | > apply d f@(R fn) as args 83 | > = case lookup fn sctxt of 84 | > Just (decl, ar, fl) -> 85 | > if (inlinable fl && ar == length as) then inline d decl (map Just as) 86 | > else App f as 87 | > _ -> App f as 88 | > apply d f as args = App f as 89 | 90 | > inline :: Int -> Decl -> [Maybe Expr] -> Expr 91 | > inline d (Decl fn _ (Bind _ _ exp _) _ _) args 92 | > = simplify (remove fn sctxt) args d exp 93 | > where remove fn [] = [] 94 | > remove fn (f@(x,_):xs) | x == fn = xs 95 | > | otherwise = f:(remove fn xs) 96 | 97 | If we do this, we can chop out some pointless assignments to Unit 98 | 99 | > simplFLet :: Expr -> Expr 100 | > simplFLet (Let n _ (ForeignCall ty f args) s) = 101 | > Let n ty (ForeignCall ty f args) s 102 | > simplFLet (Let n _ (Effect (ForeignCall ty f args)) s) = 103 | > Let n ty (Effect (ForeignCall ty f args)) s 104 | > simplFLet x = x 105 | -------------------------------------------------------------------------------- /Epic/Stackcode.lhs: -------------------------------------------------------------------------------- 1 | > module Epic.Stackcode where 2 | 3 | > import Control.Monad.State 4 | > import Data.List 5 | 6 | > import Epic.Language 7 | > import Debug.Trace 8 | 9 | A stack based byte code. 10 | 11 | Functions take arguments and local variables on the stack and put the 12 | return value at the top of the stack. 13 | 14 | If there are local variables in scope, 15 | locally bound name V n is referred to by stack location (-n) 16 | 17 | > type Loc = Int 18 | > type Tmp = Int 19 | 20 | > data ByteOp = EVAL Loc Bool -- whether to update 21 | > | PUSH Loc 22 | > | INT Int 23 | > | BIGINT Integer 24 | > | FLOAT Double 25 | > | STRING Int -- reference to string pool 26 | > | CON Tag Int 27 | > | UNIT 28 | > | UNUSED 29 | > | THUNK Int Int Name 30 | > | CALL Name 31 | > | SLIDE Int Int 32 | > | DISCARD Int 33 | > | ADDARGS Loc Int 34 | > | PROJ Int Int -- project the nth argument from stack position m 35 | > | CASE [(Int, Bytecode)] (Maybe Bytecode) 36 | > | INTCASE [(Int, Bytecode)] (Maybe Bytecode) 37 | > | IF Bytecode Bytecode -- must discard stack top! 38 | > | MEMORY Allocator Bytecode 39 | > | WHILE Bytecode Bytecode 40 | > | BREAKFALSE 41 | > | OP Op Loc Loc 42 | > | CONSTS [String] 43 | > | FOREIGN Type String [Type] 44 | > | NotImplemented String 45 | > deriving Show 46 | 47 | > type Bytecode = [ByteOp] 48 | 49 | > data FunCode = Code Bytecode 50 | > deriving Show 51 | 52 | > data CompileState = CS { num_locals :: Int, 53 | > string_pool :: [String] } 54 | 55 | > compile :: Context -> Name -> Func -> FunCode 56 | > compile ctxt fname fn@(Bind args locals def flags) = 57 | > let cs = CS (length args) [] 58 | > (code, state) = runState (scompile ctxt fname fn) cs in 59 | > Code code 60 | 61 | > data TailCall = Tail | Middle 62 | 63 | Compiling a function of n arguments replaces top n entries on the stack 64 | with one, the result. SLIDE, at the end, removes the locals. 65 | 66 | > scompile :: Context -> Name -> Func -> State CompileState Bytecode 67 | > scompile ctxt fname (Bind args locals def _) = 68 | > do code <- tcomp False False 1 def 69 | > cs <- get 70 | > return (CONSTS (string_pool cs) : code) 71 | 72 | Assumption: ecomp produces code which makes the stack have one more entry. 73 | 74 | > where ecomp :: Bool -> Bool -> 75 | > Int -> -- variable offset. Stack top is at 1. 76 | > Expr -> 77 | > State CompileState Bytecode 78 | > ecomp lazy eff off (V v) = return [PUSH (off-v)] 79 | > ecomp lazy eff off (R x) = acomp Middle lazy eff off (R x) [] 80 | > ecomp lazy eff off (App f as) = acomp Middle lazy eff off f as 81 | > ecomp lazy eff off (Lazy e) = ecomp True eff off e 82 | > ecomp lazy eff off (Effect e) = 83 | > do code <- ecomp lazy True off e 84 | > return (code ++ [EVAL 1 False]) 85 | > ecomp lazy eff off (Con t as) = 86 | > do argcode <- argcomp lazy eff off as 87 | > return (argcode ++ [CON t (length as)]) 88 | > ecomp lazy eff off (Proj con i) = 89 | > do concode <- ecomp lazy eff off con 90 | > return (concode ++ [PROJ i 0]) 91 | > ecomp lazy eff off (Const c) = ccomp c 92 | > ecomp lazy eff off (Case scr alts) = 93 | > do sccode <- ecomp lazy eff off scr 94 | > (altcode, def) <- altcomps lazy eff Middle off (order alts) 95 | > return $ sccode ++ [EVAL 0 eff, (caseop alts) altcode def] 96 | > ecomp lazy eff off (If a t e) = 97 | > do acode <- ecomp lazy eff off a 98 | > tcode <- tcomp lazy eff off t 99 | > ecode <- tcomp lazy eff off e 100 | > return (acode ++ [EVAL 0 eff, IF tcode ecode]) 101 | > ecomp lazy eff off (WithMem a e val) = 102 | > do ecode <- ecomp lazy eff off e 103 | > valcode <- ecomp lazy eff off val 104 | > return $ ecode ++ [EVAL 0 eff] ++ [MEMORY a valcode] 105 | > ecomp lazy eff off (While t b) = 106 | > do tcode <- ecomp lazy eff off t 107 | > bcode <- ecomp lazy eff off b 108 | > return [WHILE (tcode ++ [EVAL 0 False, BREAKFALSE]) 109 | > (bcode ++ [EVAL 0 False])] 110 | > ecomp lazy eff off (WhileAcc t acc b) = 111 | > do tcode <- ecomp lazy eff off t 112 | > acode <- ecomp lazy eff off acc 113 | > bcode <- ecomp lazy eff off b 114 | > return $ acode ++ 115 | > [WHILE (tcode ++ [EVAL 0 False, BREAKFALSE]) 116 | > (bcode ++ [ADDARGS 2 1, EVAL 2 False])] 117 | > {- ecomp lazy eff off (ForeignCall ty nm args) 118 | > = fcomp lazy eff off f as 119 | > ecomp lazy eff off (LazyForeignCall ty nm args) 120 | > = fcomp lazy eff off f as -} 121 | > ecomp lzy eff off x = return $ [NotImplemented (show x)] 122 | 123 | Compile case alternatives. 124 | 125 | > order :: [CaseAlt] -> [CaseAlt] 126 | > order xs = sort xs -- insertError 0 (sort xs) 127 | 128 | > altcomps :: Bool -> Bool -> TailCall -> Int -> 129 | > [CaseAlt] -> 130 | > State CompileState ([(Int, Bytecode)], Maybe Bytecode) 131 | > altcomps lazy eff tc off [] = return ([], Nothing) 132 | > altcomps lazy eff tc off (a:as) = 133 | > do (t,acode) <- altcomp lazy eff tc off a 134 | > (ascode, def) <- altcomps lazy eff tc off as 135 | > if (t<0) then return (ascode, Just acode) 136 | > else return ((t,acode):ascode, def) 137 | 138 | Assume that all the tags are in order, and unused constructors have 139 | a default inserted (i.e., tag can be ignored). 140 | 141 | Return the tag and the code - tag is -1 for default case. 142 | 143 | > altcomp :: Bool -> Bool -> TailCall -> Int -> 144 | > CaseAlt -> 145 | > State CompileState (Int, Bytecode) 146 | > altcomp lazy eff tc off (Alt tag nmargs expr) = 147 | > do let args = map snd nmargs 148 | > projcode <- project args 1 0 149 | > exprcode <- ecomp lazy eff (off+length args) expr 150 | > return (tag, projcode ++ [SLIDE 1 (length args)] ++ exprcode ++ [SLIDE (length args) 1]) 151 | > altcomp lazy eff tc off (ConstAlt tag expr) = 152 | > do exprcode <- ecomp lazy eff off expr 153 | > return (tag, (SLIDE 1 1):exprcode) 154 | > altcomp lazy eff tc off (DefaultCase expr) = 155 | > do exprcode <- ecomp lazy eff off expr 156 | > return (-1,(SLIDE 1 1):exprcode) 157 | 158 | > project [] _ _ = return [] 159 | > project (_:as) p o = 160 | > do let acode = PROJ p o 161 | > ascode <- project as (p+1) (o+1) 162 | > return (acode:ascode) 163 | 164 | > caseop ((ConstAlt _ _):_) = INTCASE 165 | > caseop _ = CASE 166 | 167 | > tcomp lazy eff off x = 168 | > do code <- ecomp lazy eff off x 169 | > return (code ++ [SLIDE off 1]) 170 | 171 | > acomp :: TailCall -> Bool -> Bool -> Int -> 172 | > Expr -> [Expr] -> 173 | > State CompileState Bytecode 174 | > acomp tl lazy eff off (R x) args 175 | > | not lazy && arity x ctxt == length args = 176 | > do argcode <- argcomp lazy eff off args 177 | > return (argcode ++ cleanstack tl off (length args) 178 | > ++ [CALL x]) 179 | > | otherwise = 180 | > do argcode <- argcomp lazy eff off args 181 | > return (argcode ++ cleanstack tl off (length args) 182 | > ++ [THUNK (arity x ctxt) (length args) x]) 183 | > acomp tl lazy eff off f args 184 | > = do argcode <- argcomp lazy eff off args 185 | > fcode <- ecomp lazy eff off f 186 | > return $ fcode ++ argcode ++ [ADDARGS (length args) (length args)] 187 | 188 | > cleanstack Middle _ n = [] 189 | > cleanstack Tail off n = [SLIDE (off-1) n] 190 | 191 | > argcomp lazy eff off [] = return [] 192 | > argcomp lazy eff off (a:as) = 193 | > do code <- ecomp lazy eff off a 194 | > acode <- argcomp lazy eff (off+1) as 195 | > return (code ++ acode) 196 | 197 | > ccomp (MkInt i) = return [INT i] 198 | > ccomp (MkBigInt i) = return [BIGINT i] 199 | > ccomp (MkChar c) = return [INT (fromEnum c)] 200 | > ccomp (MkFloat f) = return [FLOAT f] 201 | > -- ccomp (MkBigFloat f) = return [BIGFLOAT f] 202 | > ccomp (MkBool b) = return [INT (if b then 1 else 0)] 203 | > ccomp (MkString s) = do sreg <- new_string s 204 | > return [STRING sreg] 205 | > ccomp (MkUnit) = return [UNIT] 206 | > ccomp MkUnused = return [UNUSED] 207 | 208 | > new_string :: String -> State CompileState Int 209 | > new_string s = do cs <- get 210 | > let reg' = string_pool cs 211 | > put (cs { string_pool = reg'++[s] } ) 212 | > return (length reg') 213 | -------------------------------------------------------------------------------- /FL/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2006 Edwin Brady 2 | School of Computer Science, University of St Andrews 3 | All rights reserved. 4 | 5 | This code is derived from software written by Edwin Brady 6 | (eb@dcs.st-and.ac.uk). 7 | 8 | Redistribution and use in source and binary forms, with or without 9 | modification, are permitted provided that the following conditions 10 | are met: 11 | 1. Redistributions of source code must retain the above copyright 12 | notice, this list of conditions and the following disclaimer. 13 | 2. Redistributions in binary form must reproduce the above copyright 14 | notice, this list of conditions and the following disclaimer in the 15 | documentation and/or other materials provided with the distribution. 16 | 3. None of the names of the copyright holders may be used to endorse 17 | or promote products derived from this software without specific 18 | prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS ``AS IS'' AND ANY 21 | EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 22 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR 23 | PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE 24 | LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 25 | CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF 26 | SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR 27 | BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, 28 | WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE 29 | OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN 30 | IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | 32 | *** End of disclaimer. *** 33 | -------------------------------------------------------------------------------- /FL/fl.cabal: -------------------------------------------------------------------------------- 1 | Name: fl 2 | Version: 0.1.2 3 | Author: Edwin Brady 4 | License: BSD3 5 | License-file: LICENSE 6 | Maintainer: eb@cs.st-andrews.ac.uk 7 | Homepage: http://www.dcs.st-and.ac.uk/~eb/epic.php 8 | Stability: experimental 9 | Category: Compilers/Interpreters 10 | Synopsis: Demonstration language for Epic 11 | Description: Epic is a simple functional language which compiles to 12 | reasonably efficient C code. This language demonstrates it. 13 | 14 | Cabal-Version: >= 1.6 15 | Build-type: Simple 16 | 17 | Executable fl 18 | Main-is: Main.lhs 19 | hs-source-dirs: src 20 | Other-modules: Lang 21 | Build-depends: base >=4 && <5, haskell98, Cabal, directory, 22 | epic >=0.1.13 23 | -------------------------------------------------------------------------------- /FL/src/Lang.lhs: -------------------------------------------------------------------------------- 1 | > module Lang where 2 | 3 | > import Epic.Epic 4 | 5 | > data Lang = Lam (Lang -> Lang) 6 | > | Ref Name 7 | > | App Lang Lang 8 | > | Const Const 9 | > | Op Infix Lang Lang 10 | > | EpicRef Expr -- for conversion of Lam to Epic expressions 11 | 12 | > data Const = CInt Int 13 | > | CStr String 14 | 15 | > data Infix = Plus | Minus | Times | Divide | Append 16 | > | Equal | Lt | Gt 17 | 18 | > type Defs = [(Name, Lang)] 19 | 20 | > build :: Lang -> Term 21 | > build (Lam f) = term (\x -> build (f (EpicRef x))) 22 | > build (EpicRef x) = term x 23 | > build (Ref n) = ref n 24 | > build (App f a) = build f @@ build a 25 | > build (Const (CInt x)) = int x 26 | > build (Const (CStr x)) = str x 27 | > build (Op Append l r) = fn "append" @@ build l @@ build r 28 | > build (Op op l r) = op_ (buildOp op) (build l) (build r) 29 | > where buildOp Plus = plus_ 30 | > buildOp Minus = minus_ 31 | > buildOp Times = times_ 32 | > buildOp Divide = divide_ 33 | > buildOp Equal = eq_ 34 | > buildOp Lt = lt_ 35 | > buildOp Gt = gt_ 36 | 37 | > mkProg :: Defs -> Program 38 | > mkProg ds = mkProgram $ basic_defs ++ map (\ (n, d) -> EpicFn n (build d)) ds 39 | 40 | > execute :: Defs -> IO () 41 | > execute p = run (mkProg p) 42 | -------------------------------------------------------------------------------- /FL/src/Main.lhs: -------------------------------------------------------------------------------- 1 | > module Main where 2 | 3 | > import Lang 4 | > import Epic.Epic 5 | 6 | > add :: Lang 7 | > add = Lam (\x -> Lam (\y -> Op Plus x y)) 8 | 9 | > main_ = App (Ref (name "putStrLn")) 10 | > (App (Ref (name "intToString")) 11 | > (App (App (Ref (name "add")) 12 | > (Const (CInt 5))) (Const (CInt 6)))) 13 | 14 | > testdefs = [(name "add", add), (name "main", main_)] 15 | 16 | > main = do let prog = mkProg testdefs 17 | > let addNums = build (App (App (Ref (name "add")) (Const (CInt 5))) (Const (CInt 6))) 18 | > let exp = evaluate prog addNums 19 | > print exp 20 | > run prog -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2006-10 Edwin Brady 2 | School of Computer Science, University of St Andrews 3 | All rights reserved. 4 | 5 | This code is derived from software written by Edwin Brady 6 | (eb@dcs.st-and.ac.uk). 7 | 8 | Redistribution and use in source and binary forms, with or without 9 | modification, are permitted provided that the following conditions 10 | are met: 11 | 1. Redistributions of source code must retain the above copyright 12 | notice, this list of conditions and the following disclaimer. 13 | 2. Redistributions in binary form must reproduce the above copyright 14 | notice, this list of conditions and the following disclaimer in the 15 | documentation and/or other materials provided with the distribution. 16 | 3. None of the names of the copyright holders may be used to endorse 17 | or promote products derived from this software without specific 18 | prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS ``AS IS'' AND ANY 21 | EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 22 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR 23 | PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE 24 | LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 25 | CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF 26 | SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR 27 | BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, 28 | WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE 29 | OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN 30 | IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | 32 | *** End of disclaimer. *** 33 | -------------------------------------------------------------------------------- /Main.lhs: -------------------------------------------------------------------------------- 1 | > module Main where 2 | 3 | > import System.Exit 4 | > import System.Directory 5 | > import System.Environment 6 | > import System.IO 7 | > import Distribution.Version 8 | > import Control.Monad 9 | 10 | > import Epic.Compiler 11 | > import Paths_epic 12 | 13 | > versionString = showV (versionBranch version) 14 | > where 15 | > showV [] = "" 16 | > showV [a] = show a 17 | > showV (x:xs) = show x ++ "." ++ showV xs 18 | 19 | > main = do args <- getArgs 20 | > (fns, opts) <- getInput args 21 | > outfile <- getOutput opts 22 | > ofiles <- compileFiles fns (mkOpts opts) 23 | > copts <- getCOpts opts 24 | > -- extras <- getExtra opts 25 | > if ((length ofiles) > 0 && (not (elem Obj opts))) 26 | > then link (ofiles ++ copts) outfile (mkOpts opts) 27 | > else return () 28 | > where mkOpts (KeepInt:xs) = KeepC:(mkOpts xs) 29 | > mkOpts (TraceOn:xs) = Trace:(mkOpts xs) 30 | > mkOpts (Header f:xs) = MakeHeader f:(mkOpts xs) 31 | > mkOpts (DbgInfo:xs) = Debug:(mkOpts xs) 32 | > mkOpts (CheckLvl i:xs) = Checking i:(mkOpts xs) 33 | > mkOpts (ExtMain:xs) = ExternalMain:(mkOpts xs) 34 | > mkOpts (ExtraInc i:xs) = MainInc i:(mkOpts xs) 35 | > mkOpts (_:xs) = mkOpts xs 36 | > mkOpts [] = [] 37 | 38 | > compileFiles [] _ = return [] 39 | > compileFiles (fn:xs) opts 40 | > | isDotE fn = do 41 | > let ofile = getRoot fn ++ ".o" 42 | > compileOpts fn ofile (Just (getRoot fn ++ ".ei")) opts 43 | > rest <- compileFiles xs opts 44 | > return (ofile:rest) 45 | > | isDotO fn = do 46 | > rest <- compileFiles xs opts 47 | > return (fn:rest) 48 | > | otherwise = do -- probably autogenerated, just build it. 49 | > let ofile = fn ++ ".o" 50 | > compileOpts fn ofile Nothing opts 51 | > rest <- compileFiles xs opts 52 | > return (ofile:rest) 53 | 54 | > isDotE ('.':'e':[]) = True 55 | > isDotE (_:xs) = isDotE xs 56 | > isDotE [] = False 57 | 58 | > isDotC ('.':'c':[]) = True 59 | > isDotC (_:xs) = isDotC xs 60 | > isDotC [] = False 61 | 62 | > isDotO ('.':'o':[]) = True 63 | > isDotO (_:xs) = isDotO xs 64 | > isDotO [] = False 65 | 66 | > mkExecname fn = case span (/='.') fn of 67 | > (stem,".e") -> stem 68 | > (stem,_) -> fn ++ ".exe" 69 | 70 | > getRoot fn = case span (/='.') fn of 71 | > (stem,_) -> stem 72 | 73 | > getInput :: [String] -> IO ([FilePath],[Option]) 74 | > getInput args = do let opts = parseArgs args 75 | > processFlags opts False 76 | > fns <- getFile opts 77 | > if (length fns == 0) 78 | > then do showUsage 79 | > return (fns,opts) 80 | > else return (fns,opts) 81 | 82 | > showUsage = do putStrLn $ "Epic version " ++ versionString 83 | > putStrLn "Usage:\n\tepic [options]" 84 | > exitWith (ExitFailure 1) 85 | 86 | > data Option = KeepInt -- Don't delete intermediate file 87 | > | TraceOn -- Trace while running (debug option) 88 | > | Obj -- Just make the .o, don't link 89 | > | File String -- File to send the compiler 90 | > | Output String -- Output filename 91 | > | Header String -- Header output filename 92 | > | ExtraInc String -- extra files to inlude 93 | > | COpt String -- option to send straight to gcc 94 | > | ExtMain -- external main (i.e. in a .o) 95 | > | CFlags -- output include flags 96 | > | LibFlags -- output linker flags 97 | > | DbgInfo -- generate debug info 98 | > | CheckLvl Int -- Checking level, 0 for none, default none 99 | > deriving Eq 100 | 101 | > parseArgs :: [String] -> [Option] 102 | > parseArgs [] = [] 103 | > parseArgs ("-keepc":args) = KeepInt:(parseArgs args) 104 | > parseArgs ("-trace":args) = TraceOn:(parseArgs args) 105 | > parseArgs ("-c":args) = Obj:(parseArgs args) 106 | > parseArgs ("-extmain":args) = ExtMain:(parseArgs args) 107 | > parseArgs ("-o":name:args) = (Output name):(parseArgs args) 108 | > parseArgs ("-h":name:args) = (Header name):(parseArgs args) 109 | > parseArgs ("-i":inc:args) = (ExtraInc inc):(parseArgs args) 110 | > parseArgs ("-includedirs":args) = CFlags:(parseArgs args) 111 | > parseArgs ("-libdirs":args) = LibFlags:(parseArgs args) 112 | > parseArgs ("-g":args) = DbgInfo:(parseArgs args) 113 | > parseArgs ("-checking":lvl:args) = CheckLvl (read lvl):(parseArgs args) 114 | > parseArgs (('$':x):args) = (COpt (x ++ concat (map (" "++) args))):[] 115 | > parseArgs (('-':x):args) = (COpt x):(parseArgs args) 116 | > parseArgs (x:args) = (File x):(parseArgs args) 117 | 118 | > getFile :: [Option] -> IO [FilePath] 119 | > getFile ((File x):xs) = do fns <- getFile xs 120 | > return (x:fns) 121 | > getFile (_:xs) = getFile xs 122 | > getFile [] = return [] 123 | 124 | > getOutput :: [Option] -> IO FilePath 125 | > getOutput ((Output fn):xs) = return fn 126 | > getOutput (_:xs) = getOutput xs 127 | > getOutput [] = return "a.out" 128 | 129 | > getCOpts :: [Option] -> IO [String] 130 | > getCOpts ((COpt x):xs) = do fns <- getCOpts xs 131 | > return (x:fns) 132 | > getCOpts (_:xs) = getCOpts xs 133 | > getCOpts [] = return [] 134 | 135 | > processFlags :: [Option] -> Bool -> IO () 136 | > processFlags [] True = do putStrLn ""; exitWith ExitSuccess 137 | > processFlags [] False = return () 138 | > processFlags (LibFlags:xs) _ = do datadir <- getDataDir 139 | > putStr $ "-L"++datadir++"/evm " 140 | > processFlags xs True 141 | > processFlags (CFlags:xs) _ = do datadir <- getDataDir 142 | > putStr $ "-I"++datadir++"/evm " 143 | > processFlags xs True 144 | > processFlags (_:xs) quit = processFlags xs quit 145 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | DB = --user 2 | PREFIX = $(HOME) 3 | GHCOPTS = 4 | 5 | package: 6 | cabal build 7 | 8 | cabal-package: 9 | cabal sdist 10 | 11 | configure: 12 | cabal configure --user --ghc --prefix=$(PREFIX) 13 | # cd Epic; echo "module Epic.Prefix where libprefix=\"$(PREFIX)\"" > Prefix.hs 14 | 15 | rts: 16 | $(MAKE) -C evm 17 | 18 | install: .PHONY 19 | #$(MAKE) -C evm install PREFIX=$(PREFIX) 20 | #$(MAKE) -C lib install PREFIX=$(PREFIX) 21 | cabal install $(DB) 22 | 23 | unregister: 24 | cabal unregister $(DB) 25 | 26 | doc: 27 | cabal haddock 28 | 29 | clean: 30 | cabal clean 31 | $(MAKE) -C evm clean 32 | cd compiler; rm -f *.o *.hi epic 33 | 34 | test: 35 | make -C tests 36 | 37 | epic: .PHONY configure package install 38 | cd compiler; ghc $(GHCOPTS) Main.lhs -o epic -package epic 39 | 40 | epic_install: epic 41 | install compiler/epic $(PREFIX)/bin 42 | 43 | .PHONY: 44 | -------------------------------------------------------------------------------- /Papers/Epic-TFP/Makefile: -------------------------------------------------------------------------------- 1 | PAPER = epic 2 | 3 | all: ${PAPER}.pdf 4 | 5 | TEXFILES = ${PAPER}.tex intro.tex language.tex example.tex \ 6 | implementation.tex performance.tex conclusions.tex bigexample.tex 7 | 8 | DIAGS = 9 | 10 | SOURCES = ${TEXFILES} ${DIAGS} macros.ltx comments.sty library.ltx llncs.cls literature.bib 11 | 12 | DITAA = java -jar ~/Downloads/ditaa.jar 13 | 14 | ${PAPER}.pdf: ${SOURCES} 15 | # dvipdf ${PAPER}.dvi 16 | pdflatex ${PAPER} 17 | -bibtex ${PAPER} 18 | -pdflatex ${PAPER} 19 | -pdflatex ${PAPER} 20 | 21 | ${PAPER}.ps: ${PAPER}.dvi 22 | dvips -o ${PAPER}.ps ${PAPER} 23 | 24 | ${PAPER}.dvi: $(SOURCES) 25 | -latex ${PAPER} 26 | -bibtex ${PAPER} 27 | -latex ${PAPER} 28 | -latex ${PAPER} 29 | 30 | progress: .PHONY 31 | wc -w ${TEXFILES} 32 | 33 | %.png : %.diag 34 | $(DITAA) -o -E $< 35 | 36 | distrib: all 37 | cp ${PAPER}.pdf ${SOURCES} tfp9 38 | .PHONY: 39 | -------------------------------------------------------------------------------- /Papers/Epic-TFP/comments.sty: -------------------------------------------------------------------------------- 1 | % $id$ 2 | % KH: created comments style file to allow alternative versions of a document. 3 | 4 | % \newcommand{\red}[1]{#1} 5 | 6 | \usepackage{color} 7 | \definecolor{BrickRed}{cmyk}{0, .89, .5, 0} 8 | \newcommand{\red}{\color{BrickRed}} 9 | 10 | \newcommand{\eucommentary}[1]{\(\spadesuit\){\red{\textbf{EC Commentary}: \emph{#1}}\(\spadesuit\)}} 11 | \newcommand{\euevaluation}[2]{\(\spadesuit\){\red{\textbf{Evaluation Criteria ({#1})}: \emph{#2}}\(\spadesuit\)}} 12 | 13 | \newcommand{\comment}[2]{\(\spadesuit\){\bf #1: }{\rm \sf #2}\(\spadesuit\)} 14 | \newcommand{\draftpage}{\newpage} 15 | 16 | \newcommand{\FIXME}[1]{[\textbf{FIXME}: #1]} 17 | 18 | %\newcommand{\FIXME}[1]{\wibble} 19 | \newcommand{\nocomments}{ 20 | \renewcommand{\eucommentary}[1]{} 21 | \renewcommand{\euevaluation}[2]{} 22 | \renewcommand{\comment}[2]{} 23 | \renewcommand{\draftpage}{} 24 | \renewcommand{\FIXME}[1]{} 25 | } 26 | 27 | \DeclareOption{final}{\nocomments} 28 | \DeclareOption{draft}{} 29 | \ProcessOptions* 30 | -------------------------------------------------------------------------------- /Papers/Epic-TFP/conclusions.tex: -------------------------------------------------------------------------------- 1 | \section{Related Work} 2 | 3 | %% GHC's run-time system~\cite{stg, evalpush}, ABC 4 | %% machine~\cite{abc-machine} and why we don't just use one of them 5 | %% (no useful interface, imposes constraints on the type system). 6 | %% Some influence from GRIN~\cite{grin-project}. 7 | 8 | Epic is currently used by Agda and Idris~\cite{plpv11}, as well as the 9 | development version of Epigram~\cite{levitation}. Initial 10 | benchmarking~\cite{scrap-engine} shows that the code generated by Epic 11 | can be competitive with Java and is not significantly worse than C. 12 | Epic uses techniques from other functional language back 13 | ends~\cite{evalpush,stg,abc-machine} but deliberately exposes its core 14 | language as an API to make it as reusable as possible. Although there 15 | is always likely to be a trade off between reusability and efficiency, 16 | exposing the API will make it easier for other language researchers to 17 | build a new compiler quickly. 18 | % 19 | As far as we are aware, Epic occupies a unique point in the design space of 20 | code generation tools --- it is sufficiently high level that it captures common 21 | functional language abstractions without being so high level that it imposes 22 | constraints such as a type system on the language it is compiling. 23 | Alonzo, for example, is a prototype compiler for Agda~\cite{alonzo} which compiles 24 | via GHC, but requires coercions in the generated code in order for it to be accepted 25 | by GHC's type checker. Coq's program extraction tool~\cite{extraction-coq} 26 | also aims to generate executable code via a high level language, similarly requiring 27 | coercions where Coq terms can not be given a type in the high level language. 28 | In contrast, systems such as the Lazy Virtual Machine~\cite{lvm}, 29 | C\texttt{--}~\cite{c--} and LLVM~\cite{llvm} are 30 | designed as lower level target languages rather than high level APIs. We could 31 | nevertheless consider using these tools for Epic code generation. 32 | 33 | %C--~\cite{c--} and LLVM~\cite{llvm} 34 | %as possible code generation strategies. Supercompilation for 35 | %optimisations~\cite{mitchell-super}. 36 | 37 | \section{Conclusion} 38 | 39 | Epic provides a simple path for language researchers to convert 40 | experimental languages (e.g. experimenting with new type systems or 41 | domain specific language design) into larger scale, usable tools, by 42 | providing an API for generating a compiler, dealing with 43 | well-understood but difficult to implement problems such as 44 | naming and scope management, 45 | code generation, interfacing with foreign functions and 46 | garbage collection. 47 | In this paper we have seen two examples of languages which can be 48 | compiled via Epic, both functionally based, but with different 49 | features. The high-level recipe for each is the same: define primitive 50 | functions as run-time support, then translate the abstract syntax into 51 | concrete Epic functions, using a combinator style API. In addition, 52 | we have implemented a compiler for \LamPi{}~\cite{simply-easy}, a 53 | dependently typed language, which shows how Epic can handle languages 54 | with more expressive type 55 | systems\footnote{\url{http://www.idris-lang.org/examples/LambdaPi.hs}}. 56 | 57 | 58 | \subsubsection{Future work} 59 | 60 | %Epic is currently used in practice by a dependently typed functional 61 | %language, Idris~\cite{plpv11}, and experimentally by 62 | %Agda~\cite{norell-thesis} and Epigram~\cite{levitation}. 63 | 64 | Since Epic is currently used in practice by a number of dependently 65 | typed functional languages, future work will have an emphasis on 66 | providing an efficient executable environment for these and related 67 | languages. An interesting research question, for example, is whether 68 | the rich type systems of these languages can be used to guide 69 | optimisation, and if so how to present the information gained by the 70 | type system to the compiler. 71 | 72 | Currently, Epic compiles to machine code via C, using the Boehm 73 | conservative garbage collector~\cite{boehm-gc}. While this has been 74 | reasonably efficient in practice, we believe that an LLVM based 75 | implementation~\cite{llvm,llvm-haskell} with accurate garbage 76 | collection would be more appropriate as it could take advantage of 77 | functional language features such as immutability of data. 78 | 79 | Perhaps more importantly, as a very simple functional language Epic is 80 | a convenient platform with which to experiment with functional 81 | compilation techniques. For example, we are developing an evaluator 82 | which will be a starting point for experimenting with 83 | supercompilation~\cite{mitchell-super} and partial evaluation. 84 | Of course, any language which uses Epic as a back end will stand to 85 | gain from future optimisation efforts! 86 | -------------------------------------------------------------------------------- /Papers/Epic-TFP/dtp.bib: -------------------------------------------------------------------------------- 1 | @phdthesis{ brady-thesis, 2 | author = {Edwin Brady}, 3 | title = {Practical Implementation of a Dependently Typed Functional Programming Language}, 4 | year = 2005, 5 | school = {University of Durham} 6 | } 7 | 8 | @article{view-left, 9 | journal = {Journal of Functional Programming}, 10 | number = {1}, 11 | volume = {14}, 12 | title = {The View From The Left}, 13 | year = {2004}, 14 | author = {Conor McBride and James McKinna}, 15 | pages = {69--111} 16 | } 17 | 18 | @misc{epigram-afp, 19 | author = {Conor McBride}, 20 | title = {Epigram: Practical Programming with Dependent Types}, 21 | year = {2004}, 22 | howpublished = {Lecture Notes, International Summer School on Advanced Functional Programming} 23 | } 24 | 25 | @misc{coq-manual, 26 | howpublished = {\verb+http://coq.inria.fr/+}, 27 | title = {The {Coq} Proof Assistant --- Reference Manual}, 28 | year = {2004}, 29 | author = {{Coq Development Team}} 30 | } 31 | 32 | @inproceedings{extraction-coq, 33 | title = {A New Extraction for {Coq}}, 34 | year = {2002}, 35 | booktitle = {Types for proofs and programs}, 36 | editor = {Herman Geuvers and Freek Wiedijk}, 37 | publisher = {Springer}, 38 | author = {Pierre Letouzey}, 39 | series = {LNCS} 40 | } 41 | 42 | @techreport{lego-manual, 43 | title = {\textsc{Lego} Proof Development System: User's Manual}, 44 | year = {1992}, 45 | institution = {Department of Computer Science, University of Edinburgh}, 46 | author = {Zhaohui Luo and Robert Pollack} 47 | } 48 | 49 | @book{luo94, 50 | title = {Computation and Reasoning -- A Type Theory for Computer Science}, 51 | year = {1994}, 52 | publisher = {OUP}, 53 | author = {Zhaohui Luo}, 54 | series = {International Series of Monographs on Computer Science} 55 | } 56 | 57 | @phdthesis{goguen-thesis, 58 | school = {University of Edinburgh}, 59 | title = {A Typed Operational Semantics for Type Theory}, 60 | year = {1994}, 61 | author = {Healfdene Goguen} 62 | } 63 | 64 | @phdthesis{mcbride-thesis, 65 | month = {May}, 66 | school = {University of Edinburgh}, 67 | title = {Dependently Typed Functional Programs and their proofs}, 68 | year = {2000}, 69 | author = {Conor McBride} 70 | } 71 | 72 | @misc{mckinnabrady-phase, 73 | title = {Phase Distinctions in the Compilation of {Epigram}}, 74 | year = 2005, 75 | author = {James McKinna and Edwin Brady}, 76 | note = {Draft} 77 | } 78 | 79 | @article{pugh-omega, 80 | title = "The {Omega} {Test}: a fast and practical integer programming algorithm for dependence analysis", 81 | author = "William Pugh", 82 | journal = "Communication of the ACM", 83 | year = 1992, 84 | pages = {102--114} 85 | } 86 | 87 | @Article{RegionTypes, 88 | refkey = "C1753", 89 | title = "Region-Based Memory Management", 90 | author = "M. Tofte and J.-P. Talpin", 91 | pages = "109--176", 92 | journal = "Information and Computation", 93 | month = "1~" # feb, 94 | year = "1997", 95 | volume = "132", 96 | number = "2" 97 | } 98 | 99 | @phdthesis{ pedro-thesis, 100 | author = {Pedro Vasconcelos}, 101 | title = {Space Cost Modelling for Concurrent Resource Sensitive Systems}, 102 | year = 2006, 103 | school = {University of St Andrews} 104 | } 105 | 106 | @book{curry-feys, 107 | title = {Combinatory Logic, volume 1}, 108 | year = {1958}, 109 | publisher = {North Holland}, 110 | author = {Haskell B. Curry and Robert Feys} 111 | } 112 | @inproceedings{howard, 113 | title = {The formulae-as-types notion of construction}, 114 | year = {1980}, 115 | booktitle = {To H.B.Curry: Essays on combinatory logic, lambda calculus and formalism}, 116 | editor = {Jonathan P. Seldin and J. Roger Hindley}, 117 | publisher = {Academic Press}, 118 | author = {William A. Howard}, 119 | note = {A reprint of an unpublished manuscript from 1969} 120 | } 121 | 122 | @misc{ydtm, 123 | author = {Thorsten Altenkirch and Conor McBride and James McKinna}, 124 | title = {Why Dependent Types Matter}, 125 | note = {Submitted for publication}, 126 | year = 2005} 127 | 128 | @inproceedings{regular-types, 129 | author = { Peter Morris and Conor McBride and Thorsten Altenkirch}, 130 | title = {Exploring The Regular Tree Types}, 131 | year = 2005, 132 | booktitle = {Types for Proofs and Programs 2004} 133 | } 134 | 135 | @inproceedings{xi_arraybounds, 136 | author = "Hongwei Xi and Frank Pfenning", 137 | title = {Eliminating Array Bound Checking through Dependent Types}, 138 | booktitle = "Proceedings of ACM SIGPLAN Conference on Programming Language Design and Implementation", 139 | year = 1998, 140 | month = "June", 141 | address = "Montreal", 142 | pages = "249--257", 143 | } 144 | 145 | @misc{interp-cayenne, 146 | url = {\verb+http://www.cs.chalmers.se/~augustss/cayenne/+}, 147 | title = {An exercise in dependent types: A well-typed interpreter}, 148 | year = {1999}, 149 | author = {Lennart Augustsson and Magnus Carlsson} 150 | } 151 | 152 | -------------------------------------------------------------------------------- /Papers/Epic-TFP/embounded.bib: -------------------------------------------------------------------------------- 1 | @Book{BurnsWellings, 2 | author = {A. Burns and A.J. Wellings}, 3 | title = {{Real-Time Systems and Programming Languages (Third Edition)}}, 4 | publisher = {Addison Wesley Longman}, 5 | year = 2001 6 | } 7 | 8 | @Book{Ganssle:Book, 9 | author = {J.G. Ganssle}, 10 | title = {{The Art of Programming Embedded Systems}}, 11 | publisher = {Academic Press}, 12 | year = {1992}, 13 | note = {ISBN 0-12274880-8}, 14 | } 15 | 16 | @Book{Ganssle:Design, 17 | author = {J.G. Ganssle}, 18 | title = {{The Art of Designing Embedded Systems}}, 19 | publisher = {Newnes}, 20 | year = {1999}, 21 | note = {ISBN 0-75069869-1}, 22 | } 23 | 24 | @article{Ganssle:OnLanguage, 25 | author = {J.G. Ganssle}, 26 | title = {{On Language}}, 27 | journal ={{Electronic Eng. Times}}, 28 | month = "March", 29 | year = {2003} 30 | } 31 | 32 | @article{Ganssle:MicroMinis, 33 | author = {J.G. Ganssle}, 34 | title = {{Micro Minis}}, 35 | journal ={{Embedded Systems Programming}}, 36 | month = "March", 37 | year = {2003} 38 | } 39 | 40 | @article{Barr:EmbeddedSystProg, 41 | author = {M. Barr}, 42 | title = {{The Long Winter}}, 43 | journal ={{Electronic Systems Programming}}, 44 | month = "January", 45 | year = {2003} 46 | } 47 | 48 | @unpublished{Ganssle:WebSite, 49 | author = {The Ganssle Group}, 50 | title = {{Perfecting the Art of Building Embedded Systems}}, 51 | month = "May", 52 | year = 2003, 53 | note = {\url{http://www.ganssle.com}} 54 | } 55 | 56 | @article{Schoitsch, 57 | author = {E. Schoitsch}, 58 | title = {{Embedded Systems -- Introduction}}, 59 | journal = {ERCIM News}, 60 | pages = {10--11}, 61 | volume = 52, 62 | month = jan, 63 | year = 2003 64 | } 65 | 66 | @article{UMLESE, 67 | author = {C. Holland}, 68 | title = {{Telelogic Second Generation Tools}}, 69 | journal = {Embedded Systems Europe}, 70 | month = aug, 71 | year = 2002 72 | } 73 | 74 | @article{DSL, 75 | author = {P. Hudak}, 76 | title = {{Building Domain-Specific Embedded Languages}}, 77 | journal = {ACM Computing Surveys}, 78 | volume = 28, 79 | number = 4, 80 | month = dec, 81 | year = 1996 82 | } 83 | 84 | @article{DSL:devicedriver, 85 | author = {C. Conway}, 86 | title = {{A Domain-Specific Language for Device Drivers}}, 87 | journal = {ACM Computing Surveys}, 88 | volume = 28, 89 | number = 4, 90 | month = dec, 91 | year = 1996 92 | } 93 | 94 | @unpublished{Klocwork, 95 | author = {Klocwork}, 96 | year = 2003, 97 | } 98 | 99 | @inproceedings{Bernat1, 100 | author = {Bernat, G. and Burns, A. and Wellings, A.}, 101 | title = {{Portable Worst-Case Execution Time Analysis Using Java Byte Code}}, 102 | booktitle = {Proc. 12th Euromicro International Conf. on 103 | Real-Time Systems}, 104 | address = {Stockholm}, 105 | year = 2000, 106 | month = {June} 107 | } 108 | 109 | @inproceedings{Bernat2, 110 | author = {Bernat, G. and Colin, A. and Petters, S. M.}, 111 | title = {{WCET Analysis of Probabilistic Hard Real-Time Systems}}, 112 | booktitle = {Proc. 23rd IEEE Real-Time Systems Symposium (RTSS 2002)}, 113 | address = {Austin, TX. (USA)}, 114 | year = 2002, 115 | month = {December} 116 | } 117 | 118 | @inproceedings{SizedRecursion, 119 | author = {P. Vasconcelos and K. Hammond}, 120 | title = {{Inferring Costs for Recursive, Polymorphic and Higher-Order Functions}}, 121 | booktitle = {Proc. Implementation of Functional Languages (IFL 2003)}, 122 | publisher = {Springer-Verlag}, 123 | year = {2003} 124 | } 125 | 126 | @inproceedings{HAM, 127 | author = {K. Hammond and G.J. Michaelson}, 128 | title = {{An Abstract Machine Implementation for Hume}}, 129 | booktitle = {submitted to Intl. Conf. on Compilers, Architectures and Synthesis for Embedded Systems (CASES~03)}, 130 | year = {2003} 131 | } 132 | 133 | @unpublished{EmbeddedSystSurvey, 134 | author = {Embedded.com}, 135 | title = {Poll: What Language do you use for embedded work?}, 136 | note = {\url{http://www.embedded.com/pollArchive/?surveyno=2228}}, 137 | year = 2003, 138 | } 139 | 140 | @inproceedings{ESP, 141 | author = {S. Kumar and K. Li}, 142 | title = {Automatic Memory Management for Programmable Devices}, 143 | booktitle = {Proc. ACM Intl. Symp. on Memory Management, Berlin, Germany}, 144 | month = jun, 145 | year = 2002, 146 | pages = {245--255}, 147 | } 148 | 149 | @inproceedings{RegionJava, 150 | author = {F. Qian and L. Hendrie}, 151 | title = {An Adaptive Region-Based Allocator for Java}, 152 | booktitle = {Proc. ACM Intl. Symp. on Memory Management, Berlin, Germany}, 153 | month = jun, 154 | year = 2002, 155 | pages = {233--244}, 156 | } 157 | 158 | @inproceedings{RegionsRTSJ, 159 | author = {M. Deters and R.K. Cytron}, 160 | title = {Automated Discovery of Scoped Memory Regions for Real-Time Java}, 161 | booktitle = {Proc. ACM Intl. Symp. on Memory Management, Berlin, Germany}, 162 | month = jun, 163 | year = 2002, 164 | pages = {132--141}, 165 | } 166 | 167 | @inproceedings{RTGC, 168 | author = {S. Nettles and J. O'Toole}, 169 | title = {{Real-Time Replication Garbage Collection}}, 170 | booktitle = {ACM Sigplan Notices}, 171 | volume = 28, 172 | number = 6, 173 | month = jun, 174 | year = 1993, 175 | pages = {217--226}, 176 | } 177 | 178 | @inproceedings{Blelloch, 179 | author = {P. Cheng and G. Blelloch}, 180 | title = {{A Parallel, Real-Time Garbage Collector}}, 181 | booktitle = {ACM Sigplan Notices}, 182 | volume = 36, 183 | number = 5, 184 | month = may, 185 | year = 2001, 186 | pages = {125--136}, 187 | } 188 | 189 | @inproceedings{RegionsGC, 190 | author = {N. Hallenberg and M. Elsman and M. Tofte}, 191 | title = {{Combining Region Inference and Garbage Collection}}, 192 | booktitle = {Proc. ACM Conf. on Prog. Lang. Design and Impl. (PLDI~'02), Berlin, Germany}, 193 | month = jun, 194 | year = 2002, 195 | } 196 | 197 | 198 | @article{RTSJIssues, 199 | author = {K. Nilsen}, 200 | title = {{Issues in the Design and Implementation of Real-Time Java}}, 201 | booktitle = {Java Developers' Journal}, 202 | volume = 1, 203 | number = 1, 204 | year = 1996, 205 | pages = 44 206 | } 207 | 208 | 209 | 210 | @unpublished{CyCab, 211 | author = {RoboSoft SA}, 212 | title = {{CyCab Outdoor Vehicle, for Road and/or All-terrain Use}}, 213 | note = {\url{http://www.robosoft.fr/SHEET/01Mobil/2001Cycab/CyCab.html}}, 214 | year = 2003, 215 | month = may 216 | } 217 | 218 | 219 | @unpublished{Joyner, 220 | author = {I. Joyner}, 221 | title = {{C++??: a Critique of C++, 3rd Edition}}, 222 | year = 1996, 223 | institution = {Unisys - ACUS, Australia}, 224 | note = {\url{http://www.kcl.ac.uk/kis/support/cit//fortran/cpp/cppcritique.ps}} 225 | } 226 | 227 | @unpublished{Sakkinen, 228 | author = {M. Sakkinen}, 229 | title = {{The Darker Side of C++ Revisited}}, 230 | year = 1993, 231 | institution = {Univerity of Jyv\"{a}skyl\"{a}}, 232 | note = {Technical Report 1993-I-13, \url{http://www.kcl.ac.uk/kis/support/cit//fortran/cpp/dark-cpl.ps}}, 233 | } 234 | 235 | @TechReport{BCLogicDelvb, 236 | author = {Hans-Wolfgang Loidl and Olha Shkaravska and Lennart Beringer}, 237 | title = {Preliminary investigations into a bytecode logic for Grail}, 238 | institution = {Institut f{\"u}r Informatik, LMU University and LFCS, Edinburgh University}, 239 | year = 2003, 240 | month = jan, 241 | note = {Project Deliverable} 242 | } 243 | 244 | @InProceedings{HWLtofillin, 245 | author = {Lennart Beringer and Kenneth MacKenzie and Ian Stark}, 246 | title = {Grail: a functional form for imperative mobile code}, 247 | booktitle = {FGC03 --- Workshop on Foundations of Global Computing}, 248 | year = 2003, 249 | address = {28--29 June 2003, Eindhoven, The Netherlands}, 250 | note = {Submitted} 251 | } 252 | 253 | 254 | @inproceedings{AbsInt:EmsoftTahoe, 255 | author = "C. Ferdinand and R. Heckmann and M. Langenbach and 256 | F. Martin and M. Schmidt and 257 | H. Theiling and S. Thesing and R. Wilhelm", 258 | title = {Reliable and Precise {WCET} Determination for a Real-Life Processor}, 259 | booktitle = {Proc. EMSOFT 2001, First Workshop on Embedded Software}, 260 | publisher = {Springer-Verlag}, 261 | series = {LNCS}, 262 | volume = 2211, 263 | pages = {469--485}, 264 | year = 2001 265 | } 266 | 267 | 268 | @inproceedings{AbsInt:Avionics, 269 | author = "S. Thesing and J. Souyris and R. Heckmann and 270 | F. Randimbivololona and M. Langenbach and 271 | R. Wilhelm and C. Ferdinand", 272 | title = {An Abstract Interpretation-Based Timing Validation 273 | of Hard Real-Time Avionics Software}, 274 | booktitle = {Proc. 2003 Intl. Conf. 275 | on Dependable Systems and Networks (DSN 2003)}, 276 | pages = {625--632}, 277 | year = 2003 278 | } 279 | 280 | -------------------------------------------------------------------------------- /Papers/Epic-TFP/epic.tex: -------------------------------------------------------------------------------- 1 | %\documentclass{llncs} 2 | \documentclass[orivec,dvips,10pt]{llncs} 3 | 4 | \usepackage[draft]{comments} 5 | %\usepackage[final]{comments} 6 | % \newcommand{\comment}[2]{[#1: #2]} 7 | \newcommand{\khcomment}[1]{\comment{KH}{#1}} 8 | \newcommand{\ebcomment}[1]{\comment{EB}{#1}} 9 | 10 | \usepackage{epsfig} 11 | \usepackage{path} 12 | \usepackage{url} 13 | \usepackage{amsmath,amssymb} 14 | \usepackage{fancyvrb} 15 | 16 | \newenvironment{template}{\sffamily} 17 | 18 | \usepackage{graphics,epsfig} 19 | \usepackage{stmaryrd} 20 | 21 | \input{./macros.ltx} 22 | \input{./library.ltx} 23 | 24 | \NatPackage 25 | \FinPackage 26 | 27 | \newcounter{per} 28 | \setcounter{per}{1} 29 | 30 | \newcommand{\Ivor}{\textsc{Ivor}} 31 | \newcommand{\Idris}{\textsc{Idris}} 32 | \newcommand{\Funl}{\textsc{Funl}} 33 | \newcommand{\Agda}{\textsc{Agda}} 34 | \newcommand{\LamPi}{$\lambda_\Pi$} 35 | 36 | \newcommand{\perule}[1]{\vspace*{0.1cm}\noindent 37 | \begin{center} 38 | \fbox{ 39 | \begin{minipage}{7.5cm}\textbf{Rule \theper:} #1\addtocounter{per}{1} 40 | \end{minipage}} 41 | \end{center} 42 | \vspace*{0.1cm} 43 | } 44 | 45 | \newcommand{\mysubsubsection}[1]{ 46 | \noindent 47 | \textbf{#1} 48 | } 49 | \newcommand{\hdecl}[1]{\texttt{#1}} 50 | 51 | \begin{document} 52 | 53 | \title{Epic --- A Library for Generating Compilers} 54 | \author{Edwin Brady} 55 | 56 | \institute{University of St Andrews, KY16 9SX, Scotland/UK,\\ 57 | \email{eb@cs.st-andrews.ac.uk}} 58 | 59 | \maketitle 60 | 61 | \begin{abstract} 62 | Compilers for functional languages, whether strict or non-strict, 63 | typed or untyped, need to handle many of the same problems, for 64 | example thunks, lambda lifting, optimisation, garbage collection, and 65 | system interaction. Although implementation techniques are by now 66 | well understood, it remains difficult for a new functional language to 67 | exploit these techniques without either implementing a compiler from 68 | scratch, or attempting to fit the new language around another existing 69 | compiler. Epic is a compiled functional language which exposes 70 | functional compilation techniques to a language implementor, with a 71 | Haskell API. In this paper we describe Epic and outline how it may be 72 | used to implement a high level language compiler, illustrating our 73 | approach by implementing compilers for the $\lambda$-calculus and a 74 | dynamically typed graphics language. 75 | 76 | \end{abstract} 77 | 78 | \input{intro} 79 | 80 | \input{language} 81 | 82 | \input{example} 83 | 84 | \input{bigexample} 85 | 86 | %\input{implementation} 87 | 88 | %\input{performance} 89 | 90 | \input{conclusions} 91 | 92 | \vspace{-0.2in} 93 | \section*{Acknowledgments} 94 | 95 | This work was partly funded by the Scottish Informatics and Computer 96 | Science Alliance (SICSA) and by EU Framework 7 Project No. 248828 97 | (ADVANCE). Thanks to the anonymous 98 | reviewers for their constructive suggestions. 99 | 100 | \bibliographystyle{abbrv} 101 | \begin{small} 102 | \bibliography{literature.bib} 103 | 104 | \appendix 105 | 106 | %\input{code} 107 | 108 | \end{small} 109 | \end{document} 110 | -------------------------------------------------------------------------------- /Papers/Epic-TFP/example.tex: -------------------------------------------------------------------------------- 1 | \section{Example --- Compiling the $\lambda$-Calculus} 2 | 3 | \label{sec:lc} 4 | 5 | In this section we present a compiler for the untyped $\lambda$-calculus using 6 | HOAS, showing the fundamental features of Epic 7 | required to build a complete compiler. 8 | 9 | %We have also implemented compilers 10 | %for \LamPi{}~\cite{simply-easy}, a dependently typed language, which 11 | %shows how Epic can handle languages with more expressive type systems, 12 | %and a dynamically typed graphics language\footnote{\url{http://hackage.haskell.org/package/atuin}}, which shows how Epic can be 13 | %used for languages with run-time type checking and which require 14 | %foreign function calls. 15 | 16 | \subsection{Representation} 17 | 18 | Our example is an implementation of the untyped $\lambda$-calculus, plus 19 | primitive integers and strings, and arithmetic and string operators. The 20 | Haskell representation uses higher order abstract syntax (HOAS). We also 21 | include global references (\texttt{Ref}) which refer to top level functions, 22 | function application (\texttt{App}), constants (\texttt{Const}) and binary 23 | operators (\texttt{Op}): 24 | 25 | \begin{SaveVerbatim}{llang} 26 | 27 | data Lang = Lam (Lang -> Lang) 28 | | Ref Name 29 | | App Lang Lang 30 | | Const Const 31 | | Op Infix Lang Lang 32 | 33 | \end{SaveVerbatim} 34 | \useverb{llang} 35 | 36 | \noindent 37 | Constants can be either integers or strings: 38 | 39 | \begin{SaveVerbatim}{lconsts} 40 | 41 | data Const = CInt Int | CStr String 42 | 43 | \end{SaveVerbatim} 44 | \useverb{lconsts} 45 | 46 | \noindent 47 | There are infix operators for arithmetic (\texttt{Plus}, 48 | \texttt{Minus}, \texttt{Times} and \texttt{Divide}), string 49 | manipulation (\texttt{Append}) and comparison (\texttt{Eq}, 50 | \texttt{Lt} and \texttt{Gt}). The comparison operators return an 51 | integer --- zero if the comparison is true, non-zero otherwise: 52 | 53 | \begin{SaveVerbatim}{lops} 54 | 55 | data Infix = Plus | Minus | Times | Divide | Append | Eq | Lt | Gt 56 | 57 | \end{SaveVerbatim} 58 | \useverb{lops} 59 | 60 | \noindent 61 | A complete program consists of a collection of named \texttt{Lang} 62 | definitions: 63 | 64 | \begin{SaveVerbatim}{lprogs} 65 | 66 | type Defs = [(Name, Lang)] 67 | \end{SaveVerbatim} 68 | \useverb{lprogs} 69 | 70 | \vspace*{0.5em} 71 | \subsection{Compilation} 72 | 73 | Our aim is to convert a collection of \texttt{Defs} into an 74 | executable, using the \texttt{compile} or \texttt{run} function from 75 | the Epic API. 76 | Given an Epic \texttt{Program}, \texttt{compile} will generate an 77 | executable, and \texttt{run} will generate an executable then run it. 78 | Recall that a program is a collection of named Epic declarations: 79 | 80 | \begin{SaveVerbatim}{eprogs} 81 | 82 | data EpicDecl = forall e. EpicExpr e => EpicFn Name e 83 | type Program = [EpicDecl] 84 | 85 | \end{SaveVerbatim} 86 | \useverb{eprogs} 87 | 88 | \noindent 89 | Our goal is to convert a \texttt{Lang} definition into 90 | something which is an instance of \texttt{EpicExpr}. We use 91 | \texttt{Term}, which is an Epic expression which carries a name 92 | supply. Most of the term construction functions in the Epic API return 93 | a \texttt{Term}. 94 | 95 | \begin{SaveVerbatim}{buildtype} 96 | 97 | build :: Lang -> Term 98 | 99 | \end{SaveVerbatim} 100 | \useverb{buildtype} 101 | 102 | \noindent 103 | The full implementation of \texttt{build} is given in Figure \ref{lcompile}. 104 | In general, this is a straightforward traversal of the \texttt{Lang} 105 | program, converting \texttt{Lang} constants to Epic constants, 106 | \texttt{Lang} application to Epic application, and \texttt{Lang} 107 | operators to the appropriate built-in Epic operators. 108 | 109 | \begin{SaveVerbatim}{lcompile} 110 | build :: Lang -> Term 111 | build (Lam f) = term (\x -> build (f (EpicRef x))) 112 | build (EpicRef x) = term x 113 | build (Ref n) = ref n 114 | build (App f a) = build f @@ build a 115 | build (Const (CInt x)) = int x 116 | build (Const (CStr x)) = str x 117 | build (Op Append l r) = fn "append" @@ build l @@ build r 118 | build (Op op l r) = op_ (eOp op) (build l) (build r) 119 | where eOp Plus = plus_ 120 | eOp Minus = minus_ 121 | ... 122 | \end{SaveVerbatim} 123 | \codefig{lcompile}{Compiling Untyped $\lambda$-calculus} 124 | 125 | %\noindent 126 | Using HOAS has the advantage that Haskell can 127 | manage scoping, but the disadvantage that it is not straightforward to 128 | convert the abstract syntax into another form. The Epic API also 129 | allows scope management using HOAS, so we need to convert a function 130 | where the bound name refers to a \texttt{Lang} value into a function 131 | where the bound name refers to an Epic value. The easiest solution is 132 | to extend the \texttt{Lang} datatype with an Epic reference: 133 | 134 | \begin{SaveVerbatim}{lextend} 135 | 136 | data Lang = ... 137 | | EpicRef Expr 138 | 139 | build (Lam f) = term (\x -> build (f (EpicRef x))) 140 | 141 | \end{SaveVerbatim} 142 | \useverb{lextend} 143 | 144 | \noindent 145 | To convert a \texttt{Lang} function to an Epic function, we build an 146 | Epic function in which we apply the \texttt{Lang} function to the Epic 147 | reference for its argument. Every reference to a name in \texttt{Lang} 148 | is converted to the equivalent reference to the name in Epic. 149 | Although it seems undesirable to extend \texttt{Lang} in this way, this 150 | solution is simple to implement and preserves the 151 | desirable feature that Haskell manages scope. 152 | Compiling string append uses a built in function provided by the Epic 153 | interface in \texttt{basic\_defs}: 154 | 155 | \begin{SaveVerbatim}{lappend} 156 | 157 | build (Op Append l r) = fn "append" @@ build l @@ build r 158 | 159 | \end{SaveVerbatim} 160 | \useverb{lappend} 161 | 162 | \noindent 163 | Given \texttt{build}, we can translate a collection of HOAS 164 | definitions into an Epic program, add the built-in Epic definitions 165 | and execute it directly. Recall that there must be a 166 | \textit{main} function or Epic will report an error --- we therefore add a 167 | main function which prints the value of an integer expression 168 | given at compile time. 169 | 170 | \begin{SaveVerbatim}{lmain} 171 | 172 | main_ exp = App (Ref (name "putStrLn")) 173 | (App (Ref (name "intToString")) exp) 174 | 175 | mkProgram :: Defs -> Lang -> Program 176 | mkProgram ds exp = basic_defs ++ 177 | map (\ (n, d) -> EpicFn n (build d)) ds ++ 178 | [(name "main", main_ exp)] 179 | 180 | execute :: Defs -> Lang -> IO () 181 | execute p exp = run (mkProgram p exp) 182 | 183 | \end{SaveVerbatim} 184 | \useverb{lmain} 185 | 186 | \noindent 187 | Alternatively, we can generate an executable. Again, the entry point 188 | is the Epic function \textit{main}: 189 | 190 | \begin{SaveVerbatim}{lcomp} 191 | 192 | comp :: Defs -> Lang -> IO () 193 | comp p exp = compile "a.out" (mkProgram p exp) 194 | 195 | \end{SaveVerbatim} 196 | \useverb{lcomp} 197 | 198 | \noindent 199 | This is a compiler for a very simple language, but a compiler for a 200 | more complex language follows the same pattern: convert the abstract 201 | syntax for each named definition into a named Epic \texttt{Term}, add 202 | any required primitives (we have just used \texttt{basic\_defs} here), 203 | and pass the collection of definitions to \texttt{run} or 204 | \texttt{compile}. 205 | 206 | 207 | -------------------------------------------------------------------------------- /Papers/Epic-TFP/implementation.tex: -------------------------------------------------------------------------------- 1 | \section{Implementation} 2 | 3 | How it's implemented is not really important to the user --- a 4 | compiler can target Epic without knowing, and we could drop in a new 5 | back end at any time in principle. 6 | 7 | There is currently one back end, but more are planned. Compiled via 8 | C. Garbage collection with Boehm~\cite{boehm-gc}, 9 | \texttt{\%memory}. (Note that a non-moving collector makes things 10 | easier for foreign functions, but may not be the best choice in the 11 | long run). 12 | 13 | Later plans: compile via LLVM, allow plug in garbage collectors 14 | (important for embedded systems, device drivers, operating system 15 | services, for example). 16 | 17 | -------------------------------------------------------------------------------- /Papers/Epic-TFP/intro.tex: -------------------------------------------------------------------------------- 1 | \section{Introduction} 2 | 3 | When implementing a new programming language, whether for research purposes or as 4 | a realistic general purpose language, we are inevitably faced with the 5 | problem of executing the language. Ideally, we would like execution to 6 | be as fast as possible, and exploit known techniques from many years 7 | of compiler research. However, it is difficult to make use of the 8 | existing available back ends for functional langauges, such as the 9 | STG~\cite{evalpush,stg,llvm-haskell} or ABC~\cite{abc-machine} 10 | machines. They may be too low level, they may make assumptions about 11 | the source language (e.g., its type system) or there may simply be no 12 | clearly defined API. As a result, experimental languages such as 13 | Agda~\cite{norell-thesis} have resorted to generating Haskell, using 14 | \texttt{unsafeCoerce} to bypass the type system. Similarly, 15 | Cayenne~\cite{cayenne-icfp} generated LML bypassing the type 16 | checker. This is not ideal for several reasons: we cannot expect to 17 | use the full power and optimisations of the underlying compiler, nor 18 | can we expect it to exploit any specific features of our new source 19 | language, such as the optimisation opportunities presented by rich 20 | dependent type systems~\cite{brady-thesis}. 21 | 22 | Epic is a library which aims to provide the necessary features for 23 | implementing the back-end of a functional language --- thunks, 24 | closures, algebraic data types, scope management, lambda lifting --- 25 | without imposing \remph{any} design choices on the high level language 26 | designer, other than encouraging a functional style. It 27 | provides \remph{compiler combinators}, which guarantee that any output 28 | code will be syntactically correct and well-scoped. This gives a 29 | simple method for building a compiler for a new functional language, 30 | e.g., for experimentation with new type systems or new domain specific 31 | languages. In this paper, we describe Epic and its API using two 32 | example high level languages. More generally, we observe that: 33 | 34 | \begin{enumerate} 35 | \item Recent language and type system research has typically been 36 | based on extensions of existing languages, notably Haskell. While 37 | this makes implementation easier as it builds on an existing 38 | language, it discourages significant departures from the existing 39 | language (e.g., full dependent types). With Epic, we encourage 40 | more radical experiments by providing a standalone path to a realistic, 41 | efficient, language implementation. 42 | \item A tool can become significantly more useful if it is embeddable in 43 | other systems. A language back end is no different --- by providing 44 | an API for Epic, we make it more widely applicable. Haskell's 45 | expressiveness, particularly through type classes, makes it simple 46 | to provide an appropriate API for describing the core language. 47 | \item Epic's small core and clearly defined API makes it a potential 48 | platform for experimentation with optimisations and new back 49 | ends. Indeed, we avoid implementation details in 50 | this paper. Several implementations are possible, perhaps targetting 51 | .NET or the JVM as well as native code. 52 | \end{enumerate} 53 | 54 | \noindent 55 | Epic was originally written as a back end for 56 | Epigram~\cite{levitation} (the name\footnote{Coined by James McKinna} 57 | is short for ``\textbf{Epi}gram \textbf{C}ompiler''). It is now used 58 | by Idris~\cite{plpv11} and as an experimental back end for 59 | Agda. It is specifically designed for reuse by other source languages. 60 | 61 | 62 | 63 | 64 | 65 | -------------------------------------------------------------------------------- /Papers/Epic-TFP/library.ltx: -------------------------------------------------------------------------------- 1 | %%%%%%%%%%%%%%% library file for datatypes etc. 2 | 3 | %%% Identifiers 4 | 5 | \newcommand{\va}{\VV{a}} 6 | \newcommand{\vb}{\VV{b}} 7 | \newcommand{\vc}{\VV{c}} 8 | \newcommand{\vd}{\VV{d}} 9 | \newcommand{\ve}{\VV{e}} 10 | \newcommand{\vf}{\VV{f}} 11 | \newcommand{\vg}{\VV{g}} 12 | \newcommand{\vh}{\VV{h}} 13 | \newcommand{\vi}{\VV{i}} 14 | \newcommand{\vj}{\VV{j}} 15 | \newcommand{\vk}{\VV{k}} 16 | \newcommand{\vl}{\VV{l}} 17 | \newcommand{\vm}{\VV{m}} 18 | \newcommand{\vn}{\VV{n}} 19 | \newcommand{\vo}{\VV{o}} 20 | \newcommand{\vp}{\VV{p}} 21 | \newcommand{\vq}{\VV{q}} 22 | \newcommand{\vr}{\VV{r}} 23 | \newcommand{\vs}{\VV{s}} 24 | \newcommand{\vt}{\VV{t}} 25 | \newcommand{\vu}{\VV{u}} 26 | \newcommand{\vv}{\VV{v}} 27 | \newcommand{\vw}{\VV{w}} 28 | \newcommand{\vx}{\VV{x}} 29 | \newcommand{\vy}{\VV{y}} 30 | \newcommand{\vz}{\VV{z}} 31 | \newcommand{\vA}{\VV{A}} 32 | \newcommand{\vB}{\VV{B}} 33 | \newcommand{\vC}{\VV{C}} 34 | \newcommand{\vD}{\VV{D}} 35 | \newcommand{\vE}{\VV{E}} 36 | \newcommand{\vF}{\VV{F}} 37 | \newcommand{\vG}{\VV{G}} 38 | \newcommand{\vH}{\VV{H}} 39 | \newcommand{\vI}{\VV{I}} 40 | \newcommand{\vJ}{\VV{J}} 41 | \newcommand{\vK}{\VV{K}} 42 | \newcommand{\vL}{\VV{L}} 43 | \newcommand{\vM}{\VV{M}} 44 | \newcommand{\vN}{\VV{N}} 45 | \newcommand{\vO}{\VV{O}} 46 | \newcommand{\vP}{\VV{P}} 47 | \newcommand{\vQ}{\VV{Q}} 48 | \newcommand{\vR}{\VV{R}} 49 | \newcommand{\vS}{\VV{S}} 50 | \newcommand{\vT}{\VV{T}} 51 | \newcommand{\vU}{\VV{U}} 52 | \newcommand{\vV}{\VV{V}} 53 | \newcommand{\vW}{\VV{W}} 54 | \newcommand{\vX}{\VV{X}} 55 | \newcommand{\vY}{\VV{Y}} 56 | \newcommand{\vZ}{\VV{Z}} 57 | \newcommand{\vas}{\VV{as}} 58 | \newcommand{\vbs}{\VV{bs}} 59 | \newcommand{\vcs}{\VV{cs}} 60 | \newcommand{\vds}{\VV{ds}} 61 | \newcommand{\ves}{\VV{es}} 62 | \newcommand{\vfs}{\VV{fs}} 63 | \newcommand{\vgs}{\VV{gs}} 64 | \newcommand{\vhs}{\VV{hs}} 65 | \newcommand{\vis}{\VV{is}} 66 | \newcommand{\vjs}{\VV{js}} 67 | \newcommand{\vks}{\VV{ks}} 68 | \newcommand{\vls}{\VV{ls}} 69 | \newcommand{\vms}{\VV{ms}} 70 | \newcommand{\vns}{\VV{ns}} 71 | \newcommand{\vos}{\VV{os}} 72 | \newcommand{\vps}{\VV{ps}} 73 | \newcommand{\vqs}{\VV{qs}} 74 | \newcommand{\vrs}{\VV{rs}} 75 | %\newcommand{\vss}{\VV{ss}} 76 | \newcommand{\vts}{\VV{ts}} 77 | \newcommand{\vus}{\VV{us}} 78 | \newcommand{\vvs}{\VV{vs}} 79 | \newcommand{\vws}{\VV{ws}} 80 | \newcommand{\vxs}{\VV{xs}} 81 | \newcommand{\vys}{\VV{ys}} 82 | \newcommand{\vzs}{\VV{zs}} 83 | 84 | %%% Telescope Identifiers 85 | 86 | \newcommand{\ta}{\vec{\VV{a}}} 87 | \newcommand{\tb}{\vec{\VV{b}}} 88 | \newcommand{\tc}{\vec{\VV{c}}} 89 | \newcommand{\td}{\vec{\VV{d}}} 90 | \newcommand{\te}{\vec{\VV{e}}} 91 | \newcommand{\tf}{\vec{\VV{f}}} 92 | \newcommand{\tg}{\vec{\VV{g}}} 93 | %\newcommand{\th}{\vec{\VV{h}}} 94 | \newcommand{\ti}{\vec{\VV{i}}} 95 | \newcommand{\tj}{\vec{\VV{j}}} 96 | \newcommand{\tk}{\vec{\VV{k}}} 97 | \newcommand{\tl}{\vec{\VV{l}}} 98 | \newcommand{\tm}{\vec{\VV{m}}} 99 | \newcommand{\tn}{\vec{\VV{n}}} 100 | %\newcommand{\to}{\vec{\VV{o}}} 101 | \newcommand{\tp}{\vec{\VV{p}}} 102 | \newcommand{\tq}{\vec{\VV{q}}} 103 | \newcommand{\tr}{\vec{\VV{r}}} 104 | \newcommand{\tts}{\vec{\VV{s}}} 105 | \newcommand{\ttt}{\vec{\VV{t}}} 106 | \newcommand{\tu}{\vec{\VV{u}}} 107 | %\newcommand{\tv}{\vec{\VV{v}}} 108 | \newcommand{\tw}{\vec{\VV{w}}} 109 | \newcommand{\tx}{\vec{\VV{x}}} 110 | \newcommand{\ty}{\vec{\VV{y}}} 111 | \newcommand{\tz}{\vec{\VV{z}}} 112 | \newcommand{\tA}{\vec{\VV{A}}} 113 | \newcommand{\tB}{\vec{\VV{B}}} 114 | \newcommand{\tC}{\vec{\VV{C}}} 115 | \newcommand{\tD}{\vec{\VV{D}}} 116 | \newcommand{\tE}{\vec{\VV{E}}} 117 | \newcommand{\tF}{\vec{\VV{F}}} 118 | \newcommand{\tG}{\vec{\VV{G}}} 119 | \newcommand{\tH}{\vec{\VV{H}}} 120 | \newcommand{\tI}{\vec{\VV{I}}} 121 | \newcommand{\tJ}{\vec{\VV{J}}} 122 | \newcommand{\tK}{\vec{\VV{K}}} 123 | \newcommand{\tL}{\vec{\VV{L}}} 124 | \newcommand{\tM}{\vec{\VV{M}}} 125 | \newcommand{\tN}{\vec{\VV{N}}} 126 | \newcommand{\tO}{\vec{\VV{O}}} 127 | \newcommand{\tP}{\vec{\VV{P}}} 128 | \newcommand{\tQ}{\vec{\VV{Q}}} 129 | \newcommand{\tR}{\vec{\VV{R}}} 130 | \newcommand{\tS}{\vec{\VV{S}}} 131 | \newcommand{\tT}{\vec{\VV{T}}} 132 | \newcommand{\tU}{\vec{\VV{U}}} 133 | \newcommand{\tV}{\vec{\VV{V}}} 134 | \newcommand{\tW}{\vec{\VV{W}}} 135 | \newcommand{\tX}{\vec{\VV{X}}} 136 | \newcommand{\tY}{\vec{\VV{Y}}} 137 | \newcommand{\tZ}{\vec{\VV{Z}}} 138 | 139 | 140 | 141 | %%% Nat 142 | 143 | \newcommand{\NatPackage}{ 144 | \newcommand{\Nat}{\TC{\mathbb{N}}} 145 | \newcommand{\Z}{\DC{0}} 146 | \newcommand{\suc}{\DC{s}} 147 | \newcommand{\NatDecl}{ 148 | \Data \hg 149 | \Axiom{\Nat\Hab\Type} \hg 150 | \Where \hg 151 | \Axiom{\Z\Hab\Nat} \hg 152 | \Rule{\vn\Hab\Nat} 153 | {\suc\:\vn\Hab\Nat} 154 | }} 155 | 156 | %%% Bool 157 | 158 | \newcommand{\BoolPackage}{ 159 | \newcommand{\Bool}{\TC{Bool}} 160 | \newcommand{\true}{\DC{true}} 161 | \newcommand{\false}{\DC{false}} 162 | \newcommand{\BoolDecl}{ 163 | \Data \hg 164 | \Axiom{\Bool\Hab\Type} \hg 165 | \Where \hg 166 | \Axiom{\true\Hab\Bool} \hg 167 | \Axiom{\false\Hab\Bool} 168 | }} 169 | 170 | %%% So 171 | 172 | \newcommand{\SoPackage}{ 173 | \newcommand{\So}{\TC{So}} 174 | \newcommand{\oh}{\DC{oh}} 175 | \newcommand{\SoDecl}{ 176 | \Data \hg 177 | \Rule{\vb\Hab\Bool} 178 | {\So\:\vb\Hab\Type} \hg 179 | \Where \hg 180 | \Axiom{\oh\Hab\So\:\true} 181 | }} 182 | 183 | %%% Unit 184 | 185 | \newcommand{\UnitPackage}{ 186 | \newcommand{\Unit}{\TC{Unit}} 187 | \newcommand{\void}{\DC{void}} 188 | \newcommand{\UnitDecl}{ 189 | \Data \hg 190 | \Axiom{\Unit\Hab\Type} \hg 191 | \Where \hg 192 | \Axiom{\void\Hab\Unit} 193 | }} 194 | 195 | %%% Maybe 196 | 197 | \newcommand{\MaybePackage}{ 198 | \newcommand{\Maybe}{\TC{Maybe}} 199 | \newcommand{\yes}{\DC{yes}} 200 | \newcommand{\no}{\DC{no}} 201 | \newcommand{\MaybeDecl}{ 202 | \Data \hg 203 | \Rule{\vA\Hab\Type} 204 | {\Maybe\:\vA\Hab\Type} \hg 205 | \Where \hg 206 | \Rule{\va \Hab \vA} 207 | {\yes\:\va\Hab\Maybe\:\vA} \hg 208 | \Axiom{\no\Hab\Maybe\:\vA} 209 | }} 210 | 211 | %%% Cross 212 | 213 | \newcommand{\pr}[2]{(#1\DC{,}#2)} %grrrr 214 | \newcommand{\CrossPackage}{ 215 | \newcommand{\Cross}{\times} 216 | \newcommand{\CrossDecl}{ 217 | \Data \hg 218 | \Rule{\vA,\vB\Hab\Type} 219 | {\vA\Cross\vB\Hab\Type} \hg 220 | \Where \hg 221 | \Rule{\va \Hab \vA \hg \vb\Hab\vB} 222 | {\pr{\va}{\vb}\Hab\vA\Cross\vB} 223 | }} 224 | 225 | %%% Fin 226 | 227 | \newcommand{\FinPackage}{ 228 | \newcommand{\Fin}{\TC{Fin}} 229 | \newcommand{\fz}{\DC{f0}} 230 | \newcommand{\fs}{\DC{fs}} 231 | \newcommand{\FinDecl}{ 232 | \AR{ 233 | \Data \hg 234 | \Rule{\vn\Hab\Nat} 235 | {\Fin\:\vn\Hab\Type} \hg \\ 236 | \Where \hg 237 | \begin{array}[t]{c} 238 | \Axiom{\fz\Hab\Fin\:(\suc\:\vn)} \hg 239 | \Rule{\vi\Hab\Fin\:\vn} 240 | {\fs\:\vi\Hab\Fin\:(\suc\:\vn)} 241 | \end{array} 242 | } 243 | }} 244 | 245 | %%% Vect 246 | 247 | \newcommand{\VectPackage}{ 248 | \newcommand{\Vect}{\TC{Vect}} 249 | \newcommand{\vnil}{\varepsilon} 250 | \newcommand{\vcons}{\,\dcolon\,} 251 | \newcommand{\vsnoc}{\,\dcolon\,} 252 | \newcommand{\VectConsDecl}{ 253 | \Data \hg 254 | \Rule{\vA \Hab \Type \hg \vn\Hab\Nat} 255 | {\Vect\:\vA\:\vn\Hab\Type} \hg 256 | \Where \hg \begin{array}[t]{c} 257 | \Axiom{\vnil \Hab \Vect\:\vA\:\Z} \\ 258 | \Rule{\vx\Hab\vA \hg \vxs\Hab \Vect\:\vA\:\vn } 259 | {\vx\vcons\vxs\Hab\Vect\:\vA\:(\suc\vn)} 260 | \end{array} 261 | } 262 | \newcommand{\VectSnocDecl}{ 263 | \Data \hg 264 | \Rule{\vA \Hab \Type \hg \vn\Hab\Nat} 265 | {\Vect\:\vA\:\vn\Hab\Type} \hg 266 | \Where \hg \begin{array}[t]{c} 267 | \Axiom{\vnil \Hab \Vect\:\vA\:\Z} \\ 268 | \Rule{\vxs\Hab \Vect\:\vA\:\vn \hg \vx\Hab\vA} 269 | {\vxs\vsnoc\vx\Hab\Vect\:\vA\:(\suc\vn)} 270 | \end{array} 271 | } 272 | } 273 | 274 | %%% Compare 275 | 276 | %Data Compare : (x:nat)(y:nat)Type 277 | % = lt : (x:nat)(y:nat)(Compare x (plus (S y) x)) 278 | % | eq : (x:nat)(Compare x x) 279 | % | gt : (x:nat)(y:nat)(Compare (plus (S x) y) y); 280 | 281 | 282 | \newcommand{\ComparePackage}{ 283 | \newcommand{\Compare}{\TC{Compare}} 284 | \newcommand{\ltComp}{\DC{lt}} 285 | \newcommand{\eqComp}{\DC{eq}} 286 | \newcommand{\gtComp}{\DC{gt}} 287 | \newcommand{\CompareDecl}{ 288 | \Data \hg 289 | \Rule{\vm\Hab\Nat\hg\vn\Hab\Nat} 290 | {\Compare\:\vm\:\vn\Hab\Type} \\ 291 | \Where \hg\begin{array}[t]{c} 292 | \Rule{\vx\Hab\Nat\hg\vy\Hab\Nat} 293 | {\ltComp_{\vx}\:\vy\Hab\Compare\:\vx\:(\FN{plus}\:\vx\:(\suc\:\vy))} \\ 294 | \Rule{\vx\Hab\Nat} 295 | {\eqComp_{\vx}\Hab\Compare\:\vx\:\vx}\\ 296 | \Rule{\vx\Hab\Nat\hg\vy\Hab\Nat} 297 | {\gtComp_{\vy}\:\vx\Hab\Compare\:(\FN{plus}\:\vy\:(\suc\:\vx))\:\vy} \\ 298 | \end{array} 299 | } 300 | 301 | %Data CompareM : Type 302 | % = ltM : (ydiff:nat)CompareM 303 | % | eqM : CompareM 304 | % | gtM : (xdiff:nat)CompareM; 305 | 306 | \newcommand{\CompareM}{\TC{Compare^-}} 307 | \newcommand{\ltCompM}{\DC{lt^-}} 308 | \newcommand{\eqCompM}{\DC{eq^-}} 309 | \newcommand{\gtCompM}{\DC{gt^-}} 310 | \newcommand{\CompareMDecl}{ 311 | 312 | \Data \hg 313 | \Axiom{\CompareM\Hab\Type} \\ 314 | \Where \hg\begin{array}[t]{c} 315 | \Rule{\vy\Hab\Nat} 316 | {\ltCompM\:\vy\Hab\CompareM} \\ 317 | \Axiom{\eqCompM\Hab\CompareM}\\ 318 | \Rule{\vx\Hab\Nat} 319 | {\gtCompM\:\vx\Hab\CompareM} \\ 320 | \end{array} 321 | } 322 | \newcommand{\CompareRec}{\FN{CompareRec}} 323 | \newcommand{\CompareRecM}{\FN{CompareRec^-}} 324 | 325 | } 326 | -------------------------------------------------------------------------------- /Papers/Epic-TFP/performance.tex: -------------------------------------------------------------------------------- 1 | \section{Performance} 2 | -------------------------------------------------------------------------------- /Papers/Epic/Makefile: -------------------------------------------------------------------------------- 1 | PAPER = epic 2 | 3 | all: ${PAPER}.pdf 4 | 5 | TEXFILES = ${PAPER}.tex intro.tex language.tex example.tex \ 6 | implementation.tex performance.tex conclusions.tex 7 | 8 | DIAGS = 9 | 10 | SOURCES = ${TEXFILES} ${DIAGS} macros.ltx literature.bib 11 | 12 | DITAA = java -jar ~/Downloads/ditaa.jar 13 | 14 | ${PAPER}.pdf: ${SOURCES} 15 | # dvipdf ${PAPER}.dvi 16 | pdflatex ${PAPER} 17 | -bibtex ${PAPER} 18 | -pdflatex ${PAPER} 19 | -pdflatex ${PAPER} 20 | 21 | ${PAPER}.ps: ${PAPER}.dvi 22 | dvips -o ${PAPER}.ps ${PAPER} 23 | 24 | ${PAPER}.dvi: $(SOURCES) 25 | -latex ${PAPER} 26 | -bibtex ${PAPER} 27 | -latex ${PAPER} 28 | -latex ${PAPER} 29 | 30 | progress: .PHONY 31 | wc -w ${TEXFILES} 32 | 33 | %.png : %.diag 34 | $(DITAA) -o -E $< 35 | 36 | .PHONY: 37 | -------------------------------------------------------------------------------- /Papers/Epic/comments.sty: -------------------------------------------------------------------------------- 1 | % $id$ 2 | % KH: created comments style file to allow alternative versions of a document. 3 | 4 | % \newcommand{\red}[1]{#1} 5 | 6 | \usepackage{color} 7 | \definecolor{BrickRed}{cmyk}{0, .89, .5, 0} 8 | \newcommand{\red}{\color{BrickRed}} 9 | 10 | \newcommand{\eucommentary}[1]{\(\spadesuit\){\red{\textbf{EC Commentary}: \emph{#1}}\(\spadesuit\)}} 11 | \newcommand{\euevaluation}[2]{\(\spadesuit\){\red{\textbf{Evaluation Criteria ({#1})}: \emph{#2}}\(\spadesuit\)}} 12 | 13 | \newcommand{\comment}[2]{\(\spadesuit\){\bf #1: }{\rm \sf #2}\(\spadesuit\)} 14 | \newcommand{\draftpage}{\newpage} 15 | 16 | \newcommand{\FIXME}[1]{[\textbf{FIXME}: #1]} 17 | 18 | %\newcommand{\FIXME}[1]{\wibble} 19 | \newcommand{\nocomments}{ 20 | \renewcommand{\eucommentary}[1]{} 21 | \renewcommand{\euevaluation}[2]{} 22 | \renewcommand{\comment}[2]{} 23 | \renewcommand{\draftpage}{} 24 | \renewcommand{\FIXME}[1]{} 25 | } 26 | 27 | \DeclareOption{final}{\nocomments} 28 | \DeclareOption{draft}{} 29 | \ProcessOptions* 30 | -------------------------------------------------------------------------------- /Papers/Epic/conclusions.tex: -------------------------------------------------------------------------------- 1 | \section{Related Work} 2 | 3 | Should mention Agda and Idris~\cite{scrap-engine} and the development 4 | version of Epigram~\cite{levitation} as having Epic back ends. 5 | 6 | GHC's run-time system~\cite{stg, evalpush}, ABC 7 | machine~\cite{abc-machine} and why we don't just use one of them 8 | (no useful interface, imposes constraints on the type system). 9 | Some influence from GRIN~\cite{grin-project}. 10 | 11 | Lazy virtual machine~\cite{lvm}. C-~~\cite{c--} and LLVM~\cite{llvm} 12 | as possible code generation strategies. Supercompilation for 13 | optimisations~\cite{mitchell-super}. 14 | 15 | \section{Conclusion} 16 | 17 | -------------------------------------------------------------------------------- /Papers/Epic/dtp.bib: -------------------------------------------------------------------------------- 1 | @phdthesis{ brady-thesis, 2 | author = {Edwin Brady}, 3 | title = {Practical Implementation of a Dependently Typed Functional Programming Language}, 4 | year = 2005, 5 | school = {University of Durham} 6 | } 7 | 8 | @article{view-left, 9 | journal = {Journal of Functional Programming}, 10 | number = {1}, 11 | volume = {14}, 12 | title = {The View From The Left}, 13 | year = {2004}, 14 | author = {Conor McBride and James McKinna}, 15 | pages = {69--111} 16 | } 17 | 18 | @misc{epigram-afp, 19 | author = {Conor McBride}, 20 | title = {Epigram: Practical Programming with Dependent Types}, 21 | year = {2004}, 22 | howpublished = {Lecture Notes, International Summer School on Advanced Functional Programming} 23 | } 24 | 25 | @misc{coq-manual, 26 | howpublished = {\verb+http://coq.inria.fr/+}, 27 | title = {The {Coq} Proof Assistant --- Reference Manual}, 28 | year = {2004}, 29 | author = {{Coq Development Team}} 30 | } 31 | 32 | @inproceedings{extraction-coq, 33 | title = {A New Extraction for {Coq}}, 34 | year = {2002}, 35 | booktitle = {Types for proofs and programs}, 36 | editor = {Herman Geuvers and Freek Wiedijk}, 37 | publisher = {Springer}, 38 | author = {Pierre Letouzey}, 39 | series = {LNCS} 40 | } 41 | 42 | @techreport{lego-manual, 43 | title = {\textsc{Lego} Proof Development System: User's Manual}, 44 | year = {1992}, 45 | institution = {Department of Computer Science, University of Edinburgh}, 46 | author = {Zhaohui Luo and Robert Pollack} 47 | } 48 | 49 | @book{luo94, 50 | title = {Computation and Reasoning -- A Type Theory for Computer Science}, 51 | year = {1994}, 52 | publisher = {OUP}, 53 | author = {Zhaohui Luo}, 54 | series = {International Series of Monographs on Computer Science} 55 | } 56 | 57 | @phdthesis{goguen-thesis, 58 | school = {University of Edinburgh}, 59 | title = {A Typed Operational Semantics for Type Theory}, 60 | year = {1994}, 61 | author = {Healfdene Goguen} 62 | } 63 | 64 | @phdthesis{mcbride-thesis, 65 | month = {May}, 66 | school = {University of Edinburgh}, 67 | title = {Dependently Typed Functional Programs and their proofs}, 68 | year = {2000}, 69 | author = {Conor McBride} 70 | } 71 | 72 | @misc{mckinnabrady-phase, 73 | title = {Phase Distinctions in the Compilation of {Epigram}}, 74 | year = 2005, 75 | author = {James McKinna and Edwin Brady}, 76 | note = {Draft} 77 | } 78 | 79 | @article{pugh-omega, 80 | title = "The {Omega} {Test}: a fast and practical integer programming algorithm for dependence analysis", 81 | author = "William Pugh", 82 | journal = "Communication of the ACM", 83 | year = 1992, 84 | pages = {102--114} 85 | } 86 | 87 | @Article{RegionTypes, 88 | refkey = "C1753", 89 | title = "Region-Based Memory Management", 90 | author = "M. Tofte and J.-P. Talpin", 91 | pages = "109--176", 92 | journal = "Information and Computation", 93 | month = "1~" # feb, 94 | year = "1997", 95 | volume = "132", 96 | number = "2" 97 | } 98 | 99 | @phdthesis{ pedro-thesis, 100 | author = {Pedro Vasconcelos}, 101 | title = {Space Cost Modelling for Concurrent Resource Sensitive Systems}, 102 | year = 2006, 103 | school = {University of St Andrews} 104 | } 105 | 106 | @book{curry-feys, 107 | title = {Combinatory Logic, volume 1}, 108 | year = {1958}, 109 | publisher = {North Holland}, 110 | author = {Haskell B. Curry and Robert Feys} 111 | } 112 | @inproceedings{howard, 113 | title = {The formulae-as-types notion of construction}, 114 | year = {1980}, 115 | booktitle = {To H.B.Curry: Essays on combinatory logic, lambda calculus and formalism}, 116 | editor = {Jonathan P. Seldin and J. Roger Hindley}, 117 | publisher = {Academic Press}, 118 | author = {William A. Howard}, 119 | note = {A reprint of an unpublished manuscript from 1969} 120 | } 121 | 122 | @misc{ydtm, 123 | author = {Thorsten Altenkirch and Conor McBride and James McKinna}, 124 | title = {Why Dependent Types Matter}, 125 | note = {Submitted for publication}, 126 | year = 2005} 127 | 128 | @inproceedings{regular-types, 129 | author = { Peter Morris and Conor McBride and Thorsten Altenkirch}, 130 | title = {Exploring The Regular Tree Types}, 131 | year = 2005, 132 | booktitle = {Types for Proofs and Programs 2004} 133 | } 134 | 135 | @inproceedings{xi_arraybounds, 136 | author = "Hongwei Xi and Frank Pfenning", 137 | title = {Eliminating Array Bound Checking through Dependent Types}, 138 | booktitle = "Proceedings of ACM SIGPLAN Conference on Programming Language Design and Implementation", 139 | year = 1998, 140 | month = "June", 141 | address = "Montreal", 142 | pages = "249--257", 143 | } 144 | 145 | @misc{interp-cayenne, 146 | url = {\verb+http://www.cs.chalmers.se/~augustss/cayenne/+}, 147 | title = {An exercise in dependent types: A well-typed interpreter}, 148 | year = {1999}, 149 | author = {Lennart Augustsson and Magnus Carlsson} 150 | } 151 | 152 | -------------------------------------------------------------------------------- /Papers/Epic/embounded.bib: -------------------------------------------------------------------------------- 1 | @Book{BurnsWellings, 2 | author = {A. Burns and A.J. Wellings}, 3 | title = {{Real-Time Systems and Programming Languages (Third Edition)}}, 4 | publisher = {Addison Wesley Longman}, 5 | year = 2001 6 | } 7 | 8 | @Book{Ganssle:Book, 9 | author = {J.G. Ganssle}, 10 | title = {{The Art of Programming Embedded Systems}}, 11 | publisher = {Academic Press}, 12 | year = {1992}, 13 | note = {ISBN 0-12274880-8}, 14 | } 15 | 16 | @Book{Ganssle:Design, 17 | author = {J.G. Ganssle}, 18 | title = {{The Art of Designing Embedded Systems}}, 19 | publisher = {Newnes}, 20 | year = {1999}, 21 | note = {ISBN 0-75069869-1}, 22 | } 23 | 24 | @article{Ganssle:OnLanguage, 25 | author = {J.G. Ganssle}, 26 | title = {{On Language}}, 27 | journal ={{Electronic Eng. Times}}, 28 | month = "March", 29 | year = {2003} 30 | } 31 | 32 | @article{Ganssle:MicroMinis, 33 | author = {J.G. Ganssle}, 34 | title = {{Micro Minis}}, 35 | journal ={{Embedded Systems Programming}}, 36 | month = "March", 37 | year = {2003} 38 | } 39 | 40 | @article{Barr:EmbeddedSystProg, 41 | author = {M. Barr}, 42 | title = {{The Long Winter}}, 43 | journal ={{Electronic Systems Programming}}, 44 | month = "January", 45 | year = {2003} 46 | } 47 | 48 | @unpublished{Ganssle:WebSite, 49 | author = {The Ganssle Group}, 50 | title = {{Perfecting the Art of Building Embedded Systems}}, 51 | month = "May", 52 | year = 2003, 53 | note = {\url{http://www.ganssle.com}} 54 | } 55 | 56 | @article{Schoitsch, 57 | author = {E. Schoitsch}, 58 | title = {{Embedded Systems -- Introduction}}, 59 | journal = {ERCIM News}, 60 | pages = {10--11}, 61 | volume = 52, 62 | month = jan, 63 | year = 2003 64 | } 65 | 66 | @article{UMLESE, 67 | author = {C. Holland}, 68 | title = {{Telelogic Second Generation Tools}}, 69 | journal = {Embedded Systems Europe}, 70 | month = aug, 71 | year = 2002 72 | } 73 | 74 | @article{DSL, 75 | author = {P. Hudak}, 76 | title = {{Building Domain-Specific Embedded Languages}}, 77 | journal = {ACM Computing Surveys}, 78 | volume = 28, 79 | number = 4, 80 | month = dec, 81 | year = 1996 82 | } 83 | 84 | @article{DSL:devicedriver, 85 | author = {C. Conway}, 86 | title = {{A Domain-Specific Language for Device Drivers}}, 87 | journal = {ACM Computing Surveys}, 88 | volume = 28, 89 | number = 4, 90 | month = dec, 91 | year = 1996 92 | } 93 | 94 | @unpublished{Klocwork, 95 | author = {Klocwork}, 96 | year = 2003, 97 | } 98 | 99 | @inproceedings{Bernat1, 100 | author = {Bernat, G. and Burns, A. and Wellings, A.}, 101 | title = {{Portable Worst-Case Execution Time Analysis Using Java Byte Code}}, 102 | booktitle = {Proc. 12th Euromicro International Conf. on 103 | Real-Time Systems}, 104 | address = {Stockholm}, 105 | year = 2000, 106 | month = {June} 107 | } 108 | 109 | @inproceedings{Bernat2, 110 | author = {Bernat, G. and Colin, A. and Petters, S. M.}, 111 | title = {{WCET Analysis of Probabilistic Hard Real-Time Systems}}, 112 | booktitle = {Proc. 23rd IEEE Real-Time Systems Symposium (RTSS 2002)}, 113 | address = {Austin, TX. (USA)}, 114 | year = 2002, 115 | month = {December} 116 | } 117 | 118 | @inproceedings{SizedRecursion, 119 | author = {P. Vasconcelos and K. Hammond}, 120 | title = {{Inferring Costs for Recursive, Polymorphic and Higher-Order Functions}}, 121 | booktitle = {Proc. Implementation of Functional Languages (IFL 2003)}, 122 | publisher = {Springer-Verlag}, 123 | year = {2003} 124 | } 125 | 126 | @inproceedings{HAM, 127 | author = {K. Hammond and G.J. Michaelson}, 128 | title = {{An Abstract Machine Implementation for Hume}}, 129 | booktitle = {submitted to Intl. Conf. on Compilers, Architectures and Synthesis for Embedded Systems (CASES~03)}, 130 | year = {2003} 131 | } 132 | 133 | @unpublished{EmbeddedSystSurvey, 134 | author = {Embedded.com}, 135 | title = {Poll: What Language do you use for embedded work?}, 136 | note = {\url{http://www.embedded.com/pollArchive/?surveyno=2228}}, 137 | year = 2003, 138 | } 139 | 140 | @inproceedings{ESP, 141 | author = {S. Kumar and K. Li}, 142 | title = {Automatic Memory Management for Programmable Devices}, 143 | booktitle = {Proc. ACM Intl. Symp. on Memory Management, Berlin, Germany}, 144 | month = jun, 145 | year = 2002, 146 | pages = {245--255}, 147 | } 148 | 149 | @inproceedings{RegionJava, 150 | author = {F. Qian and L. Hendrie}, 151 | title = {An Adaptive Region-Based Allocator for Java}, 152 | booktitle = {Proc. ACM Intl. Symp. on Memory Management, Berlin, Germany}, 153 | month = jun, 154 | year = 2002, 155 | pages = {233--244}, 156 | } 157 | 158 | @inproceedings{RegionsRTSJ, 159 | author = {M. Deters and R.K. Cytron}, 160 | title = {Automated Discovery of Scoped Memory Regions for Real-Time Java}, 161 | booktitle = {Proc. ACM Intl. Symp. on Memory Management, Berlin, Germany}, 162 | month = jun, 163 | year = 2002, 164 | pages = {132--141}, 165 | } 166 | 167 | @inproceedings{RTGC, 168 | author = {S. Nettles and J. O'Toole}, 169 | title = {{Real-Time Replication Garbage Collection}}, 170 | booktitle = {ACM Sigplan Notices}, 171 | volume = 28, 172 | number = 6, 173 | month = jun, 174 | year = 1993, 175 | pages = {217--226}, 176 | } 177 | 178 | @inproceedings{Blelloch, 179 | author = {P. Cheng and G. Blelloch}, 180 | title = {{A Parallel, Real-Time Garbage Collector}}, 181 | booktitle = {ACM Sigplan Notices}, 182 | volume = 36, 183 | number = 5, 184 | month = may, 185 | year = 2001, 186 | pages = {125--136}, 187 | } 188 | 189 | @inproceedings{RegionsGC, 190 | author = {N. Hallenberg and M. Elsman and M. Tofte}, 191 | title = {{Combining Region Inference and Garbage Collection}}, 192 | booktitle = {Proc. ACM Conf. on Prog. Lang. Design and Impl. (PLDI~'02), Berlin, Germany}, 193 | month = jun, 194 | year = 2002, 195 | } 196 | 197 | 198 | @article{RTSJIssues, 199 | author = {K. Nilsen}, 200 | title = {{Issues in the Design and Implementation of Real-Time Java}}, 201 | booktitle = {Java Developers' Journal}, 202 | volume = 1, 203 | number = 1, 204 | year = 1996, 205 | pages = 44 206 | } 207 | 208 | 209 | 210 | @unpublished{CyCab, 211 | author = {RoboSoft SA}, 212 | title = {{CyCab Outdoor Vehicle, for Road and/or All-terrain Use}}, 213 | note = {\url{http://www.robosoft.fr/SHEET/01Mobil/2001Cycab/CyCab.html}}, 214 | year = 2003, 215 | month = may 216 | } 217 | 218 | 219 | @unpublished{Joyner, 220 | author = {I. Joyner}, 221 | title = {{C++??: a Critique of C++, 3rd Edition}}, 222 | year = 1996, 223 | institution = {Unisys - ACUS, Australia}, 224 | note = {\url{http://www.kcl.ac.uk/kis/support/cit//fortran/cpp/cppcritique.ps}} 225 | } 226 | 227 | @unpublished{Sakkinen, 228 | author = {M. Sakkinen}, 229 | title = {{The Darker Side of C++ Revisited}}, 230 | year = 1993, 231 | institution = {Univerity of Jyv\"{a}skyl\"{a}}, 232 | note = {Technical Report 1993-I-13, \url{http://www.kcl.ac.uk/kis/support/cit//fortran/cpp/dark-cpl.ps}}, 233 | } 234 | 235 | @TechReport{BCLogicDelvb, 236 | author = {Hans-Wolfgang Loidl and Olha Shkaravska and Lennart Beringer}, 237 | title = {Preliminary investigations into a bytecode logic for Grail}, 238 | institution = {Institut f{\"u}r Informatik, LMU University and LFCS, Edinburgh University}, 239 | year = 2003, 240 | month = jan, 241 | note = {Project Deliverable} 242 | } 243 | 244 | @InProceedings{HWLtofillin, 245 | author = {Lennart Beringer and Kenneth MacKenzie and Ian Stark}, 246 | title = {Grail: a functional form for imperative mobile code}, 247 | booktitle = {FGC03 --- Workshop on Foundations of Global Computing}, 248 | year = 2003, 249 | address = {28--29 June 2003, Eindhoven, The Netherlands}, 250 | note = {Submitted} 251 | } 252 | 253 | 254 | @inproceedings{AbsInt:EmsoftTahoe, 255 | author = "C. Ferdinand and R. Heckmann and M. Langenbach and 256 | F. Martin and M. Schmidt and 257 | H. Theiling and S. Thesing and R. Wilhelm", 258 | title = {Reliable and Precise {WCET} Determination for a Real-Life Processor}, 259 | booktitle = {Proc. EMSOFT 2001, First Workshop on Embedded Software}, 260 | publisher = {Springer-Verlag}, 261 | series = {LNCS}, 262 | volume = 2211, 263 | pages = {469--485}, 264 | year = 2001 265 | } 266 | 267 | 268 | @inproceedings{AbsInt:Avionics, 269 | author = "S. Thesing and J. Souyris and R. Heckmann and 270 | F. Randimbivololona and M. Langenbach and 271 | R. Wilhelm and C. Ferdinand", 272 | title = {An Abstract Interpretation-Based Timing Validation 273 | of Hard Real-Time Avionics Software}, 274 | booktitle = {Proc. 2003 Intl. Conf. 275 | on Dependable Systems and Networks (DSN 2003)}, 276 | pages = {625--632}, 277 | year = 2003 278 | } 279 | 280 | -------------------------------------------------------------------------------- /Papers/Epic/epic.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/edwinb/EpiVM/8bee2234034f71786d7fb59f75a9854ab94161e0/Papers/Epic/epic.pdf -------------------------------------------------------------------------------- /Papers/Epic/epic.tex: -------------------------------------------------------------------------------- 1 | \documentclass[preprint]{sigplanconf} 2 | %\documentclass[orivec,dvips,10pt]{llncs} 3 | 4 | \usepackage[draft]{comments} 5 | %\usepackage[final]{comments} 6 | % \newcommand{\comment}[2]{[#1: #2]} 7 | \newcommand{\khcomment}[1]{\comment{KH}{#1}} 8 | \newcommand{\ebcomment}[1]{\comment{EB}{#1}} 9 | 10 | \usepackage{epsfig} 11 | \usepackage{path} 12 | \usepackage{url} 13 | \usepackage{amsmath,amssymb} 14 | \usepackage{fancyvrb} 15 | 16 | \newenvironment{template}{\sffamily} 17 | 18 | \usepackage{graphics,epsfig} 19 | \usepackage{stmaryrd} 20 | 21 | \input{./macros.ltx} 22 | \input{./library.ltx} 23 | 24 | \NatPackage 25 | \FinPackage 26 | 27 | \newcounter{per} 28 | \setcounter{per}{1} 29 | 30 | \newcommand{\Ivor}{\textsc{Ivor}} 31 | \newcommand{\Idris}{\textsc{Idris}} 32 | \newcommand{\Funl}{\textsc{Funl}} 33 | \newcommand{\Agda}{\textsc{Agda}} 34 | \newcommand{\LamPi}{$\lambda_\Pi$} 35 | 36 | \newcommand{\perule}[1]{\vspace*{0.1cm}\noindent 37 | \begin{center} 38 | \fbox{ 39 | \begin{minipage}{7.5cm}\textbf{Rule \theper:} #1\addtocounter{per}{1} 40 | \end{minipage}} 41 | \end{center} 42 | \vspace*{0.1cm} 43 | } 44 | 45 | \newcommand{\mysubsubsection}[1]{ 46 | \noindent 47 | \textbf{#1} 48 | } 49 | \newcommand{\hdecl}[1]{\texttt{#1}} 50 | 51 | \begin{document} 52 | 53 | \title{Epic --- a Generic Intermediate Functional Programming Language} 54 | %\author{Edwin Brady} 55 | 56 | \authorinfo{Edwin C. Brady} 57 | {School of Computer Science, 58 | University of St Andrews, St Andrews, Scotland.} 59 | {Email: eb@cs.st-andrews.ac.uk} 60 | 61 | 62 | \maketitle 63 | 64 | \begin{abstract} 65 | Compilers for functional languages, whether strict or non-strict, 66 | typed or untyped, need to handle many of the same problems, for 67 | example thunks, lambda lifting, optimisation, garbage collection, and 68 | system interaction. Although implementation techniques are by now 69 | well understood, it remains difficult for a new functional language to 70 | exploit these techniques without either implementing a compiler from 71 | scratch, or attempting fit the new language around another existing 72 | compiler. 73 | 74 | Epic is a compiled functional language which exposes functional 75 | compilation techniques to a language implementor. It has both a 76 | concrete syntax and a Haskell API. It is independent of a source 77 | language's type system and semantics, supports eager or lazy 78 | evaluation, and has a range of primitive types and a lightweight 79 | foreign function interface. In this paper we describe Epic and 80 | demonstrate its flexibility by applying it to two very different 81 | functional languages: a dynamically typed turtle graphics language and 82 | a dependently typed lambda calculus. 83 | 84 | \end{abstract} 85 | 86 | \input{intro} 87 | 88 | \input{language} 89 | 90 | \input{example} 91 | 92 | \input{implementation} 93 | 94 | \input{performance} 95 | 96 | \input{conclusions} 97 | 98 | %\vspace{-0.2in} 99 | %% \section*{Acknowledgments} 100 | 101 | %% This work was partly funded by the Scottish Informatics and Computer 102 | %% Science Alliance (SICSA) and by EU Framework 7 Project No. 248828 103 | %% (ADVANCE). I thanks James McKinna, Kevin Hammond and Anil 104 | %% Madhavapeddy for several helpful discussions, and the anonymous 105 | %% reviewers for their constructive suggestions. 106 | 107 | \bibliographystyle{abbrv} 108 | \begin{small} 109 | \bibliography{literature.bib} 110 | 111 | \appendix 112 | 113 | %\input{code} 114 | 115 | \end{small} 116 | \end{document} 117 | -------------------------------------------------------------------------------- /Papers/Epic/example.tex: -------------------------------------------------------------------------------- 1 | \section{Example High Level Languages} 2 | 3 | In this section we present compilers for three different high level 4 | languages to demonstrate aspects of the Epic API. Firstly, we present 5 | a compiler for the untyped $\lambda$-calculus using Higher Order 6 | Abstract Syntax, which shows the fundamental features of Epic required 7 | to implement a complete compiler. Secondly, we present a compiler for 8 | \LamPi{}~\cite{simply-easy}, a dependently typed language, which shows 9 | how Epic can handle languages with more expressive type 10 | systems. Finally, we present a compiler for a dynamically typed 11 | graphics language, which shows how Epic can be used for languages with 12 | run-time type checking and which require foreign function calls. 13 | 14 | \subsection{Untyped $\lambda$-calculus} 15 | 16 | \subsubsection{Representation} 17 | 18 | Our first example is an implementation of the untyped 19 | $\lambda$-calculus, plus primitive integers and strings, and 20 | arithmetic and string operators. The language is represented in 21 | Haskell using higher order abstract syntax (HOAS). That is, we 22 | represent $\lambda$-bindings (\texttt{Lam}) as Haskell functions, 23 | using a Haskell variable name to refer to the locally bound 24 | variable. We also include global references (\texttt{Ref}) which refer 25 | to top level functions, function application (\texttt{App}), constants 26 | (\texttt{Const}) and binary operators (\texttt{Op}): 27 | 28 | \begin{SaveVerbatim}{llang} 29 | 30 | data Lang = Lam (Lang -> Lang) 31 | | Ref Name 32 | | App Lang Lang 33 | | Const Const 34 | | Op Infix Lang Lang 35 | 36 | \end{SaveVerbatim} 37 | \useverb{llang} 38 | 39 | \noindent 40 | Constants can be either integers or strings: 41 | 42 | \begin{SaveVerbatim}{lconsts} 43 | 44 | data Const = CInt Int 45 | | CStr String 46 | 47 | \end{SaveVerbatim} 48 | \useverb{lconsts} 49 | 50 | \noindent 51 | There are infix operators for arithmetic (\texttt{Plus}, 52 | \texttt{Minus}, \texttt{Times} and \texttt{Divide}), string 53 | manipulation (\texttt{Append}) and comparison (\texttt{Eq}, 54 | \texttt{Lt} and \texttt{Gt}). The comparison operators return an 55 | integer --- zero if the comparison is true, non-zero otherwise: 56 | 57 | \begin{SaveVerbatim}{lops} 58 | 59 | data Infix = Plus | Minus | Times | Divide | Append 60 | | Eq | Lt | Gt 61 | 62 | \end{SaveVerbatim} 63 | \useverb{lops} 64 | 65 | \noindent 66 | A complete program consists of a collection of named \texttt{Lang} 67 | definitions: 68 | 69 | \begin{SaveVerbatim}{lprogs} 70 | 71 | type Defs = [(Name, Lang)] 72 | 73 | \end{SaveVerbatim} 74 | \useverb{lprogs} 75 | 76 | \subsubsection{Compilation} 77 | 78 | Our aim is to convert a collection of \texttt{Defs} into an 79 | executable, using one of the following functions from the Epic API: 80 | 81 | \useverb{compepic} 82 | 83 | \noindent 84 | Given an Epic \texttt{Program}, \texttt{compile} will generate an 85 | executable, and \texttt{run} will generate an executable then run it. 86 | Recall that a program is a collection of named Epic declarations: 87 | 88 | \begin{SaveVerbatim}{eprogs} 89 | 90 | data EpicDecl = forall e. EpicExpr e => EpicFn Name e 91 | | ... 92 | 93 | type Program = [EpicDecl] 94 | 95 | \end{SaveVerbatim} 96 | \useverb{eprogs} 97 | 98 | Our goal, then, is to convert a \texttt{Lang} definition into 99 | something which is an instance of \texttt{EpicExpr}. We use 100 | \texttt{Term}, which is an Epic expression which carries a name 101 | supply. Most of the term construction functions in the Epic API return 102 | a \texttt{Term}. 103 | 104 | \begin{SaveVerbatim}{buildtype} 105 | 106 | build :: Lang -> Term 107 | 108 | \end{SaveVerbatim} 109 | \useverb{buildtype} 110 | 111 | \noindent 112 | The full implementation of \texttt{build} is given in Figure \ref{lcompile}. 113 | In general, this is a straightforward traversal of the \texttt{Lang} 114 | program, converting \texttt{Lang} constants to Epic constants, 115 | \texttt{Lang} application to Epic application, and \texttt{Lang} 116 | operators to the appropriate built-in Epic operators. 117 | 118 | \begin{SaveVerbatim}{lcompile} 119 | 120 | build :: Lang -> Term 121 | build (Lam f) = term (\x -> build (f (EpicRef x))) 122 | build (EpicRef x) = term x 123 | build (Ref n) = ref n 124 | build (App f a) = build f @@ build a 125 | build (Const (CInt x)) = int x 126 | build (Const (CStr x)) = str x 127 | build (Op Append l r) = fn "append" @@ build l @@ build r 128 | build (Op op l r) = op_ (eOp op) (build l) (build r) 129 | where eOp Plus = plus_ 130 | eOp Minus = minus_ 131 | eOp Times = times_ 132 | eOp Divide = divide_ 133 | eOp Eq = eq_ 134 | eOp Lt = lt_ 135 | eOp Gt = gt_ 136 | 137 | \end{SaveVerbatim} 138 | \codefig{lcompile}{Compiling Untyped $\lambda$-calculus} 139 | 140 | The cases worth noting are the compilation of $\lambda$-bindings and 141 | string concatenation. Using HOAS has the advantage that Haskell can 142 | manage scoping, but the disadvantage that it is not straightforward to 143 | convert the abstract syntax into another form. The Epic API also 144 | allows scope management using HOAS, so we need to convert a function 145 | where the bound name refers to a \texttt{Lang} value into a function 146 | where the bound name refers to an Epic value. The easiest solution is 147 | to extend the \texttt{Lang} datatype with an Epic reference: 148 | 149 | \begin{SaveVerbatim}{lextend} 150 | 151 | data Lang = ... 152 | | EpicRef Expr 153 | 154 | build (Lam f) = term (\x -> build (f (EpicRef x))) 155 | 156 | \end{SaveVerbatim} 157 | \useverb{lextend} 158 | 159 | \noindent 160 | To convert a \texttt{Lang} function to an Epic function, we build an 161 | Epic function in which we apply the \texttt{Lang} function to the Epic 162 | reference for its argument. Every reference to a name in \texttt{Lang} 163 | is converted to the equivalent reference to the name in Epic. While 164 | there may be neater solutions involving an environment, or avoiding 165 | HOAS, this solution is very simple to implement, and preserves the 166 | desirable feature that Haskell manages scope. 167 | 168 | Compiling string append uses a built in function provided by the Epic 169 | interface in \texttt{basic\_defs}: 170 | 171 | \begin{SaveVerbatim}{lappend} 172 | 173 | build (Op Append l r) 174 | = fn "append" @@ build l @@ build r 175 | 176 | \end{SaveVerbatim} 177 | \useverb{lappend} 178 | 179 | \noindent 180 | Given \texttt{build}, we can translate a collection of HOAS 181 | definitions into an Epic program, add the built-in Epic definitions 182 | and execute it directly. Recall that there must be a function called 183 | \texttt{"main"} or Epic will report an error. 184 | 185 | \begin{SaveVerbatim}{lmain} 186 | 187 | mkProgram :: Defs -> Program 188 | mkProgram ds = basic_defs ++ 189 | map (\ (n, d) -> EpicFn n (build d)) ds 190 | 191 | execute :: Defs -> IO () 192 | execute p = run (mkProgram p) 193 | 194 | \end{SaveVerbatim} 195 | \useverb{lmain} 196 | 197 | \noindent 198 | Alternatively, we can generate an executable. Again, the entry point 199 | is the Epic function called \texttt{"main"}: 200 | 201 | \begin{SaveVerbatim}{lcomp} 202 | 203 | comp :: Defs -> IO () 204 | comp p = compile "a.out" (mkProgram p) 205 | 206 | \end{SaveVerbatim} 207 | \useverb{lcomp} 208 | 209 | \noindent 210 | This is a compiler for a very simple language, but a compiler for any 211 | more complex language using the Epic API follows the same pattern: 212 | convert the abstract syntax for each named definition into a named Epic 213 | \texttt{Term}, add any required primitives (we have just used 214 | \texttt{basic\_defs} here), and pass the collection of definitions to 215 | \texttt{run} or \texttt{compile}. 216 | 217 | \subsection{Dependently Typed $\lambda$-calculus} 218 | 219 | \LamPi{}~\cite{simply-easy}. Complications: elimination 220 | operators. Representation uses de Bruijn indices. Need a way to dump 221 | output. Non-complication: odd type system. 222 | 223 | \subsubsection{Representation} 224 | 225 | \subsubsection{Compilation} 226 | 227 | \subsection{A Dynamically Typed Turtle Graphics Language} 228 | 229 | 230 | 231 | -------------------------------------------------------------------------------- /Papers/Epic/implementation.tex: -------------------------------------------------------------------------------- 1 | \section{Implementation} 2 | 3 | How it's implemented is not really important to the user --- a 4 | compiler can target Epic without knowing, and we could drop in a new 5 | back end at any time in principle. 6 | 7 | There is currently one back end, but more are planned. Compiled via 8 | C. Garbage collection with Boehm~\cite{boehm-gc}, 9 | \texttt{\%memory}. (Note that a non-moving collector makes things 10 | easier for foreign functions, but may not be the best choice in the 11 | long run). 12 | 13 | Later plans: compile via LLVM, allow plug in garbage collectors 14 | (important for embedded systems, device drivers, operating system 15 | services, for example). 16 | 17 | -------------------------------------------------------------------------------- /Papers/Epic/intro.tex: -------------------------------------------------------------------------------- 1 | \section{Introduction} 2 | 3 | [Just some notes for now...] 4 | 5 | Lots of backends for functional languages, 6 | e.g. STG~\cite{evalpush,stg,llvm-haskell}, ABC~\cite{abc-machine}. 7 | But they aren't simple enough that they are easy to bolt on to a new 8 | language. Either too low level, or an interface isn't exposed, or 9 | where an interface is exposed, there are constraints on the type 10 | system. So things like Agda~\cite{norell-thesis} have resorted to 11 | generating Haskell with unsafeCoerce, Cayenne~\cite{cayenne-icfp} used LML 12 | with the type checker switched off. This works but we can't expect 13 | GHC optimisations without working very hard, are limited to GHC's 14 | choice of evaluation order, and could throw away useful information 15 | gained from the type system. 16 | 17 | Epic originally written for Epigram~\cite{levitation} (the 18 | name\footnote{Coined by James McKinna} is 19 | short for ``\textbf{Epi}gram \textbf{C}ompiler''). Now used by 20 | Idris~\cite{idris-plpv}, also as an experimental back end for Agda. 21 | It is specifically designed for reuse by other languages (in constrast 22 | to, say, GHC Core). 23 | 24 | \subsection{Features and non-features} 25 | 26 | Epic will handle the following: 27 | 28 | \begin{itemize} 29 | \item Managing closures and thunks 30 | \item Lambda lifting 31 | \item Some optimisations (currently inlining, a supercompiler is planned) 32 | \item Marshaling values to and from foreign functions 33 | \item Garbage collection 34 | \item Name choices (optionally) 35 | \end{itemize} 36 | 37 | \noindent 38 | Epic will not do the following, by design: 39 | 40 | \begin{itemize} 41 | \item Type checking (no assumptions are made about the type system of 42 | the high level language being compiled) 43 | \end{itemize} 44 | 45 | Epic has few high level language features, but some additions will be 46 | considered which will not compromise the simplicity of the core 47 | language. For example, a pattern matching compiler is planned, and 48 | primitives for parallel execution. 49 | 50 | Also lacking, but entirely possible to add later (with some care) are 51 | unboxed types. 52 | 53 | \subsection{Why an Intermediate Language} 54 | 55 | Why not generate Haskell, OCaml, Scheme, \ldots? In general they are 56 | too high level and impose design choices and prevent certain 57 | implementation choices. An intermediate level language such as Epic 58 | allows the following: 59 | 60 | \begin{description} 61 | \item[Control of generated code] 62 | A higher level target language imposes implementation choices such as 63 | evaluation strategy and purity. Also makes it harder to use lower 64 | level features where it might be appropriate (e.g. while loops, mutation). 65 | 66 | \item[Control of language design] 67 | Choice of a high level target language (especially a typed one) might 68 | influence our type system design, restrict our choices for ease of 69 | code generation. 70 | 71 | \item[Efficiency] 72 | We might expect using a mature target language to give us 73 | optimisations for free. This might be true in many cases, but only if 74 | our source language is similar enough. e.g. in Epigram the type system 75 | tells us more about the code than we can pass on to a Haskell back 76 | end. 77 | 78 | \end{description} 79 | 80 | Epic aims to provide the necessary features for implementing the 81 | back-end of a functional language --- thunks, closures, algebraic data 82 | types, scope management, lambda lifting --- without imposing 83 | \remph{any} design choices on the high level language designer, with 84 | the obvious exception that a functional style is encouraged! 85 | A further advantage of Epic is that the library provides 86 | \remph{compiler combinators}, which guarantee that any 87 | output code will be syntactically correct and well-scoped. 88 | -------------------------------------------------------------------------------- /Papers/Epic/library.ltx: -------------------------------------------------------------------------------- 1 | %%%%%%%%%%%%%%% library file for datatypes etc. 2 | 3 | %%% Identifiers 4 | 5 | \newcommand{\va}{\VV{a}} 6 | \newcommand{\vb}{\VV{b}} 7 | \newcommand{\vc}{\VV{c}} 8 | \newcommand{\vd}{\VV{d}} 9 | \newcommand{\ve}{\VV{e}} 10 | \newcommand{\vf}{\VV{f}} 11 | \newcommand{\vg}{\VV{g}} 12 | \newcommand{\vh}{\VV{h}} 13 | \newcommand{\vi}{\VV{i}} 14 | \newcommand{\vj}{\VV{j}} 15 | \newcommand{\vk}{\VV{k}} 16 | \newcommand{\vl}{\VV{l}} 17 | \newcommand{\vm}{\VV{m}} 18 | \newcommand{\vn}{\VV{n}} 19 | \newcommand{\vo}{\VV{o}} 20 | \newcommand{\vp}{\VV{p}} 21 | \newcommand{\vq}{\VV{q}} 22 | \newcommand{\vr}{\VV{r}} 23 | \newcommand{\vs}{\VV{s}} 24 | \newcommand{\vt}{\VV{t}} 25 | \newcommand{\vu}{\VV{u}} 26 | \newcommand{\vv}{\VV{v}} 27 | \newcommand{\vw}{\VV{w}} 28 | \newcommand{\vx}{\VV{x}} 29 | \newcommand{\vy}{\VV{y}} 30 | \newcommand{\vz}{\VV{z}} 31 | \newcommand{\vA}{\VV{A}} 32 | \newcommand{\vB}{\VV{B}} 33 | \newcommand{\vC}{\VV{C}} 34 | \newcommand{\vD}{\VV{D}} 35 | \newcommand{\vE}{\VV{E}} 36 | \newcommand{\vF}{\VV{F}} 37 | \newcommand{\vG}{\VV{G}} 38 | \newcommand{\vH}{\VV{H}} 39 | \newcommand{\vI}{\VV{I}} 40 | \newcommand{\vJ}{\VV{J}} 41 | \newcommand{\vK}{\VV{K}} 42 | \newcommand{\vL}{\VV{L}} 43 | \newcommand{\vM}{\VV{M}} 44 | \newcommand{\vN}{\VV{N}} 45 | \newcommand{\vO}{\VV{O}} 46 | \newcommand{\vP}{\VV{P}} 47 | \newcommand{\vQ}{\VV{Q}} 48 | \newcommand{\vR}{\VV{R}} 49 | \newcommand{\vS}{\VV{S}} 50 | \newcommand{\vT}{\VV{T}} 51 | \newcommand{\vU}{\VV{U}} 52 | \newcommand{\vV}{\VV{V}} 53 | \newcommand{\vW}{\VV{W}} 54 | \newcommand{\vX}{\VV{X}} 55 | \newcommand{\vY}{\VV{Y}} 56 | \newcommand{\vZ}{\VV{Z}} 57 | \newcommand{\vas}{\VV{as}} 58 | \newcommand{\vbs}{\VV{bs}} 59 | \newcommand{\vcs}{\VV{cs}} 60 | \newcommand{\vds}{\VV{ds}} 61 | \newcommand{\ves}{\VV{es}} 62 | \newcommand{\vfs}{\VV{fs}} 63 | \newcommand{\vgs}{\VV{gs}} 64 | \newcommand{\vhs}{\VV{hs}} 65 | \newcommand{\vis}{\VV{is}} 66 | \newcommand{\vjs}{\VV{js}} 67 | \newcommand{\vks}{\VV{ks}} 68 | \newcommand{\vls}{\VV{ls}} 69 | \newcommand{\vms}{\VV{ms}} 70 | \newcommand{\vns}{\VV{ns}} 71 | \newcommand{\vos}{\VV{os}} 72 | \newcommand{\vps}{\VV{ps}} 73 | \newcommand{\vqs}{\VV{qs}} 74 | \newcommand{\vrs}{\VV{rs}} 75 | %\newcommand{\vss}{\VV{ss}} 76 | \newcommand{\vts}{\VV{ts}} 77 | \newcommand{\vus}{\VV{us}} 78 | \newcommand{\vvs}{\VV{vs}} 79 | \newcommand{\vws}{\VV{ws}} 80 | \newcommand{\vxs}{\VV{xs}} 81 | \newcommand{\vys}{\VV{ys}} 82 | \newcommand{\vzs}{\VV{zs}} 83 | 84 | %%% Telescope Identifiers 85 | 86 | \newcommand{\ta}{\vec{\VV{a}}} 87 | \newcommand{\tb}{\vec{\VV{b}}} 88 | \newcommand{\tc}{\vec{\VV{c}}} 89 | \newcommand{\td}{\vec{\VV{d}}} 90 | \newcommand{\te}{\vec{\VV{e}}} 91 | \newcommand{\tf}{\vec{\VV{f}}} 92 | \newcommand{\tg}{\vec{\VV{g}}} 93 | %\newcommand{\th}{\vec{\VV{h}}} 94 | \newcommand{\ti}{\vec{\VV{i}}} 95 | \newcommand{\tj}{\vec{\VV{j}}} 96 | \newcommand{\tk}{\vec{\VV{k}}} 97 | \newcommand{\tl}{\vec{\VV{l}}} 98 | \newcommand{\tm}{\vec{\VV{m}}} 99 | \newcommand{\tn}{\vec{\VV{n}}} 100 | %\newcommand{\to}{\vec{\VV{o}}} 101 | \newcommand{\tp}{\vec{\VV{p}}} 102 | \newcommand{\tq}{\vec{\VV{q}}} 103 | \newcommand{\tr}{\vec{\VV{r}}} 104 | \newcommand{\tts}{\vec{\VV{s}}} 105 | \newcommand{\ttt}{\vec{\VV{t}}} 106 | \newcommand{\tu}{\vec{\VV{u}}} 107 | %\newcommand{\tv}{\vec{\VV{v}}} 108 | \newcommand{\tw}{\vec{\VV{w}}} 109 | \newcommand{\tx}{\vec{\VV{x}}} 110 | \newcommand{\ty}{\vec{\VV{y}}} 111 | \newcommand{\tz}{\vec{\VV{z}}} 112 | \newcommand{\tA}{\vec{\VV{A}}} 113 | \newcommand{\tB}{\vec{\VV{B}}} 114 | \newcommand{\tC}{\vec{\VV{C}}} 115 | \newcommand{\tD}{\vec{\VV{D}}} 116 | \newcommand{\tE}{\vec{\VV{E}}} 117 | \newcommand{\tF}{\vec{\VV{F}}} 118 | \newcommand{\tG}{\vec{\VV{G}}} 119 | \newcommand{\tH}{\vec{\VV{H}}} 120 | \newcommand{\tI}{\vec{\VV{I}}} 121 | \newcommand{\tJ}{\vec{\VV{J}}} 122 | \newcommand{\tK}{\vec{\VV{K}}} 123 | \newcommand{\tL}{\vec{\VV{L}}} 124 | \newcommand{\tM}{\vec{\VV{M}}} 125 | \newcommand{\tN}{\vec{\VV{N}}} 126 | \newcommand{\tO}{\vec{\VV{O}}} 127 | \newcommand{\tP}{\vec{\VV{P}}} 128 | \newcommand{\tQ}{\vec{\VV{Q}}} 129 | \newcommand{\tR}{\vec{\VV{R}}} 130 | \newcommand{\tS}{\vec{\VV{S}}} 131 | \newcommand{\tT}{\vec{\VV{T}}} 132 | \newcommand{\tU}{\vec{\VV{U}}} 133 | \newcommand{\tV}{\vec{\VV{V}}} 134 | \newcommand{\tW}{\vec{\VV{W}}} 135 | \newcommand{\tX}{\vec{\VV{X}}} 136 | \newcommand{\tY}{\vec{\VV{Y}}} 137 | \newcommand{\tZ}{\vec{\VV{Z}}} 138 | 139 | 140 | 141 | %%% Nat 142 | 143 | \newcommand{\NatPackage}{ 144 | \newcommand{\Nat}{\TC{\mathbb{N}}} 145 | \newcommand{\Z}{\DC{0}} 146 | \newcommand{\suc}{\DC{s}} 147 | \newcommand{\NatDecl}{ 148 | \Data \hg 149 | \Axiom{\Nat\Hab\Type} \hg 150 | \Where \hg 151 | \Axiom{\Z\Hab\Nat} \hg 152 | \Rule{\vn\Hab\Nat} 153 | {\suc\:\vn\Hab\Nat} 154 | }} 155 | 156 | %%% Bool 157 | 158 | \newcommand{\BoolPackage}{ 159 | \newcommand{\Bool}{\TC{Bool}} 160 | \newcommand{\true}{\DC{true}} 161 | \newcommand{\false}{\DC{false}} 162 | \newcommand{\BoolDecl}{ 163 | \Data \hg 164 | \Axiom{\Bool\Hab\Type} \hg 165 | \Where \hg 166 | \Axiom{\true\Hab\Bool} \hg 167 | \Axiom{\false\Hab\Bool} 168 | }} 169 | 170 | %%% So 171 | 172 | \newcommand{\SoPackage}{ 173 | \newcommand{\So}{\TC{So}} 174 | \newcommand{\oh}{\DC{oh}} 175 | \newcommand{\SoDecl}{ 176 | \Data \hg 177 | \Rule{\vb\Hab\Bool} 178 | {\So\:\vb\Hab\Type} \hg 179 | \Where \hg 180 | \Axiom{\oh\Hab\So\:\true} 181 | }} 182 | 183 | %%% Unit 184 | 185 | \newcommand{\UnitPackage}{ 186 | \newcommand{\Unit}{\TC{Unit}} 187 | \newcommand{\void}{\DC{void}} 188 | \newcommand{\UnitDecl}{ 189 | \Data \hg 190 | \Axiom{\Unit\Hab\Type} \hg 191 | \Where \hg 192 | \Axiom{\void\Hab\Unit} 193 | }} 194 | 195 | %%% Maybe 196 | 197 | \newcommand{\MaybePackage}{ 198 | \newcommand{\Maybe}{\TC{Maybe}} 199 | \newcommand{\yes}{\DC{yes}} 200 | \newcommand{\no}{\DC{no}} 201 | \newcommand{\MaybeDecl}{ 202 | \Data \hg 203 | \Rule{\vA\Hab\Type} 204 | {\Maybe\:\vA\Hab\Type} \hg 205 | \Where \hg 206 | \Rule{\va \Hab \vA} 207 | {\yes\:\va\Hab\Maybe\:\vA} \hg 208 | \Axiom{\no\Hab\Maybe\:\vA} 209 | }} 210 | 211 | %%% Cross 212 | 213 | \newcommand{\pr}[2]{(#1\DC{,}#2)} %grrrr 214 | \newcommand{\CrossPackage}{ 215 | \newcommand{\Cross}{\times} 216 | \newcommand{\CrossDecl}{ 217 | \Data \hg 218 | \Rule{\vA,\vB\Hab\Type} 219 | {\vA\Cross\vB\Hab\Type} \hg 220 | \Where \hg 221 | \Rule{\va \Hab \vA \hg \vb\Hab\vB} 222 | {\pr{\va}{\vb}\Hab\vA\Cross\vB} 223 | }} 224 | 225 | %%% Fin 226 | 227 | \newcommand{\FinPackage}{ 228 | \newcommand{\Fin}{\TC{Fin}} 229 | \newcommand{\fz}{\DC{f0}} 230 | \newcommand{\fs}{\DC{fs}} 231 | \newcommand{\FinDecl}{ 232 | \AR{ 233 | \Data \hg 234 | \Rule{\vn\Hab\Nat} 235 | {\Fin\:\vn\Hab\Type} \hg \\ 236 | \Where \hg 237 | \begin{array}[t]{c} 238 | \Axiom{\fz\Hab\Fin\:(\suc\:\vn)} \hg 239 | \Rule{\vi\Hab\Fin\:\vn} 240 | {\fs\:\vi\Hab\Fin\:(\suc\:\vn)} 241 | \end{array} 242 | } 243 | }} 244 | 245 | %%% Vect 246 | 247 | \newcommand{\VectPackage}{ 248 | \newcommand{\Vect}{\TC{Vect}} 249 | \newcommand{\vnil}{\varepsilon} 250 | \newcommand{\vcons}{\,\dcolon\,} 251 | \newcommand{\vsnoc}{\,\dcolon\,} 252 | \newcommand{\VectConsDecl}{ 253 | \Data \hg 254 | \Rule{\vA \Hab \Type \hg \vn\Hab\Nat} 255 | {\Vect\:\vA\:\vn\Hab\Type} \hg 256 | \Where \hg \begin{array}[t]{c} 257 | \Axiom{\vnil \Hab \Vect\:\vA\:\Z} \\ 258 | \Rule{\vx\Hab\vA \hg \vxs\Hab \Vect\:\vA\:\vn } 259 | {\vx\vcons\vxs\Hab\Vect\:\vA\:(\suc\vn)} 260 | \end{array} 261 | } 262 | \newcommand{\VectSnocDecl}{ 263 | \Data \hg 264 | \Rule{\vA \Hab \Type \hg \vn\Hab\Nat} 265 | {\Vect\:\vA\:\vn\Hab\Type} \hg 266 | \Where \hg \begin{array}[t]{c} 267 | \Axiom{\vnil \Hab \Vect\:\vA\:\Z} \\ 268 | \Rule{\vxs\Hab \Vect\:\vA\:\vn \hg \vx\Hab\vA} 269 | {\vxs\vsnoc\vx\Hab\Vect\:\vA\:(\suc\vn)} 270 | \end{array} 271 | } 272 | } 273 | 274 | %%% Compare 275 | 276 | %Data Compare : (x:nat)(y:nat)Type 277 | % = lt : (x:nat)(y:nat)(Compare x (plus (S y) x)) 278 | % | eq : (x:nat)(Compare x x) 279 | % | gt : (x:nat)(y:nat)(Compare (plus (S x) y) y); 280 | 281 | 282 | \newcommand{\ComparePackage}{ 283 | \newcommand{\Compare}{\TC{Compare}} 284 | \newcommand{\ltComp}{\DC{lt}} 285 | \newcommand{\eqComp}{\DC{eq}} 286 | \newcommand{\gtComp}{\DC{gt}} 287 | \newcommand{\CompareDecl}{ 288 | \Data \hg 289 | \Rule{\vm\Hab\Nat\hg\vn\Hab\Nat} 290 | {\Compare\:\vm\:\vn\Hab\Type} \\ 291 | \Where \hg\begin{array}[t]{c} 292 | \Rule{\vx\Hab\Nat\hg\vy\Hab\Nat} 293 | {\ltComp_{\vx}\:\vy\Hab\Compare\:\vx\:(\FN{plus}\:\vx\:(\suc\:\vy))} \\ 294 | \Rule{\vx\Hab\Nat} 295 | {\eqComp_{\vx}\Hab\Compare\:\vx\:\vx}\\ 296 | \Rule{\vx\Hab\Nat\hg\vy\Hab\Nat} 297 | {\gtComp_{\vy}\:\vx\Hab\Compare\:(\FN{plus}\:\vy\:(\suc\:\vx))\:\vy} \\ 298 | \end{array} 299 | } 300 | 301 | %Data CompareM : Type 302 | % = ltM : (ydiff:nat)CompareM 303 | % | eqM : CompareM 304 | % | gtM : (xdiff:nat)CompareM; 305 | 306 | \newcommand{\CompareM}{\TC{Compare^-}} 307 | \newcommand{\ltCompM}{\DC{lt^-}} 308 | \newcommand{\eqCompM}{\DC{eq^-}} 309 | \newcommand{\gtCompM}{\DC{gt^-}} 310 | \newcommand{\CompareMDecl}{ 311 | 312 | \Data \hg 313 | \Axiom{\CompareM\Hab\Type} \\ 314 | \Where \hg\begin{array}[t]{c} 315 | \Rule{\vy\Hab\Nat} 316 | {\ltCompM\:\vy\Hab\CompareM} \\ 317 | \Axiom{\eqCompM\Hab\CompareM}\\ 318 | \Rule{\vx\Hab\Nat} 319 | {\gtCompM\:\vx\Hab\CompareM} \\ 320 | \end{array} 321 | } 322 | \newcommand{\CompareRec}{\FN{CompareRec}} 323 | \newcommand{\CompareRecM}{\FN{CompareRec^-}} 324 | 325 | } 326 | -------------------------------------------------------------------------------- /Papers/Epic/performance.tex: -------------------------------------------------------------------------------- 1 | \section{Performance} 2 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | 2 | Build instructions: 3 | 4 | * cabal install 5 | * ...that's it 6 | 7 | The command line tool, epic takes a source file and produces executable 8 | code, via C. Separate compilation is supported, in a fairly simple 9 | way, e.g. to compile a main program main.e which includes some 10 | functions defined in lib.e: 11 | 12 | * Build lib.o with the command epic -c lib.e. 13 | * Import functions in main.e with the line include "lib.ei" in the source. 14 | * Build the executable with epic main.e lib.o -o main 15 | -------------------------------------------------------------------------------- /README.Mac: -------------------------------------------------------------------------------- 1 | For gcc to know where to look on the Mac for include and library 2 | files, assuming you are installing epic in the default location in 3 | your home directory, you will need something like the following in 4 | your .profile: 5 | 6 | export C_INCLUDE_PATH=~/include:/opt/local/include:$C_INCLUDE_PATH 7 | export CPLUS_INCLUDE_PATH=~/include:/opt/local/include:$CPLUS_INCLUDE_PATH 8 | export LD_LIBRARY_PATH=~/lib:/opt/local/lib:$LD_LIBRARY_PATH 9 | export INCLUDE_PATH=~/include:/opt/local/include:$INCLUDE_PATH 10 | export LIBRARY_PATH=~/lib:/opt/local/lib:$LIBRARY_PATH 11 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | import Distribution.Simple.InstallDirs 3 | import Distribution.Simple.LocalBuildInfo 4 | import Distribution.PackageDescription 5 | 6 | import System.Exit 7 | import System.Process 8 | 9 | -- After Epic is built, we need a run time system. 10 | 11 | system' cmd = do 12 | exit <- system cmd 13 | case exit of 14 | ExitSuccess -> return () 15 | ExitFailure _ -> exitWith exit 16 | -- FIXME: This is probably all done the wrong way, I don't really understand 17 | -- Cabal properly... 18 | 19 | buildLib args flags desc local 20 | = system' "make -C evm" 21 | 22 | -- This is a hack. I don't know how to tell cabal that a data file needs 23 | -- installing but shouldn't be in the distribution. And it won't make the 24 | -- distribution if it's not there, so instead I just delete 25 | -- the file after configure. 26 | 27 | postConfLib args flags desc local 28 | = system' "make -C evm clean" 29 | 30 | addPrefix pfx var c = "export " ++ var ++ "=" ++ show pfx ++ "/" ++ c ++ ":$" ++ var 31 | 32 | postInstLib args flags desc local 33 | = do let pfx = prefix (installDirTemplates local) 34 | system' $ "make -C evm install PREFIX=" ++ show pfx 35 | 36 | main = defaultMainWithHooks (simpleUserHooks { postBuild = buildLib, 37 | postConf = postConfLib, 38 | postInst = postInstLib }) 39 | 40 | -------------------------------------------------------------------------------- /compiler/Main.lhs: -------------------------------------------------------------------------------- 1 | > module Main where 2 | 3 | > import System 4 | > import System.Directory 5 | > import System.Environment 6 | > import System.IO 7 | > import Monad 8 | 9 | > import Epic.Compiler 10 | 11 | > main = do args <- getArgs 12 | > (fns, opts) <- getInput args 13 | > outfile <- getOutput opts 14 | > ofiles <- compileFiles fns (mkOpts opts) 15 | > copts <- getCOpts opts 16 | > extras <- getExtra opts 17 | > if ((length ofiles) > 0 && (not (elem Obj opts))) 18 | > then link (ofiles ++ copts) extras outfile (not (elem ExtMain opts)) 19 | > else return () 20 | > where mkOpts (KeepInt:xs) = KeepC:(mkOpts xs) 21 | > mkOpts (TraceOn:xs) = Trace:(mkOpts xs) 22 | > mkOpts (Header f:xs) = MakeHeader f:(mkOpts xs) 23 | > mkOpts (_:xs) = mkOpts xs 24 | > mkOpts [] = [] 25 | 26 | > compileFiles [] _ = return [] 27 | > compileFiles (fn:xs) opts 28 | > | isDotE fn = do 29 | > let ofile = getRoot fn ++ ".o" 30 | > compileOpts fn ofile (Just (getRoot fn ++ ".ei")) opts 31 | > rest <- compileFiles xs opts 32 | > return (ofile:rest) 33 | > | isDotO fn = do 34 | > rest <- compileFiles xs opts 35 | > return (fn:rest) 36 | > | otherwise = do -- probably autogenerated, just build it. 37 | > let ofile = fn ++ ".o" 38 | > compileOpts fn ofile Nothing opts 39 | > rest <- compileFiles xs opts 40 | > return (ofile:rest) 41 | 42 | > isDotE ('.':'e':[]) = True 43 | > isDotE (_:xs) = isDotE xs 44 | > isDotE [] = False 45 | 46 | > isDotC ('.':'c':[]) = True 47 | > isDotC (_:xs) = isDotC xs 48 | > isDotC [] = False 49 | 50 | > isDotO ('.':'o':[]) = True 51 | > isDotO (_:xs) = isDotO xs 52 | > isDotO [] = False 53 | 54 | > mkExecname fn = case span (/='.') fn of 55 | > (stem,".e") -> stem 56 | > (stem,_) -> fn ++ ".exe" 57 | 58 | > getRoot fn = case span (/='.') fn of 59 | > (stem,_) -> stem 60 | 61 | > getInput :: [String] -> IO ([FilePath],[Option]) 62 | > getInput args = do let opts = parseArgs args 63 | > fns <- getFile opts 64 | > if (length fns == 0) 65 | > then do showUsage 66 | > return (fns,opts) 67 | > else return (fns,opts) 68 | 69 | > showUsage = do putStrLn "Epigram Supercombinator Compiler version 0.1" 70 | > putStrLn "Usage:\n\tepic [options]" 71 | > exitWith (ExitFailure 1) 72 | 73 | > data Option = KeepInt -- Don't delete intermediate file 74 | > | TraceOn -- Trace while running (debug option) 75 | > | Obj -- Just make the .o, don't link 76 | > | File String -- File to send the compiler 77 | > | Output String -- Output filename 78 | > | Header String -- Header output filename 79 | > | ExtraInc String -- extra files to inlude 80 | > | COpt String -- option to send straight to gcc 81 | > | ExtMain -- external main (i.e. in a .o) 82 | > deriving Eq 83 | 84 | > parseArgs :: [String] -> [Option] 85 | > parseArgs [] = [] 86 | > parseArgs ("-keepc":args) = KeepInt:(parseArgs args) 87 | > parseArgs ("-trace":args) = TraceOn:(parseArgs args) 88 | > parseArgs ("-c":args) = Obj:(parseArgs args) 89 | > parseArgs ("-extmain":args) = ExtMain:(parseArgs args) 90 | > parseArgs ("-o":name:args) = (Output name):(parseArgs args) 91 | > parseArgs ("-h":name:args) = (Header name):(parseArgs args) 92 | > parseArgs ("-i":inc:args) = (ExtraInc inc):(parseArgs args) 93 | > parseArgs (('$':x):args) = (COpt (x ++ concat (map (" "++) args))):[] 94 | > parseArgs (('-':x):args) = (COpt x):(parseArgs args) 95 | > parseArgs (x:args) = (File x):(parseArgs args) 96 | 97 | > getFile :: [Option] -> IO [FilePath] 98 | > getFile ((File x):xs) = do fns <- getFile xs 99 | > return (x:fns) 100 | > getFile (_:xs) = getFile xs 101 | > getFile [] = return [] 102 | 103 | > getOutput :: [Option] -> IO FilePath 104 | > getOutput ((Output fn):xs) = return fn 105 | > getOutput (_:xs) = getOutput xs 106 | > getOutput [] = return "a.out" 107 | 108 | > getCOpts :: [Option] -> IO [String] 109 | > getCOpts ((COpt x):xs) = do fns <- getCOpts xs 110 | > return (x:fns) 111 | > getCOpts (_:xs) = getCOpts xs 112 | > getCOpts [] = return [] 113 | 114 | > getExtra :: [Option] -> IO [String] 115 | > getExtra ((ExtraInc x):xs) = do fns <- getExtra xs 116 | > return (x:fns) 117 | > getExtra (_:xs) = getExtra xs 118 | > getExtra [] = return [] 119 | -------------------------------------------------------------------------------- /epic.cabal: -------------------------------------------------------------------------------- 1 | Name: epic 2 | Version: 0.9.3.2 3 | Author: Edwin Brady 4 | License: BSD3 5 | License-file: LICENSE 6 | Maintainer: eb@dcs.st-and.ac.uk 7 | Homepage: http://www.dcs.st-and.ac.uk/~eb/epic.php 8 | bug-reports: https://github.com/edwinb/EpiVM/issues 9 | Stability: experimental 10 | Category: Compilers/Interpreters 11 | Synopsis: Compiler for a simple functional language 12 | Description: Epic is a simple functional language which compiles to 13 | reasonably efficient C code, using the Boehm-Demers-Weiser 14 | garbage collector (). 15 | It is intended as a compiler back end, and is currently used 16 | as a back end for Epigram () and Idris 17 | (). 18 | It can be invoked either as a library or an application. 19 | tested-with: GHC == 7.8.3 20 | 21 | Data-files: evm/libevm.a evm/closure.h evm/stdfuns.h evm/stdfuns.c evm/mainprog.c evm/emalloc.h evm/gc_header.h 22 | Extra-source-files: evm/closure.c evm/closure.h evm/stdfuns.h evm/mainprog.c evm/stdfuns.c evm/Makefile evm/emalloc.c evm/emalloc.h evm/gc_header.h evm/sparks.c evm/sparks.h 23 | 24 | Cabal-Version: >= 1.8.0.4 25 | Build-type: Custom 26 | 27 | source-repository head 28 | type: git 29 | location: https://github.com/edwinb/EpiVM.git 30 | 31 | Library 32 | Exposed-modules: Epic.Compiler Epic.Epic 33 | Other-modules: Epic.Bytecode Epic.Parser Epic.Scopecheck 34 | Epic.Language Epic.Lexer Epic.CodegenC Epic.CodegenStack 35 | Epic.OTTLang Epic.Simplify Epic.Stackcode 36 | Epic.Evaluator Paths_epic 37 | Build-depends: base >=4 && <5, mtl, Cabal, array, directory, process 38 | Extensions: BangPatterns 39 | 40 | Executable epic 41 | Main-is: Main.lhs 42 | Other-modules: Epic.Bytecode Epic.Parser Epic.Scopecheck 43 | Epic.Language Epic.Lexer Epic.CodegenC Epic.CodegenStack 44 | Epic.OTTLang Epic.Simplify Epic.Stackcode 45 | Epic.Evaluator Paths_epic 46 | Build-depends: base >=4 && <5, mtl, array, Cabal, directory, process 47 | Extensions: BangPatterns 48 | -------------------------------------------------------------------------------- /evm/Makefile: -------------------------------------------------------------------------------- 1 | CC = gcc 2 | #CFLAGS = -Wall -g -DUSE_BOEHM 3 | CFLAGS = -Wall -O3 -DUSE_BOEHM 4 | OBJS = closure.o stdfuns.o emalloc.o sparks.o 5 | INSTALLDIR = ${PREFIX}/lib/evm 6 | 7 | TARGET = libevm.a 8 | INSTALLHDRS = closure.h stdfuns.h mainprog.c sparks.h 9 | 10 | ${TARGET} : ${OBJS} 11 | ar r ${TARGET} ${OBJS} 12 | ranlib ${TARGET} 13 | 14 | install: 15 | mkdir -p ${INSTALLDIR} 16 | install libevm.a ${INSTALLHDRS} ${INSTALLDIR} 17 | ranlib ${INSTALLDIR}/libevm.a 18 | 19 | clean: 20 | rm -f ${OBJS} ${TARGET} 21 | 22 | closure.o : closure.h emalloc.h 23 | stdfuns.o : stdfuns.h closure.h emalloc.h 24 | emalloc.o : closure.h emalloc.h 25 | sparks.o : sparks.h closure.h 26 | -------------------------------------------------------------------------------- /evm/emalloc.c: -------------------------------------------------------------------------------- 1 | #include "emalloc.h" 2 | 3 | // TMP 4 | 5 | // Also make tmps roots when assigned to. Make enough room with GROWROOTS 6 | 7 | // When copying, make sure that the addresses stored at the roots are updated. 8 | 9 | // Actually, should the root set be the addresses of the local variables? Then 10 | // when they are copied, they can be updated with the new location. 11 | 12 | extern ALLOCATOR allocate; 13 | extern REALLOCATOR reallocate; 14 | 15 | void* e_malloc(VMState* vm, size_t size) { 16 | return (VAL)allocate(size); 17 | } 18 | 19 | void* e_realloc(VMState* vm, void* ptr, size_t size) { 20 | return (VAL)reallocate(ptr, size); 21 | } 22 | -------------------------------------------------------------------------------- /evm/emalloc.h: -------------------------------------------------------------------------------- 1 | #ifndef _EMALLOC_H 2 | #define _EMALLOC_H 3 | 4 | #include "closure.h" 5 | 6 | void* e_malloc(VMState* vm, size_t size); 7 | void* e_realloc(VMState* vm, void* ptr, size_t size); 8 | 9 | #endif 10 | -------------------------------------------------------------------------------- /evm/gc_header.h: -------------------------------------------------------------------------------- 1 | #ifdef USE_BOEHM 2 | 3 | # ifndef WIN32 4 | # include 5 | # define GC_THREADS 6 | # else 7 | # define GC_WIN32_THREADS 8 | # endif 9 | 10 | #include 11 | 12 | #endif 13 | -------------------------------------------------------------------------------- /evm/mainprog.c: -------------------------------------------------------------------------------- 1 | #include "closure.h" 2 | 3 | void** _epic_top_of_stack; 4 | 5 | int main(int argc, char* argv[]) { 6 | void* stacktop = NULL; 7 | _epic_top_of_stack = (void**)&stacktop; 8 | 9 | epic_main(argc, argv); 10 | 11 | return 0; 12 | } 13 | -------------------------------------------------------------------------------- /evm/sparks.c: -------------------------------------------------------------------------------- 1 | #include "sparks.h" 2 | 3 | void sparkThread(VAL thunk) { 4 | spark* s = (spark*)(thunk->info); 5 | 6 | pthread_mutex_lock(s->lock); 7 | SETTY(thunk, RUNNING); 8 | pthread_mutex_unlock(s->lock); 9 | 10 | VAL ans = DO_EVAL(s->thunk, 1); 11 | 12 | pthread_mutex_lock(s->lock); 13 | UPDATE(thunk, ans); 14 | // pthread_cond_broadcast(s->cond); 15 | pthread_mutex_unlock(s->lock); 16 | } 17 | 18 | VAL addSpark(VAL thunk) { 19 | VAL c = EMALLOC(sizeof(Closure)+sizeof(spark)); 20 | spark* s = (spark*)(c+1); 21 | 22 | pthread_mutex_t m; 23 | pthread_mutex_init(&m, NULL); 24 | 25 | // pthread_cond_t cond; 26 | // pthread_cond_init(&cond, NULL); 27 | 28 | s->thunk = thunk; 29 | s->lock = &m; 30 | s->cond = NULL; // &cond; 31 | 32 | c->info = (void*)s; 33 | SETTY(c, RUNNING); 34 | 35 | return c; 36 | } 37 | -------------------------------------------------------------------------------- /evm/sparks.h: -------------------------------------------------------------------------------- 1 | #ifndef _SPARKS_H 2 | #define _SPARKS_H 3 | 4 | #include "gc_header.h" 5 | #include "closure.h" 6 | 7 | VAL addSpark(VAL thunk); 8 | //void startWorker(); 9 | 10 | #endif 11 | -------------------------------------------------------------------------------- /evm/stdfuns.h: -------------------------------------------------------------------------------- 1 | #ifndef _STDFUNS_H 2 | #define _STDFUNS_H 3 | 4 | # ifndef WIN32 5 | # include 6 | # define GC_THREADS 7 | # else 8 | # define GC_WIN32_THREADS 9 | # endif 10 | 11 | #include 12 | #include 13 | #include 14 | #include "closure.h" 15 | 16 | // Some basic communication with the outside world 17 | 18 | void putStr(char* str); 19 | void printInt(int x); 20 | void printBigInt(mpz_t x); 21 | void printBig(VAL x); 22 | 23 | // dump memory usage (from libgc) 24 | void epicMemInfo(); 25 | // Force garbage collection 26 | void epicGC(); 27 | 28 | FILE* get_stdin(); 29 | FILE* get_stdout(); 30 | FILE* get_stderr(); 31 | 32 | int readInt(); 33 | char* readStr(); 34 | int streq(char* x, char* y); 35 | int strlt(char* x, char* y); 36 | 37 | void* fileOpen(char* name, char* mode); 38 | void fileClose(void* h); 39 | char* freadStr(void* h); 40 | void* freadStrAny(void* h); 41 | void fputStr(void* h, char* str); 42 | 43 | int isNull(void* ptr); 44 | 45 | int epic_numArgs(); 46 | char* epic_getArg(int i); 47 | 48 | // IORefs 49 | int newRef(); 50 | void* readRef(int r); 51 | void writeRef(int r, void* val); 52 | 53 | // Locks 54 | int newLock(int sem); 55 | void doLock(int lock); 56 | void doUnlock(int lock); 57 | void doFork(void* proc); 58 | void* doWithin(int limit, void* proc, void* doOnFail); 59 | 60 | int do_utime() ; 61 | 62 | int strToInt(char* str); 63 | char* intToStr(int x); 64 | 65 | double strToFloat(char* str); 66 | char* floatToStr(double x); 67 | 68 | double intToFloat(int x); 69 | int floatToInt(double x); 70 | 71 | void* intToBigInt(int x); 72 | int bigIntToInt(void* big); 73 | 74 | mpz_t* strToBigInt(char* str); 75 | char* bigIntToStr(mpz_t x); 76 | 77 | VAL strToBig(char* str); 78 | char* bigToStr(VAL x); 79 | 80 | // get a native representation of a value 81 | void* getNative(void * fn); 82 | 83 | // String operations 84 | 85 | int strIndex(char* str, int i); 86 | int strHead(char* str); 87 | char* strTail(char* str); 88 | char* strCons(int h, char* str); 89 | char* strrev(char* str); 90 | char* substr(char* str, int start, int len); 91 | int strFind(char* str, char c); 92 | 93 | char* append(char* x, char* y); 94 | 95 | // Big integer arithmetic 96 | 97 | mpz_t* addBigInt(mpz_t x, mpz_t y); 98 | mpz_t* subBigInt(mpz_t x, mpz_t y); 99 | mpz_t* mulBigInt(mpz_t x, mpz_t y); 100 | mpz_t* divBigInt(mpz_t x, mpz_t y); 101 | mpz_t* modBigInt(mpz_t x, mpz_t y); 102 | 103 | int eqBigInt(mpz_t x, mpz_t y); 104 | int ltBigInt(mpz_t x, mpz_t y); 105 | int gtBigInt(mpz_t x, mpz_t y); 106 | int leBigInt(mpz_t x, mpz_t y); 107 | int geBigInt(mpz_t x, mpz_t y); 108 | 109 | // VAL versions, which can also cope with INT and promote to BIGINT if necessary 110 | 111 | VAL addBig(VAL x, VAL y); 112 | VAL subBig(VAL x, VAL y); 113 | VAL mulBig(VAL x, VAL y); 114 | VAL divBig(VAL x, VAL y); 115 | VAL modBig(VAL x, VAL y); 116 | 117 | int eqBig(VAL x, VAL y); 118 | int ltBig(VAL x, VAL y); 119 | int gtBig(VAL x, VAL y); 120 | int leBig(VAL x, VAL y); 121 | int geBig(VAL x, VAL y); 122 | 123 | #endif 124 | 125 | -------------------------------------------------------------------------------- /examples/Prelude.e: -------------------------------------------------------------------------------- 1 | %include "string.h" 2 | 3 | -- IO 4 | 5 | %inline putStr (x:String) -> Unit = 6 | foreign Unit "putStr" (x:String) 7 | 8 | putStrLn (x:String) -> Unit = 9 | putStr(append(x,"\n")) 10 | 11 | readStr () -> String = 12 | foreign String "readStr" () 13 | 14 | intToStr (x:Int) -> String = 15 | foreign String "intToStr" (x:Int) 16 | 17 | strToInt (x:String) -> Int = 18 | foreign Int "strToInt" (x:String) 19 | 20 | printInt (x:Int) -> Unit = 21 | foreign Unit "printInt" (x:Int) 22 | 23 | -- String operations 24 | 25 | append (x:String, y:String) -> String = 26 | foreign String "append" (x:String, y:String) 27 | 28 | length (x:String) -> String = 29 | foreign Int "strlen" (x:String) 30 | 31 | index (x:String, i:Int) -> Char = 32 | foreign Int "strIndex" (x:String, i:Int) 33 | 34 | -- Big number arithmetic 35 | 36 | addBig (x:BigInt, y:BigInt) -> BigInt = 37 | foreign BigInt "addBig" (x:BigInt, y:BigInt) 38 | 39 | subBig (x:BigInt, y:BigInt) -> BigInt = 40 | foreign BigInt "subBig" (x:BigInt, y:BigInt) 41 | 42 | mulBig (x:BigInt, y:BigInt) -> BigInt = 43 | foreign BigInt "mulBig" (x:BigInt, y:BigInt) 44 | 45 | eqBig (x:BigInt, y:BigInt) -> Bool = 46 | foreign Int "eqBig" (x:BigInt, y:BigInt) 47 | 48 | ltBig (x:BigInt, y:BigInt) -> Bool = 49 | foreign Int "ltBig" (x:BigInt, y:BigInt) 50 | 51 | gtBig (x:BigInt, y:BigInt) -> Bool = 52 | foreign Int "gtBig" (x:BigInt, y:BigInt) 53 | 54 | leBig (x:BigInt, y:BigInt) -> Bool = 55 | foreign Int "leBig" (x:BigInt, y:BigInt) 56 | 57 | geBig (x:BigInt, y:BigInt) -> Bool = 58 | foreign Int "geBig" (x:BigInt, y:BigInt) 59 | 60 | printBig (x:BigInt) -> Unit = 61 | foreign Unit "printBig" (x:BigInt) 62 | 63 | bigIntToStr (x:BigInt) -> String = 64 | foreign String "bigToStr" (x:BigInt) 65 | 66 | strToBigInt (x:String) -> Int = 67 | foreign String "strToBig" (x:String) 68 | 69 | -------------------------------------------------------------------------------- /examples/adder.e: -------------------------------------------------------------------------------- 1 | include "Prelude.e" 2 | 3 | main () -> Unit = 4 | printInt(natToInt(adder(three, two, three, four, five))) 5 | 6 | %inline adder (arity:Data, acc:Data) -> Any = 7 | case arity of { 8 | Con 0 () -> acc 9 | | Con 1 (k:Data) -> adderAux(k, acc) 10 | } 11 | 12 | adderAux (k:Data, acc:Data, n:Data) -> Any = 13 | adder(k,plus(acc,n)) 14 | 15 | adderAuxE (k:Data, acc:Data, n:Data) -> Any = 16 | case k of { 17 | Con 0 () -> plus(acc,n) 18 | | Con 1 (k:Data) -> adderAuxE(k,plus(acc,n)) 19 | } 20 | 21 | zero () -> Data = Con 0 () 22 | one () -> Data = Con 1 (zero) 23 | two () -> Data = Con 1 (one) 24 | three () -> Data = Con 1 (two) 25 | four () -> Data = Con 1 (three) 26 | five () -> Data = Con 1 (four) 27 | six () -> Data = Con 1 (five) 28 | seven () -> Data = Con 1 (six) 29 | eight () -> Data = Con 1 (seven) 30 | nine () -> Data = Con 1 (eight) 31 | ten () -> Data = Con 1 (nine) 32 | 33 | natToInt (x:Data) -> Int = 34 | case x of { 35 | Con 0 () -> 0 36 | | Con 1 (k:Data) -> 1+natToInt(k) 37 | } 38 | 39 | plus (x:Data, y:Data) -> Data = 40 | case x of { 41 | Con 0 () -> y 42 | | Con 1 (k:Data) -> Con 1 (plus(k, y)) 43 | } 44 | 45 | -------------------------------------------------------------------------------- /examples/bigint.e: -------------------------------------------------------------------------------- 1 | include "Prelude.e" 2 | 3 | main () -> Unit = putStrLn(bigIntToStr(fact(10000L))) 4 | 5 | fact (x:BigInt) -> BigInt = factAux(x,1L) 6 | 7 | factAux (x:BigInt, acc:BigInt) -> BigInt = 8 | if (eqBig(x,0L)) 9 | then acc 10 | else factAux(subBig(x,1L), mulBig(x,acc)) 11 | 12 | -------------------------------------------------------------------------------- /examples/hellouser.e: -------------------------------------------------------------------------------- 1 | include "Prelude.e" 2 | 3 | main () -> Unit = 4 | putStr("What is your name? "); 5 | let name:String = readStr() in 6 | putStrLn(append("Hello ",name)); 7 | putStrLn(append("Your name is ",append(intToStr(length(name)), 8 | " letters long"))) 9 | -------------------------------------------------------------------------------- /examples/hworld.e: -------------------------------------------------------------------------------- 1 | include "Prelude.e" 2 | 3 | main () -> Unit = 4 | putStr("Hello world!\n") 5 | 6 | 7 | -------------------------------------------------------------------------------- /examples/intthing.e: -------------------------------------------------------------------------------- 1 | include "Prelude.e" 2 | 3 | -- main () -> Unit = 4 | -- printInt(foo(10)) 5 | 6 | export "foo" foo (x:Int) -> Int = 7 | if x<=0 then 1 else x*foo(x-1) 8 | -------------------------------------------------------------------------------- /examples/listy.e: -------------------------------------------------------------------------------- 1 | include "Prelude.e" 2 | 3 | main () -> Unit = printList(maintake(10,4)) 4 | 5 | maintake (x:Int, y:Int) -> Data 6 | = zip ( \a : Any . \b : Any . y+a*2+b , take(x, ones()), take(x, testList())) 7 | 8 | zip (f:Any, xs:Data, ys:Data) -> Data 9 | = case xs of { 10 | Con 0 () -> Con 0 () 11 | | Con 1 (x:Data, xs0:Data) -> case ys of { 12 | Con 0 () -> Con 0 () 13 | | Con 1 (y:Data, ys0:Data) -> Con 1 (f(x,y), zip(f, xs0, ys0)) 14 | } 15 | } 16 | 17 | take (i:Int, x:Data) -> Data 18 | = if (i==0) then Con 0 () else 19 | case x of { 20 | Con 0 () -> Con 0 () 21 | | Con 1 (y:Any,ys:Data) -> Con 1 (y, take(i-1, ys)) 22 | } 23 | 24 | testList () -> Data 25 | = Con 1 (1, Con 1 (2, Con 1 (3, Con 1 (4, Con 1 (5, Con 0 ()))))) 26 | 27 | ones () -> Data 28 | = Con 1 (1, lazy(ones)) -- needs to be lazy or it runs forever! 29 | 30 | {- IO stuff -} 31 | 32 | printList (x:Data) -> Data 33 | = case x of { 34 | Con 1 (y:Int, ys:Data) -> 35 | putStr(append(intToStr(y),", ")); 36 | printList(ys) 37 | | Con 0 () -> putStrLn("nil") 38 | } 39 | 40 | -------------------------------------------------------------------------------- /examples/tailcall.e: -------------------------------------------------------------------------------- 1 | include "Prelude.e" 2 | 3 | {- Depending how much memory you have, you may need to reduce 'nine' -} 4 | 5 | main () -> Unit = 6 | printInt(natToInt(fact(nine))) 7 | 8 | natrec (x:Data, z:Any, s:Fun) -> Any = natrectail(x,s,z) 9 | 10 | natrectail (x:Data, s:Fun, acc:Data) -> Any = 11 | case x of { 12 | Con 0 () -> acc 13 | | Con 1 (k:Data) -> natrectail(k,s,s(k,acc)) 14 | } 15 | 16 | zero () -> Data = Con 0 () 17 | one () -> Data = Con 1 (zero) 18 | two () -> Data = Con 1 (one) 19 | three () -> Data = Con 1 (two) 20 | four () -> Data = Con 1 (three) 21 | five () -> Data = Con 1 (four) 22 | six () -> Data = Con 1 (five) 23 | seven () -> Data = Con 1 (six) 24 | eight () -> Data = Con 1 (seven) 25 | nine () -> Data = Con 1 (eight) 26 | ten () -> Data = Con 1 (nine) 27 | 28 | {- 29 | natToInt (x:Data) -> Int = 30 | case x of { 31 | Con 0 () -> 0 32 | | Con 1 (k:Data) -> 1+natToInt(k) 33 | } 34 | -} 35 | 36 | natToInt (x:Data) -> Int = 37 | natrec(x,0,n2isuc) 38 | 39 | n2isuc (k:Data, ih:Int) -> Int = 1+ih 40 | 41 | plus (x:Data, y:Data) -> Data = 42 | natrec(x,y,plussuc) 43 | 44 | plussuc (k:Data, ih:Data) -> Data = Con 1 (ih) 45 | 46 | mult (x:Data, y:Data) -> Data = 47 | natrec(x, Con 0 (), multsuc(y)) 48 | 49 | multsuc (y:Data, k:Data, ih:Data) -> Data = plus(y, ih) 50 | 51 | fact (x:Data) -> Data = 52 | case x of { 53 | Con 0 () -> one() 54 | | Con 1 (k:Data) -> mult(x, fact(k)) 55 | } 56 | 57 | -------------------------------------------------------------------------------- /examples/testprog.e: -------------------------------------------------------------------------------- 1 | include "Prelude.e" 2 | 3 | {- Depending how much memory you have, you may need to reduce 'nine' -} 4 | 5 | main () -> Unit = 6 | printInt(natToInt(fact(eight))) 7 | 8 | zero () -> Data = Con 0 () 9 | one () -> Data = Con 1 (zero) 10 | two () -> Data = Con 1 (one) 11 | three () -> Data = Con 1 (two) 12 | four () -> Data = Con 1 (three) 13 | five () -> Data = Con 1 (four) 14 | six () -> Data = Con 1 (five) 15 | seven () -> Data = Con 1 (six) 16 | eight () -> Data = Con 1 (seven) 17 | nine () -> Data = Con 1 (eight) 18 | ten () -> Data = Con 1 (nine) 19 | 20 | natToInt (x:Data) -> Int = 21 | case x of { 22 | Con 0 () -> 0 23 | | Con 1 (k:Data) -> 1+natToInt(k) 24 | } 25 | 26 | plus (x:Data, y:Data) -> Data = 27 | case x of { 28 | Con 0 () -> y 29 | | Con 1 (k:Data) -> Con 1 (plus(k, y)) 30 | } 31 | 32 | mult (x:Data, y:Data) -> Data = 33 | case x of { 34 | Con 0 () -> Con 0 () 35 | | Con 1 (k:Data) -> plus(y, (mult(k, y))) 36 | } 37 | 38 | fact (x:Data) -> Data = 39 | case x of { 40 | Con 0 () -> one() 41 | | Con 1 (k:Data) -> mult(x, fact(k)) 42 | } 43 | 44 | apply (f:Fun, a:Any) -> Any = 45 | f(a) 46 | 47 | -------------------------------------------------------------------------------- /examples/testprogslow.e: -------------------------------------------------------------------------------- 1 | include "Prelude.e" 2 | 3 | main () -> Unit = 4 | printInt(apply(natToInt, fact(eight()))) 5 | 6 | zero () -> Data = Con 0 () 7 | one () -> Data = Con 1 (zero()) 8 | two () -> Data = Con 1 (one()) 9 | three () -> Data = Con 1 (two()) 10 | four () -> Data = Con 1 (three()) 11 | five () -> Data = Con 1 (four()) 12 | six () -> Data = Con 1 (five()) 13 | seven () -> Data = Con 1 (six()) 14 | eight () -> Data = Con 1 (seven()) 15 | nine () -> Data = Con 1 (eight()) 16 | ten () -> Data = Con 1 (nine()) 17 | 18 | natToInt (x:Data) -> Int = 19 | case x of { 20 | Con 0 () -> 0 21 | | Con 1 (k:Data) -> 1+natToInt(k) 22 | } 23 | 24 | plus (x:Data, y:Data) -> Data = 25 | case x of { 26 | Con 0 () -> y 27 | | Con 1 (k:Data) -> Con 1 (plus(k, y)) 28 | } 29 | 30 | mult (x:Data, y:Data) -> Data = 31 | case x of { 32 | Con 0 () -> Con 0 () 33 | | Con 1 (k:Data) -> plus(y, (mult(k, y))) 34 | } 35 | 36 | fact (x:Data) -> Data = 37 | case x of { 38 | Con 0 () -> one() 39 | | Con 1 (k:Data) -> apply(mult(x), fact(k)) -- deliberate, to slow 40 | -- down and test thunks 41 | } 42 | 43 | apply (f:Fun, a:Any) -> Any = 44 | f(a) 45 | 46 | -------------------------------------------------------------------------------- /lib/Makefile: -------------------------------------------------------------------------------- 1 | INSTALLDIR = ${PREFIX}/lib/evm 2 | LIB = Prelude.e 3 | 4 | install: 5 | install ${LIB} ${INSTALLDIR} -------------------------------------------------------------------------------- /lib/Prelude.e: -------------------------------------------------------------------------------- 1 | %include "string.h" 2 | 3 | -- IO 4 | 5 | putStr (x:String) -> Unit = 6 | foreign Unit "putStr" (x:String) 7 | 8 | putStrLn (x:String) -> Unit = 9 | putStr(append(x,"\n")) 10 | 11 | readStr () -> String = 12 | foreign String "readStr" () 13 | 14 | intToStr (x:Int) -> String = 15 | foreign String "intToStr" (x:Int) 16 | 17 | strToInt (x:String) -> Int = 18 | foreign String "strToInt" (x:String) 19 | 20 | printInt (x:Int) -> Unit = 21 | let foo:Unit = foreign Unit "printInt" (x:Int) in unit 22 | 23 | -- String operations 24 | 25 | append (x:String, y:String) -> String = 26 | foreign String "append" (x:String, y:String) 27 | 28 | length (x:String) -> String = 29 | foreign Int "strlen" (x:String) 30 | 31 | index (x:String, i:Int) -> Char = 32 | foreign Int "strIndex" (x:String, i:Int) 33 | 34 | -- Big number arithmetic 35 | 36 | addBig (x:BigInt, y:BigInt) -> BigInt = 37 | foreign BigInt "addBigInt" (x:BigInt, y:BigInt) 38 | 39 | subBig (x:BigInt, y:BigInt) -> BigInt = 40 | foreign BigInt "subBigInt" (x:BigInt, y:BigInt) 41 | 42 | mulBig (x:BigInt, y:BigInt) -> BigInt = 43 | foreign BigInt "mulBigInt" (x:BigInt, y:BigInt) 44 | 45 | divBig (x:BigInt, y:BigInt) -> BigInt = 46 | foreign BigInt "divBigInt" (x:BigInt, y:BigInt) 47 | 48 | modBig (x:BigInt, y:BigInt) -> BigInt = 49 | foreign BigInt "modBigInt" (x:BigInt, y:BigInt) 50 | 51 | eqBig (x:BigInt, y:BigInt) -> Bool = 52 | foreign Int "eqBigInt" (x:BigInt, y:BigInt) 53 | 54 | ltBig (x:BigInt, y:BigInt) -> Bool = 55 | foreign Int "ltBigInt" (x:BigInt, y:BigInt) 56 | 57 | gtBig (x:BigInt, y:BigInt) -> Bool = 58 | foreign Int "gtBigInt" (x:BigInt, y:BigInt) 59 | 60 | leBig (x:BigInt, y:BigInt) -> Bool = 61 | foreign Int "leBigInt" (x:BigInt, y:BigInt) 62 | 63 | geBig (x:BigInt, y:BigInt) -> Bool = 64 | foreign Int "geBigInt" (x:BigInt, y:BigInt) 65 | 66 | printBig (x:BigInt) -> Unit = 67 | foreign Unit "printBigInt" (x:BigInt) 68 | 69 | bigIntToStr (x:BigInt) -> String = 70 | foreign String "bigIntToStr" (x:BigInt) 71 | 72 | strToBigInt (x:String) -> Int = 73 | foreign String "strToBigInt" (x:String) 74 | 75 | -------------------------------------------------------------------------------- /tests/Makefile: -------------------------------------------------------------------------------- 1 | test: 2 | perl test.pl 3 | -------------------------------------------------------------------------------- /tests/Prelude.e: -------------------------------------------------------------------------------- 1 | %include "string.h" 2 | 3 | -- IO 4 | 5 | putStr (x:String) -> Unit = 6 | foreign Unit "putStr" (x:String) 7 | 8 | putStrLn (x:String) -> Unit = 9 | putStr(append(x,"\n")) 10 | 11 | readStr () -> String = 12 | foreign String "readStr" () 13 | 14 | intToStr (x:Int) -> String = 15 | foreign String "intToStr" (x:Int) 16 | 17 | strToInt (x:String) -> Int = 18 | foreign Int "strToInt" (x:String) 19 | 20 | printInt (x:Int) -> Unit = 21 | let foo:Unit = foreign Unit "printInt" (x:Int) in unit 22 | 23 | -- String operations 24 | 25 | append (x:String, y:String) -> String = 26 | foreign String "append" (x:String, y:String) 27 | 28 | length (x:String) -> String = 29 | foreign Int "strlen" (x:String) 30 | 31 | index (x:String, i:Int) -> Char = 32 | foreign Int "strIndex" (x:String, i:Int) 33 | 34 | -- Big number arithmetic 35 | 36 | addBig (x:BigInt, y:BigInt) -> BigInt = 37 | foreign BigInt "addBig" (x:BigInt, y:BigInt) 38 | 39 | subBig (x:BigInt, y:BigInt) -> BigInt = 40 | foreign BigInt "subBig" (x:BigInt, y:BigInt) 41 | 42 | mulBig (x:BigInt, y:BigInt) -> BigInt = 43 | foreign BigInt "mulBig" (x:BigInt, y:BigInt) 44 | 45 | eqBig (x:BigInt, y:BigInt) -> Bool = 46 | foreign Int "eqBig" (x:BigInt, y:BigInt) 47 | 48 | ltBig (x:BigInt, y:BigInt) -> Bool = 49 | foreign Int "ltBig" (x:BigInt, y:BigInt) 50 | 51 | gtBig (x:BigInt, y:BigInt) -> Bool = 52 | foreign Int "gtBig" (x:BigInt, y:BigInt) 53 | 54 | leBig (x:BigInt, y:BigInt) -> Bool = 55 | foreign Int "leBig" (x:BigInt, y:BigInt) 56 | 57 | geBig (x:BigInt, y:BigInt) -> Bool = 58 | foreign Int "geBig" (x:BigInt, y:BigInt) 59 | 60 | printBig (x:BigInt) -> Unit = 61 | foreign Unit "printBig" (x:BigInt) 62 | 63 | bigIntToStr (x:BigInt) -> String = 64 | foreign String "bigToStr" (x:BigInt) 65 | 66 | strToBigInt (x:String) -> Int = 67 | foreign String "strToBig" (x:String) 68 | 69 | -------------------------------------------------------------------------------- /tests/adder.e: -------------------------------------------------------------------------------- 1 | include "Prelude.e" 2 | 3 | main () -> Unit = 4 | printInt(natToInt(adder(three, two, three, four, five))) 5 | 6 | adder (arity:Data, acc:Data) -> Any = 7 | case arity of { 8 | Con 0 () -> acc 9 | | Con 1 (k:Data) -> adderAux(k, acc) 10 | } 11 | 12 | adderAux (k:Data, acc:Data, n:Data) -> Any = 13 | adder(k,plus(acc,n)) 14 | 15 | zero () -> Data = Con 0 () 16 | one () -> Data = Con 1 (zero) 17 | two () -> Data = Con 1 (one) 18 | three () -> Data = Con 1 (two) 19 | four () -> Data = Con 1 (three) 20 | five () -> Data = Con 1 (four) 21 | six () -> Data = Con 1 (five) 22 | seven () -> Data = Con 1 (six) 23 | eight () -> Data = Con 1 (seven) 24 | nine () -> Data = Con 1 (eight) 25 | ten () -> Data = Con 1 (nine) 26 | 27 | natToInt (x:Data) -> Int = 28 | case x of { 29 | Con 0 () -> 0 30 | | Con 1 (k:Data) -> 1+natToInt(k) 31 | } 32 | 33 | plus (x:Data, y:Data) -> Data = 34 | case x of { 35 | Con 0 () -> y 36 | | Con 1 (k:Data) -> Con 1 (plus(k, y)) 37 | } 38 | 39 | -------------------------------------------------------------------------------- /tests/addermem.e: -------------------------------------------------------------------------------- 1 | include "Prelude.e" 2 | 3 | main () -> Unit = 4 | %memory(%fixed,10000,printInt(natToInt(adder(three, two, three, four, five)))) 5 | 6 | adder (arity:Data, acc:Data) -> Any = 7 | case arity of { 8 | Con 0 () -> acc 9 | | Con 1 (k:Data) -> adderAux(k, acc) 10 | } 11 | 12 | adderAux (k:Data, acc:Data, n:Data) -> Any = 13 | adder(k,plus(acc,n)) 14 | 15 | zero () -> Data = Con 0 () 16 | one () -> Data = Con 1 (zero) 17 | two () -> Data = Con 1 (one) 18 | three () -> Data = Con 1 (two) 19 | four () -> Data = Con 1 (three) 20 | five () -> Data = Con 1 (four) 21 | six () -> Data = Con 1 (five) 22 | seven () -> Data = Con 1 (six) 23 | eight () -> Data = Con 1 (seven) 24 | nine () -> Data = Con 1 (eight) 25 | ten () -> Data = Con 1 (nine) 26 | 27 | natToInt (x:Data) -> Int = 28 | case x of { 29 | Con 0 () -> 0 30 | | Con 1 (k:Data) -> 1+natToInt(k) 31 | } 32 | 33 | plus (x:Data, y:Data) -> Data = 34 | case x of { 35 | Con 0 () -> y 36 | | Con 1 (k:Data) -> Con 1 (plus(k, y)) 37 | } 38 | 39 | -------------------------------------------------------------------------------- /tests/bigint.e: -------------------------------------------------------------------------------- 1 | include "Prelude.e" 2 | 3 | main () -> Unit = printBig(fact(120L)) 4 | 5 | fact (x:BigInt) -> BigInt = 6 | if (eqBig(x,0L)) 7 | then 1L 8 | else mulBig(x,fact(subBig(x,1L))) 9 | 10 | -------------------------------------------------------------------------------- /tests/expected: -------------------------------------------------------------------------------- 1 | 2 | 14 3 | 14 4 | 6689502913449127057588118054090372586752746333138029810295671352301633557244962989366874165271984981308157637893214090552534408589408121859898481114389650005964960521256960000000000000000000000000000 5 | Hello world! 6 | 362880 7 | 7, 8, 9, 10, 11, nil 8 | 40320 9 | 40320 10 | -------------------------------------------------------------------------------- /tests/hworld.e: -------------------------------------------------------------------------------- 1 | include "Prelude.e" 2 | 3 | main () -> Unit = 4 | putStr("Hello world!\n") 5 | 6 | 7 | -------------------------------------------------------------------------------- /tests/intthing.e: -------------------------------------------------------------------------------- 1 | include "Prelude.e" 2 | 3 | main () -> Unit = 4 | printInt(foo(9)) 5 | 6 | foo (x:Int) -> Int = 7 | if x<=0 then 1 else x*foo(x-1) 8 | -------------------------------------------------------------------------------- /tests/listy.e: -------------------------------------------------------------------------------- 1 | include "Prelude.e" 2 | 3 | main () -> Unit = printList(maintake(10,4)) 4 | 5 | maintake (x:Int, y:Int) -> Data 6 | = zip ( \a : Any . \b : Any . y+a*2+b , take(x, ones()), take(x, testList())) 7 | 8 | zip (f:Any, xs:Data, ys:Data) -> Data 9 | = case xs of { 10 | Con 0 () -> Con 0 () 11 | | Con 1 (x:Data, xs0:Data) -> case ys of { 12 | Con 0 () -> Con 0 () 13 | | Con 1 (y:Data, ys0:Data) -> Con 1 (f(x,y), zip(f, xs0, ys0)) 14 | } 15 | } 16 | 17 | take (i:Int, x:Data) -> Data 18 | = if (i==0) then Con 0 () else 19 | case x of { 20 | Con 0 () -> Con 0 () 21 | | Con 1 (y:Any,ys:Data) -> Con 1 (y, take(i-1, ys)) 22 | } 23 | 24 | testList () -> Data 25 | = Con 1 (1, Con 1 (2, Con 1 (3, Con 1 (4, Con 1 (5, Con 0 ()))))) 26 | 27 | ones () -> Data 28 | = Con 1 (1, lazy(ones)) -- needs to be lazy or it runs forever! 29 | 30 | {- IO stuff -} 31 | 32 | printList (x:Data) -> Data 33 | = case x of { 34 | Con 1 (y:Int, ys:Data) -> 35 | putStr(append(intToStr(y),", ")); 36 | printList(ys) 37 | | Con 0 () -> putStrLn("nil") 38 | } 39 | 40 | -------------------------------------------------------------------------------- /tests/tailcall.e: -------------------------------------------------------------------------------- 1 | include "Prelude.e" 2 | 3 | {- Depending how much memory you have, you may need to reduce 'nine' -} 4 | 5 | main () -> Unit = 6 | printInt(natToInt(fact(eight))) 7 | 8 | natrec (x:Data, z:Any, s:Fun) -> Any = natrectail(x,s,z) 9 | 10 | natrectail (x:Data, s:Fun, acc:Data) -> Any = 11 | case x of { 12 | Con 0 () -> acc 13 | | Con 1 (k:Data) -> natrectail(k,s,s(k,acc)) 14 | } 15 | 16 | zero () -> Data = Con 0 () 17 | one () -> Data = Con 1 (zero) 18 | two () -> Data = Con 1 (one) 19 | three () -> Data = Con 1 (two) 20 | four () -> Data = Con 1 (three) 21 | five () -> Data = Con 1 (four) 22 | six () -> Data = Con 1 (five) 23 | seven () -> Data = Con 1 (six) 24 | eight () -> Data = Con 1 (seven) 25 | nine () -> Data = Con 1 (eight) 26 | ten () -> Data = Con 1 (nine) 27 | 28 | {- 29 | natToInt (x:Data) -> Int = 30 | case x of { 31 | Con 0 () -> 0 32 | | Con 1 (k:Data) -> 1+natToInt(k) 33 | } 34 | -} 35 | 36 | natToInt (x:Data) -> Int = 37 | natrec(x,0,n2isuc) 38 | 39 | n2isuc (k:Data, ih:Int) -> Int = 1+ih 40 | 41 | plus (x:Data, y:Data) -> Data = 42 | natrec(x,y,plussuc) 43 | 44 | plussuc (k:Data, ih:Data) -> Data = Con 1 (ih) 45 | 46 | mult (x:Data, y:Data) -> Data = 47 | natrec(x, Con 0 (), multsuc(y)) 48 | 49 | multsuc (y:Data, k:Data, ih:Data) -> Data = plus(y, ih) 50 | 51 | fact (x:Data) -> Data = 52 | case x of { 53 | Con 0 () -> one() 54 | | Con 1 (k:Data) -> mult(x, fact(k)) 55 | } 56 | 57 | -------------------------------------------------------------------------------- /tests/tailfact.e: -------------------------------------------------------------------------------- 1 | include "Prelude.e" 2 | 3 | {- Depending how much memory you have, you may need to reduce 'nine' -} 4 | 5 | main () -> Unit = 6 | printInt(natToInt(fact(eight))) 7 | 8 | zero () -> Data = Con 0 () 9 | one () -> Data = Con 1 (zero) 10 | two () -> Data = Con 1 (one) 11 | three () -> Data = Con 1 (two) 12 | four () -> Data = Con 1 (three) 13 | five () -> Data = Con 1 (four) 14 | six () -> Data = Con 1 (five) 15 | seven () -> Data = Con 1 (six) 16 | eight () -> Data = Con 1 (seven) 17 | nine () -> Data = Con 1 (eight) 18 | ten () -> Data = Con 1 (nine) 19 | 20 | natToInt(x:Data) -> Int = auxnatToInt(x,0) 21 | 22 | auxnatToInt (x:Data, acc:Int) -> Int = 23 | case x of { 24 | Con 0 () -> acc 25 | | Con 1 (k:Data) -> auxnatToInt(k,1+acc) 26 | } 27 | 28 | plus (x:Data, y:Data) -> Data = 29 | case x of { 30 | Con 0 () -> y 31 | | Con 1 (k:Data) -> plus(k, Con 1 (y)) 32 | } 33 | 34 | mult(x:Data,y:Data) -> Data = auxmult(x,y,Con 0 ()) 35 | 36 | auxmult (x:Data, y:Data, acc:Data) -> Data = 37 | case x of { 38 | Con 0 () -> acc 39 | | Con 1 (k:Data) -> auxmult(k, y, plus(y, acc)) 40 | } 41 | 42 | fact (x:Data) -> Data = 43 | case x of { 44 | Con 0 () -> one() 45 | | Con 1 (k:Data) -> mult(x, fact(k)) 46 | } 47 | 48 | apply (f:Fun, a:Any) -> Any = 49 | f(a) 50 | 51 | -------------------------------------------------------------------------------- /tests/test.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Pretty basic testing - build and run all the .e files in the directory 4 | # and check that they give the expected output 5 | 6 | opendir DIR, "."; 7 | @files = readdir DIR; 8 | closedir DIR; 9 | 10 | system("echo \"\" > output"); 11 | 12 | foreach $file (sort @files) { 13 | if ($file=~/([^\.]+)\.e$/ && $file ne "Prelude.e") { 14 | print "$file...\n"; 15 | system("epic $file -o $1 >> output"); 16 | system("./$1 >> output"); 17 | system("rm $1 $1.o $1.ei"); 18 | } 19 | } 20 | 21 | $output = `cat output`; 22 | $expected = `cat expected`; 23 | 24 | print $output; 25 | 26 | if ($output ne $expected) { 27 | print "ERRORS!!!!!\n"; 28 | } else { 29 | print "All OK\n"; 30 | } 31 | --------------------------------------------------------------------------------