diff --git a/Epic/Bytecode.lhs b/Epic/Bytecode.lhs new file mode 100644 --- /dev/null +++ b/Epic/Bytecode.lhs @@ -0,0 +1,225 @@ +> module Epic.Bytecode where + +> import Control.Monad.State +> import List + +> import Epic.Language + +> type Local = Int +> type TmpVar = Int + +Register based - most operations do an action, then put the result in a +'TmpVar' which is basically a numbered register. There are infinite registers +at this stage. + +> data ByteOp = CALL TmpVar Name [TmpVar] +> | TAILCALL TmpVar Name [TmpVar] +> | THUNK TmpVar Int Name [TmpVar] +> | ADDARGS TmpVar TmpVar [TmpVar] +> | FOREIGN Type TmpVar String [(TmpVar, Type)] +> | VAR TmpVar Local +> | ASSIGN Local TmpVar +> | CON TmpVar Tag [TmpVar] +> | UNIT TmpVar +> | INT TmpVar Int +> | BIGINT TmpVar Integer +> | FLOAT TmpVar Float +> | BIGFLOAT TmpVar Double +> | STRING TmpVar String +> | PROJ TmpVar TmpVar Int -- project into a register +> | PROJVAR Local TmpVar Int -- project into a local variable +> -- each case branch records which tag it's code for +> | CASE TmpVar [(Int, Bytecode)] (Maybe Bytecode) +> | IF TmpVar Bytecode Bytecode +> | OP TmpVar Op TmpVar TmpVar +> | LOCALS Int -- allocate space for locals +> | TMPS Int -- declare temporary variables +> | EVAL TmpVar +> -- | LET TmpVar Local TmpVar +> | RETURN TmpVar +> | DRETURN -- return dummy value +> | ERROR String -- Fatal error, exit +> | TRACE String [TmpVar] +> deriving Show + +> type Bytecode = [ByteOp] + +> data FunCode = Code [Type] Bytecode +> deriving Show + +> data CompileState = CS { arg_types :: [Type], +> num_locals :: Int, +> next_tmp :: Int } + +> compile :: Context -> Name -> Func -> FunCode +> compile ctxt fname fn@(Bind args locals def) = +> let cs = (CS (map snd args) (length args) 1) +> code = evalState (scompile ctxt fname fn) cs in +> Code (map snd args) code + +> data TailCall = Tail | Middle + +> scompile :: Context -> Name -> Func -> State CompileState Bytecode +> scompile ctxt fname (Bind args locals def) = +> do -- put (CS args (length args) 1) +> code <- ecomp Tail def 0 (length args) +> cs <- get +> return $ (LOCALS (num_locals cs)): +> (TRACE (show fname) [0..(length args)-1]): +> (TMPS (next_tmp cs)):code ++[EVAL 0, RETURN 0] + +> where + +> new_tmp :: State CompileState Int +> new_tmp = do cs <- get +> let reg' = next_tmp cs +> put (cs { next_tmp = reg'+1 } ) +> return reg' + +Add some locals, return de Bruijn level of first new one. + +> new_locals :: Int -> State CompileState Int +> new_locals args = +> do cs <- get +> let loc = num_locals cs +> put (cs { num_locals = loc+args } ) +> return loc + +Take an expression and the register (TmpVar) to put the result into; +compile code to do just that. + +Also carry the number of real variables currently in scope so that, in +particular, when we project from a data structure we store it in the right +place. + +> ecomp :: TailCall -> Expr -> TmpVar -> Int -> +> State CompileState Bytecode +> ecomp tcall (V v) reg vs = +> do return [VAR reg v] +> ecomp tcall (R x) reg vs = acomp tcall False (R x) [] reg vs +> ecomp tcall (App f as) reg vs = acomp tcall False f as reg vs +> ecomp tcall (LazyApp f as) reg vs = acomp tcall True f as reg vs +> ecomp tcall (Con t as) reg vs = +> do (argcode, argregs) <- ecomps as vs +> return $ argcode ++ [CON reg t argregs] +> ecomp tcall (Proj con i) reg vs = +> do reg' <- new_tmp +> concode <- ecomp Middle con reg' vs +> return [PROJ reg reg' i] +> ecomp tcall (Const c) reg vs = ccomp c reg +> ecomp tcall (Case scrutinee alts) reg vs = +> do screg <- new_tmp +> sccode <- ecomp Middle scrutinee screg vs +> (altcode, def) <- altcomps tcall (order alts) screg reg vs +> return $ sccode ++ [EVAL screg, CASE screg altcode def] +> ecomp tcall (If a t e) reg vs = +> do areg <- new_tmp +> acode <- ecomp Middle a areg vs +> tcode <- ecomp tcall t reg vs +> ecode <- ecomp tcall e reg vs +> return $ acode ++ [EVAL areg, IF areg tcode ecode] +> ecomp tcall (Op op l r) reg vs = +> do lreg <- new_tmp +> rreg <- new_tmp +> lcode <- ecomp Middle l lreg vs +> rcode <- ecomp Middle r rreg vs +> return $ lcode ++ [EVAL lreg] ++ +> rcode ++ [EVAL rreg, OP reg op lreg rreg] +> ecomp tcall (Let nm ty val scope) reg vs = +> do loc <- new_locals 1 +> reg' <- new_tmp +> valcode <- ecomp Middle val reg' vs +> scopecode <- ecomp tcall scope reg (vs+1) +> return $ valcode ++ (EVAL reg'):(ASSIGN vs reg'):scopecode +> ecomp tcall (Error str) reg vs = return [ERROR str] +> ecomp tcall Impossible reg vs = return [ERROR "The impossible happened."] +> ecomp tcall (ForeignCall ty fn argtypes) reg vs = do +> let (args,types) = unzip argtypes +> (argcode, argregs) <- ecomps args vs +> let evalcode = map EVAL argregs +> return $ argcode ++ evalcode ++ [FOREIGN ty reg fn (zip argregs types)] + +> ecomps :: [Expr] -> Int -> State CompileState (Bytecode, [TmpVar]) +> ecomps e vs = ecomps' [] [] e vs +> ecomps' code tmps [] vs = return (code, tmps) +> ecomps' code tmps (e:es) vs = +> do reg <- new_tmp +> ecode <- ecomp Middle e reg vs +> ecomps' (code++ecode) (tmps++[reg]) es vs + +Compile case alternatives. + +> order :: [CaseAlt] -> [CaseAlt] +> order xs = sort xs -- insertError 0 (sort xs) + +We don't do this any more, now that we have default cases. + +> insertError t [] = [] +> insertError t (a@(Alt tn _ _):xs) +> = {- (errors t tn) ++ -} a:(insertError (tn+1) xs) +> insertError t rest@((DefaultCase _):xs) +> = rest -- End at defaul case + +> errors x end | x == end = [] +> | otherwise = (Alt x [] Impossible):(errors (x+1) end) + +> altcomps :: TailCall -> [CaseAlt] -> TmpVar -> TmpVar -> Int -> +> State CompileState ([(Int, Bytecode)], Maybe Bytecode) +> altcomps tc [] _ _ vs = return ([], Nothing) +> altcomps tc (a:as) scrutinee reg vs = +> do (t,acode) <- altcomp tc a scrutinee reg vs +> (ascode, def) <- altcomps tc as scrutinee reg vs +> if (t<0) then return (ascode, Just acode) +> else return ((t,acode):ascode, def) + +Assume that all the tags are in order, and unused constructors have +a default inserted (i.e., tag can be ignored). + +Return the tag and the code - tag is -1 for default case. + +> altcomp :: TailCall -> CaseAlt -> TmpVar -> TmpVar -> Int -> +> State CompileState (Int, Bytecode) +> altcomp tc (Alt tag nmargs expr) scrutinee reg vs = +> do let args = map snd nmargs +> local <- new_locals (length args) +> projcode <- project args scrutinee vs 0 +> exprcode <- ecomp tc expr reg (vs+(length args)) +> return (tag, projcode++exprcode) +> altcomp tc (DefaultCase expr) scrutinee reg vs = +> do exprcode <- ecomp tc expr reg vs +> return (-1,exprcode) + +> project [] _ _ _ = return [] +> project (_:as) scr loc arg = +> do let acode = PROJVAR loc scr arg +> ascode <- project as scr (loc+1) (arg+1) +> return (acode:ascode) + +Compile an application of a function to arguments + +> acomp :: TailCall -> Bool -> Expr -> [Expr] -> TmpVar -> Int -> +> State CompileState Bytecode +> acomp tc lazy (R x) args reg vs +> | lazy == False && arity x ctxt == length args = +> do (argcode, argregs) <- ecomps args vs +> return $ argcode {- ++ map EVAL argregs -} ++ [(tcall tc) reg x argregs] +> | otherwise = +> do (argcode, argregs) <- ecomps args vs +> return $ argcode ++ [THUNK reg (arity x ctxt) x argregs] +> where tcall Tail = TAILCALL +> tcall Middle = CALL +> acomp _ _ f args reg vs +> = do (argcode, argregs) <- ecomps args vs +> reg' <- new_tmp +> fcode <- ecomp Middle f reg' vs +> return $ fcode ++ argcode ++ [ADDARGS reg reg' argregs] + +> ccomp (MkInt i) reg = return [INT reg i] +> ccomp (MkBigInt i) reg = return [BIGINT reg i] +> ccomp (MkChar c) reg = return [INT reg (fromEnum c)] +> ccomp (MkFloat f) reg = return [FLOAT reg f] +> ccomp (MkBigFloat f) reg = return [BIGFLOAT reg f] +> ccomp (MkBool b) reg = return [INT reg (if b then 1 else 0)] +> ccomp (MkString s) reg = return [STRING reg s] +> ccomp (MkUnit) reg = return [UNIT reg] + diff --git a/Epic/CodegenC.lhs b/Epic/CodegenC.lhs new file mode 100644 --- /dev/null +++ b/Epic/CodegenC.lhs @@ -0,0 +1,230 @@ +> module Epic.CodegenC where + +> import Control.Monad.State + +> import Epic.Language +> import Epic.Bytecode +> import Debug.Trace + +> codegenC :: Context -> [Decl] -> String +> codegenC ctxt decs = +> fileHeader ++ +> headers decs ++ "\n" ++ +> wrappers decs ++ +> workers ctxt decs +> -- ++ mainDriver + +> writeIFace :: [Decl] -> String +> writeIFace [] = "" +> writeIFace ((Decl name ret (Bind args _ _)):xs) = +> "extern " ++ showC name ++ " ("++ showextargs (args) ++ ")" ++ +> " -> " ++ show ret ++ "\n" ++ writeIFace xs +> writeIFace (_:xs) = writeIFace xs + +> showextargs [] = "" +> showextargs [(n,ty)] = showC n ++ ":" ++ show ty +> showextargs ((n,ty):xs) = showC n ++ ":" ++ show ty ++ ", " ++ +> showextargs xs + +> fileHeader = "#include \"closure.h\"\n" ++ +> "#include \"stdfuns.h\"\n" ++ +> "#include \n\n" + +> mainDriver = "int main(int argc, char*[] argv) {\nGC_init();\ninit_evm();\n_do__U_main(); return 0; }\n" + +> showarg _ i = "void* " ++ loc i + +> showargs [] i= "" +> showargs [x] i = showarg x i +> showargs (x:xs) i = showarg x i ++ ", " ++ showargs xs (i+1) + +> headers [] = "" +> headers ((Decl fname ret (Bind args _ _)):xs) = +> "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 + +> wrappers [] = "" +> wrappers ((Decl fname ret (Bind args _ _)):xs) = +> "void* " ++ thunk fname ++ "(void** block) {\n return " ++ +> quickcall fname ++ "(" ++ +> wrapperArgs (length args) ++ ");\n}\n\n" ++ +> wrappers xs +> wrappers (_:xs) = wrappers xs + +> wrapperArgs 0 = "" +> wrapperArgs 1 = "block[0]" +> wrapperArgs x = wrapperArgs (x-1) ++ ", block[" ++ show (x-1) ++ "]" + +> workers _ [] = "" +> workers ctxt ((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" ++ +> workers ctxt xs +> workers ctxt (_:xs) = workers ctxt xs + +> tmp v = "tmp" ++ show v +> loc v = "var" ++ show v + +> quickcall fn = "_do_" ++ showC fn +> thunk fn = "_wrap_" ++ showC fn + +> compileBody :: FunCode -> String +> compileBody (Code args bytecode) = +> let (code, b) = runState (cgs bytecode) 0 in +> if (b>0) then "void** block;\n" ++ code else code -- = EMALLOC("++show b++"*sizeof(void*));\n"++code else code +> where +> sizeneeded x = do +> max <- get +> if (x>max) then put x else return () + +> cgs [] = return "" +> cgs (x:xs) = do xc <- cg x +> xsc <- cgs xs +> return $ xc ++ "\n" ++ xsc + +> cg (CALL t fn args) = return $ tmp t ++ " = " ++ quickcall fn ++ +> targs "(" args ++ ");" +> cg (TAILCALL t fn args) = return $ "return " ++ quickcall fn ++ +> targs "(" args ++ ");" +> cg (THUNK t ar fn []) = do +> return $ tmp t ++ +> " = (void*)CLOSURE(" ++ thunk fn ++ ", " ++ +> show ar ++ ", 0, 0);" +> cg (THUNK t ar fn args) = do +> sizeneeded (length args) +> return $ argblock "block" args ++ tmp t ++ +> " = (void*)CLOSURE(" ++ thunk fn ++ ", " ++ +> show ar ++ "," ++ show (length args) ++ +> ", block);" +> cg (ADDARGS t th args) = do sizeneeded (length args) +> return $ closureApply t th args +> cg (FOREIGN ty t fn args) = return $ +> castFrom t ty +> (fn ++ "(" ++ foreignArgs args ++ ")") +> ++ ";" +> cg (VAR t l) = return $ tmp t ++ " = " ++ loc l ++ ";" +> cg (ASSIGN l t) = return $ loc l ++ " = " ++ tmp t ++ ";" +> cg (CON t tag args) = do sizeneeded (length args) +> return $ constructor t tag args +> cg (UNIT t) = return $ tmp t ++ " = MKUNIT;" +> cg (INT t i) = return $ "ASSIGNINT("++tmp t ++ ", " ++show i++");" +> cg (BIGINT t i) = return $ tmp t ++ " = NEWBIGINT(\"" ++show i++"\");" +> cg (FLOAT t i) = return $ tmp t ++ " = MKFLOAT("++show i++");" +> cg (BIGFLOAT t i) = return $ tmp t ++ " = NEWBIGFLOAT(\""++show i++"\");" +> cg (STRING t s) = return $ tmp t ++ " = MKSTR("++show s++");" +> cg (PROJ t1 t2 i) = return $ tmp t1 ++ " = PROJECT((Closure*)"++tmp t2++", "++show i++");" +> cg (PROJVAR l t i) = return $ loc l ++ " = PROJECT((Closure*)"++tmp t++", "++show i++");" +> cg (OP t op l r) = return $ doOp t op l r +> cg (LOCALS n) = return $ declare "void* " loc (length args) n +> cg (TMPS n) = return $ declare "void* " tmp 0 n +> cg (CASE v alts def) = do +> altscode <- cgalts alts def 0 +> return $ "assert(ISCON("++tmp v++"));\n" ++ +> "switch(TAG(" ++ tmp v ++")) {\n" ++ +> altscode +> ++ "}" +> cg (IF v t e) = do +> tcode <- cgs t +> ecode <- cgs e +> return $ "assert(ISINT("++tmp v++"));\n" ++ +> "if (GETINT("++tmp v++")) {\n" ++ tcode ++ "} else {\n" ++ +> ecode ++ "}" +> cg (EVAL v) = return $ tmp v ++ "=(void*)EVAL((VAL)"++tmp v++");" +> cg (RETURN t) = return $ "return "++tmp t++";" +> cg DRETURN = return $ "return NULL;" +> cg (ERROR s) = return $ "ERROR("++show s++");" +> cg (TRACE s args) = return $ "TRACE {\n\tprintf(\"%s\\n\", " ++ show s ++ ");\n" ++ +> concat (map dumpClosure args) ++ " }" +> where dumpClosure i +> = "\tdumpClosure(" ++ loc i ++ "); printf(\"--\\n\");\n" +> -- cg x = return $ "NOP; // not done " ++ show x + +> cgalts [] def _ = +> case def of +> Nothing -> return $ "" +> (Just bc) -> do bcode <- cgs bc +> return $ "default:\n" ++ bcode ++ "break;\n" +> cgalts ((t,bc):alts) def tag +> = do bcode <- cgs bc +> altscode <- cgalts alts def (tag+1) +> return $ "case "++ show t ++":\n" ++ +> bcode ++ "break;\n" ++ altscode + +> targs st [] = st +> targs st [x] = st ++ tmp x +> targs st (x:xs) = st ++ tmp x ++ targs ", " xs + +> argblock name [] = name ++ " = 0;\n" +> argblock name args = name ++ " = EMALLOC(sizeof(void*)*" ++ show (length args) ++ ");\n" ++ +> ab name args 0 +> ab nm [] i = "" +> ab nm (x:xs) i = nm ++ "[" ++ show i ++ "] = " ++ tmp x ++";\n" ++ +> ab nm xs (i+1) + +> constructor t tag [] +> = tmp t ++ " = CONSTRUCTOR(" ++ +> show tag ++ ", 0, 0);" +> constructor t tag args +> | length args < 3 && length args > 0 +> = tmp t ++ " = CONSTRUCTOR" ++ show (length args) ++ "(" ++ +> show tag ++ targs ", " args ++ ");" +> constructor t tag args = argblock "block" args ++ tmp t ++ +> " = (void*)CONSTRUCTOR(" ++ +> show tag ++ ", " ++ +> show (length args) ++ +> ", block);" + +> closureApply t th [] +> = tmp t ++ " = CLOSURE_APPLY((VAL)" ++ +> tmp th ++ ", 0, 0);" +> closureApply t th args +> | length args < 3 && length args > 0 +> = tmp t ++ " = CLOSURE_APPLY" ++ show (length args) ++ "((VAL)" ++ +> tmp th ++ targs ", " args ++ ");" +> closureApply t th args = argblock "block" args ++ tmp t ++ +> " = CLOSURE_APPLY((VAL)" ++ +> tmp th ++ ", " ++ +> show (length args) ++ +> ", block);" + +> declare decl fn start end +> | start == end = "" +> | otherwise = decl ++ fn start ++";\n" ++ +> declare decl fn (start+1) end + +> foreignArgs [] = "" +> foreignArgs [x] = foreignArg x +> foreignArgs (x:xs) = foreignArg x ++ ", " ++ foreignArgs xs + +> castFrom t TyUnit x = tmp t ++ " = NULL; " ++ x +> castFrom t TyString rest = tmp t ++ " = MKSTR((char*)(" ++ rest ++ "))" +> castFrom t TyPtr rest = tmp t ++ " = MKPTR(" ++ rest ++ ")" +> castFrom t TyInt rest = tmp t ++ " = MKINT((int)(" ++ rest ++ "))" +> castFrom t TyBigInt rest = tmp t ++ " = MKBIGINT((mpz_t*)(" ++ rest ++ "))" +> castFrom t _ rest = tmp t ++ " = (void*)(" ++ rest ++ ")" + +> foreignArg (t, TyInt) = "GETINT("++ tmp t ++")" +> foreignArg (t, TyBigInt) = "*(GETBIGINT("++ tmp t ++"))" +> foreignArg (t, TyString) = "GETSTR("++ tmp t ++")" +> foreignArg (t, TyPtr) = "GETPTR("++ tmp t ++")" +> foreignArg (t, _) = tmp t + +> doOp t Plus l r = tmp t ++ " = INTOP(+,"++tmp l ++ ", "++tmp r++");" +> doOp t Minus l r = tmp t ++ " = INTOP(-,"++tmp l ++ ", "++tmp r++");" +> doOp t Times l r = tmp t ++ " = INTOP(*,"++tmp l ++ ", "++tmp r++");" +> doOp t Divide l r = tmp t ++ " = INTOP(/,"++tmp l ++ ", "++tmp r++");" +> doOp t OpEQ l r = tmp t ++ " = INTOP(==,"++tmp l ++ ", "++tmp r++");" +> doOp t OpGT l r = tmp t ++ " = INTOP(>,"++tmp l ++ ", "++tmp r++");" +> doOp t OpLT l r = tmp t ++ " = INTOP(<,"++tmp l ++ ", "++tmp r++");" +> doOp t OpGE l r = tmp t ++ " = INTOP(>=,"++tmp l ++ ", "++tmp r++");" +> doOp t OpLE l r = tmp t ++ " = INTOP(<=,"++tmp l ++ ", "++tmp r++");" + diff --git a/Epic/Compiler.lhs b/Epic/Compiler.lhs new file mode 100644 --- /dev/null +++ b/Epic/Compiler.lhs @@ -0,0 +1,151 @@ +> -- | +> -- Module : EMachine.Compiler +> -- Copyright : Edwin Brady +> -- Licence : BSD-style (see LICENSE in the distribution) +> -- +> -- Maintainer : eb@dcs.st-and.ac.uk +> -- Stability : experimental +> -- Portability : portable +> -- +> -- Public interface for Epigram Supercombinator Compiler + +> module Epic.Compiler(CompileOptions(..), +> compile, +> compileOpts, +> link) where + +Brings everything together; parsing, checking, code generation + +> import System +> import System.IO +> import System.Directory +> import System.Environment + +> import Epic.Language +> import Epic.Parser +> import Epic.Scopecheck +> import Epic.CodegenC + +> import Paths_epic + +> -- | (Debugging) options to give to compiler +> data CompileOptions = KeepC -- ^ Keep intermediate C file +> | Trace -- ^ Generate trace at run-time (debug) +> | ShowBytecode -- ^ Show generated code +> | ShowParseTree -- ^ Show parse tree +> | GCCOpt String -- ^ Extra GCC option +> deriving Eq + +> addGCC :: [CompileOptions] -> String +> addGCC [] = "" +> addGCC ((GCCOpt s):xs) = s ++ " " ++ addGCC xs +> addGCC (_:xs) = addGCC xs + +> doTrace opts | elem Trace opts = " -DTRACEON" +> | otherwise = "" + +> -- |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 [] + +Chop off everything after the last / - get the directory a file is in + +> trimLast f = case span (\x -> x /= '/') (reverse f) of +> (eman, htap) -> reverse htap + +> compileOpts :: FilePath -- ^ Input file name +> -> FilePath -- ^ Output file name +> -> Maybe FilePath -- ^ Interface (.ei) file name, if desired +> -> [CompileOptions] -- Keep the C file +> -> IO () +> 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 -> do +> (tmpn,tmph) <- tempfile +> checked <- compileDecls (checkAll ds) tmph +> 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 +> -- 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) + +> 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 + +> -- |Link a collection of .o files into an executable +> link :: [FilePath] -- ^ Object files +> -> [FilePath] -- ^ Extra include files for main program +> -> FilePath -- ^ Executable filename +> -> IO () +> link infs extraIncs outf = do +> mainprog <- mkMain extraIncs +> fp <- getDataFileName "evm/closure.h" +> let libdir = trimLast fp +> let cmd = "gcc -x c -O2 -foptimize-sibling-calls " ++ mainprog ++ " -x none -L" ++ +> libdir++" -I"++libdir ++ " " ++ +> (concat (map (++" ") infs)) ++ +> " -levm -lgc -lpthread -lgmp -o "++outf +> -- putStrLn $ cmd +> exit <- system cmd +> if (exit /= ExitSuccess) +> then fail $ "Linking failed" +> else return () + +Output the main progam, adding any extra includes needed. +(Some libraries need the extra includes, notably SDL, to compile correctly. +Grr.) + +> mkMain :: [FilePath] -> IO FilePath +> mkMain extra = +> do mppath <- getDataFileName "evm/mainprog.c" +> mp <- readFile mppath +> (tmp, tmpH) <- tempfile +> hPutStr tmpH (concat (map (\x -> "#include <" ++ x ++ ">\n") extra)) +> hPutStr tmpH mp +> hClose tmpH +> return tmp + + -- |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) diff --git a/Epic/Language.lhs b/Epic/Language.lhs new file mode 100644 --- /dev/null +++ b/Epic/Language.lhs @@ -0,0 +1,165 @@ +> module Epic.Language where + +> import Control.Monad + +Raw data types. Int, Char, Bool are unboxed. + +> data Type = TyInt +> | TyChar +> | TyBool +> | TyFloat +> | TyBigInt +> | TyBigFloat +> | TyString +> | TyPtr +> | TyUnit +> | TyAny -- unchecked, polymorphic +> | TyData -- generic data type +> | TyFun -- any function +> 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 TyPtr = "Ptr" +> show TyUnit = "Unit" +> show TyAny = "Any" +> show TyData = "Data" +> show TyFun = "Fun" + +> data Const = MkInt Int +> | MkBigInt Integer +> | MkChar Char +> | MkFloat Float +> | MkBigFloat Double +> | MkString String +> | MkBool Bool +> | MkUnit +> deriving (Show, Eq) + +> data Name = UN String -- user name +> | MN String Int -- machine generated name +> deriving Eq + +> instance Show Name where +> show (UN str) = "_U_"++str +> show (MN str i) = "_M_"++show i++"_"++str + +> showuser (UN str) = str +> showuser (MN str i) = "["++str++"_"++show i++"]" + +> quotename [] = "" +> quotename ('_':cs) = "__"++quotename cs +> quotename ('\'':cs) = "_PR_"++quotename cs +> quotename ('?':cs) = "_QU_"++quotename cs +> quotename ('$':cs) = "_DO_"++quotename cs +> quotename ('#':cs) = "_HA_"++quotename cs +> quotename ('@':cs) = "_AT_"++quotename cs +> quotename (c:cs) = c:(quotename cs) + +> showC n = quotename (show n) + +> type Context = [(Name,([Type],Type))] -- Name, arg types, return type + +Get the arity of a definition in the context + +> arity x ctxt = case lookup x ctxt of +> Nothing -> error $ "No such function " ++ show x +> (Just (args,ret)) -> length args + +> type Tag = Int + +> data Expr = V Int -- Locally bound name +> | R Name -- Global reference +> | App Expr [Expr] -- Function application +> | LazyApp Expr [Expr] -- Lazy function application +> | Con Tag [Expr] -- Constructor, tags, arguments (fully applied) +> | Const Const -- a constant +> | Proj Expr Int -- Project argument +> | Case Expr [CaseAlt] +> | If Expr Expr Expr +> | Op Op Expr Expr -- Infix operator +> | Let Name Type Expr Expr -- Let binding +> | Error String -- Exit with error message +> | Impossible -- Claimed impossible to reach code +> | ForeignCall Type String [(Expr, Type)] -- Foreign function call +> deriving (Show, Eq) + +> data CaseAlt = Alt { alt_tag :: Tag, +> alt_args :: [(Name, Type)], -- bound arguments +> alt_expr :: Expr -- what to do +> } +> | DefaultCase { alt_expr :: Expr } +> deriving (Show, Eq) + +> instance Ord CaseAlt where -- only the tag matters +> compare (Alt t1 _ _) (Alt t2 _ _) = compare t1 t2 +> compare (Alt _ _ _) (DefaultCase _) = LT +> compare (DefaultCase _) (Alt _ _ _) = GT +> compare _ _ = EQ + +> data Op = Plus | Minus | Times | Divide | OpEQ | OpLT | OpLE | OpGT | OpGE +> deriving (Show, Eq) + +Supercombinator definitions + +> data Func = Bind { fun_args :: [(Name, Type)], +> locals :: Int, -- total number of locals +> defn :: Expr } +> deriving Show + +Programs + +> data Decl = Decl { fname :: Name, +> frettype :: Type, +> fdef :: Func } +> | Extern { fname :: Name, +> frettype :: Type, +> fargs :: [Type] } +> | Include String +> | Link String +> deriving Show + +> data Result r = Success r +> | Failure String String Int +> deriving (Show, Eq) +> +> instance Monad Result where +> (Success r) >>= k = k r +> (Failure err fn line) >>= k = Failure err fn line +> return = Success +> fail s = Failure s "(no file)" 0 +> +> instance MonadPlus Result where +> mzero = Failure "Error" "(no file)" 0 +> mplus (Success x) _ = (Success x) +> mplus (Failure _ _ _) y = y +> + + + +Some tests + + +foo x = let y = case x of + c1 a b -> a b + c2 c -> bar (c+2) + in y+3 + + + + + testctxt = [((UN "foo"),([TyData], TyInt)), + ((UN "bar"),([TyInt], TyInt))] + + testprog = Bind [TyData] 3 $ + Let (UN "y") TyInt (Case (V 0) + [Alt 0 [TyFun,TyInt] (App (V 1) [V 2]), + Alt 1 [TyInt] (App (R (UN "bar")) [Op Plus (V 1) (Const (MkInt 2))])]) + (Op Plus (V 1) (Const (MkInt 3))) + diff --git a/Epic/Lexer.lhs b/Epic/Lexer.lhs new file mode 100644 --- /dev/null +++ b/Epic/Lexer.lhs @@ -0,0 +1,267 @@ +> module Epic.Lexer where + +> import Char + +> import Epic.Language + +> type LineNumber = Int +> type P a = String -> String -> LineNumber -> Result a + +> getLineNo :: P LineNumber +> getLineNo = \s fn l -> Success l + +> getFileName :: P String +> getFileName = \s fn l -> Success fn + +> getContent :: P String +> getContent = \s fn l -> Success s + +> thenP :: P a -> (a -> P b) -> P b +> m `thenP` k = \s fn l -> +> case m s fn l of +> Success a -> k a s fn l +> Failure e f ln -> Failure e f ln + +> returnP :: a -> P a +> returnP a = \s fn l -> Success a +> +> failP :: String -> P a +> failP err = \s fn l -> Failure err fn l + +> catchP :: P a -> (String -> P a) -> P a +> catchP m k = \s fn l -> +> case m s fn l of +> Success a -> Success a +> Failure e f ln -> k e s fn l + +> happyError :: P a +> happyError = reportError "Parse error" + +> reportError :: String -> P a +> reportError err = getFileName `thenP` \fn -> +> getLineNo `thenP` \line -> +> getContent `thenP` \content -> +> failP (fn ++ ":" ++ show line ++ ":" ++ err ++ " at " ++ take 40 content ++ " ...") + +> data Token +> = TokenName Name +> | TokenString String +> | TokenInt Int +> | TokenFloat Float +> | TokenBigInt Integer +> | TokenBigFloat Double +> | TokenChar Char +> | TokenBool Bool +> | TokenIntType +> | TokenBigIntType +> | TokenCharType +> | TokenBoolType +> | TokenFloatType +> | TokenBigFloatType +> | TokenStringType +> | TokenPtrType +> | TokenUnitType +> | TokenAnyType +> | TokenDataType +> | TokenFunType +> | TokenForeign +> | TokenCInclude +> | TokenLink +> | TokenOB +> | TokenCB +> | TokenOCB +> | TokenCCB +> | TokenPlus +> | TokenMinus +> | TokenTimes +> | TokenDivide +> | TokenEquals +> | TokenEQ +> | TokenGE +> | TokenLE +> | TokenGT +> | TokenLT +> | TokenArrow +> | TokenColon +> | TokenUnit +> | TokenCon +> | TokenDefault +> | TokenLet +> | TokenCase +> | TokenOf +> | TokenIf +> | TokenThen +> | TokenElse +> | TokenIn +> | TokenLazy +> | TokenError +> | TokenImpossible +> | TokenProj +> | TokenSemi +> | TokenComma +> | TokenBar +> | TokenExtern +> | TokenInclude +> | TokenEOF +> deriving (Show, Eq) +> +> +> lexer :: (Token -> P a) -> P a +> lexer cont [] = cont TokenEOF [] +> lexer cont ('\n':cs) = \fn line -> lexer cont cs fn (line+1) +> lexer cont (c:cs) +> | isSpace c = \fn line -> lexer cont cs fn line +> | isAlpha c = lexVar cont (c:cs) +> | isDigit c = lexNum cont (c:cs) +> | c == '_' = lexVar cont (c:cs) +> lexer cont ('"':cs) = lexString cont cs +> lexer cont ('\'':cs) = lexChar cont cs +> lexer cont ('{':'-':cs) = lexerEatComment 0 cont cs +> lexer cont ('-':'-':cs) = lexerEatToNewline cont cs +> lexer cont ('-':'>':cs) = cont TokenArrow cs +> lexer cont ('(':cs) = cont TokenOB cs +> lexer cont (')':cs) = cont TokenCB cs +> lexer cont ('{':cs) = cont TokenOCB cs +> lexer cont ('}':cs) = cont TokenCCB cs +> lexer cont ('+':cs) = cont TokenPlus cs +> lexer cont ('-':cs) = cont TokenMinus cs +> lexer cont ('*':cs) = cont TokenTimes cs +> lexer cont ('/':cs) = cont TokenDivide cs +> lexer cont ('=':'=':cs) = cont TokenEQ cs +> lexer cont ('>':'=':cs) = cont TokenGE cs +> lexer cont ('<':'=':cs) = cont TokenLE cs +> lexer cont ('>':cs) = cont TokenGT cs +> lexer cont ('<':cs) = cont TokenLT cs +> lexer cont ('=':cs) = cont TokenEquals cs +> lexer cont (':':cs) = cont TokenColon cs +> lexer cont ('!':cs) = cont TokenProj cs +> lexer cont (';':cs) = cont TokenSemi cs +> lexer cont (',':cs) = cont TokenComma cs +> lexer cont ('|':cs) = cont TokenBar cs +> lexer cont ('%':cs) = lexSpecial cont cs +> lexer cont (c:cs) = lexError c cs + +> lexError c s l = failP (show l ++ ": Unrecognised token '" ++ [c] ++ "'\n") s l + +> lexerEatComment nls cont ('-':'}':cs) +> = \fn line -> lexer cont cs fn (line+nls) +> lexerEatComment nls cont ('\n':cs) = lexerEatComment (nls+1) cont cs +> lexerEatComment nls cont (c:cs) = lexerEatComment nls cont cs +> +> lexerEatToNewline cont ('\n':cs) +> = \fn line -> lexer cont cs fn (line+1) +> lexerEatToNewline cont (c:cs) = lexerEatToNewline cont cs + +> lexNum cont cs = case readNum cs of +> (num,'L':rest,isreal) -> +> cont (tok True num isreal) rest +> (num,rest,isreal) -> +> cont (tok False num isreal) rest +> where tok False num isreal | isreal = TokenFloat (read num) +> | otherwise = TokenInt (read num) +> tok True num isreal | isreal = TokenBigFloat (read num) +> | otherwise = TokenBigInt (read num) + +> readNum :: String -> (String,String,Bool) +> readNum x = rn' False "" x +> where rn' dot acc [] = (acc,[],dot) +> rn' False acc ('.':xs) | head xs /= '.' = rn' True (acc++".") xs +> rn' dot acc (x:xs) | isDigit x = rn' dot (acc++[x]) xs +> rn' dot acc ('e':'+':xs) = rn' True (acc++"e+") xs +> rn' dot acc ('e':'-':xs) = rn' True (acc++"e-") xs +> rn' dot acc ('e':xs) = rn' True (acc++"e") xs +> rn' dot acc xs = (acc,xs,dot) + +> lexString cont cs = +> \fn line -> +> case getstr cs of +> Just (str,rest,nls) -> cont (TokenString str) rest fn (nls+line) +> Nothing -> failP (fn++":"++show line++":Unterminated string contant") +> cs fn line + +> lexChar cont cs = +> \fn line -> +> case getchar cs of +> Just (str,rest) -> cont (TokenChar str) rest fn line +> Nothing -> +> failP (fn++":"++show line++":Unterminated character constant") +> cs fn line + +> isAllowed c = isAlpha c || isDigit c || c `elem` "_\'?#" + +> lexVar cont cs = +> case span isAllowed cs of +> -- Keywords +> ("Default",rest) -> cont TokenDefault rest +> -- Types +> ("Int",rest) -> cont TokenIntType rest +> ("Char",rest) -> cont TokenCharType rest +> ("Bool",rest) -> cont TokenBoolType rest +> ("Float",rest) -> cont TokenFloatType rest +> ("BigInt",rest) -> cont TokenBigIntType rest +> ("BigFloat",rest) -> cont TokenBigFloatType rest +> ("String",rest) -> cont TokenStringType rest +> ("Ptr",rest) -> cont TokenPtrType rest +> ("Unit",rest) -> cont TokenUnitType rest +> ("Data",rest) -> cont TokenDataType rest +> ("Fun",rest) -> cont TokenFunType rest +> ("Any",rest) -> cont TokenAnyType rest +> -- values +> ("unit",rest) -> cont TokenUnit rest +> ("Con",rest) -> cont TokenCon rest +> ("true",rest) -> cont (TokenBool True) rest +> ("false",rest) -> cont (TokenBool False) rest +> -- expressions +> ("let",rest) -> cont TokenLet rest +> ("case",rest) -> cont TokenCase rest +> ("of",rest) -> cont TokenOf rest +> ("if",rest) -> cont TokenIf rest +> ("then",rest) -> cont TokenThen rest +> ("else",rest) -> cont TokenElse rest +> ("in",rest) -> cont TokenIn rest +> ("lazy",rest) -> cont TokenLazy rest +> ("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 = +> case span isAllowed cs of +> ("include",rest) -> cont TokenCInclude rest +> ("link",rest) -> cont TokenLink rest +> (thing,rest) -> lexError '%' rest + +> mkname :: String -> Token +> mkname c = TokenName (UN c) + +> getstr :: String -> Maybe (String,String,Int) +> getstr cs = case getstr' "" cs 0 of +> Just (str,rest,nls) -> Just (reverse str,rest,nls) +> _ -> Nothing +> getstr' acc ('\"':xs) = \nl -> Just (acc,xs,nl) +> getstr' acc ('\\':'n':xs) = getstr' ('\n':acc) xs -- Newline +> getstr' acc ('\\':'r':xs) = getstr' ('\r':acc) xs -- CR +> getstr' acc ('\\':'t':xs) = getstr' ('\t':acc) xs -- Tab +> getstr' acc ('\\':'b':xs) = getstr' ('\b':acc) xs -- Backspace +> getstr' acc ('\\':'a':xs) = getstr' ('\a':acc) xs -- Alert +> getstr' acc ('\\':'f':xs) = getstr' ('\f':acc) xs -- Formfeed +> getstr' acc ('\\':'0':xs) = getstr' ('\0':acc) xs -- null +> getstr' acc ('\\':x:xs) = getstr' (x:acc) xs -- Literal +> getstr' acc ('\n':xs) = \nl ->getstr' ('\n':acc) xs (nl+1) -- Count the newline +> getstr' acc (x:xs) = getstr' (x:acc) xs +> getstr' _ _ = \nl -> Nothing + +> getchar :: String -> Maybe (Char,String) +> getchar ('\\':'n':'\'':xs) = Just ('\n',xs) -- Newline +> getchar ('\\':'r':'\'':xs) = Just ('\r',xs) -- CR +> getchar ('\\':'t':'\'':xs) = Just ('\t',xs) -- Tab +> getchar ('\\':'b':'\'':xs) = Just ('\b',xs) -- Backspace +> getchar ('\\':'a':'\'':xs) = Just ('\a',xs) -- Alert +> getchar ('\\':'f':'\'':xs) = Just ('\f',xs) -- Formfeed +> getchar ('\\':'0':'\'':xs) = Just ('\0',xs) -- null +> getchar ('\\':x:'\'':xs) = Just (x,xs) -- Literal +> getchar (x:'\'':xs) = Just (x,xs) +> getchar _ = Nothing diff --git a/Epic/OTTLang.lhs b/Epic/OTTLang.lhs new file mode 100644 --- /dev/null +++ b/Epic/OTTLang.lhs @@ -0,0 +1,20 @@ +> module Epic.OTTLang where + +> import Epic.Language + +Terms + +t = x | lam x. t | t t + | i t | hd(t) | tl(t) | + | switch(t) [t] + | TY + +> data OTTerm = OTRef Name -- Global or unresolved name +> | OTV Int -- Locally bound name +> | OTLam Name +> | OTApp OTTerm OTTerm +> | OTRec Tag OTTerm +> | OTHd OTTerm +> | OTTl OTTerm +> | OTSwitch OTTerm [OTTerm] +> | OTTY -- can't look at types, so dump them all here diff --git a/Epic/Parser.y b/Epic/Parser.y new file mode 100644 --- /dev/null +++ b/Epic/Parser.y @@ -0,0 +1,218 @@ +{ -- -*-Haskell-*- +{-# OPTIONS_GHC -fglasgow-exts #-} + +module Epic.Parser where + +import Char +import System.IO.Unsafe + +import Epic.Language +import Epic.Lexer + +} + +%name mkparse Program + +%tokentype { Token } +%monad { P } { thenP } { returnP } +%lexer { lexer } { TokenEOF } + + +%token + name { TokenName $$ } + string { TokenString $$ } + int { TokenInt $$ } + bigint { TokenBigInt $$ } + bool { TokenBool $$ } + float { TokenFloat $$ } + bigfloat { TokenBigFloat $$ } + char { TokenChar $$ } + inttype { TokenIntType } + biginttype { TokenBigIntType } + chartype { TokenCharType } + booltype { TokenBoolType } + floattype { TokenFloatType } + bigfloattype { TokenBigFloatType } + stringtype { TokenStringType } + ptrtype { TokenPtrType } + unittype { TokenUnitType } + funtype { TokenFunType } + datatype { TokenDataType } + anytype { TokenAnyType } + unit { TokenUnit } + con { TokenCon } + default { TokenDefault } + let { TokenLet } + case { TokenCase } + of { TokenOf } + if { TokenIf } + then { TokenThen } + else { TokenElse } + in { TokenIn } + lazy { TokenLazy } + foreign { TokenForeign } + errorcode { TokenError } + impossible { TokenImpossible } + '(' { TokenOB } + ')' { TokenCB } + '{' { TokenOCB } + '}' { TokenCCB } + '+' { TokenPlus } + '-' { TokenMinus } + '*' { TokenTimes } + '/' { TokenDivide } + '=' { TokenEquals } + eq { TokenEQ } + le { TokenLE } + ge { TokenGE } + '<' { TokenLT } + '>' { TokenGT } + ':' { TokenColon } + '!' { TokenProj } + ';' { TokenSemi } + ',' { TokenComma } + '|' { TokenBar } + arrow { TokenArrow } + cinclude { TokenCInclude } + extern { TokenExtern } + include { TokenInclude } + +%nonassoc NONE +%nonassoc lazy +%left LET +%left IF +%left eq +%left ';' +%left '<' '>' le ge +%left '+' '-' +%left '*' '/' +%nonassoc '!' +%nonassoc '(' + + +%% + +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 } + | biginttype { TyBigInt } + | chartype { TyChar } + | booltype { TyBool } + | floattype { TyFloat } + | bigfloattype { TyBigFloat } + | stringtype { TyString } + | ptrtype { TyPtr } + | unittype { TyUnit } + | anytype { TyAny } + | datatype { TyData } + | funtype { TyFun } + +Declaration :: { Decl } +Declaration: name '(' TypeList ')' arrow Type '=' Expr + { mkBind $1 (map snd $3) $6 (map fst $3) $8 } + | extern name '(' TypeList ')' arrow Type + { mkExtern $2 (map snd $4) $7 (map fst $4) } + | cinclude string { Include $2 } + + +TypeList :: { [(Name,Type)] } +TypeList : { [] } + | name ':' Type { [($1,$3)] } + | name ':' Type ',' TypeList { ($1,$3):$5 } + +Expr :: { Expr } +Expr : name { R $1 } + | '(' Expr ')' { $2 } + | Expr '(' ExprList ')' { App $1 $3 } + | lazy '(' Expr '(' ExprList ')' ')' { LazyApp $3 $5 } + | lazy '(' name ')' { LazyApp (R $3) [] } + | con int '(' ExprList ')' { Con $2 $4 } + | Const { Const $1 } + | Expr '!' int { Proj $1 $3 } + | let name ':' Type '=' Expr in Expr %prec LET { Let $2 $4 $6 $8 } + | Expr ';' Expr { Let (MN "unused" 0) TyUnit $1 $3 } + | if Expr then Expr else Expr %prec IF { If $2 $4 $6 } + | CaseExpr { $1 } + | MathExpr { $1 } + | errorcode string { Error $2 } + | impossible { Impossible } + | foreign Type string '(' ExprTypeList ')' + { ForeignCall $2 $3 $5 } + +CaseExpr :: { Expr } +CaseExpr : case Expr of '{' Alts '}' { Case $2 $5 } + +Alts :: { [CaseAlt] } +Alts : { [] } + | Alt { [$1] } + | Alt '|' Alts { $1:$3 } + +Alt :: { CaseAlt } +Alt : con int '(' TypeList ')' arrow Expr + { Alt $2 $4 $7 } + | default arrow Expr { DefaultCase $3 } + +MathExpr :: { Expr } +MathExpr : Expr '+' Expr { Op Plus $1 $3 } + | Expr '-' Expr { Op Minus $1 $3 } + | Expr '*' Expr { Op Times $1 $3 } + | Expr '/' Expr { Op Divide $1 $3 } + | Expr '<' Expr { Op OpLT $1 $3 } + | Expr '>' Expr { Op OpGT $1 $3 } + | Expr le Expr { Op OpLE $1 $3 } + | Expr ge Expr { Op OpGE $1 $3 } + | Expr eq Expr { Op OpEQ $1 $3 } + +ExprList :: { [Expr] } +ExprList : { [] } + | Expr { [$1] } + | Expr ',' ExprList { $1:$3 } + +ExprTypeList :: { [(Expr,Type)] } +ExprTypeList : { [] } + | Expr ':' Type { [($1,$3)] } + | Expr ':' Type ',' ExprTypeList { ($1,$3):$5 } + +Const :: { Const } +Const : int { MkInt $1 } + | bigint { MkBigInt $1 } + | char { MkChar $1 } + | bool { MkBool $1 } + | float { MkFloat $1 } + | bigfloat { MkBigFloat $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 + +parseFile :: FilePath -> IO (Result [Decl]) +parseFile fn = do s <- readFile fn + let x = parse s fn + return x + +} diff --git a/Epic/Scopecheck.lhs b/Epic/Scopecheck.lhs new file mode 100644 --- /dev/null +++ b/Epic/Scopecheck.lhs @@ -0,0 +1,101 @@ +> module Epic.Scopecheck where + +Check that an expression has all its names in scope. This is the only +checking we do (for now). + +> import Control.Monad.State + +> import Epic.Language +> import Epic.Parser + +> checkAll :: Monad m => [Decl] -> m (Context, [Decl]) +> checkAll xs = do let ctxt = mkContext xs +> ds <- ca (mkContext xs) xs +> return (ctxt,ds) +> where ca ctxt [] = return [] +> ca ctxt ((Decl nm rt fn):xs) = +> do fn' <- scopecheck ctxt fn +> xs' <- ca ctxt xs +> return $ (Decl nm rt fn'):xs' +> ca ctxt (x:xs) = +> do xs' <- ca ctxt xs +> return (x:xs') + +> mkContext [] = [] +> 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) +> mkContext (_:xs) = mkContext xs + +> scopecheck :: Monad m => Context -> Func -> m Func +> scopecheck ctxt (Bind args locs exp) = do +> (exp', locs') <- runStateT (tc (v_ise args 0) exp) (length args) +> return $ Bind args locs' exp' +> where +> tc env (R n) = case lookup n env of +> Nothing -> case lookup n ctxt of +> Nothing -> return $ Const (MkInt 1234567890) +> -- lift $ fail $ +> -- "Unknown name " ++ showuser n +> (Just _) -> return $ R n +> (Just i) -> return $ V i +> tc env (Let n ty v sc) = do +> v' <- tc env v +> sc' <- tc ((n,length env):env) sc +> maxlen <- get +> put (if (length env + 1)>maxlen +> then (length env + 1) +> else maxlen) +> return $ Let n ty v' sc' +> tc env (Case v alts) = do +> v' <- tc env v +> alts' <- tcalts env alts +> return $ Case v' alts' +> tc env (If a t e) = do +> a' <- tc env a +> t' <- tc env t +> e' <- tc env e +> return $ If a' t' e' +> tc env (App f as) = do +> f' <- tc env f +> as' <- mapM (tc env) as +> return $ App f' as' +> tc env (LazyApp f as) = do +> f' <- tc env f +> as' <- mapM (tc env) as +> return $ LazyApp f' as' +> tc env (Con t as) = do +> as' <- mapM (tc env) as +> return $ Con t as' +> tc env (Proj e i) = do +> e' <- tc env e +> return $ Proj e' i +> tc env (Op op l r) = do +> l' <- tc env l +> r' <- tc env r +> return $ Op op l' r' +> tc env (ForeignCall ty fn args) = do +> argexps' <- mapM (tc env) (map fst args) +> return $ ForeignCall ty fn (zip argexps' (map snd args)) +> tc env x = return x + +> tcalts env [] = return [] +> tcalts env ((Alt tag args expr):alts) = do +> let env' = (v_ise args (length env))++env +> expr' <- tc env' expr +> maxlen <- get +> put (if (length env')>maxlen +> then (length env') +> else maxlen) +> alts' <- tcalts env alts +> return $ (Alt tag args expr'):alts' +> tcalts env ((DefaultCase expr):alts) = do +> expr' <- tc env expr +> alts' <- tcalts env alts +> return $ (DefaultCase expr'):alts' + +Turn the argument list into a mapping from names to argument position + +> v_ise [] _ = [] +> v_ise ((n,ty):args) i = (n,i):(v_ise args (i+1)) diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,32 @@ +Copyright (c) 2006 Edwin Brady + School of Computer Science, University of St Andrews +All rights reserved. + +This code is derived from software written by Edwin Brady +(eb@dcs.st-and.ac.uk). + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. None of the names of the copyright holders may be used to endorse + or promote products derived from this software without specific + prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS ``AS IS'' AND ANY +EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR +BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE +OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN +IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +*** End of disclaimer. *** diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,26 @@ +import Distribution.Simple +import Distribution.PackageDescription + +import System + +-- After Epic is built, we need a run time system. + +-- FIXME: This is probably all done the wrong way, I don't really understand +-- Cabal properly... + +buildLib args flags desc local + = do exit <- system "make -C evm" + return () + +-- This is a hack. I don't know how to tell cabal that a data file needs +-- installing but shouldn't be in the distribution. And it won't make the +-- distribution if it's not there, so instead I just delete +-- the file after configure. + +postConfLib args flags desc local + = do exit <- system "make -C evm clean" + return () + +main = defaultMainWithHooks (simpleUserHooks { postBuild = buildLib, + postConf = postConfLib}) + diff --git a/dist/build/Epic/Parser.hs b/dist/build/Epic/Parser.hs new file mode 100644 --- /dev/null +++ b/dist/build/Epic/Parser.hs @@ -0,0 +1,1178 @@ +{-# OPTIONS -fglasgow-exts -cpp #-} +-- -*-Haskell-*- +{-# OPTIONS_GHC -fglasgow-exts #-} + +module Epic.Parser where + +import Char +import System.IO.Unsafe + +import Epic.Language +import Epic.Lexer +#if __GLASGOW_HASKELL__ >= 503 +import Data.Array +#else +import Array +#endif +#if __GLASGOW_HASKELL__ >= 503 +import GHC.Exts +#else +import GlaExts +#endif + +-- parser produced by Happy Version 1.16 + +newtype HappyAbsSyn = HappyAbsSyn (() -> ()) +happyIn4 :: ([Decl]) -> (HappyAbsSyn ) +happyIn4 x = unsafeCoerce# x +{-# INLINE happyIn4 #-} +happyOut4 :: (HappyAbsSyn ) -> ([Decl]) +happyOut4 x = unsafeCoerce# x +{-# INLINE happyOut4 #-} +happyIn5 :: (Type) -> (HappyAbsSyn ) +happyIn5 x = unsafeCoerce# x +{-# INLINE happyIn5 #-} +happyOut5 :: (HappyAbsSyn ) -> (Type) +happyOut5 x = unsafeCoerce# x +{-# INLINE happyOut5 #-} +happyIn6 :: (Decl) -> (HappyAbsSyn ) +happyIn6 x = unsafeCoerce# x +{-# INLINE happyIn6 #-} +happyOut6 :: (HappyAbsSyn ) -> (Decl) +happyOut6 x = unsafeCoerce# x +{-# INLINE happyOut6 #-} +happyIn7 :: ([(Name,Type)]) -> (HappyAbsSyn ) +happyIn7 x = unsafeCoerce# x +{-# INLINE happyIn7 #-} +happyOut7 :: (HappyAbsSyn ) -> ([(Name,Type)]) +happyOut7 x = unsafeCoerce# x +{-# INLINE happyOut7 #-} +happyIn8 :: (Expr) -> (HappyAbsSyn ) +happyIn8 x = unsafeCoerce# x +{-# INLINE happyIn8 #-} +happyOut8 :: (HappyAbsSyn ) -> (Expr) +happyOut8 x = unsafeCoerce# x +{-# INLINE happyOut8 #-} +happyIn9 :: (Expr) -> (HappyAbsSyn ) +happyIn9 x = unsafeCoerce# x +{-# INLINE happyIn9 #-} +happyOut9 :: (HappyAbsSyn ) -> (Expr) +happyOut9 x = unsafeCoerce# x +{-# INLINE happyOut9 #-} +happyIn10 :: ([CaseAlt]) -> (HappyAbsSyn ) +happyIn10 x = unsafeCoerce# x +{-# INLINE happyIn10 #-} +happyOut10 :: (HappyAbsSyn ) -> ([CaseAlt]) +happyOut10 x = unsafeCoerce# x +{-# INLINE happyOut10 #-} +happyIn11 :: (CaseAlt) -> (HappyAbsSyn ) +happyIn11 x = unsafeCoerce# x +{-# INLINE happyIn11 #-} +happyOut11 :: (HappyAbsSyn ) -> (CaseAlt) +happyOut11 x = unsafeCoerce# x +{-# INLINE happyOut11 #-} +happyIn12 :: (Expr) -> (HappyAbsSyn ) +happyIn12 x = unsafeCoerce# x +{-# INLINE happyIn12 #-} +happyOut12 :: (HappyAbsSyn ) -> (Expr) +happyOut12 x = unsafeCoerce# x +{-# INLINE happyOut12 #-} +happyIn13 :: ([Expr]) -> (HappyAbsSyn ) +happyIn13 x = unsafeCoerce# x +{-# INLINE happyIn13 #-} +happyOut13 :: (HappyAbsSyn ) -> ([Expr]) +happyOut13 x = unsafeCoerce# x +{-# INLINE happyOut13 #-} +happyIn14 :: ([(Expr,Type)]) -> (HappyAbsSyn ) +happyIn14 x = unsafeCoerce# x +{-# INLINE happyIn14 #-} +happyOut14 :: (HappyAbsSyn ) -> ([(Expr,Type)]) +happyOut14 x = unsafeCoerce# x +{-# INLINE happyOut14 #-} +happyIn15 :: (Const) -> (HappyAbsSyn ) +happyIn15 x = unsafeCoerce# x +{-# INLINE happyIn15 #-} +happyOut15 :: (HappyAbsSyn ) -> (Const) +happyOut15 x = unsafeCoerce# x +{-# INLINE happyOut15 #-} +happyIn16 :: (LineNumber) -> (HappyAbsSyn ) +happyIn16 x = unsafeCoerce# x +{-# INLINE happyIn16 #-} +happyOut16 :: (HappyAbsSyn ) -> (LineNumber) +happyOut16 x = unsafeCoerce# x +{-# INLINE happyOut16 #-} +happyIn17 :: (String) -> (HappyAbsSyn ) +happyIn17 x = unsafeCoerce# x +{-# INLINE happyIn17 #-} +happyOut17 :: (HappyAbsSyn ) -> (String) +happyOut17 x = unsafeCoerce# x +{-# INLINE happyOut17 #-} +happyInTok :: Token -> (HappyAbsSyn ) +happyInTok x = unsafeCoerce# x +{-# INLINE happyInTok #-} +happyOutTok :: (HappyAbsSyn ) -> Token +happyOutTok x = unsafeCoerce# x +{-# INLINE happyOutTok #-} + +happyActOffsets :: HappyAddr +happyActOffsets = HappyA# "\x01\x00\x04\x00\x00\x00\x04\x01\x1f\x01\x21\x01\xe2\x00\x01\x00\x12\x01\x01\x00\x00\x00\xf0\x00\x00\x00\x0d\x01\xe1\x00\xc6\x00\xff\x00\x00\x00\x00\x00\xce\x00\x20\x01\xae\x00\x20\x01\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x20\x01\xd5\x00\xaa\x00\x4b\x00\x00\x00\x00\x00\xda\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc7\x00\xbb\x00\x4b\x00\x4b\x00\x94\x00\x20\x01\xac\x00\x00\x00\x4b\x00\xb0\x00\x00\x00\xa7\x00\x28\x00\x62\x00\x4d\x00\x77\x00\x84\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\xa2\x00\x05\x00\xf6\x00\x00\x00\xed\xff\xed\xff\xed\xff\xed\xff\xe8\x00\xe1\xff\xe1\xff\xef\xff\xef\xff\x91\x00\x80\x00\x05\x00\x20\x01\x76\x00\x05\x00\xcc\x00\x72\x00\x65\x00\x00\x00\x05\x00\x00\x00\x05\x00\x70\x00\x2e\x00\x59\x00\x5f\x00\x00\x00\x05\x00\x00\x00\x00\x00\x05\x00\x61\x00\x51\x00\x75\x00\x3c\x00\x05\x00\x5e\x00\x9f\x00\x5d\x00\x00\x00\x20\x01\x4f\x00\xbe\x00\x05\x00\x4e\x00\x2e\x00\x00\x00\x83\x00\x05\x00\x00\x00\x6e\x00\xbe\x00\x00\x00\x35\x00\x05\x00\x44\x00\xbe\x00\x26\x00\x00\x00\x05\x00\xbe\x00\x00\x00"# + +happyGotoOffsets :: HappyAddr +happyGotoOffsets = HappyA# "\x32\x00\x5b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x31\x00\x00\x00\x0f\x00\x00\x00\x00\x00\x00\x00\x56\x00\x00\x00\x00\x00\x54\x00\x49\x00\x00\x00\x00\x00\x45\x00\x00\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3e\x00\x34\x00\x00\x00\xaf\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa7\x01\xa5\x01\x00\x00\x1b\x00\x00\x00\x00\x00\x9d\x01\x00\x00\x00\x00\x00\x00\x9b\x01\x00\x00\x00\x00\x00\x00\x00\x00\x4b\x01\x93\x01\x91\x01\x89\x01\x87\x01\x7f\x01\x7d\x01\x75\x01\x73\x01\x6b\x01\x00\x00\x69\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x01\x0d\x00\x00\x00\x61\x01\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x01\x00\x00\x39\x01\x00\x00\x2f\x00\x00\x00\x00\x00\x00\x00\x31\x01\x00\x00\x00\x00\x5f\x01\x00\x00\x00\x00\x00\x00\x00\x00\x57\x01\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x55\x01\x00\x00\x1c\x00\x00\x00\x00\x00\x4d\x01\x00\x00\xfe\xff\x00\x00\x00\x00\x00\x00\x50\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5a\x00\x00\x00\x00\x00"# + +happyDefActions :: HappyAddr +happyDefActions = HappyA# "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfe\xff\x00\x00\x00\x00\xfd\xff\x00\x00\xed\xff\xec\xff\x00\x00\x00\x00\xec\xff\xbb\xff\xfc\xff\x00\x00\x00\x00\x00\x00\x00\x00\xeb\xff\xfb\xff\xfa\xff\xf9\xff\xf8\xff\xf7\xff\xf6\xff\xf5\xff\xf4\xff\xf3\xff\xf0\xff\xf1\xff\xf2\xff\x00\x00\x00\x00\xec\xff\x00\x00\x00\x00\xea\xff\xee\xff\xef\xff\xde\xff\xdd\xff\xe3\xff\xe9\xff\xbe\xff\xc4\xff\xc3\xff\xc1\xff\xc0\xff\xbf\xff\xc2\xff\xbd\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdb\xff\x00\x00\x00\x00\xdc\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xca\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xff\xe2\xff\xce\xff\xcf\xff\xcc\xff\xcd\xff\xcb\xff\xd0\xff\xd1\xff\xd2\xff\xd3\xff\xc9\xff\x00\x00\xca\xff\x00\x00\x00\x00\x00\x00\x00\x00\xe9\xff\x00\x00\xe8\xff\xc7\xff\xe5\xff\xca\xff\x00\x00\xd8\xff\x00\x00\x00\x00\xe7\xff\xca\xff\xc8\xff\xe4\xff\x00\x00\x00\x00\xd7\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xda\xff\x00\x00\xe7\xff\xdf\xff\x00\x00\x00\x00\xd8\xff\xd9\xff\x00\x00\x00\x00\xd6\xff\xec\xff\xd4\xff\xe6\xff\xc6\xff\xc7\xff\x00\x00\xe1\xff\x00\x00\xc5\xff\x00\x00\xd5\xff"# + +happyCheck :: HappyAddr +happyCheck = HappyA# "\xff\xff\x03\x00\x01\x00\x01\x00\x23\x00\x01\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x01\x00\x00\x00\x23\x00\x02\x00\x23\x00\x32\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x29\x00\x2a\x00\x15\x00\x16\x00\x01\x00\x18\x00\x19\x00\x32\x00\x1b\x00\x32\x00\x06\x00\x07\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x00\x00\x00\x00\x02\x00\x02\x00\x06\x00\x07\x00\x03\x00\x37\x00\x38\x00\x39\x00\x37\x00\x38\x00\x15\x00\x16\x00\x01\x00\x18\x00\x19\x00\x01\x00\x1b\x00\x16\x00\x17\x00\x01\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x04\x00\x05\x00\x0d\x00\x03\x00\x08\x00\x03\x00\x0a\x00\x0b\x00\x36\x00\x02\x00\x04\x00\x05\x00\x15\x00\x16\x00\x08\x00\x18\x00\x19\x00\x0b\x00\x1b\x00\x1a\x00\x24\x00\x34\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x01\x00\x23\x00\x23\x00\x36\x00\x24\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x03\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x1c\x00\x32\x00\x33\x00\x24\x00\x24\x00\x24\x00\x2b\x00\x23\x00\x35\x00\x26\x00\x23\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x1d\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x23\x00\x32\x00\x33\x00\x24\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x25\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x1e\x00\x32\x00\x33\x00\x24\x00\x03\x00\x23\x00\x23\x00\x31\x00\x02\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x02\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x23\x00\x32\x00\x33\x00\x23\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x01\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x23\x00\x32\x00\x33\x00\x34\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x03\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x23\x00\x24\x00\x2b\x00\x01\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x36\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x23\x00\x32\x00\x33\x00\x36\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x34\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x23\x00\x32\x00\x33\x00\x24\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x31\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x23\x00\x32\x00\x33\x00\x01\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x24\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x23\x00\x32\x00\x33\x00\x01\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x23\x00\x02\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x23\x00\x32\x00\x33\x00\x3a\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x02\x00\x01\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x23\x00\x32\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x04\x00\x05\x00\xff\xff\xff\xff\x08\x00\x09\x00\xff\xff\x0b\x00\x04\x00\x05\x00\x04\x00\x05\x00\x08\x00\x09\x00\x08\x00\x0b\x00\x0a\x00\x0b\x00\x04\x00\x05\x00\xff\xff\xff\xff\x08\x00\x09\x00\xff\xff\x0b\x00\x04\x00\x05\x00\x04\x00\x05\x00\x08\x00\x09\x00\x08\x00\x0b\x00\xff\xff\x0b\x00\x04\x00\x05\x00\x04\x00\x05\x00\x08\x00\xff\xff\x08\x00\x0b\x00\xff\xff\x0b\x00\x04\x00\x05\x00\x04\x00\x05\x00\x08\x00\xff\xff\x08\x00\x0b\x00\xff\xff\x0b\x00\x04\x00\x05\x00\x04\x00\x05\x00\x08\x00\xff\xff\x08\x00\x0b\x00\xff\xff\x0b\x00\x04\x00\x05\x00\x04\x00\x05\x00\x08\x00\xff\xff\x08\x00\x0b\x00\xff\xff\x0b\x00\x04\x00\x05\x00\x04\x00\x05\x00\x08\x00\xff\xff\x08\x00\x0b\x00\xff\xff\x0b\x00\x04\x00\x05\x00\x04\x00\x05\x00\x08\x00\xff\xff\x08\x00\x0b\x00\xff\xff\x0b\x00\x04\x00\x05\x00\x04\x00\x05\x00\x08\x00\xff\xff\x08\x00\x0b\x00\xff\xff\x0b\x00\x04\x00\x05\x00\x04\x00\x05\x00\x08\x00\xff\xff\x08\x00\x0b\x00\xff\xff\x0b\x00\x04\x00\x05\x00\x04\x00\x05\x00\x08\x00\xff\xff\x08\x00\x0b\x00\xff\xff\x0b\x00\x04\x00\x05\x00\xff\xff\xff\xff\x08\x00\xff\xff\xff\xff\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# + +happyTable :: HappyAddr +happyTable = HappyA# "\x00\x00\x8e\x00\x04\x00\x8c\x00\x4a\x00\x04\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x6f\x00\x11\x00\x4a\x00\x07\x00\x4a\x00\x54\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4d\x00\x4e\x00\x38\x00\x39\x00\x43\x00\x3a\x00\x3b\x00\x54\x00\x3c\x00\x54\x00\x88\x00\x77\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x68\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x0a\x00\x06\x00\x07\x00\x07\x00\x76\x00\x77\x00\x29\x00\x05\x00\x06\x00\x09\x00\x05\x00\x06\x00\x38\x00\x39\x00\x2a\x00\x3a\x00\x3b\x00\x27\x00\x3c\x00\x79\x00\x7a\x00\x17\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x7c\x00\x2c\x00\x12\x00\x13\x00\x2d\x00\x0e\x00\x91\x00\x2e\x00\x93\x00\x02\x00\x93\x00\x2c\x00\x38\x00\x39\x00\x2d\x00\x3a\x00\x3b\x00\x2e\x00\x3c\x00\x65\x00\x91\x00\x8e\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x10\x00\x4a\x00\x8a\x00\x83\x00\x8c\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x84\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x66\x00\x54\x00\x55\x00\x7f\x00\x81\x00\x75\x00\x76\x00\x4a\x00\x85\x00\x86\x00\x6b\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x7b\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x4a\x00\x54\x00\x55\x00\x6c\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x6f\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x88\x00\x54\x00\x55\x00\x72\x00\x57\x00\x4a\x00\x63\x00\x64\x00\x69\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x43\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x4a\x00\x54\x00\x55\x00\x45\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x48\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x4a\x00\x54\x00\x55\x00\x73\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x49\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x80\x00\x54\x00\x55\x00\x4a\x00\x6a\x00\x29\x00\x10\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x26\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x4a\x00\x54\x00\x55\x00\x17\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x27\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x6d\x00\x54\x00\x55\x00\x25\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x15\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x4a\x00\x54\x00\x55\x00\x10\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x16\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x4a\x00\x54\x00\x55\x00\x10\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x11\x00\x0a\x00\x50\x00\x51\x00\x52\x00\x53\x00\x4a\x00\x54\x00\x55\x00\xff\xff\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x0d\x00\x0c\x00\x50\x00\x51\x00\x52\x00\x53\x00\x0e\x00\x54\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x60\x00\x2c\x00\x00\x00\x00\x00\x2d\x00\x73\x00\x00\x00\x2e\x00\x60\x00\x2c\x00\x7c\x00\x2c\x00\x2d\x00\x7b\x00\x2d\x00\x2e\x00\x7d\x00\x2e\x00\x60\x00\x2c\x00\x00\x00\x00\x00\x2d\x00\x70\x00\x00\x00\x2e\x00\x60\x00\x2c\x00\x8f\x00\x2c\x00\x2d\x00\x61\x00\x2d\x00\x2e\x00\x00\x00\x2e\x00\x8a\x00\x2c\x00\x81\x00\x2c\x00\x2d\x00\x00\x00\x2d\x00\x2e\x00\x00\x00\x2e\x00\x86\x00\x2c\x00\x6d\x00\x2c\x00\x2d\x00\x00\x00\x2d\x00\x2e\x00\x00\x00\x2e\x00\x55\x00\x2c\x00\x57\x00\x2c\x00\x2d\x00\x00\x00\x2d\x00\x2e\x00\x00\x00\x2e\x00\x58\x00\x2c\x00\x59\x00\x2c\x00\x2d\x00\x00\x00\x2d\x00\x2e\x00\x00\x00\x2e\x00\x5a\x00\x2c\x00\x5b\x00\x2c\x00\x2d\x00\x00\x00\x2d\x00\x2e\x00\x00\x00\x2e\x00\x5c\x00\x2c\x00\x5d\x00\x2c\x00\x2d\x00\x00\x00\x2d\x00\x2e\x00\x00\x00\x2e\x00\x5e\x00\x2c\x00\x5f\x00\x2c\x00\x2d\x00\x00\x00\x2d\x00\x2e\x00\x00\x00\x2e\x00\x66\x00\x2c\x00\x41\x00\x2c\x00\x2d\x00\x00\x00\x2d\x00\x2e\x00\x00\x00\x2e\x00\x45\x00\x2c\x00\x46\x00\x2c\x00\x2d\x00\x00\x00\x2d\x00\x2e\x00\x00\x00\x2e\x00\x2b\x00\x2c\x00\x00\x00\x00\x00\x2d\x00\x00\x00\x00\x00\x2e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# + +happyReduceArr = array (1, 68) [ + (1 , happyReduce_1), + (2 , happyReduce_2), + (3 , happyReduce_3), + (4 , happyReduce_4), + (5 , happyReduce_5), + (6 , happyReduce_6), + (7 , happyReduce_7), + (8 , happyReduce_8), + (9 , happyReduce_9), + (10 , happyReduce_10), + (11 , happyReduce_11), + (12 , happyReduce_12), + (13 , happyReduce_13), + (14 , happyReduce_14), + (15 , happyReduce_15), + (16 , happyReduce_16), + (17 , happyReduce_17), + (18 , happyReduce_18), + (19 , happyReduce_19), + (20 , happyReduce_20), + (21 , happyReduce_21), + (22 , happyReduce_22), + (23 , happyReduce_23), + (24 , happyReduce_24), + (25 , happyReduce_25), + (26 , happyReduce_26), + (27 , happyReduce_27), + (28 , happyReduce_28), + (29 , happyReduce_29), + (30 , happyReduce_30), + (31 , happyReduce_31), + (32 , happyReduce_32), + (33 , happyReduce_33), + (34 , happyReduce_34), + (35 , happyReduce_35), + (36 , happyReduce_36), + (37 , happyReduce_37), + (38 , happyReduce_38), + (39 , happyReduce_39), + (40 , happyReduce_40), + (41 , happyReduce_41), + (42 , happyReduce_42), + (43 , happyReduce_43), + (44 , happyReduce_44), + (45 , happyReduce_45), + (46 , happyReduce_46), + (47 , happyReduce_47), + (48 , happyReduce_48), + (49 , happyReduce_49), + (50 , happyReduce_50), + (51 , happyReduce_51), + (52 , happyReduce_52), + (53 , happyReduce_53), + (54 , happyReduce_54), + (55 , happyReduce_55), + (56 , happyReduce_56), + (57 , happyReduce_57), + (58 , happyReduce_58), + (59 , happyReduce_59), + (60 , happyReduce_60), + (61 , happyReduce_61), + (62 , happyReduce_62), + (63 , happyReduce_63), + (64 , happyReduce_64), + (65 , happyReduce_65), + (66 , happyReduce_66), + (67 , happyReduce_67), + (68 , happyReduce_68) + ] + +happy_n_terms = 59 :: Int +happy_n_nonterms = 14 :: Int + +happyReduce_1 = happySpecReduce_1 0# happyReduction_1 +happyReduction_1 happy_x_1 + = case happyOut6 happy_x_1 of { happy_var_1 -> + happyIn4 + ([happy_var_1] + )} + +happyReduce_2 = happySpecReduce_2 0# happyReduction_2 +happyReduction_2 happy_x_2 + happy_x_1 + = case happyOut6 happy_x_1 of { happy_var_1 -> + case happyOut4 happy_x_2 of { happy_var_2 -> + happyIn4 + (happy_var_1:happy_var_2 + )}} + +happyReduce_3 = happyMonadReduce 4# 0# happyReduction_3 +happyReduction_3 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_2 of { (TokenString happy_var_2) -> + case happyOut4 happy_x_3 of { happy_var_3 -> + case happyOut17 happy_x_4 of { happy_var_4 -> + ( + let rest = happy_var_3 in + let pt = unsafePerformIO (readFile happy_var_2) in + case (parse pt happy_var_4) of + Success x -> returnP (x ++ rest) + Failure err file ln -> failP err)}}} + ) (\r -> happyReturn (happyIn4 r)) + +happyReduce_4 = happySpecReduce_1 1# happyReduction_4 +happyReduction_4 happy_x_1 + = happyIn5 + (TyInt + ) + +happyReduce_5 = happySpecReduce_1 1# happyReduction_5 +happyReduction_5 happy_x_1 + = happyIn5 + (TyBigInt + ) + +happyReduce_6 = happySpecReduce_1 1# happyReduction_6 +happyReduction_6 happy_x_1 + = happyIn5 + (TyChar + ) + +happyReduce_7 = happySpecReduce_1 1# happyReduction_7 +happyReduction_7 happy_x_1 + = happyIn5 + (TyBool + ) + +happyReduce_8 = happySpecReduce_1 1# happyReduction_8 +happyReduction_8 happy_x_1 + = happyIn5 + (TyFloat + ) + +happyReduce_9 = happySpecReduce_1 1# happyReduction_9 +happyReduction_9 happy_x_1 + = happyIn5 + (TyBigFloat + ) + +happyReduce_10 = happySpecReduce_1 1# happyReduction_10 +happyReduction_10 happy_x_1 + = happyIn5 + (TyString + ) + +happyReduce_11 = happySpecReduce_1 1# happyReduction_11 +happyReduction_11 happy_x_1 + = happyIn5 + (TyPtr + ) + +happyReduce_12 = happySpecReduce_1 1# happyReduction_12 +happyReduction_12 happy_x_1 + = happyIn5 + (TyUnit + ) + +happyReduce_13 = happySpecReduce_1 1# happyReduction_13 +happyReduction_13 happy_x_1 + = happyIn5 + (TyAny + ) + +happyReduce_14 = happySpecReduce_1 1# happyReduction_14 +happyReduction_14 happy_x_1 + = happyIn5 + (TyData + ) + +happyReduce_15 = happySpecReduce_1 1# happyReduction_15 +happyReduction_15 happy_x_1 + = happyIn5 + (TyFun + ) + +happyReduce_16 = happyReduce 8# 2# happyReduction_16 +happyReduction_16 (happy_x_8 `HappyStk` + happy_x_7 `HappyStk` + happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_1 of { (TokenName happy_var_1) -> + case happyOut7 happy_x_3 of { happy_var_3 -> + case happyOut5 happy_x_6 of { happy_var_6 -> + case happyOut8 happy_x_8 of { happy_var_8 -> + happyIn6 + (mkBind happy_var_1 (map snd happy_var_3) happy_var_6 (map fst happy_var_3) happy_var_8 + ) `HappyStk` happyRest}}}} + +happyReduce_17 = happyReduce 7# 2# happyReduction_17 +happyReduction_17 (happy_x_7 `HappyStk` + happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_2 of { (TokenName happy_var_2) -> + case happyOut7 happy_x_4 of { happy_var_4 -> + case happyOut5 happy_x_7 of { happy_var_7 -> + happyIn6 + (mkExtern happy_var_2 (map snd happy_var_4) happy_var_7 (map fst happy_var_4) + ) `HappyStk` happyRest}}} + +happyReduce_18 = happySpecReduce_2 2# happyReduction_18 +happyReduction_18 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_2 of { (TokenString happy_var_2) -> + happyIn6 + (Include happy_var_2 + )} + +happyReduce_19 = happySpecReduce_0 3# happyReduction_19 +happyReduction_19 = happyIn7 + ([] + ) + +happyReduce_20 = happySpecReduce_3 3# happyReduction_20 +happyReduction_20 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { (TokenName happy_var_1) -> + case happyOut5 happy_x_3 of { happy_var_3 -> + happyIn7 + ([(happy_var_1,happy_var_3)] + )}} + +happyReduce_21 = happyReduce 5# 3# happyReduction_21 +happyReduction_21 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_1 of { (TokenName happy_var_1) -> + case happyOut5 happy_x_3 of { happy_var_3 -> + case happyOut7 happy_x_5 of { happy_var_5 -> + happyIn7 + ((happy_var_1,happy_var_3):happy_var_5 + ) `HappyStk` happyRest}}} + +happyReduce_22 = happySpecReduce_1 4# happyReduction_22 +happyReduction_22 happy_x_1 + = case happyOutTok happy_x_1 of { (TokenName happy_var_1) -> + happyIn8 + (R happy_var_1 + )} + +happyReduce_23 = happySpecReduce_3 4# happyReduction_23 +happyReduction_23 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut8 happy_x_2 of { happy_var_2 -> + happyIn8 + (happy_var_2 + )} + +happyReduce_24 = happyReduce 4# 4# happyReduction_24 +happyReduction_24 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut8 happy_x_1 of { happy_var_1 -> + case happyOut13 happy_x_3 of { happy_var_3 -> + happyIn8 + (App happy_var_1 happy_var_3 + ) `HappyStk` happyRest}} + +happyReduce_25 = happyReduce 7# 4# happyReduction_25 +happyReduction_25 (happy_x_7 `HappyStk` + happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut8 happy_x_3 of { happy_var_3 -> + case happyOut13 happy_x_5 of { happy_var_5 -> + happyIn8 + (LazyApp happy_var_3 happy_var_5 + ) `HappyStk` happyRest}} + +happyReduce_26 = happyReduce 4# 4# happyReduction_26 +happyReduction_26 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_3 of { (TokenName happy_var_3) -> + happyIn8 + (LazyApp (R happy_var_3) [] + ) `HappyStk` happyRest} + +happyReduce_27 = happyReduce 5# 4# happyReduction_27 +happyReduction_27 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_2 of { (TokenInt happy_var_2) -> + case happyOut13 happy_x_4 of { happy_var_4 -> + happyIn8 + (Con happy_var_2 happy_var_4 + ) `HappyStk` happyRest}} + +happyReduce_28 = happySpecReduce_1 4# happyReduction_28 +happyReduction_28 happy_x_1 + = case happyOut15 happy_x_1 of { happy_var_1 -> + happyIn8 + (Const happy_var_1 + )} + +happyReduce_29 = happySpecReduce_3 4# happyReduction_29 +happyReduction_29 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut8 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_3 of { (TokenInt happy_var_3) -> + happyIn8 + (Proj happy_var_1 happy_var_3 + )}} + +happyReduce_30 = happyReduce 8# 4# happyReduction_30 +happyReduction_30 (happy_x_8 `HappyStk` + happy_x_7 `HappyStk` + happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_2 of { (TokenName happy_var_2) -> + case happyOut5 happy_x_4 of { happy_var_4 -> + case happyOut8 happy_x_6 of { happy_var_6 -> + case happyOut8 happy_x_8 of { happy_var_8 -> + happyIn8 + (Let happy_var_2 happy_var_4 happy_var_6 happy_var_8 + ) `HappyStk` happyRest}}}} + +happyReduce_31 = happySpecReduce_3 4# happyReduction_31 +happyReduction_31 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut8 happy_x_1 of { happy_var_1 -> + case happyOut8 happy_x_3 of { happy_var_3 -> + happyIn8 + (Let (MN "unused" 0) TyUnit happy_var_1 happy_var_3 + )}} + +happyReduce_32 = happyReduce 6# 4# happyReduction_32 +happyReduction_32 (happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut8 happy_x_2 of { happy_var_2 -> + case happyOut8 happy_x_4 of { happy_var_4 -> + case happyOut8 happy_x_6 of { happy_var_6 -> + happyIn8 + (If happy_var_2 happy_var_4 happy_var_6 + ) `HappyStk` happyRest}}} + +happyReduce_33 = happySpecReduce_1 4# happyReduction_33 +happyReduction_33 happy_x_1 + = case happyOut9 happy_x_1 of { happy_var_1 -> + happyIn8 + (happy_var_1 + )} + +happyReduce_34 = happySpecReduce_1 4# happyReduction_34 +happyReduction_34 happy_x_1 + = case happyOut12 happy_x_1 of { happy_var_1 -> + happyIn8 + (happy_var_1 + )} + +happyReduce_35 = happySpecReduce_2 4# happyReduction_35 +happyReduction_35 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_2 of { (TokenString happy_var_2) -> + happyIn8 + (Error happy_var_2 + )} + +happyReduce_36 = happySpecReduce_1 4# happyReduction_36 +happyReduction_36 happy_x_1 + = happyIn8 + (Impossible + ) + +happyReduce_37 = happyReduce 6# 4# happyReduction_37 +happyReduction_37 (happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut5 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { (TokenString happy_var_3) -> + case happyOut14 happy_x_5 of { happy_var_5 -> + happyIn8 + (ForeignCall happy_var_2 happy_var_3 happy_var_5 + ) `HappyStk` happyRest}}} + +happyReduce_38 = happyReduce 6# 5# happyReduction_38 +happyReduction_38 (happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut8 happy_x_2 of { happy_var_2 -> + case happyOut10 happy_x_5 of { happy_var_5 -> + happyIn9 + (Case happy_var_2 happy_var_5 + ) `HappyStk` happyRest}} + +happyReduce_39 = happySpecReduce_0 6# happyReduction_39 +happyReduction_39 = happyIn10 + ([] + ) + +happyReduce_40 = happySpecReduce_1 6# happyReduction_40 +happyReduction_40 happy_x_1 + = case happyOut11 happy_x_1 of { happy_var_1 -> + happyIn10 + ([happy_var_1] + )} + +happyReduce_41 = happySpecReduce_3 6# happyReduction_41 +happyReduction_41 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut11 happy_x_1 of { happy_var_1 -> + case happyOut10 happy_x_3 of { happy_var_3 -> + happyIn10 + (happy_var_1:happy_var_3 + )}} + +happyReduce_42 = happyReduce 7# 7# happyReduction_42 +happyReduction_42 (happy_x_7 `HappyStk` + happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_2 of { (TokenInt happy_var_2) -> + case happyOut7 happy_x_4 of { happy_var_4 -> + case happyOut8 happy_x_7 of { happy_var_7 -> + happyIn11 + (Alt happy_var_2 happy_var_4 happy_var_7 + ) `HappyStk` happyRest}}} + +happyReduce_43 = happySpecReduce_3 7# happyReduction_43 +happyReduction_43 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut8 happy_x_3 of { happy_var_3 -> + happyIn11 + (DefaultCase happy_var_3 + )} + +happyReduce_44 = happySpecReduce_3 8# happyReduction_44 +happyReduction_44 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut8 happy_x_1 of { happy_var_1 -> + case happyOut8 happy_x_3 of { happy_var_3 -> + happyIn12 + (Op Plus happy_var_1 happy_var_3 + )}} + +happyReduce_45 = happySpecReduce_3 8# happyReduction_45 +happyReduction_45 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut8 happy_x_1 of { happy_var_1 -> + case happyOut8 happy_x_3 of { happy_var_3 -> + happyIn12 + (Op Minus happy_var_1 happy_var_3 + )}} + +happyReduce_46 = happySpecReduce_3 8# happyReduction_46 +happyReduction_46 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut8 happy_x_1 of { happy_var_1 -> + case happyOut8 happy_x_3 of { happy_var_3 -> + happyIn12 + (Op Times happy_var_1 happy_var_3 + )}} + +happyReduce_47 = happySpecReduce_3 8# happyReduction_47 +happyReduction_47 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut8 happy_x_1 of { happy_var_1 -> + case happyOut8 happy_x_3 of { happy_var_3 -> + happyIn12 + (Op Divide happy_var_1 happy_var_3 + )}} + +happyReduce_48 = happySpecReduce_3 8# happyReduction_48 +happyReduction_48 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut8 happy_x_1 of { happy_var_1 -> + case happyOut8 happy_x_3 of { happy_var_3 -> + happyIn12 + (Op OpLT happy_var_1 happy_var_3 + )}} + +happyReduce_49 = happySpecReduce_3 8# happyReduction_49 +happyReduction_49 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut8 happy_x_1 of { happy_var_1 -> + case happyOut8 happy_x_3 of { happy_var_3 -> + happyIn12 + (Op OpGT happy_var_1 happy_var_3 + )}} + +happyReduce_50 = happySpecReduce_3 8# happyReduction_50 +happyReduction_50 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut8 happy_x_1 of { happy_var_1 -> + case happyOut8 happy_x_3 of { happy_var_3 -> + happyIn12 + (Op OpLE happy_var_1 happy_var_3 + )}} + +happyReduce_51 = happySpecReduce_3 8# happyReduction_51 +happyReduction_51 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut8 happy_x_1 of { happy_var_1 -> + case happyOut8 happy_x_3 of { happy_var_3 -> + happyIn12 + (Op OpGE happy_var_1 happy_var_3 + )}} + +happyReduce_52 = happySpecReduce_3 8# happyReduction_52 +happyReduction_52 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut8 happy_x_1 of { happy_var_1 -> + case happyOut8 happy_x_3 of { happy_var_3 -> + happyIn12 + (Op OpEQ happy_var_1 happy_var_3 + )}} + +happyReduce_53 = happySpecReduce_0 9# happyReduction_53 +happyReduction_53 = happyIn13 + ([] + ) + +happyReduce_54 = happySpecReduce_1 9# happyReduction_54 +happyReduction_54 happy_x_1 + = case happyOut8 happy_x_1 of { happy_var_1 -> + happyIn13 + ([happy_var_1] + )} + +happyReduce_55 = happySpecReduce_3 9# happyReduction_55 +happyReduction_55 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut8 happy_x_1 of { happy_var_1 -> + case happyOut13 happy_x_3 of { happy_var_3 -> + happyIn13 + (happy_var_1:happy_var_3 + )}} + +happyReduce_56 = happySpecReduce_0 10# happyReduction_56 +happyReduction_56 = happyIn14 + ([] + ) + +happyReduce_57 = happySpecReduce_3 10# happyReduction_57 +happyReduction_57 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut8 happy_x_1 of { happy_var_1 -> + case happyOut5 happy_x_3 of { happy_var_3 -> + happyIn14 + ([(happy_var_1,happy_var_3)] + )}} + +happyReduce_58 = happyReduce 5# 10# happyReduction_58 +happyReduction_58 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut8 happy_x_1 of { happy_var_1 -> + case happyOut5 happy_x_3 of { happy_var_3 -> + case happyOut14 happy_x_5 of { happy_var_5 -> + happyIn14 + ((happy_var_1,happy_var_3):happy_var_5 + ) `HappyStk` happyRest}}} + +happyReduce_59 = happySpecReduce_1 11# happyReduction_59 +happyReduction_59 happy_x_1 + = case happyOutTok happy_x_1 of { (TokenInt happy_var_1) -> + happyIn15 + (MkInt happy_var_1 + )} + +happyReduce_60 = happySpecReduce_1 11# happyReduction_60 +happyReduction_60 happy_x_1 + = case happyOutTok happy_x_1 of { (TokenBigInt happy_var_1) -> + happyIn15 + (MkBigInt happy_var_1 + )} + +happyReduce_61 = happySpecReduce_1 11# happyReduction_61 +happyReduction_61 happy_x_1 + = case happyOutTok happy_x_1 of { (TokenChar happy_var_1) -> + happyIn15 + (MkChar happy_var_1 + )} + +happyReduce_62 = happySpecReduce_1 11# happyReduction_62 +happyReduction_62 happy_x_1 + = case happyOutTok happy_x_1 of { (TokenBool happy_var_1) -> + happyIn15 + (MkBool happy_var_1 + )} + +happyReduce_63 = happySpecReduce_1 11# happyReduction_63 +happyReduction_63 happy_x_1 + = case happyOutTok happy_x_1 of { (TokenFloat happy_var_1) -> + happyIn15 + (MkFloat happy_var_1 + )} + +happyReduce_64 = happySpecReduce_1 11# happyReduction_64 +happyReduction_64 happy_x_1 + = case happyOutTok happy_x_1 of { (TokenBigFloat happy_var_1) -> + happyIn15 + (MkBigFloat happy_var_1 + )} + +happyReduce_65 = happySpecReduce_1 11# happyReduction_65 +happyReduction_65 happy_x_1 + = case happyOutTok happy_x_1 of { (TokenString happy_var_1) -> + happyIn15 + (MkString happy_var_1 + )} + +happyReduce_66 = happySpecReduce_1 11# happyReduction_66 +happyReduction_66 happy_x_1 + = happyIn15 + (MkUnit + ) + +happyReduce_67 = happyMonadReduce 0# 12# happyReduction_67 +happyReduction_67 (happyRest) tk + = happyThen (( getLineNo) + ) (\r -> happyReturn (happyIn16 r)) + +happyReduce_68 = happyMonadReduce 0# 13# happyReduction_68 +happyReduction_68 (happyRest) tk + = happyThen (( getFileName) + ) (\r -> happyReturn (happyIn17 r)) + +happyNewToken action sts stk + = lexer(\tk -> + let cont i = happyDoAction i tk action sts stk in + case tk of { + TokenEOF -> happyDoAction 58# tk action sts stk; + TokenName happy_dollar_dollar -> cont 1#; + TokenString happy_dollar_dollar -> cont 2#; + TokenInt happy_dollar_dollar -> cont 3#; + TokenBigInt happy_dollar_dollar -> cont 4#; + TokenBool happy_dollar_dollar -> cont 5#; + TokenFloat happy_dollar_dollar -> cont 6#; + TokenBigFloat happy_dollar_dollar -> cont 7#; + TokenChar happy_dollar_dollar -> cont 8#; + TokenIntType -> cont 9#; + TokenBigIntType -> cont 10#; + TokenCharType -> cont 11#; + TokenBoolType -> cont 12#; + TokenFloatType -> cont 13#; + TokenBigFloatType -> cont 14#; + TokenStringType -> cont 15#; + TokenPtrType -> cont 16#; + TokenUnitType -> cont 17#; + TokenFunType -> cont 18#; + TokenDataType -> cont 19#; + TokenAnyType -> cont 20#; + TokenUnit -> cont 21#; + TokenCon -> cont 22#; + TokenDefault -> cont 23#; + TokenLet -> cont 24#; + TokenCase -> cont 25#; + TokenOf -> cont 26#; + TokenIf -> cont 27#; + TokenThen -> cont 28#; + TokenElse -> cont 29#; + TokenIn -> cont 30#; + TokenLazy -> cont 31#; + TokenForeign -> cont 32#; + TokenError -> cont 33#; + TokenImpossible -> cont 34#; + TokenOB -> cont 35#; + TokenCB -> cont 36#; + TokenOCB -> cont 37#; + TokenCCB -> cont 38#; + TokenPlus -> cont 39#; + TokenMinus -> cont 40#; + TokenTimes -> cont 41#; + TokenDivide -> cont 42#; + TokenEquals -> cont 43#; + TokenEQ -> cont 44#; + TokenLE -> cont 45#; + TokenGE -> cont 46#; + TokenLT -> cont 47#; + TokenGT -> cont 48#; + TokenColon -> cont 49#; + TokenProj -> cont 50#; + TokenSemi -> cont 51#; + TokenComma -> cont 52#; + TokenBar -> cont 53#; + TokenArrow -> cont 54#; + TokenCInclude -> cont 55#; + TokenExtern -> cont 56#; + TokenInclude -> cont 57#; + _ -> happyError' tk + }) + +happyError_ tk = happyError' tk + +happyThen :: () => P a -> (a -> P b) -> P b +happyThen = (thenP) +happyReturn :: () => a -> P a +happyReturn = (returnP) +happyThen1 = happyThen +happyReturn1 :: () => a -> P a +happyReturn1 = happyReturn +happyError' :: () => Token -> P a +happyError' tk = (\token -> happyError) tk + +mkparse = happySomeParser where + happySomeParser = happyThen (happyParse 0#) (\x -> happyReturn (happyOut4 x)) + +happySeq = happyDontSeq + + +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 + +parseFile :: FilePath -> IO (Result [Decl]) +parseFile fn = do s <- readFile fn + let x = parse s fn + return x +{-# LINE 1 "GenericTemplate.hs" #-} +{-# LINE 1 "GenericTemplate.hs" #-} +{-# LINE 1 "" #-} +{-# LINE 1 "" #-} +{-# LINE 1 "GenericTemplate.hs" #-} +-- Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp + +{-# LINE 28 "GenericTemplate.hs" #-} + + +data Happy_IntList = HappyCons Int# Happy_IntList + + + + + +{-# LINE 49 "GenericTemplate.hs" #-} + +{-# LINE 59 "GenericTemplate.hs" #-} + +{-# LINE 68 "GenericTemplate.hs" #-} + +infixr 9 `HappyStk` +data HappyStk a = HappyStk a (HappyStk a) + +----------------------------------------------------------------------------- +-- starting the parse + +happyParse start_state = happyNewToken start_state notHappyAtAll notHappyAtAll + +----------------------------------------------------------------------------- +-- Accepting the parse + +-- If the current token is 0#, it means we've just accepted a partial +-- parse (a %partial parser). We must ignore the saved token on the top of +-- the stack in this case. +happyAccept 0# tk st sts (_ `HappyStk` ans `HappyStk` _) = + happyReturn1 ans +happyAccept j tk st sts (HappyStk ans _) = + (happyTcHack j (happyTcHack st)) (happyReturn1 ans) + +----------------------------------------------------------------------------- +-- Arrays only: do the next action + + + +happyDoAction i tk st + = {- nothing -} + + + case action of + 0# -> {- nothing -} + happyFail i tk st + -1# -> {- nothing -} + happyAccept i tk st + n | (n <# (0# :: Int#)) -> {- nothing -} + + (happyReduceArr ! rule) i tk st + where rule = (I# ((negateInt# ((n +# (1# :: Int#)))))) + n -> {- nothing -} + + + happyShift new_state i tk st + where new_state = (n -# (1# :: Int#)) + where off = indexShortOffAddr happyActOffsets st + off_i = (off +# i) + check = if (off_i >=# (0# :: Int#)) + then (indexShortOffAddr happyCheck off_i ==# i) + else False + action | check = indexShortOffAddr happyTable off_i + | otherwise = indexShortOffAddr happyDefActions st + +{-# LINE 127 "GenericTemplate.hs" #-} + + +indexShortOffAddr (HappyA# arr) off = +#if __GLASGOW_HASKELL__ > 500 + narrow16Int# i +#elif __GLASGOW_HASKELL__ == 500 + intToInt16# i +#else + (i `iShiftL#` 16#) `iShiftRA#` 16# +#endif + where +#if __GLASGOW_HASKELL__ >= 503 + i = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low) +#else + i = word2Int# ((high `shiftL#` 8#) `or#` low) +#endif + high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) + low = int2Word# (ord# (indexCharOffAddr# arr off')) + off' = off *# 2# + + + + + +data HappyAddr = HappyA# Addr# + + + + +----------------------------------------------------------------------------- +-- HappyState data type (not arrays) + +{-# LINE 170 "GenericTemplate.hs" #-} + +----------------------------------------------------------------------------- +-- Shifting a token + +happyShift new_state 0# tk st sts stk@(x `HappyStk` _) = + let i = (case unsafeCoerce# x of { (I# (i)) -> i }) in +-- trace "shifting the error token" $ + happyDoAction i tk new_state (HappyCons (st) (sts)) (stk) + +happyShift new_state i tk st sts stk = + happyNewToken new_state (HappyCons (st) (sts)) ((happyInTok (tk))`HappyStk`stk) + +-- happyReduce is specialised for the common cases. + +happySpecReduce_0 i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happySpecReduce_0 nt fn j tk st@((action)) sts stk + = happyGoto nt j tk st (HappyCons (st) (sts)) (fn `HappyStk` stk) + +happySpecReduce_1 i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happySpecReduce_1 nt fn j tk _ sts@((HappyCons (st@(action)) (_))) (v1`HappyStk`stk') + = let r = fn v1 in + happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) + +happySpecReduce_2 i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happySpecReduce_2 nt fn j tk _ (HappyCons (_) (sts@((HappyCons (st@(action)) (_))))) (v1`HappyStk`v2`HappyStk`stk') + = let r = fn v1 v2 in + happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) + +happySpecReduce_3 i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happySpecReduce_3 nt fn j tk _ (HappyCons (_) ((HappyCons (_) (sts@((HappyCons (st@(action)) (_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk') + = let r = fn v1 v2 v3 in + happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) + +happyReduce k i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happyReduce k nt fn j tk st sts stk + = case happyDrop (k -# (1# :: Int#)) sts of + sts1@((HappyCons (st1@(action)) (_))) -> + let r = fn stk in -- it doesn't hurt to always seq here... + happyDoSeq r (happyGoto nt j tk st1 sts1 r) + +happyMonadReduce k nt fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happyMonadReduce k nt fn j tk st sts stk = + happyThen1 (fn stk tk) (\r -> happyGoto nt j tk st1 sts1 (r `HappyStk` drop_stk)) + where sts1@((HappyCons (st1@(action)) (_))) = happyDrop k (HappyCons (st) (sts)) + drop_stk = happyDropStk k stk + +happyMonad2Reduce k nt fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happyMonad2Reduce k nt fn j tk st sts stk = + happyThen1 (fn stk tk) (\r -> happyNewToken new_state sts1 (r `HappyStk` drop_stk)) + where sts1@((HappyCons (st1@(action)) (_))) = happyDrop k (HappyCons (st) (sts)) + drop_stk = happyDropStk k stk + + off = indexShortOffAddr happyGotoOffsets st1 + off_i = (off +# nt) + new_state = indexShortOffAddr happyTable off_i + + + + +happyDrop 0# l = l +happyDrop n (HappyCons (_) (t)) = happyDrop (n -# (1# :: Int#)) t + +happyDropStk 0# l = l +happyDropStk n (x `HappyStk` xs) = happyDropStk (n -# (1#::Int#)) xs + +----------------------------------------------------------------------------- +-- Moving to a new state after a reduction + + +happyGoto nt j tk st = + {- nothing -} + happyDoAction j tk new_state + where off = indexShortOffAddr happyGotoOffsets st + off_i = (off +# nt) + new_state = indexShortOffAddr happyTable off_i + + + + +----------------------------------------------------------------------------- +-- Error recovery (0# is the error token) + +-- parse error if we are in recovery and we fail again +happyFail 0# tk old_st _ stk = +-- trace "failing" $ + happyError_ tk + +{- We don't need state discarding for our restricted implementation of + "error". In fact, it can cause some bogus parses, so I've disabled it + for now --SDM + +-- discard a state +happyFail 0# tk old_st (HappyCons ((action)) (sts)) + (saved_tok `HappyStk` _ `HappyStk` stk) = +-- trace ("discarding state, depth " ++ show (length stk)) $ + happyDoAction 0# tk action sts ((saved_tok`HappyStk`stk)) +-} + +-- Enter error recovery: generate an error token, +-- save the old token and carry on. +happyFail i tk (action) sts stk = +-- trace "entering error recovery" $ + happyDoAction 0# tk action sts ( (unsafeCoerce# (I# (i))) `HappyStk` stk) + +-- Internal happy errors: + +notHappyAtAll = error "Internal Happy error\n" + +----------------------------------------------------------------------------- +-- Hack to get the typechecker to accept our action functions + + +happyTcHack :: Int# -> a -> a +happyTcHack x y = y +{-# INLINE happyTcHack #-} + + +----------------------------------------------------------------------------- +-- Seq-ing. If the --strict flag is given, then Happy emits +-- happySeq = happyDoSeq +-- otherwise it emits +-- happySeq = happyDontSeq + +happyDoSeq, happyDontSeq :: a -> b -> b +happyDoSeq a b = a `seq` b +happyDontSeq a b = b + +----------------------------------------------------------------------------- +-- Don't inline any functions from the template. GHC has a nasty habit +-- of deciding to inline happyGoto everywhere, which increases the size of +-- the generated parser quite a bit. + + +{-# NOINLINE happyDoAction #-} +{-# NOINLINE happyTable #-} +{-# NOINLINE happyCheck #-} +{-# NOINLINE happyActOffsets #-} +{-# NOINLINE happyGotoOffsets #-} +{-# NOINLINE happyDefActions #-} + +{-# NOINLINE happyShift #-} +{-# NOINLINE happySpecReduce_0 #-} +{-# NOINLINE happySpecReduce_1 #-} +{-# NOINLINE happySpecReduce_2 #-} +{-# NOINLINE happySpecReduce_3 #-} +{-# NOINLINE happyReduce #-} +{-# NOINLINE happyMonadReduce #-} +{-# NOINLINE happyGoto #-} +{-# NOINLINE happyFail #-} + +-- end of Happy Template. diff --git a/epic.cabal b/epic.cabal new file mode 100644 --- /dev/null +++ b/epic.cabal @@ -0,0 +1,27 @@ +Name: epic +Version: 0.1.2 +Author: Edwin Brady +License: BSD3 +License-file: LICENSE +Maintainer: eb@dcs.st-and.ac.uk +Homepage: http://www.dcs.st-and.ac.uk/~eb/epic.php +Stability: experimental +Category: Compilers/Interpreters +Synopsis: Compiler for a supercombinator language +Description: Epic is a simple functional language which compiles to + reasonably efficient C code, using the Boehm-Demers-Weiser + garbage collector. It is currently used as a back end for + the Idris dependently typed programming language. It is invoked + as a library, as it is intended as a compiler back end. + +Build-depends: base, haskell98, mtl, Cabal, array, directory +Build-type: Simple + +Extensions: MultiParamTypeClasses, FunctionalDependencies, + ExistentialQuantification, OverlappingInstances +Exposed-modules: Epic.Compiler +Other-modules: Epic.Bytecode Epic.Parser Epic.Scopecheck + Epic.Language Epic.Lexer Epic.CodegenC + Epic.OTTLang Paths_epic +Data-files: evm/libevm.a evm/closure.h evm/stdfuns.h evm/mainprog.c +Extra-source-files: evm/closure.c evm/closure.h evm/stdfuns.h evm/mainprog.c evm/Makefile diff --git a/evm/Makefile b/evm/Makefile new file mode 100644 --- /dev/null +++ b/evm/Makefile @@ -0,0 +1,22 @@ +CC = gcc +CFLAGS = -g -Wall # -O2 +OBJS = closure.o stdfuns.o +INSTALLDIR = ${PREFIX}/lib/evm + +TARGET = libevm.a +INSTALLHDRS = closure.h stdfuns.h mainprog.c + +${TARGET} : ${OBJS} + ar r ${TARGET} ${OBJS} + ranlib ${TARGET} + +install: + mkdir -p ${INSTALLDIR} + install libevm.a ${INSTALLHDRS} ${INSTALLDIR} + ranlib ${INSTALLDIR}/libevm.a + +clean: + rm -f ${OBJS} ${TARGET} + +closure.o : closure.h +stdfuns.o : stdfuns.h closure.h diff --git a/evm/closure.c b/evm/closure.c new file mode 100644 --- /dev/null +++ b/evm/closure.c @@ -0,0 +1,698 @@ +#include "closure.h" +#include +#include +#include +#include +#include + +VAL one; + +void dumpCon(con* c) { + printf("%d", c->tag); +} + +void dumpClosure(Closure* c) { + switch(GETTY(c)) { + case FUN: + printf("FUN["); + break; + case THUNK: + printf("THUNK["); + break; + case CON: + printf("CON["); + dumpCon((con*)c->info); + break; + case INT: + printf("INT[%d", ((int)c)>>1); + break; + case BIGINT: + printf("BIGINT["); + break; + case FLOAT: + printf("FLOAT["); + break; + case BIGFLOAT: + printf("BIGFLOAT["); + break; + case STRING: + printf("STRING["); + break; + case UNIT: + printf("UNIT["); + break; + case PTR: + printf("PTR["); + break; + case FREEVAR: + printf("FREEVAR["); + break; + default: + printf("[%d,%d", GETTY(c), (int)c->info); + } + printf("]\n"); +} + + +inline VAL CLOSURE(func x, int arity, int args, void** block) +{ + VAL c = EMALLOC(sizeof(Closure)+sizeof(fun)); // MKCLOSURE; + fun* fn = (fun*)(c+1); + fn->fn = x; + fn->arity = arity; + if (args==0) { + fn->args = 0; + fn->arg_end = 0; + } else { + fn->args = MKARGS(args); + fn->arg_end=fn->args+args; + memcpy((void*)(fn->args), (void*)block, args*sizeof(VAL)); + } + + SETTY(c, FUN); + c->info = (void*)fn; + return c; +} + +inline VAL CONSTRUCTOR(int tag, int arity, void** block) +{ + VAL c = EMALLOC(sizeof(Closure)+sizeof(con)); // MKCLOSURE; + con* cn = (con*)(c+1); + cn->tag = tag; + if (arity==0) { + cn->args = 0; + } else { + cn->args = MKARGS(arity); + memcpy((void*)(cn->args), (void*)block, arity*sizeof(VAL)); + } + SETTY(c, CON); + c->info = (void*)cn; + return c; +} + +inline VAL CONSTRUCTOR1(int tag, VAL a1) +{ + VAL c = EMALLOC(sizeof(Closure)+sizeof(con)); // MKCLOSURE; + con* cn = (con*)(c+1); + cn->tag = tag; + cn->args = MKARGS(1); + cn->args[0] = a1; + SETTY(c,CON); + c->info = (void*)cn; + return c; +} + +inline VAL CONSTRUCTOR2(int tag, VAL a1, VAL a2) +{ + VAL c = EMALLOC(sizeof(Closure)+sizeof(con)); // MKCLOSURE; + con* cn = (con*)(c+1); + cn->tag = tag; + cn->args = MKARGS(2); + cn->args[0] = a1; + cn->args[1] = a2; + SETTY(c,CON); + c->info = (void*)cn; + return c; +} + +inline VAL CONSTRUCTOR3(int tag, VAL a1, VAL a2, VAL a3) +{ + VAL c = EMALLOC(sizeof(Closure)+sizeof(con)); // MKCLOSURE; + con* cn = (con*)(c+1); + cn->tag = tag; + cn->args = MKARGS(3); + cn->args[0] = a1; + cn->args[1] = a2; + cn->args[2] = a3; + SETTY(c,CON); + c->info = (void*)cn; + return c; +} + +inline VAL CONSTRUCTOR4(int tag, VAL a1, VAL a2, VAL a3, VAL a4) +{ + VAL c = EMALLOC(sizeof(Closure)+sizeof(con)); // MKCLOSURE; + con* cn = (con*)(c+1); + cn->tag = tag; + cn->args = MKARGS(2); + cn->args[0] = a1; + cn->args[1] = a2; + cn->args[2] = a3; + cn->args[3] = a4; + SETTY(c,CON); + c->info = (void*)cn; + return c; +} + +inline VAL CONSTRUCTOR5(int tag, VAL a1, VAL a2, VAL a3, VAL a4, VAL a5) +{ + VAL c = EMALLOC(sizeof(Closure)+sizeof(con)); // MKCLOSURE; + con* cn = (con*)(c+1); + cn->tag = tag; + cn->args = MKARGS(5); + cn->args[0] = a1; + cn->args[1] = a2; + cn->args[2] = a3; + cn->args[3] = a4; + cn->args[4] = a5; + SETTY(c,CON); + c->info = (void*)cn; + return c; +} + +// This needs to make a copy +inline VAL CLOSURE_ADDN(VAL xin, int args, void** block) +{ + assert(GETTY(xin) == FUN); + + fun* finf = (fun*)xin->info; + + VAL x = CLOSURE(finf->fn, finf->arity, + finf->arg_end-finf->args, finf->args); + + fun* fn = (fun*)(x->info); + int diff = fn->arg_end - fn->args; + + fn->args = MOREARGS(fn->args, args + diff); + fn->arg_end = fn->args + diff; + + memcpy((void*)(fn->arg_end), (void*)block, args*sizeof(VAL)); + fn->arg_end += args; + return x; +} + +/* +VAL CLOSURE_ADDN(VAL xin, int args, void** block) +{ + switch(args) { + case 1: return CLOSURE_ADD1(xin,block[0]); + case 2: return CLOSURE_ADD2(xin,block[0],block[1]); + case 3: return CLOSURE_ADD3(xin,block[0],block[1],block[2]); + case 4: return CLOSURE_ADD4(xin,block[0],block[1],block[2],block[3]); + case 5: return CLOSURE_ADD5(xin,block[0],block[1],block[2],block[3],block[4]); + default: return aux_CLOSURE_ADDN(xin,args,block); + } +} +*/ + +inline VAL CLOSURE_ADD1(VAL xin, VAL a1) +{ + assert(GETTY(xin)==FUN); + + fun* finf = (fun*)xin->info; + + VAL x = CLOSURE(finf->fn, finf->arity, + finf->arg_end-finf->args, finf->args); + + fun* fn = (fun*)(x->info); + int diff = fn->arg_end - fn->args; + + fn->args = MOREARGS(fn->args, diff + 1); + fn->arg_end = fn->args + diff; + fn->arg_end[0] = a1; + fn->arg_end+=1; + + return x; +} + +inline VAL CLOSURE_ADD2(VAL xin, VAL a1, VAL a2) +{ + assert(GETTY(xin)==FUN); + + fun* finf = (fun*)xin->info; + + VAL x = CLOSURE(finf->fn, finf->arity, + finf->arg_end-finf->args, finf->args); + + fun* fn = (fun*)(x->info); + int diff = fn->arg_end - fn->args; + + fn->args = MOREARGS(fn->args, diff + 2); + fn->arg_end = fn->args + diff; + fn->arg_end[0] = a1; + fn->arg_end[1] = a2; + fn->arg_end+=2; + + return x; +} + +inline VAL CLOSURE_ADD3(VAL xin, VAL a1, VAL a2, VAL a3) +{ + assert(GETTY(xin)==FUN); + + fun* finf = (fun*)xin->info; + + VAL x = CLOSURE(finf->fn, finf->arity, + finf->arg_end-finf->args, finf->args); + + fun* fn = (fun*)(x->info); + int diff = fn->arg_end - fn->args; + + fn->args = MOREARGS(fn->args, diff + 3); + fn->arg_end = fn->args + diff; + fn->arg_end[0] = a1; + fn->arg_end[1] = a2; + fn->arg_end[2] = a3; + fn->arg_end+=3; + + return x; +} + +inline VAL CLOSURE_ADD4(VAL xin, VAL a1, VAL a2, VAL a3, VAL a4) +{ + assert(GETTY(xin)==FUN); + + fun* finf = (fun*)xin->info; + + VAL x = CLOSURE(finf->fn, finf->arity, + finf->arg_end-finf->args, finf->args); + + fun* fn = (fun*)(x->info); + int diff = fn->arg_end - fn->args; + + fn->args = MOREARGS(fn->args, diff + 4); + fn->arg_end = fn->args + diff; + fn->arg_end[0] = a1; + fn->arg_end[1] = a2; + fn->arg_end[2] = a3; + fn->arg_end[3] = a4; + fn->arg_end+=4; + + return x; +} + +inline VAL CLOSURE_ADD5(VAL xin, VAL a1, VAL a2, VAL a3, VAL a4, VAL a5) +{ + assert(GETTY(xin)==FUN); + + fun* finf = (fun*)xin->info; + + VAL x = CLOSURE(finf->fn, finf->arity, + finf->arg_end-finf->args, finf->args); + + fun* fn = (fun*)(x->info); + int diff = fn->arg_end - fn->args; + + fn->args = MOREARGS(fn->args, diff + 5); + fn->arg_end = fn->args + diff; + fn->arg_end[0] = a1; + fn->arg_end[1] = a2; + fn->arg_end[2] = a3; + fn->arg_end[3] = a4; + fn->arg_end[4] = a5; + fn->arg_end+=2; + + return x; +} + +inline VAL CLOSURE_APPLY(VAL f, int args, void** block) +{ + VAL c = EMALLOC(sizeof(Closure)+sizeof(thunk)); // MKCLOSURE; + thunk* fn = (thunk*)(c+1); + + if (ISFUN(f)) { + return CLOSURE_ADDN(f,args,block); + } + + fn->fn = (void*)f; + fn->numargs = args; + if (args==0) { + fn->args = 0; + } else { + fn->args = MKARGS(args); + memcpy((void*)(fn->args), (void*)block, args*sizeof(VAL)); + } + + SETTY(c,THUNK); + c->info = (void*)fn; + return c; +} + +inline VAL aux_CLOSURE_APPLY1(VAL f, VAL a1) +{ + VAL c = EMALLOC(sizeof(Closure)+sizeof(thunk)); // MKCLOSURE; + thunk* fn = (thunk*)(c+1); + + if (ISFUN(f)) { + return CLOSURE_ADD1(f,a1); + } + + fn->fn = (void*)f; + fn->numargs = 1; + fn->args = MKARGS(1); + fn->args[0] = a1; + + SETTY(c,THUNK); + c->info = (void*)fn; + return c; +} + +inline VAL aux_CLOSURE_APPLY2(VAL f, VAL a1, VAL a2) +{ + VAL c = EMALLOC(sizeof(Closure)+sizeof(thunk)); // MKCLOSURE; + thunk* fn = (thunk*)(c+1); + + if (ISFUN(f)) { + return CLOSURE_ADD2(f,a1,a2); + } + + fn->fn = (void*)f; + fn->numargs = 2; + fn->args = MKARGS(2); + fn->args[0] = a1; + fn->args[1] = a2; + + SETTY(c,THUNK); + c->info = (void*)fn; + return c; +} + +inline VAL aux_CLOSURE_APPLY3(VAL f, VAL a1, VAL a2, VAL a3) +{ + VAL c = EMALLOC(sizeof(Closure)+sizeof(thunk)); // MKCLOSURE; + thunk* fn = (thunk*)(c+1); + + if (ISFUN(f)) { + return CLOSURE_ADD3(f,a1,a2,a3); + } + + fn->fn = (void*)f; + fn->numargs = 2; + fn->args = MKARGS(3); + fn->args[0] = a1; + fn->args[1] = a2; + fn->args[2] = a3; + + SETTY(c,THUNK); + c->info = (void*)fn; + return c; +} + +inline VAL aux_CLOSURE_APPLY4(VAL f, VAL a1, VAL a2, VAL a3, VAL a4) +{ + VAL c = EMALLOC(sizeof(Closure)+sizeof(thunk)); // MKCLOSURE; + thunk* fn = (thunk*)(c+1); + + if (ISFUN(f)) { + return CLOSURE_ADD4(f,a1,a2,a3,a4); + } + + fn->fn = (void*)f; + fn->numargs = 2; + fn->args = MKARGS(4); + fn->args[0] = a1; + fn->args[1] = a2; + fn->args[2] = a3; + fn->args[3] = a4; + + SETTY(c,THUNK); + c->info = (void*)fn; + return c; +} + +inline VAL aux_CLOSURE_APPLY5(VAL f, VAL a1, VAL a2, VAL a3, VAL a4, VAL a5) +{ + VAL c = EMALLOC(sizeof(Closure)+sizeof(thunk)); // MKCLOSURE; + thunk* fn = (thunk*)(c+1); + + if (ISFUN(f)) { + return CLOSURE_ADD5(f,a1,a2,a3,a4,a5); + } + + fn->fn = (void*)f; + fn->numargs = 2; + fn->args = MKARGS(5); + fn->args[0] = a1; + fn->args[1] = a2; + fn->args[2] = a3; + fn->args[3] = a4; + fn->args[4] = a5; + + SETTY(c,THUNK); + c->info = (void*)fn; + return c; +} + +inline VAL CLOSURE_APPLY1(VAL f, VAL a1) +{ + if (ISFUN(f)) { + fun* finf = (fun*)(f->info); + int got = finf->arg_end-finf->args; + if (finf->arity == (got+1)) { + void* block[got+1]; + memcpy(block, finf->args, got*sizeof(VAL)); + block[got] = a1; + return (VAL)(finf->fn(block)); + } + else return CLOSURE_ADD1(f,a1); + } + else return aux_CLOSURE_APPLY1(f,a1); +} + +inline VAL CLOSURE_APPLY2(VAL f, VAL a1, VAL a2) +{ + if (ISFUN(f)) { + fun* finf = (fun*)(f->info); + int got = finf->arg_end-finf->args; + if (finf->arity == (got+2)) { + void* block[got+2]; + memcpy(block, finf->args, got*sizeof(VAL)); + block[got] = a1; + block[got+1] = a2; + return (VAL)(finf->fn(block)); + } + else return CLOSURE_ADD2(f,a1,a2); + } + else return aux_CLOSURE_APPLY2(f,a1,a2); +} + +inline VAL CLOSURE_APPLY3(VAL f, VAL a1, VAL a2, VAL a3) +{ + if (ISFUN(f)) { + fun* finf = (fun*)(f->info); + int got = finf->arg_end-finf->args; + if (finf->arity == (got+3)) { + void* block[got+3]; + memcpy(block, finf->args, got*sizeof(VAL)); + block[got] = a1; + block[got+1] = a2; + block[got+2] = a3; + return (VAL)(finf->fn(block)); + } + else return CLOSURE_ADD3(f,a1,a2,a3); + } + else return aux_CLOSURE_APPLY3(f,a1,a2,a3); +} + +inline VAL CLOSURE_APPLY4(VAL f, VAL a1, VAL a2, VAL a3, VAL a4) +{ + if (ISFUN(f)) { + fun* finf = (fun*)(f->info); + int got = finf->arg_end-finf->args; + if (finf->arity == (got+4)) { + void* block[got+4]; + memcpy(block, finf->args, got*sizeof(VAL)); + block[got] = a1; + block[got+1] = a2; + block[got+2] = a3; + block[got+3] = a4; + return (VAL)(finf->fn(block)); + } + else return CLOSURE_ADD4(f,a1,a2,a3,a4); + } + else return aux_CLOSURE_APPLY4(f,a1,a2,a3,a4); +} + +inline VAL CLOSURE_APPLY5(VAL f, VAL a1, VAL a2, VAL a3, VAL a4, VAL a5) +{ + if (ISFUN(f)) { + fun* finf = (fun*)(f->info); + int got = finf->arg_end-finf->args; + if (finf->arity == (got+5)) { + void* block[got+5]; + memcpy(block, finf->args, got*sizeof(VAL)); + block[got] = a1; + block[got+1] = a2; + block[got+2] = a3; + block[got+3] = a4; + block[got+4] = a5; + return (VAL)(finf->fn(block)); + } + else return CLOSURE_ADD5(f,a1,a2,a3,a4,a5); + } + else return aux_CLOSURE_APPLY5(f,a1,a2,a3,a4,a5); +} + +VAL DO_EVAL(VAL x) { +// dummy value we'll never inspect, leave it alone. + if (x==NULL) return x; + + VAL result; +// VAL x = (VAL)(*xin); + fun* fn; + thunk* th; + int excess; + +// dumpClosure(x); + + switch(GETTY(x)) { + case CON: + case INT: + case FLOAT: + case STRING: + case PTR: + case UNIT: + return x; // Already evaluated + case FUN: + // If the number of arguments is right, run it. + fn = (fun*)(x->info); + excess = (fn->arg_end - fn->args) - fn->arity; + if (excess == 0) { + result = fn->fn(fn->args); + // If the result is still a function, better eval again to make + // more progress. + // It could reasonably be null though, so be careful. It's null + // if it was a foreign/io call in particular. + if (result) { + if (GETTY(result)==FUN || GETTY(result)==THUNK) { + result=DO_EVAL(result); + } +/* if (ISINT(result)) { + printf("Updating with %d\n", x); + } else { + printf("Updating %d %d with %d\n", x, GETTY(x), result); + }*/ + UPDATE(x,result); + } + else { + SETTY(x, INT); x->info=(void*)42; + } + } + // If there are too many arguments, run it with the right number + // then apply the remaining arguments to the resulting closure + else if (excess > 0) { + result = fn->fn(fn->args); + result = CLOSURE_APPLY(result, excess, fn->args + fn->arity); + result = DO_EVAL(result); + UPDATE(x,result); + return x; + } + break; + case THUNK: + th = (thunk*)(x->info); + // Evaluate inner thunk, which should give us a function + th->fn = DO_EVAL((VAL)(th->fn)); + // Apply this thunk's arguments to it + CLOSURE_APPLY((VAL)th->fn, th->numargs, th->args); + // And off we go again... + th->fn = DO_EVAL((VAL)(th->fn)); + UPDATE(x,((VAL)(th->fn))); + return x; + break; + default: + assert(0); // Can't happen + } + return x; +} + +/* +void* DO_PROJECT(VAL x, int arg) +{ + assert(x->ty == CON); + con* cn = (con*)x->info; + return cn->args[arg]; +} +*/ + +void* MKINT(int x) +{ + return (void*)((x<<1)+1); +// VAL c = MKCLOSURE; +// SETTY(c, INT); +// c->info = (void*)x; +// return c; +} + +void* NEWBIGINT(char* intstr) +{ + mpz_t* bigint; + VAL c = EMALLOC(sizeof(Closure)+sizeof(mpz_t)); + bigint = (mpz_t*)(c+1); + mpz_init(*bigint); + mpz_set_str(*bigint, intstr, 10); + + SETTY(c, BIGINT); + c->info = (void*)bigint; + return c; +} + +void* MKBIGINT(mpz_t* big) +{ + mpz_t* bigint; + VAL c = EMALLOC(sizeof(Closure)+sizeof(mpz_t)); + bigint = (mpz_t*)(c+1); + mpz_init(*bigint); + mpz_set(*bigint, *big); + + SETTY(c, BIGINT); + c->info = (void*)bigint; + return c; +} + +int GETINT(void* x) +{ + return ((int)x)>>1; +} + +mpz_t* GETBIGINT(void* x) +{ + return ((mpz_t*)(((VAL)x)->info)); +} + + +void* MKSTR(char* x) +{ + VAL c = MKCLOSURE; + SETTY(c, STRING); + c->info = (void*)(EMALLOC(strlen(x)*sizeof(char)+1)); + strcpy(c->info,x); + return c; +} + +void* MKPTR(void* x) +{ + VAL c = MKCLOSURE; + SETTY(c, PTR); + c->info = x; + return c; +} + +char* GETSTR(void* x) +{ + return (char*)(((VAL)x)->info); +} + +void* GETPTR(void* x) +{ + return (void*)(((VAL)x)->info); +} + +void ERROR(char* msg) +{ + printf("*** error : %s ***\n",msg); + assert(0); + exit(1); +} + +void* MKFREE(int x) +{ + VAL c = MKCLOSURE; + SETTY(c, FREEVAR); + c->info = (void*)x; + return c; +} + +void init_evm() +{ + one = MKINT(1); +} diff --git a/evm/closure.h b/evm/closure.h new file mode 100644 --- /dev/null +++ b/evm/closure.h @@ -0,0 +1,162 @@ +#ifndef _CLOSURE_H +#define _CLOSURE_H + +# ifndef WIN32 +# include +# define GC_THREADS +# else +# define GC_WIN32_THREADS +# endif + +#include +#include +#include +#include + +#define EMALLOC GC_MALLOC +#define EREALLOC GC_REALLOC +#define EFREE GC_FREE + +#define MKCON (con*)EMALLOC(sizeof(con)) +#define MKFUN (fun*)EMALLOC(sizeof(fun)) +#define MKTHUNK (thunk*)EMALLOC(sizeof(thunk)) +#define MKCLOSURE (Closure*)EMALLOC(sizeof(Closure)) +#define MKUNIT (void*)0 + +#define INTOP(op,x,y) MKINT((((int)x)>>1) op (((int)y)>>1)) +#define CHECKEVALUATED(x) if(ISFUN(x) || ISTHUNK(x) \ + || ISFV(x)) return 0; + +#define MKARGS(x) (void**)EMALLOC(sizeof(VAL)*(x)); +#define MOREARGS(args,x) (void**)EREALLOC(args,sizeof(VAL)*(x)); + +typedef enum { + FUN, + THUNK, + CON, + INT, + BIGINT, + FLOAT, + BIGFLOAT, + STRING, + UNIT, + PTR, + FREEVAR +} ClosureType; + +typedef struct { + int ty; + void* info; +} Closure; + +void dumpClosure(Closure* c); + +typedef Closure* VAL; + +#define GETTY(x) (ISINT(x) ? INT : ((ClosureType)(((x)->ty) >> 24))) +#define QGETTY(x) ((ClosureType)(((x)->ty) >> 24)) +#define SETTY(x,t) (x)->ty = (((int)t) << 24) + +#define REF(x) x +#define DEREF(x) + +typedef void*(*func)(void**); + +typedef struct { + func fn; + void** args; + void** arg_end; + int arity; +} fun; + +typedef struct { + void* fn; + void** args; + int numargs; +} thunk; + +typedef struct { + int tag; + void** args; +} con; + +#define UPDATE(x,res) if (ISINT(res)) { x = MKINT(GETINT(res)); } else { \ + SETTY(x, GETTY(res)); x->info=res->info; } +#define TAG(x) ((con*)((Closure*)x)->info)->tag + +#define ISCON(x) GETTY(((Closure*)(x)))==CON +#define ISINT(x) ((((int)x)&1) == 1) +#define ISTHUNK(x) GETTY(((Closure*)(x)))==THUNK +#define ISFUN(x) GETTY(((Closure*)(x)))==FUN +#define ISFV(x) GETTY(((Closure*)(x)))==FREEVAR + +#ifdef TRACEON +#define TRACE if(1) +#else +#define TRACE if(0) +#endif + +// Evaluate x to head normal form +VAL DO_EVAL(VAL x); + +//#define EVAL(x) DO_EVAL(x) +#define EVAL(x) ((x && (ISTHUNK(x) || ISFUN(x))) ? DO_EVAL(x) : x) + +// Return a new constructor +VAL CONSTRUCTOR(int tag, int arity, void** block); +VAL CONSTRUCTOR1(int tag, VAL a1); +VAL CONSTRUCTOR2(int tag, VAL a1, VAL a2); +VAL CONSTRUCTOR3(int tag, VAL a1, VAL a2, VAL a3); +VAL CONSTRUCTOR4(int tag, VAL a1, VAL a2, VAL a3, VAL a4); +VAL CONSTRUCTOR5(int tag, VAL a1, VAL a2, VAL a3, VAL a4, VAL a5); + +// Return a new function node +VAL CLOSURE(func x, int arity, int args, void** block); + +// Add arguments to an already existing thunk +VAL CLOSURE_ADDN(VAL x, int args, void** block); +VAL CLOSURE_ADD1(VAL xin, VAL a1); +VAL CLOSURE_ADD2(VAL xin, VAL a1, VAL a2); +VAL CLOSURE_ADD3(VAL xin, VAL a1, VAL a2, VAL a3); +VAL CLOSURE_ADD4(VAL xin, VAL a1, VAL a2, VAL a3, VAL a4); +VAL CLOSURE_ADD5(VAL xin, VAL a1, VAL a2, VAL a3, VAL a4, VAL a5); + +// Apply a closure to some arguments +VAL CLOSURE_APPLY(VAL x, int args, void** block); +VAL CLOSURE_APPLY1(VAL x, VAL a1); +VAL CLOSURE_APPLY2(VAL x, VAL a1, VAL a2); +VAL CLOSURE_APPLY3(VAL x, VAL a1, VAL a2, VAL a3); +VAL CLOSURE_APPLY4(VAL x, VAL a1, VAL a2, VAL a3, VAL a4); +VAL CLOSURE_APPLY5(VAL x, VAL a1, VAL a2, VAL a3, VAL a4, VAL a5); + +// Project an argument from a constructor +#define PROJECT(x,arg) (((con*)((x)->info))->args[arg]) +//void* DO_PROJECT(VAL x, int arg); + +#define ASSIGNINT(t, x) t=MKINT(x); + +//extern VAL one; + +void* MKINT(int x); +void* NEWBIGINT(char* bigint); +void* MKBIGINT(mpz_t* bigint); + +void* MKSTR(char* str); +void* MKPTR(void* ptr); + +// Get values from a closure +int GETINT(void* x); +mpz_t* GETBIGINT(void* x); +char* GETSTR(void* x); +void* GETPTR(void* x); + +void* MKFREE(int x); + +// Exit with fatal error +void ERROR(char* msg); + +// Initialise everything +void init_evm(); + + +#endif diff --git a/evm/libevm.a b/evm/libevm.a new file mode 100644 Binary files /dev/null and b/evm/libevm.a differ diff --git a/evm/mainprog.c b/evm/mainprog.c new file mode 100644 --- /dev/null +++ b/evm/mainprog.c @@ -0,0 +1,17 @@ +# ifndef WIN32 +# include +# define GC_THREADS +# else +# define GC_WIN32_THREADS +# endif + +#include "closure.h" + +void* _do__U_main(); + +int main(int argc, char* argv[]) { + GC_init(); + init_evm(); + _do___U__main(); + return 0; +} diff --git a/evm/stdfuns.h b/evm/stdfuns.h new file mode 100644 --- /dev/null +++ b/evm/stdfuns.h @@ -0,0 +1,74 @@ +#ifndef _STDFUNS_H +#define _STDFUNS_H + +# ifndef WIN32 +# include +# define GC_THREADS +# else +# define GC_WIN32_THREADS +# endif + +#include +#include +#include +#include "closure.h" + +// Some basic communication with the outside world + +void putStr(char* str); +void printInt(int x); +void printBigInt(mpz_t x); + +// dump memory usage (from libgc) +void epicMemInfo(); + +int readInt(); +char* readStr(); + +void* fileOpen(char* name, char* mode); +void fileClose(void* h); +char* freadStr(void* h); +void fputStr(void* h, char* str); + +int isNull(void* ptr); + +// IORefs +int newRef(); +void* readRef(int r); +void writeRef(int r, void* val); + +// Locks +int newLock(int sem); +void doLock(int lock); +void doUnlock(int lock); +void doFork(void* proc); + +int strToInt(char* str); +char* intToStr(int x); + +mpz_t* strToBigInt(char* str); +char* bigIntToStr(mpz_t x); + +// get a native representation of a value +void* getNative(void * fn); + +// String operations + +int strIndex(char* str, int i); +char* append(char* x, char* y); + +// Big integer arithmetic + +mpz_t* addBigInt(mpz_t x, mpz_t y); +mpz_t* subBigInt(mpz_t x, mpz_t y); +mpz_t* mulBigInt(mpz_t x, mpz_t y); +mpz_t* divBigInt(mpz_t x, mpz_t y); + +int eqBigInt(mpz_t x, mpz_t y); +int ltBigInt(mpz_t x, mpz_t y); +int gtBigInt(mpz_t x, mpz_t y); +int leBigInt(mpz_t x, mpz_t y); +int geBigInt(mpz_t x, mpz_t y); + +#endif +