Permalink
Browse files

Added explicit inlining

Ignore-this: 9f99e56305d70616619c88e3036a4e5b

darcs-hash:20090906092457-6ac22-38456b94ae4f6c811967db78a6472b1fe764e4f7.gz
  • Loading branch information...
1 parent 70d6955 commit c38b6071df7e3f4f81f981b1cbe0d87b0e35f8e8 eb committed Sep 6, 2009
Showing with 133 additions and 23 deletions.
  1. +7 −7 Epic/CodegenC.lhs
  2. +5 −3 Epic/Compiler.lhs
  3. +5 −1 Epic/Language.lhs
  4. +2 −0 Epic/Lexer.lhs
  5. +12 −4 Epic/Parser.y
  6. +3 −3 Epic/Scopecheck.lhs
  7. +81 −0 Epic/Simplify.lhs
  8. +1 −1 epic.cabal
  9. +1 −1 evm/closure.c
  10. +3 −1 evm/closure.h
  11. +4 −0 evm/stdfuns.c
  12. +1 −0 evm/stdfuns.h
  13. +1 −1 examples/Prelude.e
  14. +7 −1 examples/adder.e
View
@@ -20,7 +20,7 @@
> writeIFace :: [Decl] -> String
> writeIFace [] = ""
-> writeIFace ((Decl name ret (Bind args _ _) _):xs) =
+> writeIFace ((Decl name ret (Bind args _ _) _ _):xs) =
> "extern " ++ showC name ++ " ("++ showextargs (args) ++ ")" ++
> " -> " ++ show ret ++ "\n" ++ writeIFace xs
> writeIFace (_:xs) = writeIFace xs
@@ -47,7 +47,7 @@
> showlist (x:xs) = x ++ ", " ++ showlist xs
> headers [] = ""
-> headers ((Decl fname ret (Bind args _ _) _):xs) =
+> headers ((Decl fname ret (Bind args _ _) _ _):xs) =
> "void* " ++ thunk fname ++ "(void** block);\n" ++
> "void* " ++ quickcall fname ++ "(" ++ showargs args 0 ++ ");\n" ++
> headers xs
@@ -60,7 +60,7 @@
> headers (_:xs) = headers xs
> wrappers [] = ""
-> wrappers ((Decl fname ret (Bind args _ _) _):xs) =
+> wrappers ((Decl fname ret (Bind args _ _) _ _):xs) =
> "void* " ++ thunk fname ++ "(void** block) {\n return " ++
> quickcall fname ++ "(" ++
> wrapperArgs (length args) ++ ");\n}\n\n" ++
@@ -72,7 +72,7 @@
> wrapperArgs x = wrapperArgs (x-1) ++ ", block[" ++ show (x-1) ++ "]"
> workers _ [] = ""
-> workers ctxt (decl@(Decl fname ret func@(Bind args locals defn) _):xs) =
+> workers ctxt (decl@(Decl fname ret func@(Bind args locals defn) _ _):xs) =
> -- trace (show fname ++ ": " ++ show defn) $
> "void* " ++ quickcall fname ++ "(" ++ showargs args 0 ++ ") {\n" ++
> compileBody (compile ctxt fname func) ++ "\n}\n\n" ++ exportC decl ++
@@ -188,7 +188,7 @@
> = tmp t ++ " = CONSTRUCTOR(" ++
> show tag ++ ", 0, 0);"
> constructor t tag args
-> | length args < 3 && length args > 0
+> | length args < 6 && length args > 0
> = tmp t ++ " = CONSTRUCTOR" ++ show (length args) ++ "(" ++
> show tag ++ targs ", " args ++ ");"
> constructor t tag args = argblock "block" args ++ tmp t ++
@@ -276,7 +276,7 @@ Write out code for an export
> ctyarg (n,ty) = cty ty ++ " " ++ showuser n
> exportC :: Decl -> String
-> exportC (Decl nm rt (Bind args _ _) (Just cname)) =
+> exportC (Decl nm rt (Bind args _ _) (Just cname) _) =
> cty rt ++ " " ++ cname ++ "(" ++ ctys args ++ ") {\n\t" ++
> if (rt==TyUnit) then "" else "return " ++
> epicToC (quickcall nm ++ "(" ++ showlist (map conv args) ++ ")") rt ++
@@ -288,6 +288,6 @@ Write out code for an export
... and in the header file
> exportH :: Decl -> String
-> exportH (Decl nm rt (Bind args _ _) (Just cname)) =
+> exportH (Decl nm rt (Bind args _ _) (Just cname) _) =
> cty rt ++ " " ++ cname ++ "(" ++ ctys args ++ ");\n"
> exportH _ = ""
View
@@ -26,6 +26,7 @@ Brings everything together; parsing, checking, code generation
> import Epic.Parser
> import Epic.Scopecheck
> import Epic.CodegenC
+> import Epic.Simplify
> import Paths_epic
@@ -78,7 +79,9 @@ Chop off everything after the last / - get the directory a file is in
> Success ds -> do
> (tmpn,tmph) <- tempfile
> let hdr = outputHeader opts
-> checked <- compileDecls (checkAll ds) tmph hdr
+> scchecked <- checkAll ds
+> let simplified = simplifyAll scchecked
+> checked <- compileDecls simplified tmph hdr
> fp <- getDataFileName "evm/closure.h"
> let libdir = trimLast fp
> let cmd = "gcc -c -O2 -foptimize-sibling-calls -x c " ++ tmpn ++ " -I" ++ libdir ++ " -o " ++ outf ++ " " ++ addGCC opts ++ doTrace opts
@@ -102,7 +105,7 @@ Chop off everything after the last / - get the directory a file is in
> (stem,_) -> stem
-> compileDecls (Success (ctxt, decls)) outh hdr
+> compileDecls (ctxt, decls) outh hdr
> = do hPutStr outh $ codegenC ctxt decls
> case hdr of
> Just fpath ->
@@ -112,7 +115,6 @@ Chop off everything after the last / - get the directory a file is in
> hFlush outh
> hClose outh
> return decls
-> compileDecls (Failure err _ _) _ _ = fail err
> -- |Link a collection of .o files into an executable
> link :: [FilePath] -- ^ Object files
View
@@ -121,7 +121,8 @@ Programs
> data Decl = Decl { fname :: Name,
> frettype :: Type,
> fdef :: Func,
-> fexport :: Maybe String -- C name
+> fexport :: Maybe String, -- C name
+> fcompflags :: [CGFlag]
> }
> | Extern { fname :: Name,
> frettype :: Type,
@@ -131,6 +132,9 @@ Programs
> | CType Name
> deriving Show
+> data CGFlag = Inline
+> deriving (Show, Eq)
+
> data Result r = Success r
> | Failure String String Int
> deriving (Show, Eq)
View
@@ -67,6 +67,7 @@
> | TokenForeign
> | TokenCInclude
> | TokenLink
+> | TokenInline
> | TokenOB
> | TokenCB
> | TokenOCB
@@ -240,6 +241,7 @@
> case span isAllowed cs of
> ("include",rest) -> cont TokenCInclude rest
> ("link",rest) -> cont TokenLink rest
+> ("inline",rest) -> cont TokenInline rest
> (thing,rest) -> lexError '%' rest
> mkname :: String -> Token
View
@@ -80,6 +80,7 @@ import Epic.Lexer
export { TokenExport }
ctype { TokenCType }
include { TokenInclude }
+ inline { TokenInline }
%nonassoc NONE
%nonassoc lazy
@@ -123,12 +124,19 @@ Type : inttype { TyInt }
| funtype { TyFun }
Declaration :: { Decl }
-Declaration: Export name '(' TypeList ')' arrow Type '=' Expr
- { mkBind $2 (map snd $4) $7 (map fst $4) $9 $1 }
+Declaration: Export Flags name '(' TypeList ')' arrow Type '=' Expr
+ { mkBind $3 (map snd $5) $8 (map fst $5) $10 $1 $2 }
| extern name '(' TypeList ')' arrow Type
{ mkExtern $2 (map snd $4) $7 (map fst $4) }
| cinclude string { Include $2 }
+Flags :: { [CGFlag] }
+Flags : { [] }
+ | Flag Flags { $1:$2 }
+
+Flag :: { CGFlag }
+ : inline { Inline }
+
Export :: { Maybe String }
Export : { Nothing }
| export string { Just $2 }
@@ -214,8 +222,8 @@ File :: { String }
{
-mkBind :: Name -> [Type] -> Type -> [Name] -> Expr -> Maybe String -> Decl
-mkBind n tys ret ns expr export = Decl n ret (Bind (zip ns tys) 0 expr) export
+mkBind :: Name -> [Type] -> Type -> [Name] -> Expr -> Maybe String -> [CGFlag] -> Decl
+mkBind n tys ret ns expr export fl = Decl n ret (Bind (zip ns tys) 0 expr) export fl
mkExtern :: Name -> [Type] -> Type -> [Name] -> Decl
mkExtern n tys ret ns = Extern n ret tys
View
@@ -13,16 +13,16 @@ checking we do (for now).
> ds <- ca (mkContext xs) xs
> return (ctxt,ds)
> where ca ctxt [] = return []
-> ca ctxt ((Decl nm rt fn exp):xs) =
+> ca ctxt ((Decl nm rt fn exp fl):xs) =
> do fn' <- scopecheck ctxt fn
> xs' <- ca ctxt xs
-> return $ (Decl nm rt fn' exp):xs'
+> return $ (Decl nm rt fn' exp fl):xs'
> ca ctxt (x:xs) =
> do xs' <- ca ctxt xs
> return (x:xs')
> mkContext [] = []
-> mkContext ((Decl nm rt (Bind args _ _) _):xs) =
+> mkContext ((Decl nm rt (Bind args _ _) _ _):xs) =
> (nm,(map snd args, rt)):(mkContext xs)
> mkContext ((Extern nm rt args):xs) =
> (nm,(args, rt)):(mkContext xs)
View
@@ -0,0 +1,81 @@
+> module Epic.Simplify(simplifyAll) where
+
+> import Epic.Language
+
+> import Data.Maybe
+> import Debug.Trace
+
+> simplifyAll :: (Context, [Decl]) -> (Context, [Decl])
+> simplifyAll (ctxt, xs) = let sctxt = mapMaybe mkEntry xs in
+> simpl sctxt ctxt xs
+> where mkEntry d@(Decl n _ fn _ fl) = Just (n, (d, (length (fun_args fn)), fl))
+> mkEntry _ = Nothing
+
+For each supercombinator, evaluate it as far as we believe sensible - basically just inlining
+definitions marked as such, constant folding, case on constants, etc.
+
+Also consider creating specialised versions of functions?
+
+> type SCtxt = [(Name, (Decl, Int, [CGFlag]))]
+
+> simpl :: SCtxt -> Context -> [Decl] -> (Context, [Decl])
+> simpl sctxt ctxt ds = (ctxt, map simplD ds)
+> where simplD (Decl fn fr fd fe fl) = let simpled = simplFun fd in
+> diff fn simpled fd $
+> Decl fn fr (simplFun fd) fe fl
+> simplD d = d
+
+> simplFun (Bind args locs def)
+> = Bind args locs (simplify sctxt (map (\x -> Nothing) args) (length args) def)
+> diff fn simpled fd x | defn simpled == defn fd = x
+> | otherwise = {- trace (show fn ++ "\n" ++ show simpled ++ "\n" ++
+> show fd) -} x
+
+> inlinable = elem Inline
+
+> simplify :: SCtxt -> [Maybe Expr] -> Int -> Expr -> Expr
+> simplify sctxt args arity exp = s' args exp where
+> s' args (V i) = if i<length args then
+> case args!!i of
+> Nothing -> V i
+> Just v -> v
+> else V (i + (arity - length args)) -- adjust case/let offset
+> s' args (R fn)
+> = case lookup fn sctxt of
+> Just (decl, 0, fl) ->
+> if (inlinable fl) then s' args (inline decl [])
+> else R fn
+> _ -> R fn
+> s' args (App f a) = apply (s' args f) (map (s' args) a)
+> s' args (Lazy e) = Lazy $ s' args e
+> s' args (Con t a) = Con t (map (s' args) a)
+> s' args (Proj e i) = project (s' args e) i
+> s' args (Case e alts) = runCase (s' args e) (map (salt args) alts)
+> s' args (If x t e) = runIf (s' args x) (s' args t) (s' args e)
+> s' args (Op op l r) = runOp op (s' args l) (s' args r)
+> s' args (Let n ty v sc) = Let n ty (s' args v) (s' args sc)
+> s' args (ForeignCall ty nm a)
+> = ForeignCall ty nm (map (\ (x,y) -> (s' args x, y)) a)
+> s' args (LazyForeignCall ty nm a)
+> = LazyForeignCall ty nm (map (\ (x,y) -> (s' args x, y)) a)
+> s' args x = x
+
+> salt args (Alt t bargs e) = Alt t bargs (s' args e)
+> salt args (ConstAlt c e) = ConstAlt c (s' args e)
+> salt args (DefaultCase e) = DefaultCase (s' args e)
+
+> project e i = Proj e i
+> runCase e alts = Case e alts
+> runIf x t e = If x t e
+> runOp op l r = Op op l r
+
+> apply f@(R fn) as
+> = case lookup fn sctxt of
+> Just (decl, ar, fl) ->
+> if (inlinable fl && ar == length as) then s' args (inline decl as)
+> else App f as
+> _ -> App f as
+> apply f as = App f as
+
+> inline :: Decl -> [Expr] -> Expr
+> inline (Decl _ _ (Bind _ _ exp) _ _) args = simplify sctxt (map Just args) arity exp
View
@@ -22,6 +22,6 @@ Extensions: MultiParamTypeClasses, FunctionalDependencies,
Exposed-modules: Epic.Compiler
Other-modules: Epic.Bytecode Epic.Parser Epic.Scopecheck
Epic.Language Epic.Lexer Epic.CodegenC
- Epic.OTTLang Paths_epic
+ Epic.OTTLang Epic.Simplify Paths_epic
Data-files: evm/libevm.a evm/closure.h evm/stdfuns.h evm/stdfuns.c evm/mainprog.c
Extra-source-files: evm/closure.c evm/closure.h evm/stdfuns.h evm/mainprog.c evm/stdfuns.c evm/Makefile
View
@@ -74,7 +74,7 @@ void dumpClosure(Closure* c) {
printf("\n");
}
-void assertCon(Closure* c)
+void assertConR(Closure* c)
{
if (c==NULL) { printf("Null constructor\n"); assert(0); }
if (!ISCON(c)) { dumpClosure(c); assert(0); }
View
@@ -54,9 +54,11 @@ typedef struct {
} Closure;
void dumpClosure(Closure* c);
-void assertCon(Closure* c);
+void assertConR(Closure* c);
void assertInt(Closure* c);
+#define assertCon(x) assertConR(x)
+
typedef Closure* VAL;
#define GETTY(x) (ISINT(x) ? INT : ((ClosureType)(((x)->ty) >> 24)))
View
@@ -47,6 +47,10 @@ void fputStr(void* h, char* str) {
fputs(str, f);
}
+int streq(char* x, char* y) {
+ return !(strcmp(x,y));
+}
+
int strToInt(char* str)
{
return strtol(str,NULL,10);
View
@@ -24,6 +24,7 @@ void epicMemInfo();
int readInt();
char* readStr();
+int streq(char* x, char* y);
void* fileOpen(char* name, char* mode);
void fileClose(void* h);
View
@@ -2,7 +2,7 @@
-- IO
-putStr (x:String) -> Unit =
+%inline putStr (x:String) -> Unit =
foreign Unit "putStr" (x:String)
putStrLn (x:String) -> Unit =
View
@@ -3,7 +3,7 @@ include "Prelude.e"
main () -> Unit =
printInt(natToInt(adder(three, two, three, four, five)))
-adder (arity:Data, acc:Data) -> Any =
+%inline adder (arity:Data, acc:Data) -> Any =
case arity of {
Con 0 () -> acc
| Con 1 (k:Data) -> adderAux(k, acc)
@@ -12,6 +12,12 @@ adder (arity:Data, acc:Data) -> Any =
adderAux (k:Data, acc:Data, n:Data) -> Any =
adder(k,plus(acc,n))
+adderAuxE (k:Data, acc:Data, n:Data) -> Any =
+ case k of {
+ Con 0 () -> plus(acc,n)
+ | Con 1 (k:Data) -> adderAuxE(k,plus(acc,n))
+ }
+
zero () -> Data = Con 0 ()
one () -> Data = Con 1 (zero)
two () -> Data = Con 1 (one)

0 comments on commit c38b607

Please sign in to comment.