epic 0.1.7 → 0.1.8
raw patch · 14 files changed
+604/−95 lines, 14 files
Files
- Epic/Compiler.lhs +45/−42
- Epic/Epic.lhs +446/−0
- Epic/Language.lhs +23/−1
- Epic/Lexer.lhs +4/−0
- Epic/Parser.y +4/−1
- Epic/Scopecheck.lhs +17/−4
- epic.cabal +4/−4
- evm/closure.c +40/−0
- evm/closure.h +3/−0
- evm/libevm.a binary
- evm/mainprog.c +1/−35
- evm/stdfuns.c +10/−0
- evm/stdfuns.h +3/−0
- main/Main.lhs +4/−8
Epic/Compiler.lhs view
@@ -11,7 +11,8 @@ > module Epic.Compiler(CompileOptions(..), > compile, -> compileOpts, +> compileOpts,+> compileDecls, > link) where Brings everything together; parsing, checking, code generation@@ -68,36 +69,44 @@ > case s of > Failure err _ _ -> fail err > Success ds -> do-> (tmpn,tmph) <- tempfile-> let hdr = outputHeader opts-> scchecked <- checkAll opts ds-> let simplified = simplifyAll scchecked-> checked <- compileDecls simplified tmph hdr-> fp <- getDataFileName "evm/closure.h"-> let libdir = trimLast fp-> let dbg = if (elem Debug opts) then "-g" else "-O3"-> let cmd = "gcc -DUSE_BOEHM -c " ++ dbg ++ " -foptimize-sibling-calls -x c " ++ tmpn ++ " -I" ++ libdir ++ " -o " ++ outf ++ " " ++ addGCC opts ++ doTrace opts-> -- putStrLn $ cmd-> -- putStrLn $ fp-> exit <- system cmd-> if (elem KeepC opts)-> then do system $ "cp " ++ tmpn ++ " " ++ -> (getRoot fn) ++ ".c"-> return ()-> else return ()-> -- removeFile tmpn-> if (exit /= ExitSuccess) -> then fail $ "gcc failed"-> else return ()-> case iface of-> Nothing -> return ()-> (Just fn) -> do writeFile fn (writeIFace checked)+> compileDecls outf iface ds opts +> compileDecls :: FilePath -- ^ Output file name+> -> Maybe FilePath -- ^ Interface (.ei) file name, if desired+> -> [Decl] -- ^ Declarations+> -> [CompileOptions]+> -> IO ()+> compileDecls outf iface ds opts+> = do (tmpn,tmph) <- tempfile+> let hdr = outputHeader opts+> scchecked <- checkAll opts ds+> let simplified = simplifyAll scchecked+> checked <- docompileDecls simplified tmph hdr+> fp <- getDataFileName "evm/closure.h"+> let libdir = trimLast fp+> let dbg = if (elem Debug opts) then "-g" else "-O3"+> let cmd = "gcc -DUSE_BOEHM -c " ++ dbg ++ " -foptimize-sibling-calls -x c " ++ tmpn ++ " -I" ++ libdir ++ " -o " ++ outf ++ " " ++ addGCC opts ++ doTrace opts+> -- putStrLn $ cmd+> -- putStrLn $ fp+> exit <- system cmd+> if (elem KeepC opts)+> then do system $ "cp " ++ tmpn ++ " " ++ +> (getRoot outf) ++ ".c"+> return ()+> else return ()+> -- removeFile tmpn+> if (exit /= ExitSuccess) +> then fail $ "gcc failed"+> else return ()+> case iface of+> Nothing -> return ()+> (Just fn) -> do writeFile fn (writeIFace checked)+ > getRoot fn = case span (/='.') fn of > (stem,_) -> stem -> compileDecls (ctxt, decls) outh hdr+> docompileDecls (ctxt, decls) outh hdr > = do hPutStr outh $ codegenC ctxt decls > case hdr of > Just fpath ->@@ -108,22 +117,27 @@ > hClose outh > return decls +> getExtra :: [CompileOptions] -> IO [String]+> getExtra ((MainInc x):xs) = do fns <- getExtra xs+> return (x:fns)+> getExtra (_:xs) = getExtra xs+> getExtra [] = return []+ > -- |Link a collection of .o files into an executable > link :: [FilePath] -- ^ Object files-> -> [FilePath] -- ^ Extra include files for main program > -> FilePath -- ^ Executable filename-> -> Bool -- ^ Generate a 'main' (False if externally defined) > -> [CompileOptions] -- Keep the C file > -> IO ()-> link infs extraIncs outf genmain opts = do-> mainprog <- if genmain then mkMain extraIncs else return ""+> link infs outf opts = do+> extraIncs <- getExtra opts+> mainprog <- if (not (elem ExternalMain opts)) then mkMain extraIncs else return "" > fp <- getDataFileName "evm/closure.h" > let libdir = trimLast fp > let dbg = if (elem Debug opts) then "-g" else "-O3" > let cmd = "gcc -DUSE_BOEHM -x c " ++ dbg ++ " -foptimize-sibling-calls " ++ mainprog ++ " -x none -L" ++ > libdir++" -I"++libdir ++ " " ++ > (concat (map (++" ") infs)) ++ -> " -levm -lgc -lpthread -lgmp -o "++outf+> " -levm -lgc -lpthread -lgmp -o "++outf ++ " " ++ addGCC opts > -- putStrLn $ cmd > exit <- system cmd > if (exit /= ExitSuccess)@@ -148,14 +162,3 @@ libdir :: FilePath libdir = libprefix ++ "/lib/evm" -> tempfile :: IO (FilePath, Handle)-> tempfile = do env <- environment "TMPDIR"-> let dir = case env of-> Nothing -> "/tmp"-> (Just d) -> d-> openTempFile dir "esc"--> environment :: String -> IO (Maybe String)-> environment x = catch (do e <- getEnv x-> return (Just e))-> (\_ -> return Nothing)
+ Epic/Epic.lhs view
@@ -0,0 +1,446 @@+> {-# OPTIONS_GHC -fglasgow-exts #-}++> -- |+> -- Module : Epic.Epic+> -- Copyright : Edwin Brady+> -- Licence : BSD-style (see LICENSE in the distribution)+> --+> -- Maintainer : eb@cs.st-andrews.ac.uk+> -- Stability : experimental+> -- Portability : non-portable+> --+> -- Combinators for builing Epic programs++> module Epic.Epic(-- * Expressions+> EpicExpr, term, EpicFn, Alternative,+> Expr, Term, Name, name,+> (@@), case_, con_, tuple_, con, tuple,+> constcase, defaultcase,+> if_, while_, whileAcc_, error_, op_,+> lazy_, effect_,+> foreign_, foreignL_, foreignConst_, foreignConstL_,+> let_, letN_, Op(..),+> str, int, float, char, bool, unit_, (!.), fn, ref, (+>),+> -- * Types+> Type, tyInt, tyChar, tyBool, tyFloat, tyString,+> tyPtr, tyUnit, tyAny, tyC, +> -- * Declarations and programs+> EpicDecl(..), Program, +> -- * Compiling and execution+> Epic.Epic.compile, compileObj, Epic.Epic.link, +> Epic.Epic.compileWith, compileObjWith, Epic.Epic.linkWith, +> run,+> CompileOptions(..),+> -- * Some basic definitions+> basic_defs) where++Combinators for constructing an expression++> import Control.Monad.State+> import System+> import System.IO++> import Epic.Language+> import Epic.Compiler++Allow Haskell functions to be used to build expressions.++> -- | A sub-term, with a name supply+> type Term = State Int Expr++> -- | Build expressions, with a name supply+> class EpicExpr e where+> term :: e -> State Int Expr++> instance EpicExpr Expr where+> term e = return e++> instance EpicExpr Term where+> term e = e++> instance (EpicExpr e) => EpicExpr (Expr -> e) where+> term f = do var <- get+> put (var+1)+> let arg = MN "evar" var+> e' <- term (f (R arg))+> return (Lam arg TyAny e')++> instance EpicExpr ([Name], Expr) where+> term (ns, e) = lam ns e where+> lam [] e = return e+> lam (n:ns) e = do e' <- lam ns e+> return (Lam n TyAny e')++> -- | Build a function definition, with a name supply+> class EpicFn e where+> func :: e -> State Int Func++> instance EpicFn Expr where+> func e = return (delam e [])+> where delam (Lam n ty e) acc = delam e ((n,ty):acc)+> delam e acc = Bind (reverse acc) 0 e []++> instance EpicFn Term where+> func e = do e' <- e+> func e'++> instance (EpicFn e) => EpicFn (Expr -> e) where+> func f = do var <- get+> put (var+1)+> let arg = MN "evar" var+> (Bind vars l e' flags) <- func (f (R arg))+> return (Bind ((arg, TyAny):vars) l e' flags)++ instance EpicFn ([Name], Expr) where+ func (ns, e) = return (Bind (map (\x -> (x, TyAny)) ns) 0 e [])++> instance (EpicFn e) => EpicFn ([Name], e) where+> func (ns, e) +> = do (Bind vars l e' flags) <- func e+> return (Bind (map (\x -> (x, TyAny)) ns ++ vars) 0 e' [])++Binary operators++> eq = Op OpEQ+> lt = Op OpLT+> lte = Op OpLE+> gt = Op OpGT+> gte = Op OpGE++> mkFunc :: EpicFn e => e -> Func+> mkFunc e = evalState (func e) 0++Build case expressions. Allow functions to be used to bind names in+case alternatives++> infixl 5 <|>++> class Cases c where+> (<|>) :: Cases d => c -> d -> [CaseAlt]+> alt :: c -> [CaseAlt]++> (<|>) c1 c2 = alt c1 ++ alt c2++> instance Cases CaseAlt where+> alt c = [c]++> instance (Cases c) => Cases [c] where+> alt cs = concatMap alt cs++> -- | Build a case alternative, with a name supply+> class Alternative e where+> mkAlt :: Tag -> e -> State Int CaseAlt++> instance Alternative Expr where+> mkAlt t e = return (Alt t [] e)++> instance Alternative Term where+> mkAlt t e = do e' <- e+> return (Alt t [] e')++> instance (Alternative e) => Alternative (Expr -> e) where+> mkAlt t f = do var <- get+> put (var+1)+> let arg = MN "alt" var+> (Alt t vars e') <- mkAlt t (f (R arg))+> return $ Alt t ((arg, TyAny):vars) e'++> instance Alternative ([Name], Expr) where+> mkAlt t (vars, e) = return $ Alt t (map (\x -> (x, TyAny)) vars) e++> -- | Case alternative for constructor with the given tag+> con :: Alternative e => Int -- ^ the tag+> -> e -- ^ RHS of alternative+> -> State Int CaseAlt+> con t e = mkAlt t e++> -- | Case alternative for a tuple with the given tag+> tuple :: Alternative e => e -- ^ RHS of alternative+> -> State Int CaseAlt+> tuple e = mkAlt 0 e++> -- | Case alternative for a constant+> constcase :: EpicExpr a => Int -- ^ the constant+> -> a -> State Int CaseAlt+> constcase t a = do a' <- term a+> return (ConstAlt t a')++> -- | Default case if no other branches apply+> defaultcase :: EpicExpr a => a -> State Int CaseAlt+> defaultcase a = do a' <- term a+> return (DefaultCase a')+++Remaining expression constructs++> exp1 :: (EpicExpr a) =>+> (Expr -> Expr) -> a -> Term+> exp1 f a = do a' <- term a+> return (f a')++> exp2 :: (EpicExpr a, EpicExpr b) =>+> (Expr -> Expr -> Expr) -> a -> b -> Term+> exp2 f a b = do a' <- term a; b'<- term b+> return (f a' b')++> exp3 :: (EpicExpr a, EpicExpr b, EpicExpr c) =>+> (Expr -> Expr -> Expr -> Expr) -> a -> b -> c -> Term+> exp3 f a b c = do a' <- term a; b'<- term b; c' <- term c+> return (f a' b' c')++> if_ :: (EpicExpr a, EpicExpr t, EpicExpr e) =>+> a -> t -> e -> Term+> if_ = exp3 If++> -- | While loops (primitive, for efficiency).+> while_ :: (EpicExpr t, EpicExpr b) =>+> t -- ^ Boolean test (most likely effectful)+> -> b -- ^ Body+> -> Term+> while_ = exp2 While++> -- | While loop, with an accumulator+> whileAcc_ :: (EpicExpr t, EpicExpr a, EpicExpr b) =>+> t -- ^ Boolean test (most likely effectful)+> -> a -- ^ Accumulator (of type a)+> -> b -- ^ Body (of type a -> a)+> -> Term+> whileAcc_ = exp3 WhileAcc++> error_ :: String -> Term+> error_ str = return (Error str)++> op_ :: (EpicExpr a, EpicExpr b) => Op -> a -> b -> Term+> op_ op = exp2 (Op op)++> -- | Evaluate an expression lazily+> lazy_ :: (EpicExpr a) => a -> Term+> lazy_ = exp1 Lazy++> -- | Evaluate an expression but don't update the closure with the result.+> -- | Use this if the expression has a side effect.+> effect_ :: (EpicExpr a) => a -> Term+> effect_ = exp1 Effect++> termF (x,y) = do x' <-term x+> return (x', y)++> foreign_, foreignL_ :: EpicExpr e => Type -> String -> [(e, Type)] -> Term+> foreign_ t str args = do args' <- mapM termF args+> term $ ForeignCall t str args'+> foreignL_ t str args = do args' <- mapM termF args+> term $ LazyForeignCall t str args'++> foreignConst_, foreignConstL_ :: Type -> String -> Term+> foreignConst_ t str = term $ ForeignCall t str []+> foreignConstL_ t str = term $ LazyForeignCall t str []++ mkCon :: Int -> [Term] -> Term+ mkCon tag args = do args' <- mapM expr args+ return (Con tag args')++> -- | Build a constructor with the given tag+> con_ :: Int -- ^ Tag+> -> Term+> con_ t = return (Con t [])++> -- | Build a tuple+> tuple_ :: Term+> tuple_ = con_ 0++> -- | Build a case expression with a list of alternatives+> case_ :: (EpicExpr e) => e -> [State Int CaseAlt] -> Term+> case_ e alts = do e' <- term e+> alts' <- mapM id alts+> return (Case e' alts')++> -- | Let bindings with an explicit name+> letN_ :: (EpicExpr val, EpicExpr scope) =>+> Name -> val -> scope -> Term+> letN_ n val sc = do val' <- term val+> sc' <- term sc+> return $ Let n TyAny val' sc'++> -- | Let bindings with higher order syntax+> let_ :: (EpicExpr e) =>+> e -> (Expr -> Term) -> Term+> let_ e f = do e' <- term e+> f' <- f (R (MN "DUMMY" 0))+> let var = MN "loc" (topVar f')+> fv <- f (R var)+> return $ Let var TyAny e' fv++> maxs = foldr max 0++> topVar (Let (MN "loc" x) _ _ _) = x+1+> topVar (Let _ _ e1 e2) = max (topVar e1) (topVar e2)+> topVar (App f as) = max (topVar f) (maxs (map topVar as))+> topVar (Lazy e) = topVar e+> topVar (Effect e) = topVar e+> topVar (Con t es) = maxs (map topVar es)+> topVar (Proj e i) = topVar e+> topVar (If a t e) = max (max (topVar a) (topVar t)) (topVar e)+> topVar (While a e) = max (topVar a) (topVar e)+> topVar (WhileAcc a t e) = max (max (topVar a) (topVar t)) (topVar e)+> topVar (Op op a e) = max (topVar a) (topVar e)+> topVar (WithMem a e1 e2) = max (topVar e1) (topVar e2)+> topVar (ForeignCall t s es) = maxs (map topVar (map fst es))+> topVar (LazyForeignCall t s es) = maxs (map topVar (map fst es))+> topVar (Case e alts) = max (topVar e) (maxs (map caseLet alts))+> where caseLet (Alt t n e) = topVar e+> caseLet (ConstAlt t e) = topVar e+> caseLet (DefaultCase e) = topVar e+> topVar _ = 0+++> -- | Constant string+> str :: String -> Term+> str x = term $ Const (MkString x)++> -- | Constant integer+> int :: Int -> Term+> int x = term $ Const (MkInt x)++> -- | Constant float+> float :: Float -> Term+> float x = term $ Const (MkFloat x)++> -- | Constant character+> char :: Char -> Term+> char x = term $ Const (MkChar x)++> -- | Constant bool+> bool :: Bool -> Term+> bool b = term $ Const (MkBool b)++> -- | Constructor for the unit type+> unit_ = con_ 0++> infixl 1 +>++> -- | Sequence terms --- evaluate the first then second+> (+>) :: (EpicExpr c) => c -> Term -> Term+> (+>) c k = let_ c (\x -> k)++> tyInt, tyChar, tyBool, tyFloat, tyString, tyPtr, tyUnit, tyAny :: Type+> tyC :: String -> Type++> tyInt = TyInt+> tyChar = TyChar+> tyBool = TyBool+> tyFloat = TyFloat+> tyString = TyString+> tyPtr = TyPtr+> tyUnit = TyUnit+> tyAny = TyAny+> tyC = TyCType++> infixl 5 !., @@++> -- | Project an argument from an expression which evaluates to+> -- constructor form. +> (!.) :: (EpicExpr t) => t -- ^ Expression in constructor form+> -> Int -- ^ Argument number+> -> Term+> (!.) t i = exp1 (\x -> Proj x i) t++> -- | Reference to a function name+> fn :: String -> Term+> fn x = term (R (UN x))++> -- | Reference to a function name+> ref :: Name -> Term+> ref x = term (R x)++> -- | Application+> (@@) :: (EpicExpr f, EpicExpr a) => f -- ^ function+> -> a -- ^ argument+> -> Term+> (@@) f a = do f' <- term f+> a' <- term a+> case f' of+> App fi as -> return $ App fi (as ++ [a'])+> Con t as -> return $ Con t (as ++ [a'])+> _ -> return $ App f' [a']++> -- | Top level declarations+> data EpicDecl = forall e. EpicFn e => EpicFn e -- ^ Normal function+> | Include String -- ^ Include a C header+> | Link String -- ^ Link to a C library+> | CType String -- ^ Export a C type++> instance Show EpicDecl where+> show (EpicFn e) = show (evalState (func e) 0)++> type Program = [(Name, EpicDecl)]++> name :: String -> Name+> name = UN++> mkDecl :: (Name, EpicDecl) -> Decl+> mkDecl (n, EpicFn e) = Decl n TyAny (mkFunc e) Nothing []+> -- mkDecl (n, Epic.Epic.Extern nm ty tys) = Epic.Language.Extern nm ty tys+> mkDecl (n, Epic.Epic.Include f) = Epic.Language.Include f+> mkDecl (n, Epic.Epic.Link f) = Epic.Language.Link f+> mkDecl (n, Epic.Epic.CType f) = Epic.Language.CType f++> -- |Compile a program to an executable+> compile :: Program -> FilePath -> IO ()+> compile = compileWith []++> -- |Compile a program to an executable, with options+> compileWith :: [CompileOptions] -> Program -> FilePath -> IO ()+> compileWith opts tms outf +> = do compileDecls (outf++".o") Nothing (map mkDecl tms) opts+> Epic.Compiler.link [outf++".o"] outf opts++> -- |Compile a program to a .o+> compileObj :: Program -> FilePath -> IO ()+> compileObj = compileObjWith []++> -- |Compile a program to a .o, with options+> compileObjWith :: [CompileOptions] -> Program -> FilePath -> IO ()+> compileObjWith opts tms outf +> = compileDecls outf Nothing (map mkDecl tms) opts++> -- |Link a collection of object files. By convention, the entry point is+> -- the function called 'main'.+> link :: [FilePath] -> FilePath -> IO ()+> link = linkWith []++> -- |Link a collection of object files, with options. By convention, +> -- the entry point is the function called 'main'.+> linkWith :: [CompileOptions] -> [FilePath] -> FilePath -> IO ()+> linkWith opts fs outf = Epic.Compiler.link fs outf opts++> run :: Program -> IO ()+> run tms = do (tmpn, tmph) <- tempfile+> hClose tmph+> Epic.Epic.compile tms tmpn+> system tmpn+> return ()++Some useful functions++> putStr_ :: Expr -> Term+> putStr_ x = foreign_ tyUnit "putStr" [(x, tyString)]++> putStrLn_ :: Expr -> Term+> putStrLn_ x = (fn "putStr") @@ ((fn "append") @@ x @@ str "\n")++> readStr_ :: Term+> readStr_ = foreign_ tyString "readStr" ([] :: [(Expr, Type)])++> append_ :: Expr -> Expr -> Term+> append_ x y = foreign_ tyString "append" [(x, tyString), (y, tyString)]++> intToString_ :: Expr -> Term+> intToString_ x = foreign_ tyString "intToStr" [(x, tyInt)]++> -- | Some default definitions: putStr, putStrLn, readStr, append, intToString+> basic_defs = [(name "putStr", EpicFn putStr_),+> (name "putStrLn", EpicFn putStrLn_),+> (name "readStr", EpicFn readStr_),+> (name "append", EpicFn append_),+> (name "intToString", EpicFn intToString_)]+
Epic/Language.lhs view
@@ -1,6 +1,10 @@ > module Epic.Language where > import Control.Monad+> import System+> import System.IO+> import System.Directory+> import System.Environment > -- | (Debugging) options to give to compiler > data CompileOptions = KeepC -- ^ Keep intermediate C file@@ -11,6 +15,8 @@ > | GCCOpt String -- ^ Extra GCC option > | Debug -- ^ Generate debug info > | Checking Int -- ^ Checking level (0 none)+> | ExternalMain -- ^ main is defined externally (in C)+> | MainInc FilePath -- ^ File to #include in main program > deriving Eq Raw data types. Int, Char, Bool are unboxed.@@ -102,6 +108,7 @@ > | WhileAcc Expr Expr Expr > | Op Op Expr Expr -- Infix operator > | Let Name Type Expr Expr -- Let binding+> | Lam Name Type Expr -- inner lambda > | Error String -- Exit with error message > | Impossible -- Claimed impossible to reach code > | WithMem Allocator Expr Expr -- evaluate with manual allocation@@ -155,6 +162,8 @@ > show (Op o l r) = "(" ++ show l ++ " " ++ show o ++ " " ++ show r ++")" > show (Let n t v e) = "let " ++ show n ++ ":" ++ show t ++ " = " ++ > show v ++ " in " ++ show e+> show (Lam n t e) = "\\ " ++ show n ++ ":" ++ show t ++ " . " +++> show e > show (Error e) = "error(" ++ show e ++ ")" > show Impossible = "Impossible" > show (WithMem a m e) = "%memory(" ++ show a ++ "," ++ show m ++ ", " ++ show e ++ ")"@@ -224,10 +233,23 @@ > appForm _ = False > checkLevel :: [CompileOptions] -> Int-> checkLevel [] = 0+> checkLevel [] = 1 > checkLevel (Checking i:_) = i > checkLevel (_:xs) = checkLevel xs +Temp files for compiler output++> tempfile :: IO (FilePath, Handle)+> tempfile = do env <- environment "TMPDIR"+> let dir = case env of+> Nothing -> "/tmp"+> (Just d) -> d+> openTempFile dir "esc"++> environment :: String -> IO (Maybe String)+> environment x = catch (do e <- getEnv x+> return (Just e))+> (\_ -> return Nothing) Some tests
Epic/Lexer.lhs view
@@ -121,6 +121,8 @@ > | TokenSemi > | TokenComma > | TokenBar+> | TokenLam+> | TokenDot > | TokenExtern > | TokenMemory > | TokenFixed@@ -175,6 +177,8 @@ > lexer cont (';':cs) = cont TokenSemi cs > lexer cont (',':cs) = cont TokenComma cs > lexer cont ('|':cs) = cont TokenBar cs+> lexer cont ('.':cs) = cont TokenDot cs+> lexer cont ('\\':cs) = cont TokenLam cs > lexer cont ('%':cs) = lexSpecial cont cs > lexer cont (c:cs) = lexError c cs
Epic/Parser.y view
@@ -93,8 +93,10 @@ ';' { TokenSemi } ',' { TokenComma } '|' { TokenBar }+ '.' { TokenDot }+ '\\' { TokenLam } arrow { TokenArrow }- cinclude { TokenCInclude }+ cinclude { TokenCInclude } extern { TokenExtern } export { TokenExport } ctype { TokenCType }@@ -180,6 +182,7 @@ | Const { Const $1 } | Expr '!' int { Proj $1 $3 } | let name ':' Type '=' Expr in Expr %prec LET { Let $2 $4 $6 $8 }+ | '\\' name ':' Type '.' Expr %prec LET { Lam $2 $4 $6 } | Expr ';' Expr { Let (MN "unused" 0) TyUnit $1 $3 } | if Expr then Expr else Expr %prec IF { If $2 $4 $6 } | while '(' Expr ',' Expr ')' { While $3 $5 }
Epic/Scopecheck.lhs view
@@ -30,11 +30,14 @@ > (nm,(args, rt)):(mkContext xs) > mkContext (_:xs) = mkContext xs -Check all names are in scope in a function, and convert global references (R) to local names-(V). Also, if any lazy expressions are not already applications, lift them out and make-a new function. Returns the modified function, and a list of new declarations. The new -declarations will *not* have been scopechecked.+Check all names are in scope in a function, and convert global+references (R) to local names (V). Also, if any lazy expressions are+not already applications, lift them out and make a new+function. Returns the modified function, and a list of new+declarations. The new declarations will *not* have been scopechecked. +Do Lambda Lifting here too+ > scopecheck :: Monad m => Int -> Context -> Name -> Func -> m (Func, [Decl]) > scopecheck checking ctxt nm (Bind args locs exp fl) = do > (exp', (locs', _, ds)) <- runStateT (tc (v_ise args 0) exp) (length args, 0, [])@@ -93,6 +96,16 @@ > put (maxlen, nextn+1, newd:decls) > return $ Lazy (App (R newname) (map V (map snd env))) +> tc env (Lam n ty e) = lift e [(n,ty)] where+> lift (Lam n ty e) args = lift e ((n,ty):args)+> lift e args = do (maxlen, nextn, decls) <- get+> let newname = MN (getRoot nm) nextn+> let newargs = zip (map fst env) (repeat TyAny)+> ++ reverse args+> let newfn = Bind newargs 0 e []+> let newd = Decl newname TyAny newfn Nothing []+> put (maxlen, nextn+1, newd:decls)+> return $ App (R newname) (map V (map snd env)) > tc env (Effect e) = do > e' <- tc env e > return $ Effect e'
epic.cabal view
@@ -1,5 +1,5 @@ Name: epic-Version: 0.1.7+Version: 0.1.8 Author: Edwin Brady License: BSD3 License-file: LICENSE@@ -7,13 +7,13 @@ Homepage: http://www.dcs.st-and.ac.uk/~eb/epic.php Stability: experimental Category: Compilers/Interpreters-Synopsis: Compiler for a supercombinator language+Synopsis: Compiler for a simple functional language Description: Epic is a simple functional language which compiles to reasonably efficient C code, using the Boehm-Demers-Weiser garbage collector (<http://www.hpl.hp.com/personal/Hans_Boehm/gc/>). It is intended as a compiler back end, and is currently used as a back end for Epigram (<http://www.e-pig.org>) and Idris - (<http://www.cs.st-and.ac.uk/~eb/Idris>).+ (<http://idris-lang.org/>). It can be invoked either as a library or an application. Data-files: evm/libevm.a evm/closure.h evm/stdfuns.h evm/stdfuns.c evm/mainprog.c evm/emalloc.h evm/gc_header.h@@ -23,7 +23,7 @@ Build-type: Custom Library- Exposed-modules: Epic.Compiler+ Exposed-modules: Epic.Compiler Epic.Epic Other-modules: Epic.Bytecode Epic.Parser Epic.Scopecheck Epic.Language Epic.Lexer Epic.CodegenC Epic.OTTLang Epic.Simplify Paths_epic
evm/closure.c view
@@ -11,7 +11,10 @@ VAL* zcon; int v_argc; VAL* v_argv;+VMState* vm; +extern func _do___U__main();+ ALLOCATOR allocate; REALLOCATOR reallocate; pool_t** pools = NULL;@@ -1013,6 +1016,43 @@ vm->next = 0; */ return NULL;+}++void epic_main(int argc, char* argv[])+{+ GC_init();++ vm = init_evm(argc, argv);++// GC_use_entire_heap = 1;+// GC_free_space_divisor = 2;+// GC_enable_incremental();+// GC_time_limit = GC_TIME_UNLIMITED;++// GC_full_freq=15;+// fprintf(stderr, "Heap: %d\n", GC_get_heap_size());+++ GC_expand_hp(1000000);+// fprintf(stderr, "Heap: %d\n", GC_get_heap_size());++// GC_disable();++ _do___U__main();++// GC_gcollect();+/* fprintf(stderr, "%d\n", GC_gc_no);+ fprintf(stderr, "Heap: %d\n", GC_get_heap_size());+ fprintf(stderr, "Free: %d\n", GC_get_free_bytes());+ fprintf(stderr, "Total: %d\n", GC_get_total_bytes());*/++/*+ if (vm->start_roots!=vm->roots) {+ fprintf(stderr, "Warning: roots left %d\n", vm->roots-vm->start_roots);+ }+*/++ close_evm(vm); } void close_evm(VMState* vm)
evm/closure.h view
@@ -283,6 +283,9 @@ VMState* init_evm(int argc, char* argv[]); void close_evm(VMState* vm); +// Run the main program+void epic_main(int argc, char* argv[]);+ void* FASTMALLOC(int size); #define CONSTRUCTOR1m(c,t,x) \
evm/libevm.a view
binary file changed (30528 → 30952 bytes)
evm/mainprog.c view
@@ -1,46 +1,12 @@-#include <gc_header.h> #include "closure.h" -void* _do__U_main();- void** _epic_top_of_stack; -VMState* vm;- int main(int argc, char* argv[]) { void* stacktop = NULL; _epic_top_of_stack = (void**)&stacktop; - GC_init();- vm = init_evm(argc, argv);--// GC_use_entire_heap = 1;-// GC_free_space_divisor = 2;-// GC_enable_incremental();-// GC_time_limit = GC_TIME_UNLIMITED;--// GC_full_freq=15;-// fprintf(stderr, "Heap: %d\n", GC_get_heap_size());- GC_expand_hp(1000000);-// fprintf(stderr, "Heap: %d\n", GC_get_heap_size());--// GC_disable();-- _do___U__main();--// GC_gcollect();-/* fprintf(stderr, "%d\n", GC_gc_no);- fprintf(stderr, "Heap: %d\n", GC_get_heap_size());- fprintf(stderr, "Free: %d\n", GC_get_free_bytes());- fprintf(stderr, "Total: %d\n", GC_get_total_bytes());*/--/*- if (vm->start_roots!=vm->roots) {- fprintf(stderr, "Warning: roots left %d\n", vm->roots-vm->start_roots);- }-*/-- close_evm(vm);+ epic_main(argc, argv); return 0; }
evm/stdfuns.c view
@@ -91,6 +91,16 @@ return buf; } +double intToFloat(int x)+{+ return (double)x;+}++int floatToInt(double x)+{+ return (int)x;+}+ double strToFloat(char* str) { // printf("%s, %f\n",str, strtod(str,NULL));
evm/stdfuns.h view
@@ -59,6 +59,9 @@ double strToFloat(char* str); char* floatToStr(double x); +double intToFloat(int x);+int floatToInt(double x);+ mpz_t* strToBigInt(char* str); char* bigIntToStr(mpz_t x);
main/Main.lhs view
@@ -21,15 +21,17 @@ > outfile <- getOutput opts > ofiles <- compileFiles fns (mkOpts opts) > copts <- getCOpts opts-> extras <- getExtra opts+> -- extras <- getExtra opts > if ((length ofiles) > 0 && (not (elem Obj opts)))-> then link (ofiles ++ copts) extras outfile (not (elem ExtMain opts)) (mkOpts opts)+> then link (ofiles ++ copts) outfile (mkOpts opts) > else return () > where mkOpts (KeepInt:xs) = KeepC:(mkOpts xs) > mkOpts (TraceOn:xs) = Trace:(mkOpts xs) > mkOpts (Header f:xs) = MakeHeader f:(mkOpts xs) > mkOpts (DbgInfo:xs) = Debug:(mkOpts xs) > mkOpts (CheckLvl i:xs) = Checking i:(mkOpts xs)+> mkOpts (ExtMain:xs) = ExternalMain:(mkOpts xs)+> mkOpts (ExtraInc i:xs) = MainInc i:(mkOpts xs) > mkOpts (_:xs) = mkOpts xs > mkOpts [] = [] @@ -129,12 +131,6 @@ > return (x:fns) > getCOpts (_:xs) = getCOpts xs > getCOpts [] = return []--> getExtra :: [Option] -> IO [String]-> getExtra ((ExtraInc x):xs) = do fns <- getExtra xs-> return (x:fns)-> getExtra (_:xs) = getExtra xs-> getExtra [] = return [] > processFlags :: [Option] -> Bool -> IO () > processFlags [] True = do putStrLn ""; exitWith ExitSuccess