Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Basic separate compilation support

With new options to esc, and separating compile and link functions:
  -c make a .o file
  -o give output filename
compiling a .o also outputs a .ei interface file, which can be included
into other .e files with 'include file.ei'

darcs-hash:20060723220202-974a0-c5407a4c6dbc0e762cfa543fb52ebc57b53a89e8.gz
  • Loading branch information...
commit 841f1c17f602c4bc18e0399132b41cc6e2c7d922 1 parent 7768de6
eb authored
View
22 EMachine/CodegenC.lhs
@@ -10,12 +10,25 @@
> fileHeader ++
> headers decs ++ "\n" ++
> wrappers decs ++
-> workers ctxt decs ++
-> mainDriver
+> workers ctxt decs
+> -- ++ mainDriver
+
+> writeIFace :: [Decl] -> String
+> writeIFace [] = ""
+> writeIFace ((Decl name ret (Bind args _ _)):xs) =
+> "extern " ++ showuser name ++ " ("++ showextargs (args) ++ ")" ++
+> " -> " ++ show ret ++ "\n" ++ writeIFace xs
+> writeIFace (_:xs) = writeIFace xs
+
+> showextargs [] = ""
+> showextargs [(n,ty)] = showuser n ++ ":" ++ show ty
+> showextargs ((n,ty):xs) = showuser n ++ ":" ++ show ty ++ ", " ++
+> showextargs xs
> fileHeader = "#include \"closure.h\"\n" ++
> "#include \"stdfuns.h\"\n" ++
> "#include <assert.h>\n\n"
+
> mainDriver = "int main() {\nGC_init();\ninit_evm();\n_do__U_main(); return 0; }\n"
> showarg _ i = "void* " ++ loc i
@@ -29,6 +42,11 @@
> "void* " ++ thunk fname ++ "(void** block);\n" ++
> "void* " ++ quickcall fname ++ "(" ++ showargs args 0 ++ ");\n" ++
> headers xs
+> headers ((Extern fname ret tys):xs) =
+> "void* " ++ thunk fname ++ "(void** block);\n" ++
+> "void* " ++ quickcall fname ++ "(" ++ showargs (zip (names 0) tys) 0 ++ ");\n" ++
+> headers xs
+> where names i = (MN "arg" i):(names (i+1))
> headers ((Include h):xs) = "#include <"++h++">\n" ++ headers xs
> headers (_:xs) = headers xs
View
90 EMachine/Compiler.lhs
@@ -9,11 +9,18 @@
> --
> -- Public interface for Epigram Supercombinator Compiler
-> module EMachine.Compiler(compile, libdir) where
+> module EMachine.Compiler(CompileOptions(..),
+> compile,
+> compileOpts,
+> link,
+> libdir) where
Brings everything together; parsing, checking, code generation
+> import System
> import System.IO
+> import System.Directory
+> import System.Environment
> import EMachine.Language
> import EMachine.Parser
@@ -21,25 +28,88 @@ Brings everything together; parsing, checking, code generation
> import EMachine.CodegenC
> import EMachine.Prefix
-> -- |Compile a source file in supercombinator language to C
-> compile :: FilePath -- ^ Input file
-> -> Handle -- ^ Output C filehandle
+> -- | (Debugging) options to give to compiler
+> data CompileOptions = KeepC -- ^ Keep intermediate C file
+> | ShowBytecode -- ^ Show generated code
+> | ShowParseTree -- ^ Show parse tree
+> deriving Eq
+
+> -- |Compile a source file in supercombinator language to a .o
+> compile :: FilePath -- ^ Input file name
+> -> FilePath -- ^ Output file name
+> -> Maybe FilePath -- ^ Interface (.ei) file name, if desired
+> -> IO ()
+> compile fn outf iface
+> = compileOpts fn outf iface []
+
+> compileOpts :: FilePath -- ^ Input file name
+> -> FilePath -- ^ Output file name
+> -> Maybe FilePath -- ^ Interface (.ei) file name, if desired
+> -> [CompileOptions] -- Keep the C file
> -> IO ()
-> compile fn outh
-> = do prelude <- readFile $ libdir ++ "/Prelude.e"
-> input <- readFile fn
-> let s = parse (prelude ++ input) fn
+> compileOpts fn outf iface opts
+> = do input <- readFile fn
+> -- prelude <- readFile (libdir ++ "/Prelude.e")
+> let s = parse input fn
> case s of
> Failure err _ _ -> fail err
-> Success ds -> compileDecls (checkAll ds) outh
+> Success ds -> do
+> (tmpn,tmph) <- tempfile
+> checked <- compileDecls (checkAll ds) tmph
+> let cmd = "gcc -c -O2 -foptimize-sibling-calls -x c " ++ tmpn ++ " -I" ++ libdir ++ " -o " ++ outf
+> -- putStrLn $ cmd
+> 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)
+
+> getRoot fn = case span (/='.') fn of
+> (stem,_) -> stem
+
> compileDecls (Success (ctxt, decls)) outh
> = do hPutStr outh $ codegenC ctxt decls
> hFlush outh
> hClose outh
+> return decls
+> compileDecls (Failure err _ _) _ = fail err
-> compileDecls (Failure err _ _) _ = putStrLn err
+> -- |Link a collection of .o files into an executable
+> link :: [FilePath] -- ^ Object files
+> -> FilePath -- ^ Executable filename
+> -> IO ()
+> link infs outf = do
+> let cmd = "gcc " ++ libdir ++ "/mainprog.c -L" ++
+> libdir++" -I"++libdir ++ " " ++
+> (concat (map (++" ") infs)) ++
+> " -levm -lgc -lgmp -o "++outf
+> -- putStrLn $ cmd
+> exit <- system cmd
+> if (exit /= ExitSuccess)
+> then fail $ "Linking failed"
+> else return ()
> -- |Get the path where the required C libraries and include files are stored
> 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)
View
18 EMachine/Language.lhs
@@ -15,7 +15,20 @@ Raw data types. Int, Char, Bool are unboxed.
> | TyAny -- unchecked, polymorphic
> | TyData -- generic data type
> | TyFun -- any function
-> deriving (Show, Eq)
+> deriving Eq
+
+> instance Show Type where
+> show TyInt = "Int"
+> show TyChar = "Char"
+> show TyBool = "Bool"
+> show TyFloat = "Float"
+> show TyBigInt = "BigInt"
+> show TyBigFloat = "BigFloat"
+> show TyString = "String"
+> show TyUnit = "Unit"
+> show TyAny = "Any"
+> show TyData = "Data"
+> show TyFun = "Fun"
> data Const = MkInt Int
> | MkBigInt Integer
@@ -86,6 +99,9 @@ Programs
> data Decl = Decl { fname :: Name,
> frettype :: Type,
> fdef :: Func }
+> | Extern { fname :: Name,
+> frettype :: Type,
+> fargs :: [Type] }
> | Include String
> | Link String
> deriving Show
View
5 EMachine/Lexer.lhs
@@ -97,6 +97,8 @@
> | TokenSemi
> | TokenComma
> | TokenBar
+> | TokenExtern
+> | TokenInclude
> | TokenEOF
> deriving (Show, Eq)
>
@@ -216,6 +218,9 @@
> ("error",rest) -> cont TokenError rest
> ("impossible",rest) -> cont TokenImpossible rest
> ("foreign",rest) -> cont TokenForeign rest
+> -- declarations
+> ("extern",rest) -> cont TokenExtern rest
+> ("include",rest) -> cont TokenInclude rest
> (var,rest) -> cont (mkname var) rest
> lexSpecial cont cs =
View
26 EMachine/Parser.y
@@ -4,6 +4,7 @@
module EMachine.Parser where
import Char
+import System.IO.Unsafe
import EMachine.Language
import EMachine.Lexer
@@ -70,8 +71,11 @@ import EMachine.Lexer
',' { TokenComma }
'|' { TokenBar }
arrow { TokenArrow }
- include { TokenCInclude }
+ cinclude { TokenCInclude }
+ extern { TokenExtern }
+ include { TokenInclude }
+%nonassoc NONE
%nonassoc lazy
%left LET
%left IF
@@ -89,6 +93,13 @@ import EMachine.Lexer
Program :: { [Decl] }
Program: Declaration { [$1] }
| Declaration Program { $1:$2 }
+ | include string Program File {%
+ let rest = $3 in
+ let pt = unsafePerformIO (readFile $2) in
+ case (parse pt $4) of
+ Success x -> returnP (x ++ rest)
+ Failure err file ln -> failP err
+ }
Type :: { Type }
Type : inttype { TyInt }
@@ -106,7 +117,9 @@ Type : inttype { TyInt }
Declaration :: { Decl }
Declaration: name '(' TypeList ')' arrow Type '=' Expr
{ mkBind $1 (map snd $3) $6 (map fst $3) $8 }
- | include string { Include $2 }
+ | extern name '(' TypeList ')' arrow Type
+ { mkExtern $2 (map snd $4) $7 (map fst $4) }
+ | cinclude string { Include $2 }
TypeList :: { [(Name,Type)] }
@@ -176,11 +189,20 @@ Const : int { MkInt $1 }
| string { MkString $1 }
| unit { MkUnit }
+Line :: { LineNumber }
+ : {- empty -} {% getLineNo }
+
+File :: { String }
+ : {- empty -} %prec NONE {% getFileName }
+
{
mkBind :: Name -> [Type] -> Type -> [Name] -> Expr -> Decl
mkBind n tys ret ns expr = Decl n ret (Bind (zip ns tys) 0 expr)
+mkExtern :: Name -> [Type] -> Type -> [Name] -> Decl
+mkExtern n tys ret ns = Extern n ret tys
+
parse :: String -> FilePath -> Result [Decl]
parse s fn = mkparse s fn 1
View
86 ESC/Main.lhs
@@ -9,19 +9,34 @@
> import EMachine.Compiler
> main = do args <- getArgs
-> (fn, opts) <- usage args
-> (tmpn,tmph) <- tempfile
-> compile fn tmph
-> let cmd = "gcc -O2 -foptimize-sibling-calls -x c " ++ tmpn ++ " -o " ++ (mkExecname fn) ++
-> " -L"++libdir++" -I"++libdir ++ " -levm -lgc -lgmp"
-> exit <- system cmd
-> when (KeepC `elem` opts) $ do
-> rawc <- readFile tmpn
-> writeFile ((getRoot fn)++".c") rawc
-> removeFile tmpn
-> if (exit /= ExitSuccess)
-> then exitWith exit
+> (fns, opts) <- getInput args
+> outfile <- getOutput opts
+> ofiles <- compileFiles fns (mkOpts opts)
+> if ((length ofiles) > 0 && (not (elem Obj opts)))
+> then link ofiles outfile
> else return ()
+> where mkOpts (KeepInt:xs) = KeepC:(mkOpts xs)
+> mkOpts (_:xs) = mkOpts xs
+> mkOpts [] = []
+
+> compileFiles [] _ = return []
+> compileFiles (fn:xs) opts
+> | isDotE fn = do
+> let ofile = getRoot fn ++ ".o"
+> compileOpts fn ofile (Just (getRoot fn ++ ".ei")) opts
+> rest <- compileFiles xs opts
+> return (ofile:rest)
+> | isDotO fn = do
+> rest <- compileFiles xs opts
+> return (fn:rest)
+
+> isDotE ('.':'e':[]) = True
+> isDotE (_:xs) = isDotE xs
+> isDotE [] = False
+
+> isDotO ('.':'o':[]) = True
+> isDotO (_:xs) = isDotO xs
+> isDotO [] = False
> mkExecname fn = case span (/='.') fn of
> (stem,".e") -> stem
@@ -30,27 +45,38 @@
> getRoot fn = case span (/='.') fn of
> (stem,_) -> stem
-> usage (fn:args) = do let opts = parseArgs args
-> return (fn,opts)
-> usage _ = do putStrLn "Epigram Supercombinator Compiler version 0.1"
-> putStrLn "Usage:\n\tesc <input file>"
-> exitWith (ExitFailure 1)
+> getInput :: [String] -> IO ([FilePath],[Option])
+> getInput args = do let opts = parseArgs args
+> fns <- getFile opts
+> if (length fns == 0)
+> then do showUsage
+> return (fns,opts)
+> else return (fns,opts)
-> data Option = KeepC -- Don't delete intermediate file
+> showUsage = do putStrLn "Epigram Supercombinator Compiler version 0.1"
+> putStrLn "Usage:\n\tesc <input file> [options]"
+> exitWith (ExitFailure 1)
+
+> data Option = KeepInt -- Don't delete intermediate file
+> | Obj -- Just make the .o, don't link
+> | File String -- File to send the compiler
+> | Output String -- Output filename
> deriving Eq
+> parseArgs :: [String] -> [Option]
> parseArgs [] = []
-> parseArgs ("-keepc":args) = KeepC:(parseArgs args)
-
-> tempfile :: IO (FilePath, Handle)
-> tempfile = do env <- environment "TMPDIR"
-> let dir = case env of
-> Nothing -> "/tmp"
-> (Just d) -> d
-> openTempFile dir "esc"
+> parseArgs ("-keepc":args) = KeepInt:(parseArgs args)
+> parseArgs ("-c":args) = Obj:(parseArgs args)
+> parseArgs ("-o":name:args) = (Output name):(parseArgs args)
+> parseArgs (x:args) = (File x):(parseArgs args)
-> environment :: String -> IO (Maybe String)
-> environment x = catch (do e <- getEnv x
-> return (Just e))
-> (\_ -> return Nothing)
+> getFile :: [Option] -> IO [FilePath]
+> getFile ((File x):xs) = do fns <- getFile xs
+> return (x:fns)
+> getFile (_:xs) = getFile xs
+> getFile [] = return []
+> getOutput :: [Option] -> IO FilePath
+> getOutput ((Output fn):xs) = return fn
+> getOutput (_:xs) = getOutput xs
+> getOutput [] = return "a.out"
View
2  Makefile
@@ -14,7 +14,7 @@ rts:
install: .PHONY rts
$(MAKE) -C evm install PREFIX=$(PREFIX)
- $(MAKE) -C lib install PREFIX=$(PREFIX)
+ #$(MAKE) -C lib install PREFIX=$(PREFIX)
runhaskell Setup.lhs install $(DB)
unregister:
View
2  evm/Makefile
@@ -4,7 +4,7 @@ OBJS = closure.o stdfuns.o
INSTALLDIR = ${PREFIX}/lib/evm
TARGET = libevm.a
-INSTALLHDRS = closure.h stdfuns.h
+INSTALLHDRS = closure.h stdfuns.h mainprog.c
${TARGET} : ${OBJS}
ar r ${TARGET} ${OBJS}
View
68 examples/Prelude.e
@@ -0,0 +1,68 @@
+%include "string.h"
+
+-- IO
+
+putStr (x:String) -> Unit =
+ foreign Unit "putStr" (x:String)
+
+putStrLn (x:String) -> Unit =
+ putStr(append(x,"\n"))
+
+readStr () -> String =
+ foreign String "readStr" ()
+
+intToStr (x:Int) -> String =
+ foreign String "intToStr" (x:Int)
+
+strToInt (x:String) -> Int =
+ foreign String "strToInt" (x:String)
+
+printInt (x:Int) -> Unit =
+ let foo:Unit = foreign Unit "printInt" (x:Int) in unit
+
+-- String operations
+
+append (x:String, y:String) -> String =
+ foreign String "append" (x:String, y:String)
+
+length (x:String) -> String =
+ foreign Int "strlen" (x:String)
+
+index (x:String, i:Int) -> Char =
+ foreign Int "strIndex" (x:String, i:Int)
+
+-- Big number arithmetic
+
+addBig (x:BigInt, y:BigInt) -> BigInt =
+ foreign BigInt "addBigInt" (x:BigInt, y:BigInt)
+
+subBig (x:BigInt, y:BigInt) -> BigInt =
+ foreign BigInt "subBigInt" (x:BigInt, y:BigInt)
+
+mulBig (x:BigInt, y:BigInt) -> BigInt =
+ foreign BigInt "mulBigInt" (x:BigInt, y:BigInt)
+
+eqBig (x:BigInt, y:BigInt) -> Bool =
+ foreign Int "eqBigInt" (x:BigInt, y:BigInt)
+
+ltBig (x:BigInt, y:BigInt) -> Bool =
+ foreign Int "ltBigInt" (x:BigInt, y:BigInt)
+
+gtBig (x:BigInt, y:BigInt) -> Bool =
+ foreign Int "gtBigInt" (x:BigInt, y:BigInt)
+
+leBig (x:BigInt, y:BigInt) -> Bool =
+ foreign Int "leBigInt" (x:BigInt, y:BigInt)
+
+geBig (x:BigInt, y:BigInt) -> Bool =
+ foreign Int "geBigInt" (x:BigInt, y:BigInt)
+
+printBig (x:BigInt) -> Unit =
+ foreign Unit "printBigInt" (x:BigInt)
+
+bigIntToStr (x:BigInt) -> String =
+ foreign String "bigIntToStr" (x:BigInt)
+
+strToBigInt (x:String) -> Int =
+ foreign String "strToBigInt" (x:String)
+
View
2  examples/adder.e
@@ -1,3 +1,5 @@
+include "Prelude.e"
+
main () -> Unit =
printInt(natToInt(adder(three, two, three, four, five)))
View
2  examples/bigint.e
@@ -1,3 +1,5 @@
+include "Prelude.e"
+
main () -> Unit = putStrLn(bigIntToStr(fact(10000L)))
fact (x:BigInt) -> BigInt = factAux(x,1L)
View
2  examples/hellouser.e
@@ -1,3 +1,5 @@
+include "Prelude.e"
+
main () -> Unit =
putStr("What is your name? ");
let name:String = readStr() in
View
2  examples/hworld.e
@@ -1,3 +1,5 @@
+include "Prelude.e"
+
main () -> Unit =
putStr("Hello world!\n")
View
2  examples/intthing.e
@@ -1,3 +1,5 @@
+include "Prelude.e"
+
main () -> Unit =
printInt(foo(9))
View
2  examples/listy.e
@@ -1,4 +1,4 @@
-%include "string.h"
+include "Prelude.e"
main () -> Unit = printList(take(3,ones))
View
2  examples/tailcall.e
@@ -1,3 +1,5 @@
+include "Prelude.e"
+
{- Depending how much memory you have, you may need to reduce 'nine' -}
main () -> Unit =
View
2  examples/testprog.e
@@ -1,3 +1,5 @@
+include "Prelude.e"
+
{- Depending how much memory you have, you may need to reduce 'nine' -}
main () -> Unit =
View
2  examples/testprogslow.e
@@ -1,3 +1,5 @@
+include "Prelude.e"
+
main () -> Unit =
printInt(apply(natToInt, fact(nine())))
View
68 tests/Prelude.e
@@ -0,0 +1,68 @@
+%include "string.h"
+
+-- IO
+
+putStr (x:String) -> Unit =
+ foreign Unit "putStr" (x:String)
+
+putStrLn (x:String) -> Unit =
+ putStr(append(x,"\n"))
+
+readStr () -> String =
+ foreign String "readStr" ()
+
+intToStr (x:Int) -> String =
+ foreign String "intToStr" (x:Int)
+
+strToInt (x:String) -> Int =
+ foreign String "strToInt" (x:String)
+
+printInt (x:Int) -> Unit =
+ let foo:Unit = foreign Unit "printInt" (x:Int) in unit
+
+-- String operations
+
+append (x:String, y:String) -> String =
+ foreign String "append" (x:String, y:String)
+
+length (x:String) -> String =
+ foreign Int "strlen" (x:String)
+
+index (x:String, i:Int) -> Char =
+ foreign Int "strIndex" (x:String, i:Int)
+
+-- Big number arithmetic
+
+addBig (x:BigInt, y:BigInt) -> BigInt =
+ foreign BigInt "addBigInt" (x:BigInt, y:BigInt)
+
+subBig (x:BigInt, y:BigInt) -> BigInt =
+ foreign BigInt "subBigInt" (x:BigInt, y:BigInt)
+
+mulBig (x:BigInt, y:BigInt) -> BigInt =
+ foreign BigInt "mulBigInt" (x:BigInt, y:BigInt)
+
+eqBig (x:BigInt, y:BigInt) -> Bool =
+ foreign Int "eqBigInt" (x:BigInt, y:BigInt)
+
+ltBig (x:BigInt, y:BigInt) -> Bool =
+ foreign Int "ltBigInt" (x:BigInt, y:BigInt)
+
+gtBig (x:BigInt, y:BigInt) -> Bool =
+ foreign Int "gtBigInt" (x:BigInt, y:BigInt)
+
+leBig (x:BigInt, y:BigInt) -> Bool =
+ foreign Int "leBigInt" (x:BigInt, y:BigInt)
+
+geBig (x:BigInt, y:BigInt) -> Bool =
+ foreign Int "geBigInt" (x:BigInt, y:BigInt)
+
+printBig (x:BigInt) -> Unit =
+ foreign Unit "printBigInt" (x:BigInt)
+
+bigIntToStr (x:BigInt) -> String =
+ foreign String "bigIntToStr" (x:BigInt)
+
+strToBigInt (x:String) -> Int =
+ foreign String "strToBigInt" (x:String)
+
View
2  tests/adder.e
@@ -1,3 +1,5 @@
+include "Prelude.e"
+
main () -> Unit =
printInt(natToInt(adder(three, two, three, four, five)))
View
2  tests/bigint.e
@@ -1,3 +1,5 @@
+include "Prelude.e"
+
main () -> Unit = printBig(fact(120L))
fact (x:BigInt) -> BigInt =
View
2  tests/hworld.e
@@ -1,3 +1,5 @@
+include "Prelude.e"
+
main () -> Unit =
putStr("Hello world!\n")
View
2  tests/intthing.e
@@ -1,3 +1,5 @@
+include "Prelude.e"
+
main () -> Unit =
printInt(foo(9))
View
2  tests/listy.e
@@ -1,4 +1,4 @@
-%include "string.h"
+include "Prelude.e"
main () -> Unit = printList(take(3,ones))
View
2  tests/tailcall.e
@@ -1,3 +1,5 @@
+include "Prelude.e"
+
{- Depending how much memory you have, you may need to reduce 'nine' -}
main () -> Unit =
View
2  tests/tailfact.e
@@ -1,3 +1,5 @@
+include "Prelude.e"
+
{- Depending how much memory you have, you may need to reduce 'nine' -}
main () -> Unit =
View
4 tests/test.pl
@@ -10,9 +10,9 @@
system("echo \"\" > output");
foreach $file (sort @files) {
- if ($file=~/([^\.]+)\.e/) {
+ if ($file=~/([^\.]+)\.e$/ && $file ne "Prelude.e") {
print "$file...\n";
- system("esc $file >> output");
+ system("esc $file -o $1 >> output");
system("./$1 >> output");
system("rm $1");
}
Please sign in to comment.
Something went wrong with that request. Please try again.