From acab64cc0f21c0ee9fc5b9b08b60e08997818222 Mon Sep 17 00:00:00 2001 From: "Juan J. Martinez" Date: Sat, 10 Sep 2022 22:10:01 +0100 Subject: Preparing constant folding --- app/Main.hs | 2 +- src/Micro/Ast.hs | 1 + src/Micro/Compiler.hs | 59 +++++++++++++++++++++++---------------------------- test/Language.hs | 2 +- 4 files changed, 29 insertions(+), 35 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index fb3c132..4a3128a 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -68,7 +68,7 @@ compileFile filename onlyParse = do Left err -> hPutStrLn stderr (showParserError err) >> exitFailure Right ast -> do res <- return $ compile ast - case crExit res of + case res of Right out -> if onlyParse then exitSuccess else hPutStrLn stdout out Left errs -> hPutStr stderr (showErrorList errs) >> exitFailure diff --git a/src/Micro/Ast.hs b/src/Micro/Ast.hs index 45697de..8500661 100644 --- a/src/Micro/Ast.hs +++ b/src/Micro/Ast.hs @@ -31,6 +31,7 @@ data Expr | Call Expr [Expr] SourcePos | Return (Maybe Expr) SourcePos | Module String SourcePos + | Nop deriving (Eq, Ord, Show) data Op diff --git a/src/Micro/Compiler.hs b/src/Micro/Compiler.hs index b3ec8a1..629ea45 100644 --- a/src/Micro/Compiler.hs +++ b/src/Micro/Compiler.hs @@ -1,6 +1,5 @@ module Micro.Compiler ( version, - Result (..), compile, ) where @@ -22,21 +21,14 @@ data CompState = CompState } deriving (Show) -data Result = Result +data CompResult = Result { -- last resolved type crType :: Maybe A.Type, - -- only in last call - crExit :: Either [Error] String + crExpr :: A.Expr } -typeResult :: Maybe A.Type -> Result -typeResult t = Result {crType = t, crExit = Left []} - -errorResult :: [Error] -> Result -errorResult err = Result {crType = Nothing, crExit = Left err} - -successResult :: String -> Result -successResult out = Result {crType = Nothing, crExit = Right out} +typeResult :: Maybe A.Type -> A.Expr -> CompResult +typeResult t e = Result t e startState :: CompState startState = CompState emptyEnv [] @@ -56,11 +48,11 @@ foldlEither fn init xs = -- | @addError error@ adds @error@ to the state and returns no type to allow -- the compilation to continue. -addError :: Error -> State CompState Result +addError :: Error -> State CompState CompResult addError e = do st <- get put st {stErr = e : stErr st} - pure $ typeResult Nothing + pure $ typeResult Nothing A.Nop -- | @typecheckCall args params@ resolves @args@ and compares it with @params@, -- returning a string describing an error or Nothing in case of type match. @@ -107,14 +99,14 @@ typecheckReturn (Just value) fret = typecheckVal value fret -- | @typecheckBinOp a b pos@ resolves @a@ (left) and compares it to the type -- of @b@ via typecheckVal. -typecheckBinOp :: A.Expr -> A.Expr -> SourcePos -> State CompState Result -typecheckBinOp a b pos = do +typecheckBinOp :: A.Expr -> A.Expr -> A.Expr -> SourcePos -> State CompState CompResult +typecheckBinOp op a b pos = do l <- compileOne a let tl = crType l tr <- typecheckVal b $ tl case tr of Just err -> addError $ Error TypeError err pos - Nothing -> return $ typeResult tl + Nothing -> return $ typeResult tl op -- built-in types types :: [String] @@ -140,19 +132,19 @@ verifyFuncType ident params ret pos = do then [Error UndefinedType ("undefined return type in \"" ++ ident ++ "\"") pos] else [] -compileOne :: A.Expr -> State CompState Result +compileOne :: A.Expr -> State CompState CompResult compileOne x = do case x of - (A.Module _ _) -> return $ typeResult Nothing - (A.Num _ _) -> return $ typeResult $ Just $ A.Type "u8" -- TODO: placeholder - (A.Bool' _ _) -> return $ typeResult $ Just $ A.Type "bool" + (A.Module _ _) -> return $ typeResult Nothing x + (A.Num _ _) -> return $ typeResult (Just $ A.Type "u8") x -- TODO: placeholder + (A.Bool' _ _) -> return $ typeResult (Just $ A.Type "bool") x (A.BinOp A.Assign pos a@(A.Variable _ _) b) -> - typecheckBinOp a b pos + typecheckBinOp x a b pos (A.BinOp A.Assign pos _ _) -> addError $ Error InvalidTarget "invalid assignment target" pos (A.BinOp _ pos a b) -> -- TODO: types and invalid operators - typecheckBinOp a b pos + typecheckBinOp x a b pos (A.Func ident params ret body priv anon pos) -> do -- current env st <- get @@ -174,7 +166,7 @@ compileOne x = do st <- get -- store updated errors and the env with the function put st {stEnv = ev} - return $ typeResult $ Just ftype + return $ typeResult (Just ftype) x where ftype = A.toFuncType params ret (A.Call ident args pos) -> do @@ -184,7 +176,7 @@ compileOne x = do r <- typecheckCall args params case r of Just err -> addError $ Error TypeError err pos - Nothing -> return $ typeResult rtyp + Nothing -> return $ typeResult rtyp x _ -> addError $ Error NonCallable "non callable value in function call" pos (A.Var ident typ val priv pos) -> do st <- get @@ -198,7 +190,7 @@ compileOne x = do vt <- typecheckVal val $ Just typ case vt of Just err -> addError $ Error TypeError err pos - Nothing -> return $ typeResult $ Just typ + Nothing -> return $ typeResult (Just typ) x (A.Return value pos) -> do st <- get case getSyml (stEnv st) "$fn$" of @@ -206,23 +198,24 @@ compileOne x = do r <- typecheckReturn value rtyp case r of Just err -> addError $ Error TypeError err pos - Nothing -> return $ typeResult rtyp + Nothing -> return $ typeResult rtyp x _ -> addError $ Error UnexpectedReturn "return without function call" pos (A.Variable ident pos) -> do st <- get case getSym (stEnv st) ident of - Just Sym {symType = t} -> return $ typeResult $ Just t + Just Sym {symType = t} -> return $ typeResult (Just t) x Nothing -> addError $ Error Undefined ("undefined \"" ++ ident ++ "\"") pos + (A.Nop) -> return $ typeResult Nothing x -compileAll :: [A.Expr] -> State CompState Result +compileAll :: [A.Expr] -> State CompState (Either [Error] String) compileAll ast = do - _ <- traverse compileOne ast + result <- traverse compileOne ast st <- get let (Env sym _) = stEnv st let errs = stErr st case errs of - [] -> pure $ successResult $ generate version sym ast - _ -> return $ errorResult errs + [] -> pure $ Right $ generate version sym (map (\r -> crExpr r) result) + _ -> return $ Left errs -compile :: [A.Expr] -> Result +compile :: [A.Expr] -> Either [Error] String compile ast = evalState (compileAll ast) startState diff --git a/test/Language.hs b/test/Language.hs index 6bedc68..83736b2 100644 --- a/test/Language.hs +++ b/test/Language.hs @@ -23,7 +23,7 @@ expectError input etyp = do Left e -> assertFailure $ show e Right ast -> do res <- return $ compile ast - case crExit res of + case res of Left e -> case (find (\(E.Error t _ _) -> t == etyp) e) of Just _ -> return () Nothing -> assertFailure $ "expected " ++ show etyp ++ " didn't happen, got instead:\n" ++ unlines (map (\(E.Error t _ _) -> show t) e) -- cgit v1.2.3