From b1b415e1d66859bf1ea57dca796e816e78097ed0 Mon Sep 17 00:00:00 2001 From: Edwin Brady Date: Wed, 12 Jan 2011 10:33:43 +0000 Subject: [PATCH] Functions rather than constructors for building operations in Epic.Epic --- Atuin/src/MkEpic.lhs | 22 +++++++++---------- Atuin/src/Parser.y | 12 +++++------ Atuin/src/SDLprims.lhs | 32 ++++++++++++++-------------- Atuin/src/Turtle.lhs | 6 +++--- Epic/Epic.lhs | 43 ++++++++++++++++++++++++++++++------- FL/src/Lang.lhs | 20 ++++++++--------- FL/src/Main.lhs | 2 +- Papers/Epic/epic.tex | 2 +- Papers/Epic/intro.tex | 46 ++++++++++++++++++++++++++++++++++++++-- Papers/Epic/language.tex | 33 ++++++++++++++++++++++------ epic.cabal | 2 +- evm/closure.c | 16 ++++++++++++-- evm/closure.h | 14 ++++++++++++ 13 files changed, 182 insertions(+), 68 deletions(-) diff --git a/Atuin/src/MkEpic.lhs b/Atuin/src/MkEpic.lhs index f47bb9f..51519ec 100644 --- a/Atuin/src/MkEpic.lhs +++ b/Atuin/src/MkEpic.lhs @@ -77,15 +77,15 @@ in SDLprims do this for us. > instance Compile Exp where > compile state (Infix op l r) > = (mkOp op) (compile state l) (compile state r) -> where mkOp Turtle.Plus = primPlus -> mkOp Turtle.Minus = primMinus -> mkOp Turtle.Times = primTimes -> mkOp Turtle.Divide = primDivide -> mkOp Turtle.Eq = primEq -> mkOp Turtle.LT = primLT -> mkOp Turtle.LE = primLE -> mkOp Turtle.GT = primGT -> mkOp Turtle.GE = primGE +> where mkOp Plus = primPlus +> mkOp Minus = primMinus +> mkOp Times = primTimes +> mkOp Divide = primDivide +> mkOp Eq = primEq +> mkOp Lt = primLT +> mkOp Le = primLE +> mkOp Gt = primGT +> mkOp Ge = primGE > compile state (Var i) = ref (epicId i) > compile state (Const i) = compile state i @@ -118,8 +118,8 @@ them to the current state and the given argument. > instance Compile Command where > compile state (Fd i) = fn "forward" @@ state @@ compile state i -> compile state (Rt i) = fn "right" @@ state @@ compile state i -> compile state (Lt i) = fn "left" @@ state @@ compile state i +> compile state (RightT i) = fn "right" @@ state @@ compile state i +> compile state (LeftT i) = fn "left" @@ state @@ compile state i > compile state (Colour c) = fn "colour" @@ state @@ compile state c > compile state PenUp = fn "pen" @@ state @@ bool False > compile state PenDown = fn "pen" @@ state @@ bool True diff --git a/Atuin/src/Parser.y b/Atuin/src/Parser.y index ab016e8..1fcf4c3 100644 --- a/Atuin/src/Parser.y +++ b/Atuin/src/Parser.y @@ -92,8 +92,8 @@ Turtle : name '(' ExprList ')' { Call $1 $3 } | eval Expr { Eval $2 } | repeat Expr Block { Repeat $2 $3 } | forward Expr { Turtle (Fd $2) } - | right Expr { Turtle (Rt $2) } - | left Expr { Turtle (Lt $2) } + | right Expr { Turtle (RightT $2) } + | left Expr { Turtle (LeftT $2) } | colour Expr { Turtle (Colour $2) } | penup { Turtle PenUp } | pendown { Turtle PenDown } @@ -115,10 +115,10 @@ Expr : name { Var $1 } | Expr '*' Expr { Infix Times $1 $3 } | Expr '/' Expr { Infix Divide $1 $3 } | Expr eq Expr { Infix Eq $1 $3 } - | Expr '<' Expr { Infix Turtle.LT $1 $3 } - | Expr '>' Expr { Infix Turtle.GT $1 $3 } - | Expr le Expr { Infix LE $1 $3 } - | Expr ge Expr { Infix GE $1 $3 } + | Expr '<' Expr { Infix Lt $1 $3 } + | Expr '>' Expr { Infix Gt $1 $3 } + | Expr le Expr { Infix Le $1 $3 } + | Expr ge Expr { Infix Ge $1 $3 } | '(' Expr ')' { $2 } | '{' TurtleProg '}' { Block $2 } diff --git a/Atuin/src/SDLprims.lhs b/Atuin/src/SDLprims.lhs index 259c9b5..b9686e4 100644 --- a/Atuin/src/SDLprims.lhs +++ b/Atuin/src/SDLprims.lhs @@ -72,18 +72,18 @@ we stop any other instances for (a -> e) being allowed somehow? Arithmetic operations -> primPlus x y = mkint $ op_ Plus (getInt x) (getInt y) -> primMinus x y = mkint $ op_ Minus (getInt x) (getInt y) -> primTimes x y = mkint $ op_ Times (getInt x) (getInt y) -> primDivide x y = mkint $ op_ Divide (getInt x) (getInt y) +> primPlus x y = mkint $ op_ plus_ (getInt x) (getInt y) +> primMinus x y = mkint $ op_ minus_ (getInt x) (getInt y) +> primTimes x y = mkint $ op_ times_ (getInt x) (getInt y) +> primDivide x y = mkint $ op_ divide_ (getInt x) (getInt y) Comparisons -> primEq x y = mkbool $ op_ OpEQ (getInt x) (getInt y) -> primLT x y = mkbool $ op_ OpLT (getInt x) (getInt y) -> primLE x y = mkbool $ op_ OpLE (getInt x) (getInt y) -> primGT x y = mkbool $ op_ OpGT (getInt x) (getInt y) -> primGE x y = mkbool $ op_ OpGE (getInt x) (getInt y) +> primEq x y = mkbool $ op_ eq_ (getInt x) (getInt y) +> primLT x y = mkbool $ op_ lt_ (getInt x) (getInt y) +> primLE x y = mkbool $ op_ lte_ (getInt x) (getInt y) +> primGT x y = mkbool $ op_ gt_ (getInt x) (getInt y) +> primGE x y = mkbool $ op_ gte_ (getInt x) (getInt y) Graphics primitive, just extracts the tuple of RGBA values for the colour and calls the SDL_gfx primitive. @@ -105,7 +105,7 @@ Here's some primitives to do the necessary conversions. > intToFloat x = foreign_ tyFloat "intToFloat" [(x, tyInt)] > floatToInt x = foreign_ tyInt "floatToInt" [(x, tyFloat)] -> rad x = op_ FTimes (intToFloat x) (float (pi/180)) +> rad x = op_ timesF_ (intToFloat x) (float (pi/180)) > esin x = foreign_ tyFloat "sin" [(rad x, tyFloat)] > ecos x = foreign_ tyFloat "cos" [(rad x, tyFloat)] @@ -122,10 +122,10 @@ Return the new state. > forward st dist = case_ st > [tuple (\ (surf :: Expr) (x :: Expr) (y :: Expr) > (dir :: Expr) (col :: Expr) (pen :: Expr) -> -> let_ (op_ Plus x (floatToInt (op_ FTimes (intToFloat (getInt dist)) +> let_ (op_ plus_ x (floatToInt (op_ timesF_ (intToFloat (getInt dist)) > (esin dir)))) -> (\x' -> let_ (op_ Plus y (floatToInt -> (op_ FTimes (intToFloat (getInt dist)) +> (\x' -> let_ (op_ plus_ y (floatToInt +> (op_ timesF_ (intToFloat (getInt dist)) > (ecos dir)))) > (\y' -> if_ pen (fn "drawLine" @@ surf @@ x @@ y > @@ x' @@ y' @@ col) @@ -139,7 +139,7 @@ Return the new state. > right st ang = case_ st > [tuple (\ (surf :: Expr) (x :: Expr) (y :: Expr) > (dir :: Expr) (col :: Expr) (pen :: Expr) -> -> (tuple_ @@ surf @@ x @@ y @@ op_ Minus dir (getInt ang) @@ col @@ pen))] +> (tuple_ @@ surf @@ x @@ y @@ op_ minus_ dir (getInt ang) @@ col @@ pen))] To turn left, create a new state with the turtle turned left. Return the new state. @@ -148,7 +148,7 @@ Return the new state. > left st ang = case_ st > [tuple (\ (surf :: Expr) (x :: Expr) (y :: Expr) > (dir :: Expr) (col :: Expr) (pen :: Expr) -> -> (tuple_ @@ surf @@ x @@ y @@ op_ Plus dir (getInt ang) @@ col @@ pen))] +> (tuple_ @@ surf @@ x @@ y @@ op_ plus_ dir (getInt ang) @@ col @@ pen))] > colour :: Expr -> Expr -> Term > colour st col' = case_ st @@ -169,7 +169,7 @@ Repeat n times > [constcase 0 st, > defaultcase (let_ (e @@ st) > (\st' -> fn "repeat" @@ st' -> @@ mkint (op_ Minus (getInt n) (int 1)) +> @@ mkint (op_ minus_ (getInt n) (int 1)) > @@ e))] Turtle state consists of an SDL surface, diff --git a/Atuin/src/Turtle.lhs b/Atuin/src/Turtle.lhs index ed7e558..6452529 100644 --- a/Atuin/src/Turtle.lhs +++ b/Atuin/src/Turtle.lhs @@ -35,13 +35,13 @@ > type Function = ([Id], Turtle) > data Op = Plus | Minus | Times | Divide -- int ops -> | Eq | LT | LE | GT | GE -- bool ops +> | Eq | Lt | Le | Gt | Ge -- bool ops > | Car | Cdr | Append | Index -- TODO: string/char ops > deriving Show > data Command = Fd Exp -> | Rt Exp -> | Lt Exp +> | RightT Exp +> | LeftT Exp > | Colour Exp > | PenUp > | PenDown diff --git a/Epic/Epic.lhs b/Epic/Epic.lhs index b7a29f2..15a8e73 100644 --- a/Epic/Epic.lhs +++ b/Epic/Epic.lhs @@ -16,14 +16,19 @@ > Expr, Term, Name, name, > (@@), case_, con_, tuple_, con, tuple, > constcase, defaultcase, -> if_, while_, whileAcc_, error_, op_, +> if_, while_, whileAcc_, error_, > lazy_, effect_, > foreign_, foreignL_, foreignConst_, foreignConstL_, -> let_, letN_, update_, Op(..), +> let_, letN_, update_, op_, > str, int, float, char, bool, unit_, (!.), fn, ref, (+>), > -- * Types > Type, tyInt, tyChar, tyBool, tyFloat, tyString, -> tyPtr, tyUnit, tyAny, tyC, +> tyPtr, tyUnit, tyAny, tyC, +> -- * Operators +> plus_, minus_, times_, divide_, +> plusF_, minusF_, timesF_, divideF_, +> eq_, lt_, lte_, gt_, gte_, +> eqF_, ltF_, lteF_, gtF_, gteF_, shiftl_, shiftr_, > -- * Declarations and programs > EpicDecl(..), Program, > -- * Compiling and execution @@ -101,11 +106,33 @@ Allow Haskell functions to be used to build expressions. Binary operators -> eq = Op OpEQ -> lt = Op OpLT -> lte = Op OpLE -> gt = Op OpGT -> gte = Op OpGE +> plus_, minus_, times_, divide_, plusF_, minusF_, timesF_, divideF_ :: Op +> lt_, lte_, gt_, gte_, ltF_, lteF_, gtF_, gteF_, shiftl_, shiftr_ :: Op + +> plus_ = Plus +> minus_ = Minus +> times_ = Times +> divide_ = Divide + +> plusF_ = FPlus +> minusF_ = FMinus +> timesF_ = FTimes +> divideF_ = FDivide + +> eq_ = OpEQ +> lt_ = OpLT +> lte_ = OpLE +> gt_ = OpGT +> gte_ = OpGE + +> eqF_ = OpFEQ +> ltF_ = OpFLT +> lteF_ = OpFLE +> gtF_ = OpFGT +> gteF_ = OpFGE + +> shiftl_ = ShL +> shiftr_ = ShR > mkFunc :: EpicFn e => e -> Func > mkFunc e = evalState (func e) 0 diff --git a/FL/src/Lang.lhs b/FL/src/Lang.lhs index 38e9629..426c818 100644 --- a/FL/src/Lang.lhs +++ b/FL/src/Lang.lhs @@ -14,8 +14,8 @@ > data Const = CInt Int > | CStr String -> data Infix = IPlus | IMinus | ITimes | IDivide | IAppend -> | IEQ | ILT | IGT +> data Infix = Plus | Minus | Times | Divide | Append +> | Equal | Lt | Gt > data Def = LangDef Lang > | PrimDef EpicDecl @@ -29,15 +29,15 @@ > build (App f a) = build f @@ build a > build (Const (CInt x)) = int x > build (Const (CStr x)) = str x -> build (Op IAppend l r) = fn "append" @@ build l @@ build r +> build (Op Append l r) = fn "append" @@ build l @@ build r > build (Op op l r) = op_ (buildOp op) (build l) (build r) -> where buildOp IPlus = Plus -> buildOp IMinus = Minus -> buildOp ITimes = Times -> buildOp IDivide = Divide -> buildOp IEQ = OpEQ -> buildOp ILT = OpLT -> buildOp IGT = OpGT +> where buildOp Plus = plus_ +> buildOp Minus = minus_ +> buildOp Times = times_ +> buildOp Divide = divide_ +> buildOp Equal = eq_ +> buildOp Lt = lt_ +> buildOp Gt = gt_ > mkEpic :: Def -> EpicDecl > mkEpic (PrimDef p) = p diff --git a/FL/src/Main.lhs b/FL/src/Main.lhs index 2b1f0cc..13a9543 100644 --- a/FL/src/Main.lhs +++ b/FL/src/Main.lhs @@ -6,7 +6,7 @@ > import Epic.Epic > add :: Lang -> add = Lam (\x -> Lam (\y -> Op IPlus x y)) +> add = Lam (\x -> Lam (\y -> Op Plus x y)) > main_ = App (Ref (name "putStrLn")) > (App (Ref (name "intToString")) diff --git a/Papers/Epic/epic.tex b/Papers/Epic/epic.tex index 87ebf62..32c653d 100644 --- a/Papers/Epic/epic.tex +++ b/Papers/Epic/epic.tex @@ -50,7 +50,7 @@ \begin{document} -\title{Epic --- a Generic Back End for Functional Programming Languages} +\title{Epic --- a Generic Intermediate Functional Programming Language} %\author{Edwin Brady} \authorinfo{Edwin C. Brady} diff --git a/Papers/Epic/intro.tex b/Papers/Epic/intro.tex index 441eba2..96ac4ed 100644 --- a/Papers/Epic/intro.tex +++ b/Papers/Epic/intro.tex @@ -1,19 +1,25 @@ \section{Introduction} +[Just some notes for now...] + Lots of backends for functional languages, e.g. STG~\cite{evalpush,stg,llvm-haskell}, ABC~\cite{abc-machine}. But they aren't simple enough that they are easy to bolt on to a new language. Either too low level, or an interface isn't exposed, or where an interface is exposed, there are constraints on the type system. So things like Agda~\cite{norell-thesis} have resorted to -generating Haskell with unsafeCoerce. This works but we can't expect +generating Haskell with unsafeCoerce, Cayenne~\cite{cayenne-icfp} used LML +with the type checker switched off. This works but we can't expect GHC optimisations without working very hard, are limited to GHC's choice of evaluation order, and could throw away useful information gained from the type system. -Epic originally written for Epigram~\cite{levitation} (the name is +Epic originally written for Epigram~\cite{levitation} (the +name\footnote{Coined by James McKinna} is short for ``\textbf{Epi}gram \textbf{C}ompiler''). Now used by Idris~\cite{idris-plpv}, also as an experimental back end for Agda. +It is specifically designed for reuse by other languages (in constrast +to, say, Haskell Core). \subsection{Features and non-features} @@ -43,3 +49,39 @@ \subsection{Features and non-features} Also lacking, but entirely possible to add later (with some care) are unboxed types. + +\subsection{Why an Intermediate Language} + +Why not generate Haskell, OCaml, Scheme, \ldots? In general they are +too high level and impose design choices and prevent certain +implementation choices. An intermediate level language such as Epic +allows the following: + +\begin{description} +\item[Control of generated code] +A higher level target language imposes implementation choices such as +evaluation strategy and purity. Also makes it harder to use lower +level features where it might be appropriate (e.g. while loops, mutation). + +\item[Control of language design] +Choice of a high level target language (especially a typed one) might +influence our type system design, restrict our choices for ease of +code generation. + +\item[Efficiency] +We might expect using a mature target language to give us +optimisations for free. This might be true in many cases, but only if +our source language is similar enough. e.g. in Epigram the type system +tells us more about the code than we can pass on to a Haskell back +end. + +\end{description} + +Epic aims to provide the necessary features for implementing the +back-end of a functional language --- thunks, closures, algebraic data +types, scope management, lambda lifting --- without imposing +\remph{any} design choices on the high level language designer, with +the obvious exception that a functional style is encouraged! +A further advantage of Epic is that the library provides +\remph{compiler combinators}, which guarantee that any +output code will be syntactically correct and well-scoped. diff --git a/Papers/Epic/language.tex b/Papers/Epic/language.tex index 3aad644..3a60a5d 100644 --- a/Papers/Epic/language.tex +++ b/Papers/Epic/language.tex @@ -1,19 +1,28 @@ \section{The Epic Language} -\subsection{Definitions} +Epic is an untyped $\lambda$-calculus with algebraic data types. +There are additional control structures for specifying evaluation +order, primitive loop constructs, and calling foreign +functions. Foreign function calls are annotated with types, to assist +with marshaling data between Epic and C, but otherwise there are no +type annotations and there is no type checking --- as Epic is intended +as an intermediate language, it is assumed that the high level +language has already performed any necessary type checking. The +abstract syntax of the core language is given in Figure \ref{epicsyn}. \newcommand{\Con}[2]{\DC{Con}\:#1(#2)} \FFIG{ \AR{ \begin{array}{rcll}\\ -\VV{def} & ::= & \vx\vec{(\vx\Hab\vT)} \rightarrow \vT = \vt & +\vp & ::= & \vec{\VV{def}} & \mbox{(Epic program)} \\ +\VV{def} & ::= & \vx(\tx) = \vt & \mbox{(Top level definition)} \\ \\ \vt & ::= & \vx & \mbox{(Variable)} \\ & \mid & \vt(\ttt) & \mbox{(Function application)} \\ -& \mid & \lam{\vx}{\vT}\SC\vt & \mbox{(Lambda binding)} \\ -& \mid & \RW{let}\:\vx\Hab\vT\:=\:\vt\:\RW{in}\:\vt & \mbox{(Let +& \mid & \lambda\:\vx\SC\vt & \mbox{(Lambda binding)} \\ +& \mid & \RW{let}\:\vx\:=\:\vt\:\RW{in}\:\vt & \mbox{(Let binding)} \\ & \mid & \Con{\vi}{\ttt} & \mbox{(Constructor application)} \\ & \mid & \vt ! \vi & \mbox{(Argument projection)} \\ @@ -23,6 +32,7 @@ \subsection{Definitions} & \mid & \RW{lazy}(\vt) & \mbox{(Lazy evaluation)} \\ & \mid & \RW{effect}(\vt) & \mbox{(Evaluate an effectful term)} \\ & \mid & \RW{while}(\vt,\vt) & \mbox{(While loops)} \\ +& \mid & \vx := \:\vt\:\RW{in}\:\vt & \mbox{(Variable update)} \\ & \mid & \RW{foreign}\:\vT\:\VV{str}\:\vec{(\vt\Hab\vT)} & \mbox{(Foreign call)} \\ & \mid & \vi \mid \vf \mid \vc \mid \vb \mid \VV{str} & \mbox{(Constants)} \\ \\ @@ -63,8 +73,9 @@ \subsection{Definitions} {Epic syntax} {epicsyn} -BNF in Figure \ref{epicsyn}. Expressions. \texttt{let}, \texttt{case}, -\texttt{lazy}, \texttt{while} +\subsection{Definitions} + +Expressions. \texttt{let}, \texttt{case}, \texttt{lazy} \subsection{Types} @@ -73,6 +84,12 @@ \subsection{Types} Run-time representation (31 bit ints). +\subsection{Imperative Features} + +Motivation: no need to limit ourselves to functional languages, and in +some situations may help a high level language implement some optimisations. +\texttt{while}, variable update. + \subsection{Foreign Functions} Calling, exporting. @@ -82,7 +99,9 @@ \subsection{Implementation} How it's implemented is not really important --- a compiler can target Epic without knowing. There is currently one back end, but more are planned. Compiled via C. Garbage collection with -Boehm~\cite{boehm-gc}, \texttt{\%memory}. +Boehm~\cite{boehm-gc}, \texttt{\%memory}. (Note that a non-moving +collector makes things easier for foreign functions, but may not be +the best choice in the long run). Later plans: compile via LLVM, allow plug in garbage collectors (important for embedded systems, device drivers, operating system diff --git a/epic.cabal b/epic.cabal index f2fe6b3..e67d9bf 100644 --- a/epic.cabal +++ b/epic.cabal @@ -1,5 +1,5 @@ Name: epic -Version: 0.1.8 +Version: 0.1.9 Author: Edwin Brady License: BSD3 License-file: LICENSE diff --git a/evm/closure.c b/evm/closure.c index da84b5b..cf53064 100644 --- a/evm/closure.c +++ b/evm/closure.c @@ -964,6 +964,14 @@ void* MKFREE(int x) return c; } +void slide(VMState* vm, int lose, int keep) { + int i; + for(i = 1; i <= keep; i++) { + vm->stack_top[-(lose+i)] = *(vm->stack_top-i); + } + vm->stack_top-=lose; +} + VAL evm_getArg(int i) { if (i>=0 && istack = malloc(sizeof(VAL)*STACK_INIT); + vm->stack_top = vm->stack+STACK_INIT; + vm->stack_top = vm->stack; + +/* vm->roots = malloc(sizeof(VAL)*1024); vm->start_roots = vm->roots; @@ -1015,7 +1027,7 @@ VMState* init_evm(int argc, char* argv[]) vm->next_nursery = 0; vm->next = 0; */ - return NULL; + return vm; } void epic_main(int argc, char* argv[]) diff --git a/evm/closure.h b/evm/closure.h index b3b5f5f..a64c352 100644 --- a/evm/closure.h +++ b/evm/closure.h @@ -145,11 +145,25 @@ typedef struct { VAL* to_space; VAL* nursery; + VAL* stack; + VAL* stack_top; + VAL* stack_limit; + int heap_size; int next; int next_nursery; } VMState; +#define STACK_INIT 8192 + +#define STACK(x) (*(vm->stack_top-x)) +#define PUSH(x) vm->stack_top=x; vm->stack_top++; +#define DROP(x) vm->stack_top-=x; +#define SLIDE1(x) vm->stack_top[-(x+1)]=*(vm->stack_top-1); vm->stack_top-=x; +#define SLIDE(x,keep) slide(vm,x,keep); + +void slide(VMState* vm, int lose, int keep); + extern void* e_malloc(VMState* vm, size_t size); extern void* e_realloc(VMState* vm, void* ptr, size_t size);