diff options
Diffstat (limited to 'Sjit')
| -rw-r--r-- | Sjit/Compile.dcl | 4 | ||||
| -rw-r--r-- | Sjit/Compile.icl | 54 | ||||
| -rw-r--r-- | Sjit/Syntax.dcl | 5 | ||||
| -rw-r--r-- | Sjit/Syntax.icl | 130 |
4 files changed, 167 insertions, 26 deletions
diff --git a/Sjit/Compile.dcl b/Sjit/Compile.dcl index 4bc1ed5..166b5c4 100644 --- a/Sjit/Compile.dcl +++ b/Sjit/Compile.dcl @@ -1,5 +1,6 @@ definition module Sjit.Compile +from Data.Either import :: Either from Data.Map import :: Map from Data.Maybe import :: Maybe from Sjit.Syntax import :: Function @@ -40,5 +41,4 @@ from Sjit.Syntax import :: Function appendProgram :: !Bool !Program !JITState -> JITState bootstrap :: (!Program, !CompileState) -compile :: !Function !CompileState -> CompileState -compile_all :: !(Maybe CompileState) ![Function] -> CompileState +compile :: !Function !CompileState -> Either String CompileState diff --git a/Sjit/Compile.icl b/Sjit/Compile.icl index 31b6523..5e4cef5 100644 --- a/Sjit/Compile.icl +++ b/Sjit/Compile.icl @@ -5,6 +5,9 @@ import StdGeneric import StdMaybe import StdOverloadedList +import Control.Applicative +import Control.Monad +import Data.Either from Data.Func import mapSt, $ from Data.Map import :: Map(..), get, put, newMap, fromList @@ -80,39 +83,42 @@ where ccall init_jit "II:Vpp" } -compile :: !Function !CompileState -> CompileState +compile :: !Function !CompileState -> Either String CompileState compile f cs # cs & funs = put f.fun_name cs.pc cs.funs # vars = cs.vars # cs & vars = foldr (uncurry put) cs.vars [(v,sp) \\ v <- f.fun_args & sp <- [cs.sp+1..]] -# (is,cs) = expr f.fun_expr cs -# is = {i \\ i <- reverse [Ret:Put (max 1 (length f.fun_args)+1):is]} -= - { cs - & vars = vars - , pc = cs.pc+2 - , blocks = cs.blocks ++| [!is!] - , jitst = appendProgram (f.fun_name == "main") is cs.jitst - } += case expr f.fun_expr cs of + Left e -> Left e + Right (is,cs) + # is = {i \\ i <- reverse [Ret:Put (max 1 (length f.fun_args)+1):is]} + -> Right + { cs + & vars = vars + , pc = cs.pc+2 + , blocks = cs.blocks ++| [!is!] + , jitst = appendProgram (f.fun_name == "main") is cs.jitst + } where - expr :: !Expr !CompileState -> (![Instr], !CompileState) - expr (Int i) cs = ([PushI i], {cs & sp=cs.sp+1, pc=cs.pc+1}) + expr :: !Expr !CompileState -> Either String (![Instr], !CompileState) + expr (Int i) cs = Right ([PushI i], {cs & sp=cs.sp+1, pc=cs.pc+1}) expr (Var v) cs = case get v cs.vars of - Just i -> ([PushRef (i-cs.sp)], {cs & sp=cs.sp+1, pc=cs.pc+1}) - Nothing -> abort "undefined variable\n" + Just i -> Right ([PushRef (i-cs.sp)], {cs & sp=cs.sp+1, pc=cs.pc+1}) + Nothing -> Left ("undefined variable '" +++ v +++ "'") expr (App f args) cs # args = if (args=:[]) [Int 0] args - # (iss,cs) = mapSt expr args {cs & sp=cs.sp+1} - = case get f cs.funs of - Just f -> ([Pop (length args-1):Call f:flatten iss], {cs & sp=cs.sp+2-length args, pc=cs.pc+2}) - Nothing -> abort "undefined function\n" + = case mapStM expr args {cs & sp=cs.sp+1} of + Left e -> Left e + Right (iss,cs) -> case get f cs.funs of + Just f -> Right + ( [Pop (length args-1):Call f:flatten iss] + , {cs & sp=cs.sp+2-length args, pc=cs.pc+2} + ) + Nothing -> Left ("undefined function '" +++ toString f +++ "'") -compile_all :: !(Maybe CompileState) ![Function] -> CompileState -compile_all mcs funs -# cs = case mcs of - Just cs -> cs - Nothing -> snd bootstrap -= foldl (flip compile) cs funs + mapStM :: !(a st -> m (b, st)) ![a] !st -> m ([b], st) | Monad m + mapStM _ [] st = pure ([], st) + mapStM f [x:xs] st = f x st >>= \(y,st) -> mapStM f xs st >>= \(ys,st) -> pure ([y:ys],st) generic gEncodedSize a :: !a -> Int gEncodedSize{|Int|} _ = 1 diff --git a/Sjit/Syntax.dcl b/Sjit/Syntax.dcl index a289b5a..44adbfa 100644 --- a/Sjit/Syntax.dcl +++ b/Sjit/Syntax.dcl @@ -1,5 +1,7 @@ definition module Sjit.Syntax +from Data.Either import :: Either + :: Expr = Int !Int | Var !String @@ -10,3 +12,6 @@ definition module Sjit.Syntax , fun_args :: ![String] , fun_expr :: !Expr } + +parse_function :: !String -> Either String Function +parse_interactive_line :: !String -> Either String Function diff --git a/Sjit/Syntax.icl b/Sjit/Syntax.icl index e512e0c..ae75087 100644 --- a/Sjit/Syntax.icl +++ b/Sjit/Syntax.icl @@ -1 +1,131 @@ implementation module Sjit.Syntax + +import StdEnv + +import Control.Applicative +import Control.Monad +import Data.Either +from Data.Func import $ +import Data.Functor +import Data.GenEq +import Text.Parsers.Simple.Core + +:: Token + = TIdent !String + | TInt !Int + + | TEq + | TComma + + | TParenOpen + | TParenClose + +derive gEq Token +instance == Token where == a b = a === b + +instance toString Token +where + toString t = case t of + TIdent s -> "'" +++ s +++ "'" + TInt n -> toString n + TEq -> "=" + TComma -> "," + TParenOpen -> "(" + TParenClose -> ")" + +lex :: !String -> Either String [Token] +lex s = reverse <$> lex [] 0 (size s) s +where + lex :: ![Token] !Int !Int !String -> Either String [Token] + lex tks i e s | i >= e = Right tks + lex tks i e s = case s.[i] of + w | isSpace w + -> lex tks (i+1) e s + + n | isIdent n + # (i,n) = readIdent isIdent [] i e s + -> lex [TIdent n:tks] i e s + + n | isFunnyIdent n + # (i,n) = readIdent isFunnyIdent [] i e s + -> lex [TIdent n:tks] i e s + + n | isDigit n + # (i,n) = readInt [] i e s + -> lex [TInt n:tks] i e s + + '=' -> lex [TEq: tks] (i+1) e s + ',' -> lex [TComma: tks] (i+1) e s + '(' -> lex [TParenOpen: tks] (i+1) e s + ')' -> lex [TParenClose:tks] (i+1) e s + + c -> Left ("Unexpected character '" +++ {c} +++ "'") + + isIdent :: !Char -> Bool + isIdent c = isAlpha c || c == '_' + + isFunnyIdent :: !Char -> Bool + isFunnyIdent c = isMember c ['+-*/'] + + readIdent :: !(Char -> Bool) ![Char] !Int !Int !String -> (!Int, !String) + readIdent ok cs i e s + | i >= e = (i,{c \\ c <- reverse cs}) + # c = s.[i] + | ok c = readIdent ok [c:cs] (i+1) e s + | otherwise = (i,{c \\ c <- reverse cs}) + + readInt :: ![Char] !Int !Int !String -> (!Int, !Int) + readInt cs i e s + | i >= e = (i,toInt {#c \\ c <- reverse cs}) + # c = s.[i] + | isDigit c = readInt [c:cs] (i+1) e s + | otherwise = (i,toInt {#c \\ c <- reverse cs}) + +function :: Parser Token Function +function =: + liftM3 make_fun ident (many arg) (pToken TEq *> expr) +where + make_fun :: !String ![String] !Expr -> Function + make_fun name args expr = {fun_name=name, fun_args=args, fun_expr=expr} + +expr :: Parser Token Expr +expr + = leftAssoc (tok "+" <|> tok "-") + $ leftAssoc (tok "*" <|> tok "/") + $ noInfix +where + tok :: !String -> Parser Token String + tok s = pToken (TIdent s) $> s + + leftAssoc :: !(Parser Token String) !(Parser Token Expr) -> Parser Token Expr + leftAssoc opp exprp = exprp >>= \e1 -> + many (opp >>= \op -> exprp >>= \e -> pure (op,e)) >>= + foldM (\e (op,e2) -> pure $ App op [e,e2]) e1 + + noInfix :: Parser Token Expr + noInfix = + liftM2 App ident (pToken TParenOpen *> pSepBy expr (pToken TComma) <* pToken TParenClose) + <|> Var <$> ident + <|> Int <$> int + <|> (pToken TParenOpen *> expr <* pToken TParenClose) + +ident :: Parser Token String +ident =: (\(TIdent n) -> n) <$> pSatisfy (\t->t=:TIdent _) + +arg :: Parser Token String +arg =: ident + +int :: Parser Token Int +int =: (\(TInt n) -> n) <$> pSatisfy (\t->t=:TInt _) + +parse_function :: !String -> Either String Function +parse_function s = lex s >>= \tks -> case parse function tks of + Right f -> Right f + Left _ -> Left "parsing failed" + +parse_interactive_line :: !String -> Either String Function +parse_interactive_line s = lex s >>= \tks -> case parse function tks of + Right f -> Right f + Left _ -> case parse expr tks of + Right e -> Right {fun_name="main", fun_args=[], fun_expr=e} + Left _ -> Left "parsing failed" |