diff --git a/Epic/Compiler.lhs b/Epic/Compiler.lhs --- a/Epic/Compiler.lhs +++ b/Epic/Compiler.lhs @@ -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) diff --git a/Epic/Epic.lhs b/Epic/Epic.lhs new file mode 100644 --- /dev/null +++ b/Epic/Epic.lhs @@ -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_)] + diff --git a/Epic/Language.lhs b/Epic/Language.lhs --- a/Epic/Language.lhs +++ b/Epic/Language.lhs @@ -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 diff --git a/Epic/Lexer.lhs b/Epic/Lexer.lhs --- a/Epic/Lexer.lhs +++ b/Epic/Lexer.lhs @@ -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 diff --git a/Epic/Parser.y b/Epic/Parser.y --- a/Epic/Parser.y +++ b/Epic/Parser.y @@ -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 } diff --git a/Epic/Scopecheck.lhs b/Epic/Scopecheck.lhs --- a/Epic/Scopecheck.lhs +++ b/Epic/Scopecheck.lhs @@ -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' diff --git a/epic.cabal b/epic.cabal --- a/epic.cabal +++ b/epic.cabal @@ -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 (). It is intended as a compiler back end, and is currently used as a back end for Epigram () and Idris - (). + (). 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 diff --git a/evm/closure.c b/evm/closure.c --- a/evm/closure.c +++ b/evm/closure.c @@ -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) diff --git a/evm/closure.h b/evm/closure.h --- a/evm/closure.h +++ b/evm/closure.h @@ -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) \ diff --git a/evm/libevm.a b/evm/libevm.a Binary files a/evm/libevm.a and b/evm/libevm.a differ diff --git a/evm/mainprog.c b/evm/mainprog.c --- a/evm/mainprog.c +++ b/evm/mainprog.c @@ -1,46 +1,12 @@ -#include #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; } diff --git a/evm/stdfuns.c b/evm/stdfuns.c --- a/evm/stdfuns.c +++ b/evm/stdfuns.c @@ -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)); diff --git a/evm/stdfuns.h b/evm/stdfuns.h --- a/evm/stdfuns.h +++ b/evm/stdfuns.h @@ -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); diff --git a/main/Main.lhs b/main/Main.lhs --- a/main/Main.lhs +++ b/main/Main.lhs @@ -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