Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Added Epic.Epic module, an EDSL for generating epic programs

  • Loading branch information...
commit ac4ef7c3e906f3e3e1ab6535a09c8cf4a4eb4ec3 1 parent abae144
Edwin Brady authored
Showing with 206 additions and 28 deletions.
  1. +35 −26 Epic/Compiler.lhs
  2. +169 −0 Epic/Epic.lhs
  3. +2 −2 epic.cabal
View
61 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 @@ Chop off everything after the last / - get the directory a file is in
> 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 ->
View
169 Epic/Epic.lhs
@@ -0,0 +1,169 @@
+> {-# OPTIONS_GHC -fglasgow-exts #-}
+
+> module Epic.Epic(module Epic.Epic,
+> Expr, Op(..)) where
+
+Combinators for constructing an expression
+
+> import Control.Monad.State
+> import Epic.Language
+> import Epic.Compiler
+
+Allow Haskell functions to be used to build expressions, as long as they
+are top level functions.
+
+> class Epic e where
+> expr :: e -> State Int Func
+
+> instance Epic Expr where
+> expr e = return (Bind [] 0 e [])
+
+> instance (Epic e) => Epic (Expr -> e) where
+> expr f = do var <- get
+> put (var+1)
+> let arg = MN "evar" var
+> (Bind vars l e' flags) <- expr (f (R arg))
+> return (Bind ((arg, TyAny):vars) l e' flags)
+
+Use arithmetic operators for expressions
+[FIXME: we're going to have to do something cleverer for Eq. Maybe wrap
+Expr in another type.]
+
+> instance Num Expr where
+> (+) = Op Plus
+> (-) = Op Minus
+> (*) = Op Times
+> negate x = Const (MkInt 0) - x
+> abs = undefined
+> signum = undefined
+> fromInteger x = Const (MkInt (fromInteger x))
+
+> eq = Op OpEQ
+> lt = Op OpLT
+> lte = Op OpLE
+> gt = Op OpGT
+> gte = Op OpGE
+
+> instance Fractional Expr where
+> (/) = Op Divide
+> fromRational x = Const (MkFloat (fromRational x))
+
+> class Alternative e where
+> mkAlt :: Tag -> e -> State Int CaseAlt
+
+> instance Alternative Expr where
+> mkAlt t 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')
+
+> mkFunc :: Epic e => e -> Func
+> mkFunc e = evalState (expr 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
+
+> con :: Alternative e => Int -> e -> CaseAlt
+> con t e = evalState (mkAlt t e) 0
+
+> const = ConstAlt
+> defaultcase = DefaultCase
+
+Remaining expression constructs
+
+> if_ = If
+> while_ = While
+> whileAcc_ = WhileAcc
+> case_ = Case
+> apply_ = App
+> error_ = Error
+> var x = R (UN x)
+> mkCon = Con
+> op_ = Op
+> foreign_ = ForeignCall
+> foreignL_ = LazyForeignCall
+
+> let_ e f = let var = MN "loc" (topLet (f (R (MN "DUMMY" 0)))) in
+> Let var TyAny e (f (R var))
+
+> maxs = foldr max 0
+
+> topLet (Let (MN "loc" x) _ _ _) = x+1
+> topLet (Let _ _ e1 e2) = max (topLet e1) (topLet e2)
+> topLet (App f as) = max (topLet f) (maxs (map topLet as))
+> topLet (Lazy e) = topLet e
+> topLet (Effect e) = topLet e
+> topLet (Con t es) = maxs (map topLet es)
+> topLet (Proj e i) = topLet e
+> topLet (If a t e) = max (max (topLet a) (topLet t)) (topLet e)
+> topLet (While a e) = max (topLet a) (topLet e)
+> topLet (WhileAcc a t e) = max (max (topLet a) (topLet t)) (topLet e)
+> topLet (Op op a e) = max (topLet a) (topLet e)
+> topLet (WithMem a e1 e2) = max (topLet e1) (topLet e2)
+> topLet (ForeignCall t s es) = maxs (map topLet (map fst es))
+> topLet (LazyForeignCall t s es) = maxs (map topLet (map fst es))
+> topLet (Case e alts) = max (topLet e) (maxs (map caseLet alts))
+> where caseLet (Alt t n e) = topLet e
+> caseLet (ConstAlt t e) = topLet e
+> caseLet (DefaultCase e) = topLet e
+> topLet _ = 0
+
+> str x = Const (MkString x)
+
+> infixl 1 +>
+> (+>) c k = Let (MN "discard" 0) TyAny c k
+
+> tyInt = TyInt
+> tyChar = TyChar
+> tyBool = TyBool
+> tyFloat = TyFloat
+> tyString = TyString
+> tyPtr = TyPtr
+> tyUnit = TyUnit
+> tyAny = TyAny
+> tyC = TyCType
+
+> infixl 5 !., <$>
+
+> (!.) = Proj
+> (<$>) nm args = apply_ (R (UN nm)) args
+
+> data EpicTm = forall e. Epic e => Epic e
+> | Extern Name Type [Type]
+> | Include String
+> | Link String
+> | CType String
+
+> type Program = [(Name, EpicTm)]
+
+> name :: String -> Name
+> name = UN
+
+> mkDecl :: (Name, EpicTm) -> Decl
+> mkDecl (n, Epic 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 :: Program -> FilePath -> IO ()
+> compile tms outf = do compileDecls (outf++".o") Nothing (map mkDecl tms) []
+> link [outf++".o"] [] outf True []
View
4 epic.cabal
@@ -1,5 +1,5 @@
Name: epic
-Version: 0.1.7
+Version: 0.1.8
Author: Edwin Brady
License: BSD3
License-file: LICENSE
@@ -23,7 +23,7 @@ Cabal-Version: >= 1.8.0.4
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
Please sign in to comment.
Something went wrong with that request. Please try again.