diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -69,7 +69,7 @@ 21 56 # -377 +77 ``` **NOTE 1:** printed newlines have to be stated explicitly. Consider a hello-world @@ -106,8 +106,6 @@ input into the llvm-binary and compares the actual output with the current output. The result will be printed to stdout. -(TODO: do we have to run cabal first manually?) - ## Dependencies / Building the Compiler - Install cabal (package cabal-install in most distributions) @@ -119,7 +117,7 @@ - `cabal test` to run the tests - Run the compiler with `dist/build/SWPSoSe14/SWPSoSe14 -c -i -o output` - You still need to link the stack manually if you want to have executables: - `llvm-link src/RailCompiler/stack.ll -o executable` + `llvm-link src/RailCompiler/*.ll -o executable` ## Documentation diff --git a/data/icon.png b/data/icon.png new file mode 100644 Binary files /dev/null and b/data/icon.png differ diff --git a/rail-compiler-editor.cabal b/rail-compiler-editor.cabal --- a/rail-compiler-editor.cabal +++ b/rail-compiler-editor.cabal @@ -1,5 +1,5 @@ name: rail-compiler-editor -version: 0.2.0.0 +version: 0.3.0.0 synopsis: Compiler and editor for the esolang rail. description: A compiler and a graphical editor for the esoteric programming language rail. homepage: https://github.com/SWP-Ubau-SoSe2014-Haskell/SWPSoSe14 @@ -11,56 +11,80 @@ -- copyright: category: Language build-type: Simple -extra-source-files: README.md, tests/integration_tests, src/RailCompiler/stack.ll +extra-source-files: README.md, tests/integration_tests, src/RailCompiler/stack.ll, src/RailCompiler/cmp.ll, src/RailCompiler/math.ll, src/RailCompiler/string.ll src/RailCompiler/linked_stack.ll src/RailCompiler/list.ll +data-files: data/icon.png cabal-version: >=1.10 source-repository head type: git location: https://github.com/SWP-Ubau-SoSe2014-Haskell/SWPSoSe14.git -executable RailCompiler - main-is: Main.hs - other-modules: +library + build-depends: base (>=4.5.0.0 && <5), llvm-general-pure, llvm-general <3.3.12 || (>=3.4 && < 3.4.3), mtl, containers + ghc-prof-options: -fprof-auto + exposed-modules: + AST Backend - CodeOptimization ErrorHandling + InstructionPointer InterfaceDT IntermediateCode Lexer Preprocessor SemanticalAnalysis SyntacticalAnalysis + FunctionDeclarations + TypeDefinitions + hs-source-dirs: src/RailCompiler + default-language: Haskell2010 + +executable RailCompiler + main-is: Main.hs + build-depends: base (>=4.5.0.0 && <5), rail-compiler-editor + ghc-options: -rtsopts + ghc-prof-options: -fprof-auto --other-extensions: DeriveDataTypeable, GADTs, StandaloneDeriving - build-depends: base (>=4.5.0.0 && <5), llvm-general-pure, llvm-general <3.3.12 || (>=3.4 && < 3.4.3), mtl, containers + --build-depends: base (>=4.5.0.0 && <5), llvm-general-pure, llvm-general <3.3.12 || (>=3.4 && < 3.4.3), mtl, containers -- Directories containing source files. - hs-source-dirs: src/RailCompiler + hs-source-dirs: src/RailCompiler-command -- Base language which the package is written in. default-language: Haskell2010 executable RailEditor - main-is: Main.hs + main-is: Editor.hs + ghc-prof-options: -fprof-auto other-modules: - EditorBackend + FooterBar + Highlighter + InteractionField + Interpreter + KeyHandler + MainWindow + MenuBar Execute - Menu + RedoUndo + TextAreaContent + Selection + TextAreaContentUtils TextArea - build-depends: base (>=4.5.0.0 && <5), llvm-general-pure, llvm-general < 3.4.3, mtl, containers, transformers, gtk, process - hs-source-dirs: src/RailEditor src/RailCompiler + ToolBar + Paths_rail_compiler_editor + build-depends: base (>=4.5.0.0 && <5), containers, transformers, gtk, cairo, process, mtl, rail-compiler-editor + hs-source-dirs: src/RailEditor default-language: Haskell2010 Test-suite testcases main-is: Main.hs other-modules: TBackend - TCodeOpt TInterCode TLexer TPreProc TSemAna TSynAna - build-depends: base (>=4.5.0.0 && <5), HUnit, llvm-general-pure, llvm-general < 3.4.3, mtl, containers, process - hs-source-dirs: tests, src/RailCompiler + build-depends: base (>=4.5.0.0 && <5), HUnit, rail-compiler-editor, process, containers + hs-source-dirs: tests default-language: Haskell2010 type: exitcode-stdio-1.0 diff --git a/src/RailCompiler-command/Main.hs b/src/RailCompiler-command/Main.hs new file mode 100644 --- /dev/null +++ b/src/RailCompiler-command/Main.hs @@ -0,0 +1,116 @@ +{- | +Module : Main.hs +Description : . +Maintainer : (c) Christopher Pockrandt, Nicolas Lehmann, Tobias Kranz +License : MIT + +Stability : stable + +Entrypoint of the rail2llvm-compiler. Contains main-function. + +See also: +--https://www.haskell.org/ghc/docs/7.8.2/html/libraries/base-4.7.0.0/System-Console-GetOpt.html +--http://leiffrenzel.de/papers/commandline-options-in-haskell.html (Outdated!) + +-} +module Main( main ) where + +-- imports -- +import System.Environment +import System.Exit +import System.Console.GetOpt +import Data.Maybe( fromMaybe ) +import InterfaceDT as IDT +import qualified Preprocessor as PreProc +import qualified Lexer +import qualified SyntacticalAnalysis as SynAna +import qualified SemanticalAnalysis as SemAna +import qualified IntermediateCode as InterCode +import qualified Backend + +-- defining the option settings for the main-function +data Options = Options { + optInput :: IO String, + optOutput :: String -> IO (), + optASTOutput :: String -> IO (), + compile :: Bool, + impAST :: Bool, + expAST :: Bool + } + +-- default Options +defaultOptions :: Options +defaultOptions = Options { + optInput = getContents, + optOutput = putStr, + optASTOutput = putStr, + compile = False, + impAST = False, + expAST = False + + } + +-- usageInfo +options :: [OptDescr (Options -> IO Options)] +options = [ + --Option ['V'] ["version"] (NoArg showVersion) "show version number", + Option "h" ["help" ] (NoArg showHelp ) "display Help Text", + Option "i" ["input" ] (ReqArg setInput "FILE" ) "input file (don't set to use stdin')", + Option "o" ["output" ] (ReqArg setOutput "FILE" ) "output file (don't set to use stdout')", + Option "c" ["compile" ] (NoArg setCompile ) "compile 'rail' to 'llvm'", + Option [ ] ["exportAST"] (OptArg setExpAST "FILE" ) "export frontend AST (don't offer a File to use stdout) \n(dont set with --importAST)", + Option [ ] ["importAST"] (NoArg setImpAST ) "import frontend AST and compile to llvm\nautosets -c \n(set input via -i; (dont set with --exportAST)\n\nset -c with --exportAST and get both: the AST and the llvm code" + ] + +-- output for the help-function +showHelp _ = do + putStrLn "rail2llvm--haskell-compiler (development version)" + putStr "https://github.com/SWP-Ubau-SoSe2014-Haskell/SWPSoSe14\n\n" + putStr $ usageInfo "Usage: main [OPTION...]" options + exitSuccess + +-- options-getter for optional output for exprotAST +getOut (Just arg) = writeFile arg +getOut Nothing = putStr + +-- options-setters +setInput arg opt = return opt { optInput = readFile arg } +setOutput arg opt = return opt { optOutput = writeFile arg } +setExpAST arg opt = return opt { optASTOutput = getOut arg, expAST = True} +setImpAST opt = return opt { impAST = True, compile = True } +setCompile opt = return opt { compile = True } + +-- main-function -- +main = do args <- getArgs + let (actions,nonOpts,msgs) = getOpt RequireOrder options args + -- intercept errors + if msgs /= [] + then error $ concat msgs ++ usageInfo "Usage: main [OPTION...]" options + -- unrecognized arguments error + else if nonOpts /= [] + then error $ "unrecognized arguments: " ++ unwords nonOpts ++ "\nUsage: For basic information, try the `--help' option." + else do opts <- foldl (>>=) (return defaultOptions) actions + -- option aliases + let Options { optInput = input, optOutput = output, optASTOutput = outputAST, compile = cmpl, impAST = imp, expAST = exp} = opts + inputWithoutIO <- input + -- importAST and exportAST can't be set together (error) + if imp && exp + then do error "No export of the imported AST (Usage: For basic information, try the `--help' option.)'" + exitSuccess + -- compile a file + else if cmpl + then do let transform (IBO x) = x + -- compile an imported AST to a LLVM-file + if imp + then transform (Backend.process . InterCode.process . SemAna.process . SynAna.process . Lexer.toAST $ inputWithoutIO) >>= output + -- compile a RAIL-file to an AST as an export-file + else if exp + then do outputAST (Lexer.fromAST . Lexer.process . PreProc.process $ IIP inputWithoutIO) + transform (Backend.process . InterCode.process . SemAna.process . SynAna.process . Lexer.process . PreProc.process $ IIP inputWithoutIO) >>= output + -- compile a RAIL-file to a LLVM-file + else transform (Backend.process . InterCode.process . SemAna.process . SynAna.process . Lexer.process . PreProc.process $ IIP inputWithoutIO) >>= output + -- exportAST (without compiling it to llvm) + else if exp + then outputAST (Lexer.fromAST . Lexer.process . PreProc.process $ IIP inputWithoutIO) + -- missing argument error + else error "Error. Set atleast -c or --importAST or --exportAST." diff --git a/src/RailCompiler/AST.hs b/src/RailCompiler/AST.hs new file mode 100644 --- /dev/null +++ b/src/RailCompiler/AST.hs @@ -0,0 +1,348 @@ +{- | +Module : Abstract Syntax Tree +Description : Helper module for Lexer which cares about everything related to the interchageable AST. +Maintainer : Christian H. et al. +License : MIT +-} +module AST (fromAST, toAST, parse, adjacent, valids) + where + + import InterfaceDT as IDT + import ErrorHandling as EH + import Data.Maybe + import Data.List + import Text.Printf + import qualified Data.Map as Map + import InstructionPointer + + -- |Convert a graph/AST into a portable text representation. + -- See also 'fromGraph'. + fromAST :: IDT.Lexer2SynAna -- ^Input graph/AST/forest. + -> String -- ^Portable text representation of the AST: + -- + -- Each function is represented by its own section. A section has a header + -- and content; it continues either until the next section, a blank line or + -- the end of the file, whichever comes first. + -- + -- A section header consists of a single line containing the name of the function, + -- enclosed in square brackets, e. g. @[function_name]@. There cannot be any whitespace + -- before the opening bracket. + -- + -- The section content consists of zero or more non-blank lines containing exactly + -- three records delimited by a semicolon @;@. Each line describes a node and contains + -- the following records, in this order: + -- + -- * The node ID (numeric), e. g. @1@. + -- * The Rail lexeme, e. g. @o@ or @[constant]@ etc. Note that track lexemes like + -- @-@ or @+@ are not included in the graph. Multi-character lexemes like constants + -- may include semicolons, so you need to parse them correctly! In other words, you need + -- to take care of lines like @1;[some ; constant];2@. + -- * Node ID of the follower node, e. g. @2@. May be @0@ if there is no next node. + fromAST (IDT.ILS graph) = unlines $ map fromGraph graph + + -- |Convert a portable text representation of a graph into a concrete graph representation. + -- See also 'toGraph'. See 'fromAST' for a specification of the portable text representation. + toAST :: String -- ^Portable text representation. See 'fromAST'. + -> IDT.Lexer2SynAna -- ^Output graph. + toAST input = IDT.ILS (map toGraph $ splitfunctions input) + + -- |Convert an 'IDT.Graph' for a single function to a portable text representation. + -- See 'fromAST' for a specification of the representation. + -- + -- TODO: Currently, this apparently crashes the program on invalid input. More sensible error handling? + -- At least a nice error message would be nice. + fromGraph :: IDT.Graph -- ^Input graph. + -> String -- ^Text representation. + fromGraph (funcname, nodes) = unlines $ ("["++funcname++"]"):tail (map (fromLexNode . offset (-1)) nodes) + where + fromLexNode :: IDT.LexNode -> String + fromLexNode (id, lexeme, follower) = show id ++ ";" ++ fromLexeme lexeme ++ ";" ++ show follower ++ optional lexeme + fromLexeme :: IDT.Lexeme -> String + fromLexeme Boom = "b" + fromLexeme EOF = "e" + fromLexeme Input = "i" + fromLexeme Output = "o" + fromLexeme Underflow = "u" + fromLexeme RType = "?" + fromLexeme (Constant string) = "["++escapestring string++"]" + fromLexeme (Push string) = "("++string++")" + fromLexeme (Pop string) = "(!"++string++"!)" + fromLexeme (Call string) = "{"++string++"}" + fromLexeme Add1 = "a" + fromLexeme Divide = "d" + fromLexeme Multiply = "m" + fromLexeme Remainder = "r" + fromLexeme Subtract = "s" + fromLexeme Cut = "c" + fromLexeme Append = "p" + fromLexeme Size = "z" + fromLexeme Nil = "n" + fromLexeme Cons = ":" + fromLexeme Breakup = "~" + fromLexeme Greater = "g" + fromLexeme Equal = "q" + fromLexeme Start = "$" + fromLexeme Finish = "#" + fromLexeme (Junction _) = "v" + fromLexeme (Lambda _) = "&" + fromLexeme NOP = "." + optional (Junction follow) = ';' : show follow + optional (Lambda follow) = ';' : show follow + optional _ = ";0" + + -- |Split a portable text representation of multiple function graphs (a forest) into separate + -- text representations of each function graph. + splitfunctions :: String -- ^Portable text representation of the forest. + -> [[String]] -- ^List of lists, each being a list of lines making up a separate function graph. + splitfunctions = groupBy (\_ y -> null y || head y /= '[') . filter (not . null) . lines + + -- |Convert a portable text representation of a single function into an 'IDT.Graph'. + -- Raises 'error's on invalid input (see 'ErrorHandling'). + toGraph :: [String] -- ^List of lines making up the text representation of the function. + -> IDT.Graph -- ^Graph describing the function. + toGraph lns = (init $ tail $ head lns, (1, Start, if null nodelist then 0 else 2):map (offset 1) nodelist) + where + nodelist = nodes $ tail lns + nodes [] = [] + nodes (ln:lns) = (read id, fixedlex, read follower):nodes lns + where + (id, other) = span (/=';') ln + (lex, ip) = parse (convert [other]) (IP 0 1 0 E Forward Map.empty) + (follower, attribute) = span (/=';') (drop (2 + posx ip) other) + fixedlex + | isJunction lex = Junction (read $ tail attribute) + | isLambda lex = Lambda (read $ tail attribute) + | otherwise = fromJust lex + fromJust Nothing = error $ printf EH.shrLineNoLexeme ln + fromJust (Just x) = x + isJunction (Just (Junction _)) = True + isJunction _ = False + isLambda (Just (Lambda _)) = True + isLambda _ = False + convert code = Map.fromList $ zip [0..] (map (Map.fromList . zip [0..]) code) + + -- |Shift a node by the given amount. May be positive or negative. + -- This is used by 'toGraph' and 'fromGraph' to shift all nodes by 1 or -1, respectively, + -- which is done because the portable text representation of the graph does not include + -- a leading "Start" node with ID 1 -- instead, the node with ID 1 is the first "real" + -- graph node. In other words, when exporting to the text representation, the "Start" + -- node is removed and all other nodes are "shifted" by -1 using this function. When + -- importing, a "Start" node is added and all nodes are shifted by 1. + offset :: Int -- ^Amount to shift node by. + -> IDT.LexNode -- ^Node to operate on. + -> IDT.LexNode -- ^Shifted node. + offset c (node, lexeme, 0) = (node + c, lexeme, 0) + offset c (node, lexeme, following) = (node + c, lexeme, following + c) + + -- |Get adjacent (left secondary, primary, right secondary) + -- symbols for the current IP position. + adjacent :: IDT.Grid2D -- ^Line representation of the current function. + -> IP -- ^Current instruction pointer. + -> (Char, Char, Char) -- ^Adjacent (left secondary, primary, right secondary) symbols + adjacent code ip + | current code ip `elem` turnblocked = (' ', charat code (posdir ip Forward), ' ') + | otherwise = (charat code (posdir ip InstructionPointer.Left), charat code (posdir ip Forward), charat code (posdir ip InstructionPointer.Right)) + + -- |Get the next lexeme at the current position. + parse :: IDT.Grid2D -- ^Line representation of current function. + -> IP -- ^Current instruction pointer. + -> (Maybe IDT.Lexeme, IP) -- ^Resulting lexeme (if any) and + -- the new instruction pointer. + parse code ip = junctioncheck $ case current code ip of + 'b' -> (Just Boom, ip) + 'e' -> (Just EOF, ip) + 'i' -> (Just Input, ip) + 'o' -> (Just Output, ip) + 'u' -> (Just Underflow, ip) + '?' -> (Just RType, ip) + 'a' -> (Just Add1, ip) + 'd' -> (Just Divide, ip) + 'm' -> (Just Multiply, ip) + 'r' -> (Just Remainder, ip) + 's' -> (Just Subtract, ip) + '0' -> (Just (Constant "0"), ip) + '1' -> (Just (Constant "1"), ip) + '2' -> (Just (Constant "2"), ip) + '3' -> (Just (Constant "3"), ip) + '4' -> (Just (Constant "4"), ip) + '5' -> (Just (Constant "5"), ip) + '6' -> (Just (Constant "6"), ip) + '7' -> (Just (Constant "7"), ip) + '8' -> (Just (Constant "8"), ip) + '9' -> (Just (Constant "9"), ip) + 'c' -> (Just Cut, ip) + 'p' -> (Just Append, ip) + 'z' -> (Just Size, ip) + 'n' -> (Just Nil, ip) + ':' -> (Just Cons, ip) + '~' -> (Just Breakup, ip) + 'f' -> (Just (Constant "0"), ip) + 't' -> (Just (Constant "1"), ip) + 'g' -> (Just Greater, ip) + 'q' -> (Just Equal, ip) + '$' -> (Just Start, ip) + '#' -> (Just Finish, ip) + '.' -> (Just NOP, ip) + 'v' -> (Just (Junction 0), ip) + '^' -> (Just (Junction 0), ip) + '>' -> (Just (Junction 0), ip) + '<' -> (Just (Junction 0), ip) + '&' -> (Just (Lambda 0), ip) + '[' -> let (string, newip) = readconstant code tempip '[' ']' in (Just (Constant string), newip) + ']' -> let (string, newip) = readconstant code tempip ']' '[' in (Just (Constant string), newip) + '{' -> let (string, newip) = stepwhile code tempip (/= '}') in (Just (Call $ checkstring string), newip) + '}' -> let (string, newip) = stepwhile code tempip (/= '{') in (Just (Call $ checkstring string), newip) + '(' -> let (string, newip) = stepwhile code tempip (/= ')') in (pushpop string, newip) + ')' -> let (string, newip) = stepwhile code tempip (/= '(') in (pushpop string, newip) + _ -> (Nothing, turn (current code ip) ip) + where + junctioncheck (Nothing, ip) + | current code ip `elem` "+x*" && next code ip `elem` "v^<>" = (Nothing, crashfrom ip) +-- | forward == ' ' && (left == current code ip || right == current code ip) = (Nothing, crashfrom ip) + | forward == ' ' && (left `elem` "v^<>+x*" || right `elem` "v^<>+x*") = (Nothing, crashfrom ip) + | otherwise = (Nothing, ip) + where + (left, forward, right) = adjacent code ip + junctioncheck (lexeme, ip) + | next code ip `elem` "v^<>" = (lexeme, crashfrom ip) + | otherwise = (lexeme, ip) + tempip = move ip Forward + checkstring string = if '!' `elem` string then error EH.strInvalidVarName else string + pushpop string + | length string < 2 = Just (Push $ checkstring string) + | head string == '!' && last string == '!' = Just (Pop (checkstring $ tail $ init string)) + | otherwise = Just (Push $ checkstring string) + + -- |Collect characters until a condition is met while moving in the current direction. + stepwhile :: IDT.Grid2D -- ^Line representation of current function. + -> IP -- ^Current instruction pointer. + -> (Char -> Bool) -- ^Function: Should return True if collection should stop. + -- Gets the current Char as an argument. + -> (String, IP) -- ^Collected characters and the new instruction pointer. + stepwhile code ip fn + | not (fn curchar) = ("", ip) + | not (moveable code ip Forward) = error EH.strMissingClosingBracket + | curchar `elem` "'{}()" = error EH.strInvalidVarName + | otherwise = (curchar:resstring, resip) + where + curchar = current code ip + (resstring, resip) = stepwhile code (move ip Forward) fn + + -- |Checks if the instruction pointer can be moved without leaving the grid + moveable :: IDT.Grid2D -- ^Line representation of current function + -> IP -- ^Current instruction pointer + -> RelDirection -- ^Where to move to + -> Bool -- ^Whether or not the move could be made + moveable code ip reldir + | Map.size code == 0 = False + | isNothing (Map.lookup newy code) = False + | dir ip `elem` [W, E] && isNothing (Map.lookup newx line) = False + | otherwise = True + where + (newy, newx) = posdir ip reldir + line = fromJust (Map.lookup newy code) + + -- |Read a string constant and handle escape sequences like \n. + -- Raises an error on invalid escape sequences and badly formatted constants. + readconstant :: IDT.Grid2D -- ^Current function in line representation + -> IP -- ^Current instruction pointer + -> Char -- ^Opening string delimiter, e. g. '[' + -> Char -- ^Closing string delimiter, e. g. ']' + -> (String, IP) -- ^The processed constant and the new instruction pointer + readconstant code ip startchar endchar + | curchar == startchar = error EH.strNestedOpenBracket + | curchar == endchar = ("", ip) + | not (moveable code ip Forward) = error EH.strMissingClosingBracket + | otherwise = (newchar:resstring, resip) + where + curchar = current code ip + (newchar, newip) = processescape + (resstring, resip) = readconstant code newip startchar endchar + + -- This does the actual work and converts the escape sequence + -- (if there is no escape sequence at the current position, do + -- nothing and pass the current Char through). + processescape :: (Char, IP) + processescape + | curchar /= '\\' = (curchar, move ip Forward) + | curchar == '\\' && escsym == '\\' = ('\\', skip code ip 2) + | esctrail /= '\\' = error EH.strNonSymmetricEscape + | otherwise = case escsym of + '[' -> ('[', escip) + ']' -> (']', escip) + 'n' -> ('\n', escip) + 't' -> ('\t', escip) + _ -> error $ printf EH.strUnhandledEscape escsym + where + [escsym, esctrail] = lookahead code ip 2 + -- Points to the character after the trailing backslash + escip = skip code ip 3 + + escapestring :: String -> String + escapestring [] = [] + escapestring (x:xs) = newx ++ escapestring xs + where + newx = case x of + '\\' -> "\\\\" + '\n' -> "\\n\\" + '[' -> "\\[\\" + ']' -> "\\]\\" + '\t' -> "\\t\\" + _ -> [x] + + -- |Lookahead n characters in the current direction. + lookahead :: IDT.Grid2D -- ^Line representation of current function + -> IP -- ^Current instruction pointer + -> Int -- ^How many characters of lookahead to produce? + -> String -- ^n characters of lookahead + lookahead code ip 0 = [] + lookahead code ip n = current code newip : lookahead code newip (n-1) + where + newip = move ip Forward + + -- |Skip n characters in the current direction and return the new IP. + skip :: IDT.Grid2D -- ^Line representation of current function + -> IP -- ^Current instruction pointer + -> Int -- ^How many characters to skip? If 1, this is the same + -- as doing "move ip Forward". + -> IP -- ^New instruction pointer + skip code ip n = foldl (\x _ -> move x Forward) ip [1..n] + + -- |Get the 'Char' at the next position of the instruction pointer + next :: IDT.Grid2D -> IP -> Char + next code ip = current code $ move ip Forward + + -- |Return valid chars for movement depending on the current direction. + valids :: IDT.Grid2D -- ^Line representation of current function. + -> IP -- ^Current instruction pointer. + -> (String, String, String) -- ^Tuple consisting of: + -- + -- * Valid characters for movement to the (relative) left. + -- * Valid characters for movement in the (relative) forward direction. + -- * Valid characters for movement to the (relative) right. + valids code ip = tripleinvert (secinv code ip InstructionPointer.Left, finvalid ip, secinv code ip InstructionPointer.Right) + where + secinv code ip direction = [current code ip] ++ commandchars ++ dirinvalid ip ++ finvalid ip{dir = absolute ip direction} + tripleinvert (l, f, r) = (filter (`notElem` l) everything, filter (`notElem` f) everything, filter (`notElem` r) everything) + finvalid ip = dirinvalid ip ++ crossinvalid ip -- illegal to move forward + dirinvalid ip -- illegal without crosses + | dir ip `elem` [E, W] = "|" + | dir ip `elem` [NE, SW] = "\\" + | dir ip `elem` [N, S] = "-" + | dir ip `elem` [NW, SE] = "/" + | otherwise = "" + crossinvalid ip -- illegal crosses + | dir ip `elem` [N, E, S, W] = "x" + | otherwise = "+" + cur = current code ip + everything = "+\\/x|-" ++ always + always = "^v<>*@{}[]()" ++ commandchars + + -- list of chars that are commands in rail + commandchars :: String + commandchars = "abcdefgimnopqrstuz:~0123456789?#&" + + -- list of chars which do not allow any turning + turnblocked :: String + turnblocked = "$*+x" ++ commandchars +-- vim:ts=2 sw=2 et diff --git a/src/RailCompiler/Backend.hs b/src/RailCompiler/Backend.hs --- a/src/RailCompiler/Backend.hs +++ b/src/RailCompiler/Backend.hs @@ -1,8 +1,7 @@ {- | Module : Backend Description : Converts the internal LLVM representation into textual LLVM IR. -Maintainer : See the AUTHORS file in the root directory of this project for a list - of contributors. +Maintainer : Tilman Blumenbach, Nicolas Lehmann, Philipp Borgers License : MIT Uses the LLVM bindings for Haskell to convert the internal LLVM representation @@ -16,30 +15,25 @@ where -- imports -- -import InterfaceDT as IDT import ErrorHandling as EH +import InterfaceDT as IDT +import Control.Monad.Error import LLVM.General.AST -import qualified LLVM.General.AST as AST +import LLVM.General.AST.Global import LLVM.General.Context import LLVM.General.Module -import Control.Monad.Error -import LLVM.General.AST.Global - +import qualified LLVM.General.AST as AST -- functions -- -- |Converts the internal LLVM representation into textual LLVM IR. -process :: IDT.CodeOpt2Backend -> IDT.Backend2Output -process input = output - where - output = IDT.IBO $ generateOutput input +process :: IDT.InterCode2Backend -> IDT.Backend2Output +process input = IDT.IBO $ generateOutput input -- |Uses the Haskell LLVM bindings to convert the internal LLVM -- representation into textual LLVM IR. -generateOutput :: IDT.CodeOpt2Backend -> IO String -generateOutput (IDT.ICB mod) = do +generateOutput :: IDT.InterCode2Backend -> IO String +generateOutput (IDT.IIB mod) = do s <- withContext $ \context -> runErrorT $ withModuleFromAST context mod $ \m -> moduleLLVMAssembly m - case s of - Left err -> return err - Right ll -> return ll + either error return s diff --git a/src/RailCompiler/CodeOptimization.hs b/src/RailCompiler/CodeOptimization.hs deleted file mode 100644 --- a/src/RailCompiler/CodeOptimization.hs +++ /dev/null @@ -1,23 +0,0 @@ -{- | -Module : CodeOptimization.hs -Description : . -Maintainer : Christopher Pockrandt -License : MIT - -This module might be used for optimizing intermediate llvm code one day (or not). -Until then, `process` equals the identity function. - --}module CodeOptimization ( - process -- main function of the module "CodeOptimization" - ) - where - - -- imports -- - import InterfaceDT as IDT - import ErrorHandling as EH - - -- functions -- - process :: IDT.InterCode2CodeOpt -> IDT.CodeOpt2Backend - process (IDT.IIC input) = IDT.ICB output - where - output = input diff --git a/src/RailCompiler/ErrorHandling.hs b/src/RailCompiler/ErrorHandling.hs --- a/src/RailCompiler/ErrorHandling.hs +++ b/src/RailCompiler/ErrorHandling.hs @@ -24,6 +24,8 @@ strNonSymmetricEscape = "Non-symmetric escape sequence in string constant." strUnhandledEscape = "Unhandled escape sequence `\\%c' in string constant." strMissingClosingBracket= "Closing Bracket not found." +strInvalidVarName = "Invalid Variable Name used." +strInvalidFuncName = "Invalid Function Name used." -- "shr" like in "shared graph representation". shrLineNoLexeme = "No lexeme found in line: %s" @@ -33,9 +35,10 @@ -- SemanticalAnalysis-Errors strInvalidMovement = "Invalid movement." strMainMissing = "No 'main' Method found." +strUnknownNode = "Unknown Node in AST." +strEmptyProgram = "Empty Program." +strDuplicateFunctions = "Duplicate Functions found." -- IntermediateCode-Errors - --- CodeOptimization-Errors -- Backend diff --git a/src/RailCompiler/FunctionDeclarations.hs b/src/RailCompiler/FunctionDeclarations.hs new file mode 100644 --- /dev/null +++ b/src/RailCompiler/FunctionDeclarations.hs @@ -0,0 +1,320 @@ +{- | +Module : FunctionDeclarations.hs +Description : Function declarations for intermediate code generation +Maintainer : Philipp Borgers, Tilman Blumenbach, Lyudmila Vaseva, Sascha Zinke, + Maximilian Claus, Michal Ajchman, Nicolas Lehmann, Tudor Soroceanu +License : MIT +Stability : unstable + +All function declarations live here. + +-} + +module FunctionDeclarations where + +import LLVM.General.AST.AddrSpace +import LLVM.General.AST +import qualified LLVM.General.AST.Global as Global + +import TypeDefinitions + +-- |Function declaration for 'start'. +start :: Definition +start = GlobalDefinition $ Global.functionDefaults { + Global.name = Name "start", + Global.returnType = VoidType, + Global.parameters = ([], False) +} + +-- |Function declaration for 'underflow_check'. +underflowCheck :: Definition +underflowCheck = GlobalDefinition $ Global.functionDefaults { + Global.name = Name "underflow_check", + Global.returnType = VoidType, + Global.parameters = ([], False) +} + +-- |Function declaration for 'print'. +print :: Definition +print = GlobalDefinition $ Global.functionDefaults { + Global.name = Name "print", + Global.returnType = VoidType, + Global.parameters = ([], False) +} + +-- |Function declaration for 'crash'. +crash :: Definition +crash = GlobalDefinition $ Global.functionDefaults { + Global.name = Name "crash", + Global.returnType = VoidType, + Global.parameters = ([ Parameter (IntegerType 1) (Name "is_custom_error") [] ], False) +} + +-- |Function declaration for 'finish'. +finish :: Definition +finish = GlobalDefinition $ Global.functionDefaults { + Global.name = Name "finish", + Global.returnType = VoidType, + Global.parameters = ([], False) +} + +-- |Function declaration for 'input'. +inputFunc :: Definition +inputFunc = GlobalDefinition $ Global.functionDefaults { + Global.name = Name "input", + Global.returnType = VoidType, + Global.parameters = ([], False) +} + +-- |Function declaration for 'eof_check'. +eofCheck :: Definition +eofCheck = GlobalDefinition $ Global.functionDefaults { + Global.name = Name "eof_check", + Global.returnType = VoidType, + Global.parameters = ([], False) +} + +-- |Function declaration for 'add'. +add :: Definition +add = GlobalDefinition $ Global.functionDefaults { + Global.name = Name "add", + Global.returnType = VoidType, + Global.parameters = ([], False) +} + +-- |Function declaration for 'rem'. +rem1 :: Definition +rem1 = GlobalDefinition $ Global.functionDefaults { + Global.name = Name "rem", + Global.returnType = VoidType, + Global.parameters = ([], False) +} + +-- |Function declaration for 'sub'. +sub :: Definition +sub = GlobalDefinition $ Global.functionDefaults { + Global.name = Name "sub", + Global.returnType = VoidType, + Global.parameters = ([], False) +} + +-- |Function declaration for 'mul'. +mul :: Definition +mul = GlobalDefinition $ Global.functionDefaults { + Global.name = Name "mult", + Global.returnType = VoidType, + Global.parameters = ([], False) +} + +-- |Function declaration for 'div'. +div1 :: Definition +div1 = GlobalDefinition $ Global.functionDefaults { + Global.name = Name "div", + Global.returnType = VoidType, + Global.parameters = ([], False) +} + +-- |Function declaration for 'type'. +type1 :: Definition +type1 = GlobalDefinition $ Global.functionDefaults { + Global.name = Name "type", + Global.returnType = VoidType, + Global.parameters = ([], False) +} + +-- |Function declaration for pushing constants. +pushStringCpy :: Definition +pushStringCpy = GlobalDefinition $ Global.functionDefaults { + Global.name = Name "push_string_cpy", + Global.returnType = stackElementPointerType, + Global.parameters = ([ Parameter bytePointerType (UnName 0) [] ], False) +} + +-- |Function declaration for 'pop'. +pop :: Definition +pop = GlobalDefinition $ Global.functionDefaults { + Global.name = Name "pop", + Global.returnType = bytePointerType, + Global.parameters = ([], False) +} + +-- |Function declaration for 'peek' +peek :: Definition +peek = GlobalDefinition $ Global.functionDefaults { + Global.name = Name "peek", + Global.returnType = bytePointerType, + Global.parameters = ([], False) +} + +-- |Function declaration for 'streq' +streq :: Definition +streq = GlobalDefinition $ Global.functionDefaults { + Global.name = Name "streq", + Global.returnType = bytePointerType, + Global.parameters = ([], False) +} + +-- |Function declaration for 'strlen' +strlen :: Definition +strlen = GlobalDefinition $ Global.functionDefaults { + Global.name = Name "strlen", + Global.returnType = bytePointerType, + Global.parameters = ([], False) +} + +-- |Function declaration for 'strapp' +strapp :: Definition +strapp = GlobalDefinition $ Global.functionDefaults { + Global.name = Name "strapp", + Global.returnType = bytePointerType, + Global.parameters = ([], False) +} + +-- |Function declaration for 'strcut'. +strcut :: Definition +strcut = GlobalDefinition $ Global.functionDefaults { + Global.name = Name "strcut", + Global.returnType = bytePointerType, + Global.parameters = ([], False) +} + +-- |Function declaration for 'pop_int' +popInt :: Definition +popInt = GlobalDefinition $ Global.functionDefaults { + Global.name = Name "pop_int", + Global.returnType = IntegerType 64, + Global.parameters = ([], False) +} + +-- |Function declaration for 'pop_bool' +popBool :: Definition +popBool = GlobalDefinition $ Global.functionDefaults { + Global.name = Name "pop_bool", + Global.returnType = IntegerType 64, + Global.parameters = ([], False) +} + +-- |Function declaration for 'equal' +equal :: Definition +equal = GlobalDefinition $ Global.functionDefaults { + Global.name = Name "equal", + Global.returnType = VoidType, + Global.parameters = ([], False) +} + +-- |Function declaration for 'greater' +greater :: Definition +greater = GlobalDefinition $ Global.functionDefaults { + Global.name = Name "greater", + Global.returnType = VoidType, + Global.parameters = ([], False) +} + +-- |Function declaration for 'pop_into' +popInto :: Definition +popInto = GlobalDefinition $ Global.functionDefaults { + Global.name = Name "pop_into", + Global.returnType = VoidType, + Global.parameters = ( [ Parameter (PointerType (NamedTypeReference $ Name + "struct.table") (AddrSpace 0)) (UnName 0) [], + Parameter bytePointerType (UnName 0) [] ], False) +} + +-- |Function declaration for 'push_from' +pushFrom :: Definition +pushFrom = GlobalDefinition $ Global.functionDefaults { + Global.name = Name "push_from", + Global.returnType = VoidType, + Global.parameters = ( [ Parameter (PointerType (NamedTypeReference $ Name + "struct.table") (AddrSpace 0)) (UnName 0) [], + Parameter bytePointerType (UnName 0) [] ], False) +} + +-- |Function declaration for initialising of the symbol table +initialiseSymbolTable :: Definition +initialiseSymbolTable = GlobalDefinition $ Global.functionDefaults { + Global.name = Name "initialise", + Global.returnType = VoidType, + Global.parameters = ([ Parameter (PointerType (NamedTypeReference $ + Name "struct.table") (AddrSpace 0)) (UnName 0) [] ], False) +} + +-- |Function declaration for malloc +malloc :: Definition +malloc = GlobalDefinition $ Global.functionDefaults { + Global.name = Name "malloc", + Global.returnType = bytePointerType, + Global.parameters = ([ Parameter (IntegerType 64) (UnName 0) [] ], False) +} + +-- |Function declaration for copying of the symbol table +copySymbolTable :: Definition +copySymbolTable = GlobalDefinition $ Global.functionDefaults { + Global.name = Name "copy_symbol_table", + Global.returnType = VoidType, + Global.parameters = ([ Parameter (PointerType (NamedTypeReference $ + Name "struct.table") (AddrSpace 0)) (UnName 0) [], + Parameter (PointerType (NamedTypeReference $ + Name "struct.table") (AddrSpace 0)) (UnName 0) [] ], False) +} + +-- |Function declaration for pushing lambda +pushLambda :: Definition +pushLambda = GlobalDefinition $ Global.functionDefaults { + Global.name = Name "push_lambda", + Global.returnType = VoidType, + Global.parameters = ([ Parameter (PointerType ( + PointerType functionReturnLambda (AddrSpace 0)) (AddrSpace 0)) (UnName 0) [], + Parameter (PointerType (NamedTypeReference $ + Name "struct.table") (AddrSpace 0)) (UnName 0) [] ], False) +} + +-- |Function declaration for popping a lambda element +popLambda :: Definition +popLambda = GlobalDefinition $ Global.functionDefaults { + Global.name = Name "pop_lambda", + Global.returnType = PointerType (NamedTypeReference $ Name "lambda_element") (AddrSpace 0), + Global.parameters = ([], False) +} + +-- |Function declaration for getting a pointer to a lambda function +getLambda :: Definition +getLambda = GlobalDefinition $ Global.functionDefaults { + Global.name = Name "get_lambda_pointer", + Global.returnType = PointerType functionReturnLambda (AddrSpace 0), + Global.parameters = ([ Parameter (PointerType (NamedTypeReference $ + Name "lambda_element") (AddrSpace 0)) (UnName 0) [] ], False) +} + +-- |Function declaration for getting lambda symbol table +getTable :: Definition +getTable = GlobalDefinition $ Global.functionDefaults { + Global.name = Name "get_lambda_table", + Global.returnType = PointerType (NamedTypeReference $ Name "struct.table") (AddrSpace 0), + Global.parameters = ([ Parameter (PointerType (NamedTypeReference $ + Name "lambda_element") (AddrSpace 0)) (UnName 0) [] ], False) +} + +-- |Function declaration for pushing nil onto the stack. +listPushNil :: Definition +listPushNil = GlobalDefinition $ Global.functionDefaults { + Global.name = Name "gen_list_push_nil", + Global.returnType = VoidType, + Global.parameters = ([], False) +} + +-- |Function declaration for list cons. +listCons :: Definition +listCons = GlobalDefinition $ Global.functionDefaults { + Global.name = Name "gen_list_cons", + Global.returnType = VoidType, + Global.parameters = ([], False) +} + +-- |Function declaration for list breakup. +listBreakup :: Definition +listBreakup = GlobalDefinition $ Global.functionDefaults { + Global.name = Name "gen_list_breakup", + Global.returnType = VoidType, + Global.parameters = ([], False) +} diff --git a/src/RailCompiler/InstructionPointer.hs b/src/RailCompiler/InstructionPointer.hs new file mode 100644 --- /dev/null +++ b/src/RailCompiler/InstructionPointer.hs @@ -0,0 +1,215 @@ +{- | +Module : Instruction Pointer +Description : Helper module for Lexer to actually move on code. +Maintainer : Christian H. et al. +License : MIT +-} +module InstructionPointer ( + -- constructors + start, crash, crashfrom, ipmerge, IP(IP), + RelDirection(Left, Right, Forward), + Direction (N, NE, E, SE, S, SW, W, NW), + -- movement + junctionturns, lambdadirs, move, turnaround, + -- attribute/pseudoattribute functions + dir, nodecount, posx, posy, count, path, visited, + -- other + posdir, absolute, nodeadd, turn, current, charat + ) + where + + import InterfaceDT as IDT + import Data.Maybe + import qualified Data.Map as Map + + -- |An absolute direction. + data Direction = N | NE | E | SE | S | SW | W | NW deriving (Ord, Eq, Show) + -- |A relative direction. + data RelDirection = Left | Forward | Right deriving (Eq, Show) + -- |Instruction pointer consisting of position and an orientation. + data IP = + IP { + -- |Number of processed characters since start of current function. + count :: Int, + -- |Current X position. + posx :: Int, + -- |Current Y position. + posy :: Int, + -- |Current 'Direction'. + dir :: Direction, + -- |Determines if the instruction pointer is on a left or right path of a Junction + path :: RelDirection, + -- |Map of Position and Direction to Id + known :: Map.Map (Int, Int, Direction) Int + } + deriving (Show) + + instance Eq IP + where + (==) ipl ipr = posx ipl == posx ipr && posy ipl == posy ipr && dir ipl == dir ipr + + -- |Initial value for the instruction pointer at the start of a function. + start :: IP + start = IP 0 0 0 SE Forward (Map.singleton (0, 0, SE) 1) + + -- |An instruction pointer representing a "crash" (fatal error). + crash :: IP + crash = IP 0 (-1) (-1) NW Forward Map.empty + + crashfrom :: IP -> IP + crashfrom = ipmerge crash + + ipmerge :: IP -> IP -> IP + ipmerge ipl ipr = ipl{known = known ipr} + + turn :: Char -> IP -> IP + turn '@' ip = turnaround ip + turn '|' ip + | dir ip `elem` [NW, N, NE] = ip{dir = N} + | dir ip `elem` [SW, S, SE] = ip{dir = S} + turn '/' ip + | dir ip `elem` [N, NE, E] = ip{dir = NE} + | dir ip `elem` [S, SW, W] = ip{dir = SW} + turn '-' ip + | dir ip `elem` [NE, E, SE] = ip{dir = E} + | dir ip `elem` [SW, S, NW] = ip{dir = W} + turn '\\' ip + | dir ip `elem` [W, NW, N] = ip{dir = NW} + | dir ip `elem` [E, SE, S] = ip{dir = SE} + turn _ ip = ip + + -- |Move the instruction pointer in a relative direction. + move :: IP -- ^Current instruction pointer. + -> RelDirection -- ^Relative direction to move in. + -> IP -- ^New instruction pointer. + move ip reldir = ip{count = newcount, posx = newx, posy = newy, dir = absolute ip reldir} + where + (newy, newx) = posdir ip reldir + newcount = count ip + 1 + + -- |Get the 'Char' at the current position of the instruction pointer. + current :: IDT.Grid2D -- ^Line representation of the current function. + -> IP -- ^Current instruction pointer. + -> Char -- ^'Char' at the current IP position. + current code ip = charat code (posy ip, posx ip) + + -- |Returns 'Char' at given position, @\' \'@ if position is invalid. + charat :: IDT.Grid2D -- ^Line representation of current function. + -> (Int, Int) -- ^Position as (x, y) coordinate. + -> Char -- ^'Char' at given position. + charat code _ | Map.size code == 0 = ' ' + charat code (y, _) | isNothing (Map.lookup y code) = ' ' + charat code (y, x) + | isNothing (Map.lookup x line) = ' ' + | otherwise = fromJust (Map.lookup x line) + where + line = fromJust (Map.lookup y code) + + -- returns instruction pointers turned for (False, True) + junctionturns :: IDT.Grid2D -> IP -> (IP, IP) + junctionturns code ip = tuplecheck $ tuplemove $ addpath $ turning (current code ip) ip + where + check ip = if current code ip == primary ip then ip else crashfrom ip + tuplecheck (ipl, ipr) = (check ipl, check ipr) + turning char ip + | char == '<' = case dir ip of + E -> (ip{dir = NE}, ip{dir = SE}) + SW -> (ip{dir = SE}, ip{dir = W}) + NW -> (ip{dir = W}, ip{dir = NE}) + _ -> (crashfrom ip, crashfrom ip) + | char == '>' = case dir ip of + W -> (ip{dir = SW}, ip{dir = NW}) + SE -> (ip{dir = E}, ip{dir = SW}) + NE -> (ip{dir = NW}, ip{dir = E}) + _ -> (crashfrom ip, crashfrom ip) + | char == '^' = case dir ip of + S -> (ip{dir = SE}, ip{dir = SW}) + NE -> (ip{dir = N}, ip{dir = SE}) + NW -> (ip{dir = SW}, ip{dir = N}) + _ -> (crashfrom ip, crashfrom ip) + | char == 'v' = case dir ip of + N -> (ip{dir = NW}, ip{dir = NE}) + SE -> (ip{dir = NE}, ip{dir = S}) + SW -> (ip{dir = S}, ip{dir = NW}) + _ -> (crashfrom ip, crashfrom ip) + | otherwise = (ip, ip) + + -- returns insturction pointers turned for (Lambda, Reflected) + lambdadirs :: IP -> (IP, IP) + lambdadirs ip = addpath (ip, turnaround ip) + + -- moves both pointers one step + tuplemove :: (IP, IP) -> (IP, IP) + tuplemove (ipl, ipr) = (move ipl Forward, move ipr Forward) + + nodecount :: IP -> Int + nodecount ip = Map.size (known ip) + + nodeadd :: IP -> Int -> IP + nodeadd ip newnode = ip{count = 0, known = Map.insert (posx ip, posy ip, dir ip) newnode (known ip)} + + -- saves path information in instruction pointers + addpath :: (IP, IP) -> (IP, IP) + addpath (ipl, ipr) = (ipl{path = InstructionPointer.Left}, ipr{path = InstructionPointer.Right}) + + -- make a 180° turn on instruction pointer + turnaround :: IP -> IP + turnaround ip = ip{dir = absolute ip{dir = absolute ip{dir = absolute ip{dir = absolute ip InstructionPointer.Left} InstructionPointer.Left} InstructionPointer.Left} InstructionPointer.Left} + + -- |Get ID of the node that has been already visited using the current IP + -- (direction and coordinates). + visited :: IP -- ^Instruction pointer to use. + -> Int -- ^ID of visited node or 0 if none. + visited ip = Map.findWithDefault 0 (posx ip, posy ip, dir ip) (known ip) + + -- |Get the position of a specific heading. + posdir :: IP -- ^Current instruction pointer. + -> RelDirection -- ^Current relative direction. + -> (Int, Int) -- ^New position that results from the given relative movement. + posdir ip reldir = posabsdir ip (absolute ip reldir) + + -- |Get the position of an absolute direction. + posabsdir :: IP -- ^Current instruction pointer. + -> Direction -- ^Current absolute direction. + -> (Int, Int) -- ^New position that results from the given absolute movement. + posabsdir ip N = (posy ip - 1, posx ip) + posabsdir ip NE = (posy ip - 1, posx ip + 1) + posabsdir ip E = (posy ip, posx ip + 1) + posabsdir ip SE = (posy ip + 1, posx ip + 1) + posabsdir ip S = (posy ip + 1, posx ip) + posabsdir ip SW = (posy ip + 1, posx ip - 1) + posabsdir ip W = (posy ip, posx ip - 1) + posabsdir ip NW = (posy ip - 1, posx ip - 1) + + -- |Convert a relative direction into a relative one. + absolute :: IP -- ^Current instruction pointer. + -> RelDirection -- ^Relative direction to convert. + -> Direction -- ^Equivalent absolute direction. + absolute x Forward = dir x + absolute (IP {dir=N}) InstructionPointer.Left = NW + absolute (IP {dir=N}) InstructionPointer.Right = NE + absolute (IP {dir=NE}) InstructionPointer.Left = N + absolute (IP {dir=NE}) InstructionPointer.Right = E + absolute (IP {dir=E}) InstructionPointer.Left = NE + absolute (IP {dir=E}) InstructionPointer.Right = SE + absolute (IP {dir=SE}) InstructionPointer.Left = E + absolute (IP {dir=SE}) InstructionPointer.Right = S + absolute (IP {dir=S}) InstructionPointer.Left = SE + absolute (IP {dir=S}) InstructionPointer.Right = SW + absolute (IP {dir=SW}) InstructionPointer.Left = S + absolute (IP {dir=SW}) InstructionPointer.Right = W + absolute (IP {dir=W}) InstructionPointer.Left = SW + absolute (IP {dir=W}) InstructionPointer.Right = NW + absolute (IP {dir=NW}) InstructionPointer.Left = W + absolute (IP {dir=NW}) InstructionPointer.Right = N + + -- what is the primary rail for the given direction? + -- mainly used to check if junctions turn away correctly + primary :: IP -> Char + primary ip + | dir ip `elem` [N, S] = '|' + | dir ip `elem` [E, W] = '-' + | dir ip `elem` [NE, SW] = '/' + | dir ip `elem` [NW, SE] = '\\' + +-- vim:ts=2 sw=2 et diff --git a/src/RailCompiler/InterfaceDT.hs b/src/RailCompiler/InterfaceDT.hs --- a/src/RailCompiler/InterfaceDT.hs +++ b/src/RailCompiler/InterfaceDT.hs @@ -14,10 +14,12 @@ module InterfaceDT where import qualified LLVM.General.AST as LAST + import qualified Data.Map as Map -- type definitions -- - type Grid2D = [String] - + type Grid2D = Map.Map Int (Map.Map Int Char) + -- Int gives the line on which the function starts + type PositionedGrid = (Grid2D, Int) -- |(NodeID (start: 1), Lexeme of Node, NodeID of following Node (0 if none)) type LexNode = (Int, Lexeme, Int) -- |(FunctionID, Graph of Function as adjacency list) @@ -27,17 +29,17 @@ -- |* following Nodes or Pathes could have ID==0, in this case there is no Follower -- |Junction Int <=> if false goto Int; if true <=> following node + -- |Lambda Int <=> Int holds node of anonymous function data Lexeme = NOP | Boom | EOF | Input | Output | Underflow | RType | Constant String | Push String | Pop String | Call String | Add1 | Divide | Multiply | Remainder | Subtract | Cut | Append | Size | Nil | Cons | - Breakup | Greater | Equal | Start | Finish | Junction Int deriving (Eq, Show) + Breakup | Greater | Equal | Start | Finish | Junction Int | Lambda Int deriving (Eq, Show) -- interface datatypes -- data Input2PreProc = IIP String deriving (Eq, Show) - data PreProc2Lexer = IPL [Grid2D] deriving (Eq, Show) + data PreProc2Lexer = IPL [PositionedGrid] deriving (Eq, Show) data Lexer2SynAna = ILS [Graph] deriving (Eq, Show) data SynAna2SemAna = ISS [AST] deriving (Eq, Show) data SemAna2InterCode = ISI [AST] deriving (Eq, Show) - data InterCode2CodeOpt = IIC LAST.Module deriving (Eq, Show) - data CodeOpt2Backend = ICB LAST.Module deriving (Eq, Show) + data InterCode2Backend = IIB LAST.Module deriving (Eq, Show) data Backend2Output = IBO (IO String) diff --git a/src/RailCompiler/IntermediateCode.hs b/src/RailCompiler/IntermediateCode.hs --- a/src/RailCompiler/IntermediateCode.hs +++ b/src/RailCompiler/IntermediateCode.hs @@ -1,7 +1,8 @@ {- | Module : IntermediateCode.hs Description : Intermediate code generation -Copyright : (c) AUTHORS +Maintainer : Philipp Borgers, Tilman Blumenbach, Lyudmila Vaseva, Sascha Zinke, + Maximilian Claus, Michal Ajchman, Nicolas Lehmann, Tudor Soroceanu License : MIT Stability : unstable @@ -16,26 +17,27 @@ module IntermediateCode(process) where -- imports -- -import InterfaceDT as IDT import ErrorHandling as EH +import InterfaceDT as IDT +import FunctionDeclarations +import TypeDefinitions +import Control.Applicative +import Control.Monad.State +import Data.Char +import Data.List +import Data.Map hiding (filter, map) +import Data.Word import LLVM.General.AST -import qualified LLVM.General.AST.Global as Global +import LLVM.General.AST.AddrSpace import LLVM.General.AST.CallingConvention import LLVM.General.AST.Constant as Constant -import LLVM.General.AST.Linkage -import LLVM.General.AST.AddrSpace -import LLVM.General.AST.Operand +import LLVM.General.AST.Float import LLVM.General.AST.Instruction as Instruction import LLVM.General.AST.IntegerPredicate -import LLVM.General.AST.Float -import Data.Char -import Data.Word -import Data.List -import Data.Map hiding (filter, map) - -import Control.Monad.State -import Control.Applicative +import LLVM.General.AST.Linkage +import LLVM.General.AST.Operand +import qualified LLVM.General.AST.Global as Global data CodegenState = CodegenState { blocks :: [BasicBlock], @@ -59,7 +61,7 @@ execCodegen :: Map String (Int, Integer) -> Codegen a -> a execCodegen d m = evalState (runCodegen m) $ CodegenState [] 0 d --- generate module from list of definitions +-- |Generate module from list of definitions. generateModule :: [Definition] -> Module generateModule definitions = defaultModule { moduleName = "rail-heaven", @@ -76,7 +78,7 @@ metadata' = [] } --- generate global byte array (constant string) +-- |Generate global byte array (from a constant string). createGlobalString :: Lexeme -> Global createGlobalString (Constant s) = globalVariableDefaults { Global.type' = ArrayType { @@ -92,218 +94,65 @@ l = toInteger $ 1 + length s trans c = Int { integerBits = 8, integerValue = toInteger $ ord c } --- create constant strings/byte arrays for module --- TODO maybe rename these subfunctions? +-- |Create constant strings/byte arrays for a module. +-- TODO: Maybe rename these subfunctions? generateConstants :: [AST] -> [Global] generateConstants = map createGlobalString . getAllCons +-- |Get all 'Constant's in a module. getAllCons :: [AST] -> [Lexeme] getAllCons = concatMap generateCons + where + generateCons :: AST -> [Lexeme] + generateCons (name, paths) = concatMap generateC paths -generateCons :: AST -> [Lexeme] -generateCons (name, paths) = concatMap generateC paths + generateC :: (Int, [Lexeme], Int) -> [Lexeme] + generateC (pathID, lex, nextPath) = filter checkCons lex -generateC :: (Int, [Lexeme], Int) -> [Lexeme] -generateC (pathID, lex, nextPath) = filter checkCons lex -checkCons (Constant c) = True -checkCons _ = False + checkCons :: Lexeme -> Bool + checkCons (Constant c) = True + checkCons _ = False -------------------------------------------------------------------------------- --- generate global variables for push and pop form and into variables +-- |Generate global variables for push and pop from and into variables. createGlobalVariable :: Lexeme -> Global createGlobalVariable (Pop v) = globalVariableDefaults { Global.name = Name v, - Global.type' = bytePointerTypeVar, - Global.initializer = Just (Undef VoidType) + Global.type' = ArrayType { + nArrayElements = fromInteger l, + elementType = IntegerType {typeBits = 8} + }, + Global.initializer = Just Array { + memberType = IntegerType {typeBits = 8}, + memberValues = map trans v ++ [Int { integerBits = 8, integerValue = 0 }] + } } + where + l = toInteger $ 1 + length v + trans c = Int { integerBits = 8, integerValue = toInteger $ ord c } +-- |Generate all global variable definitions for a module. generateVariables :: [AST] -> [Global] generateVariables = map createGlobalVariable . getAllVars - -getAllVars :: [AST] -> [Lexeme] -getAllVars = concatMap generateVars - -generateVars :: AST -> [Lexeme] -generateVars (name, paths) = nub $ concatMap generateV paths --delete duplicates - -generateV :: (Int, [Lexeme], Int) -> [Lexeme] -generateV (pathID, lex, nextPath) = filter checkVars lex -checkVars (Pop v) = True -checkVars _ = False --------------------------------------------------------------------------------- - --- pointer type for i8* used e.g. as "string" pointer -bytePointerType = PointerType { - pointerReferent = IntegerType 8, - pointerAddrSpace = AddrSpace 0 -} - --- pointer type for i8** used as variable pointer -bytePointerTypeVar = PointerType { - pointerReferent = PointerType { - pointerReferent = IntegerType 8, - pointerAddrSpace = AddrSpace 0 - }, - pointerAddrSpace = AddrSpace 0 -} - --- |Function declaration for 'underflow_check'. -underflowCheck = GlobalDefinition $ Global.functionDefaults { - Global.name = Name "underflow_check", - Global.returnType = VoidType, - Global.parameters = ([], False) -} - --- |Function declaration for 'print'. -print = GlobalDefinition $ Global.functionDefaults { - Global.name = Name "print", - Global.returnType = VoidType, - Global.parameters = ([], False) -} - --- |Function declaration for 'crash'. -crash = GlobalDefinition $ Global.functionDefaults { - Global.name = Name "crash", - Global.returnType = VoidType, - Global.parameters = ([ Parameter (IntegerType 1) (Name "is_custom_error") [] ], False) -} - --- |Function declaration for 'finish'. -finish = GlobalDefinition $ Global.functionDefaults { - Global.name = Name "finish", - Global.returnType = VoidType, - Global.parameters = ([], False) -} - --- |Function declaration for 'input'. -inputFunc = GlobalDefinition $ Global.functionDefaults { - Global.name = Name "input", - Global.returnType = VoidType, - Global.parameters = ([], False) -} - --- |Function declaration for 'eof_check'. -eofCheck = GlobalDefinition $ Global.functionDefaults { - Global.name = Name "eof_check", - Global.returnType = VoidType, - Global.parameters = ([], False) -} - --- |Function declaration for 'add'. -add = GlobalDefinition $ Global.functionDefaults { - Global.name = Name "add", - Global.returnType = VoidType, - Global.parameters = ([], False) -} - --- |Function declaration for 'rem'. -rem1 = GlobalDefinition $ Global.functionDefaults { - Global.name = Name "rem", - Global.returnType = VoidType, - Global.parameters = ([], False) -} - --- |Function declaration for 'sub'. -sub = GlobalDefinition $ Global.functionDefaults { - Global.name = Name "sub", - Global.returnType = VoidType, - Global.parameters = ([], False) -} - --- |Function declaration for 'mul'. -mul = GlobalDefinition $ Global.functionDefaults { - Global.name = Name "mult", - Global.returnType = VoidType, - Global.parameters = ([], False) -} - --- |Function declaration for 'div'. -div1 = GlobalDefinition $ Global.functionDefaults { - Global.name = Name "div", - Global.returnType = VoidType, - Global.parameters = ([], False) -} - - --- function declaration for push -push = GlobalDefinition $ Global.functionDefaults { - Global.name = Name "push", - Global.returnType = VoidType, - Global.parameters = ([ Parameter bytePointerType (UnName 0) [] ], False) -} - --- function declaration for pop -pop = GlobalDefinition $ Global.functionDefaults { - Global.name = Name "pop", - Global.returnType = bytePointerType, - Global.parameters = ([], False) -} - --- function declaration for peek -peek = GlobalDefinition $ Global.functionDefaults { - Global.name = Name "peek", - Global.returnType = bytePointerType, - Global.parameters = ([], False) -} - - --- function declaration for streq -streq = GlobalDefinition $ Global.functionDefaults { - Global.name = Name "streq", - Global.returnType = bytePointerType, - Global.parameters = ([], False) -} - --- function declaration for strlen -strlen = GlobalDefinition $ Global.functionDefaults { - Global.name = Name "strlen", - Global.returnType = bytePointerType, - Global.parameters = ([], False) -} - --- function declaration for strapp -strapp = GlobalDefinition $ Global.functionDefaults { - Global.name = Name "strapp", - Global.returnType = bytePointerType, - Global.parameters = ([], False) -} + where + getAllVars :: [AST] -> [Lexeme] + getAllVars = concatMap generateVars --- function declaration for pop_int -popInt = GlobalDefinition $ Global.functionDefaults { - Global.name = Name "pop_int", - Global.returnType = IntegerType 64, - Global.parameters = ([], False) -} + generateVars :: AST -> [Lexeme] + generateVars (name, paths) = nub $ concatMap generateV paths --delete duplicates --- function declaration for equal -equal = GlobalDefinition $ Global.functionDefaults { - Global.name = Name "equal", - Global.returnType = VoidType, - Global.parameters = ([], False) -} --- function declaration for greater -greater = GlobalDefinition $ Global.functionDefaults { - Global.name = Name "greater", - Global.returnType = VoidType, - Global.parameters = ([], False) -} + generateV :: (Int, [Lexeme], Int) -> [Lexeme] + generateV (pathID, lex, nextPath) = filter checkVars lex --- function declaration for pop_into -popInto = GlobalDefinition $ Global.functionDefaults { - Global.name = Name "pop_into", - Global.returnType = VoidType, - Global.parameters = ([ Parameter bytePointerTypeVar (UnName 0) [] ], False) -} + checkVars :: Lexeme -> Bool + checkVars (Pop v) = True + checkVars _ = False --- function declaration for push_from -pushFrom = GlobalDefinition $ Global.functionDefaults { - Global.name = Name "push_from", - Global.returnType = VoidType, - Global.parameters = ([ Parameter bytePointerTypeVar (UnName 0) [] ], False) -} +-------------------------------------------------------------------------------- -- |Generate an instruction for the 'u'nderflow check command. -generateInstruction Underflow = +generateInstruction :: (Lexeme, String) -> Codegen [Named Instruction] +generateInstruction (Underflow, funcName) = return [Do LLVM.General.AST.Call { isTailCall = False, callingConvention = C, @@ -314,14 +163,15 @@ metadata = [] }] -generateInstruction (Junction label) = do +-- |Generate instructions for junctions. +generateInstruction (Junction label, funcName) = do index <- fresh index2 <- fresh return [ UnName index := LLVM.General.AST.Call { isTailCall = False, callingConvention = C, returnAttributes = [], - function = Right $ ConstantOperand $ GlobalReference $ Name "pop_int", + function = Right $ ConstantOperand $ GlobalReference $ Name "pop_bool", arguments = [], functionAttributes = [], metadata = [] @@ -332,62 +182,51 @@ metadata = [] }] - --- generate instruction for pop into a variable -generateInstruction (Pop name) = do +-- |Generate instruction for pop into a variable +generateInstruction (Pop name, funcName) = do index <- fresh - index2 <- fresh - index3 <- fresh - return [ UnName index := Instruction.Alloca { - allocatedType = bytePointerType, - numElements = Nothing, --Just (LocalReference (Name name)), - alignment = 4, - metadata = [] - }, - UnName index2 := LLVM.General.AST.Call { + return [ UnName index := LLVM.General.AST.Call { isTailCall = False, callingConvention = C, returnAttributes = [], function = Right $ ConstantOperand $ GlobalReference $ Name "pop_into", - arguments = [(LocalReference $ UnName index, [])], + arguments = [ (LocalReference $ Name "table", []), + (ConstantOperand Constant.GetElementPtr { + Constant.inBounds = True, + Constant.address = Constant.GlobalReference (Name name), + Constant.indices = [ + Int { integerBits = 8, integerValue = 0 }, + Int { integerBits = 8, integerValue = 0 } + ]}, [])], functionAttributes = [], metadata = [] - }, - UnName index3 := Instruction.Store { - volatile = False, - Instruction.address = ConstantOperand $ GlobalReference $ Name name, - value = LocalReference (UnName index), - maybeAtomicity = Nothing, - alignment = 4, - metadata = [] -}] + }] --- generate instruction for push from a variable -generateInstruction (Push name) = do +-- |Generate instruction for push from a variable +generateInstruction (Push name, funcName) = do index <- fresh - index2 <- fresh - return [ UnName index := Instruction.Load { - volatile = False, - Instruction.address = ConstantOperand $ GlobalReference $ Name name, - maybeAtomicity = Nothing, - alignment = 4, - metadata = [] - }, - UnName index2 := LLVM.General.AST.Call { + return [ UnName index := LLVM.General.AST.Call { isTailCall = False, callingConvention = C, returnAttributes = [], function = Right $ ConstantOperand $ GlobalReference $ Name "push_from", - arguments = [(LocalReference $ UnName index, [])], + arguments = [(LocalReference $ Name "table", []), + (ConstantOperand Constant.GetElementPtr { + Constant.inBounds = True, + Constant.address = Constant.GlobalReference (Name name), + Constant.indices = [ + Int { integerBits = 8, integerValue = 0 }, + Int { integerBits = 8, integerValue = 0 } + ]}, [])], functionAttributes = [], metadata = [] }] --- generate instruction for push of a constant +-- |Generate instruction for push of a constant. -- access to our push function definied in stack.ll?? -- http://llvm.org/docs/LangRef.html#call-instruction -generateInstruction (Constant value) = do +generateInstruction (Constant value, funcName) = do index <- fresh dict <- gets localDict return [UnName index := LLVM.General.AST.Call { @@ -402,7 +241,7 @@ -- 'signext', and 'inreg' attributes are valid here returnAttributes = [], -- actual function to call - function = Right $ ConstantOperand $ GlobalReference $ Name "push", + function = Right $ ConstantOperand $ GlobalReference $ Name "push_string_cpy", -- argument list whose types match the function signature argument types -- and parameter attributes. All arguments must be of first class type. If -- the function signature indicates the function accepts a variable number of @@ -433,7 +272,7 @@ -- a list of Instructions that we can insert in the BasicBlock -- |Generate instruction for printing strings to stdout. -generateInstruction Output = +generateInstruction (Output, funcName) = return [Do LLVM.General.AST.Call { isTailCall = False, callingConvention = C, @@ -445,7 +284,7 @@ }] -- |Generate instruction for the Boom lexeme (crashes program). -generateInstruction Boom = +generateInstruction (Boom, funcName) = return [Do LLVM.General.AST.Call { isTailCall = False, callingConvention = C, @@ -457,7 +296,7 @@ }] -- |Generate instruction for the Input lexeme. -generateInstruction Input = +generateInstruction (Input, funcName) = return [Do LLVM.General.AST.Call { isTailCall = False, callingConvention = C, @@ -469,7 +308,7 @@ }] -- |Generate instruction for the EOF lexeme. -generateInstruction EOF = +generateInstruction (EOF, funcName) = return [Do LLVM.General.AST.Call { isTailCall = False, callingConvention = C, @@ -481,7 +320,7 @@ }] -- |Generate instruction for the add instruction. -generateInstruction Add1 = +generateInstruction (Add1, funcName) = return [Do LLVM.General.AST.Call { isTailCall = False, callingConvention = C, @@ -493,7 +332,7 @@ }] -- |Generate instruction for the remainder instruction. -generateInstruction Remainder = +generateInstruction (Remainder, funcName) = return [Do LLVM.General.AST.Call { isTailCall = False, callingConvention = C, @@ -504,9 +343,20 @@ metadata = [] }] +-- |Generate instruction for the type instruction. +generateInstruction (RType, funcName) = + return [Do LLVM.General.AST.Call { + isTailCall = False, + callingConvention = C, + returnAttributes = [], + function = Right $ ConstantOperand $ GlobalReference $ Name "type", + arguments = [], + functionAttributes = [], + metadata = [] + }] -- |Generate instruction for the sub instruction. -generateInstruction Subtract = +generateInstruction (Subtract, funcName) = return [Do LLVM.General.AST.Call { isTailCall = False, callingConvention = C, @@ -518,7 +368,7 @@ }] -- |Generate instruction for the mul instruction. -generateInstruction Multiply = +generateInstruction (Multiply, funcName) = return [Do LLVM.General.AST.Call { isTailCall = False, callingConvention = C, @@ -530,7 +380,7 @@ }] -- |Generate instruction for the div instruction. -generateInstruction Divide = +generateInstruction (Divide, funcName) = return [Do LLVM.General.AST.Call { isTailCall = False, callingConvention = C, @@ -541,9 +391,8 @@ metadata = [] }] - -- |Generate instruction for the strlen instruction. -generateInstruction Size = +generateInstruction (Size, funcName) = return [Do LLVM.General.AST.Call { isTailCall = False, callingConvention = C, @@ -555,7 +404,7 @@ }] -- |Generate instruction for the strapp instruction. -generateInstruction Append = +generateInstruction (Append, funcName) = return [Do LLVM.General.AST.Call { isTailCall = False, callingConvention = C, @@ -566,8 +415,20 @@ metadata = [] }] +-- |Generate instruction for the strcut instruction. +generateInstruction (Cut, funcName) = + return [Do LLVM.General.AST.Call { + isTailCall = False, + callingConvention = C, + returnAttributes = [], + function = Right $ ConstantOperand $ GlobalReference $ Name "strcut", + arguments = [], + functionAttributes = [], + metadata = [] + }] + -- |Generate instruction for the equal instruction. -generateInstruction Equal = +generateInstruction (Equal, funcName) = return [Do LLVM.General.AST.Call { isTailCall = False, callingConvention = C, @@ -578,9 +439,8 @@ metadata = [] }] - -- |Generate instruction for the greater instruction. -generateInstruction Greater = +generateInstruction (Greater, funcName) = return [Do LLVM.General.AST.Call { isTailCall = False, callingConvention = C, @@ -591,13 +451,87 @@ metadata = [] }] --- do nothing? ---generateInstruction Start = --- undefined +-- |Generate instruction for start instruction +generateInstruction (Start, funcName) = do + index <- fresh + index2 <- fresh + return [ UnName index := LLVM.General.AST.Call { + isTailCall = False, + callingConvention = C, + returnAttributes = [], + function = Right $ ConstantOperand $ GlobalReference $ Name "start", + arguments = [], + functionAttributes = [], + metadata = [] + }] +-- |Generate instructions for lambda push +generateInstruction (Lambda label, funcName) = do + index <- fresh + index2 <- fresh + index3 <- fresh + index4 <- fresh + index5 <- fresh + index6 <- fresh + return [ UnName index := LLVM.General.AST.Call { + isTailCall = False, + callingConvention = C, + returnAttributes = [], + function = Right $ ConstantOperand $ GlobalReference $ Name "malloc", + arguments = [(ConstantOperand $ Int 64 24, [])], + functionAttributes = [], + metadata = [] + }, + UnName index2 := LLVM.General.AST.BitCast { + Instruction.operand0 = LocalReference $ UnName index, + Instruction.type' = PointerType (NamedTypeReference $ Name "struct.table") (AddrSpace 0), + metadata = [] + }, + UnName index3 := LLVM.General.AST.Call { + isTailCall = False, + callingConvention = C, + returnAttributes = [], + function = Right $ ConstantOperand $ GlobalReference $ Name "initialise", + arguments = [(LocalReference $ UnName index2, [])], + functionAttributes = [], + metadata = [] + }, + UnName index4 := LLVM.General.AST.Call { + isTailCall = False, + callingConvention = C, + returnAttributes = [], + function = Right $ ConstantOperand $ GlobalReference $ Name "copy_symbol_table", + arguments = [(LocalReference $ Name "table", []), (LocalReference $ UnName index2, [])], + functionAttributes = [], + metadata = [] + }, + UnName index5 := LLVM.General.AST.Alloca { + allocatedType = PointerType functionReturnLambda (AddrSpace 0), + numElements = Nothing, + alignment = 8, + metadata = [] + }, + Do LLVM.General.AST.Store { + volatile = False, + Instruction.address = LocalReference $ UnName index5, + value = ConstantOperand $ GlobalReference $ Name (funcName ++ "!" ++ show label), + maybeAtomicity = Nothing, + alignment = 8, + metadata = [] + }, + UnName index6 := LLVM.General.AST.Call { + isTailCall = False, + callingConvention = C, + returnAttributes = [], + function = Right $ ConstantOperand $ GlobalReference $ Name "push_lambda", + arguments = [(LocalReference $ UnName index5, []), (LocalReference $ UnName index2, [])], + functionAttributes = [], + metadata = [] + }] + -- |Generate instruction for finish instruction -generateInstruction Finish = - return [Do LLVM.General.AST.Call { +generateInstruction (Finish, funcName) = + return [Do LLVM.General.AST.Call { isTailCall = False, callingConvention = C, returnAttributes = [], @@ -607,22 +541,116 @@ metadata = [] }] --- noop -generateInstruction _ = return [ Do $ Instruction.FAdd (ConstantOperand $ Float $ Single 1.0) (ConstantOperand $ Float $ Single 1.0) [] ] -isUsefulInstruction Start = False -isUsefulInstruction _ = True +-- |Generate instruction for function call +generateInstruction (IDT.Call "", funcName) = do + index <- fresh + index2 <- fresh + index6 <- fresh + return [ UnName index := LLVM.General.AST.Call { + isTailCall = False, + callingConvention = C, + returnAttributes = [], + function = Right $ ConstantOperand $ GlobalReference $ Name "pop_lambda", + arguments = [], + functionAttributes = [], + metadata = [] + }, + UnName index2 := LLVM.General.AST.Call { + isTailCall = False, + callingConvention = C, + returnAttributes = [], + function = Right $ ConstantOperand $ GlobalReference $ Name "get_lambda_pointer", + arguments = [(LocalReference $ UnName index, [])], + functionAttributes = [], + metadata = [] + }, + UnName index6 := LLVM.General.AST.Call { + isTailCall = False, + callingConvention = C, + returnAttributes = [], + function = Right $ ConstantOperand $ GlobalReference $ Name "get_lambda_table", + arguments = [(LocalReference $ UnName index, [])], + functionAttributes = [], + metadata = [] + }, + Do LLVM.General.AST.Call { + isTailCall = False, + callingConvention = C, + returnAttributes = [], + function = Right $ LocalReference $ UnName index2, + arguments = [(LocalReference $ UnName index6, [])], + functionAttributes = [], + metadata = [] + }] +generateInstruction (IDT.Call functionName, funcName) = + return [Do LLVM.General.AST.Call { + isTailCall = False, + callingConvention = C, + returnAttributes = [], + function = Right $ ConstantOperand $ GlobalReference $ Name functionName, + arguments = [], + functionAttributes = [], + metadata = [] + }] --- removes Lexemes without meaning to us -filterInstrs = filter isUsefulInstruction +-- |Generate instruction for pushing nil. +generateInstruction (Nil, funcName) = + return [Do LLVM.General.AST.Call { + isTailCall = False, + callingConvention = C, + returnAttributes = [], + function = Right $ ConstantOperand $ GlobalReference $ Name "gen_list_push_nil", + arguments = [], + functionAttributes = [], + metadata = [] + }] +-- |Generate instruction for list cons. +generateInstruction (Cons, funcName) = + return [Do LLVM.General.AST.Call { + isTailCall = False, + callingConvention = C, + returnAttributes = [], + function = Right $ ConstantOperand $ GlobalReference $ Name "gen_list_cons", + arguments = [], + functionAttributes = [], + metadata = [] + }] -generateBasicBlock :: (Int, [Lexeme], Int) -> Codegen BasicBlock -generateBasicBlock (label, instructions, 0) = do - tmp <- mapM generateInstruction $ filterInstrs instructions +-- |Generate instruction for list breakup. +generateInstruction (Breakup, funcName) = + return [Do LLVM.General.AST.Call { + isTailCall = False, + callingConvention = C, + returnAttributes = [], + function = Right $ ConstantOperand $ GlobalReference $ Name "gen_list_breakup", + arguments = [], + functionAttributes = [], + metadata = [] + }] + + +-- |Fallback for unhandled lexemes (generates no-op). +generateInstruction _ = return [ Do $ Instruction.FAdd (ConstantOperand $ Float $ Single 1.0) (ConstantOperand $ Float $ Single 1.0) [] ] + +-- |Appends the function name to the lexemes/instructions. +-- +-- The function name is only relevant for the Lambda instruction, because we use +-- "functionName"!"jumpLable" as name for the Lambda functions. +appendName :: [a] -> String -> [(a, String)] +appendName [] name = [] +appendName (x:[]) name = [(x, name)] +appendName (x:xs) name = (x, name):rest + where rest = appendName xs name + +-- |Generate the instructions making up one basic block. +generateBasicBlock :: ((Int, [Lexeme], Int), String) -> Codegen BasicBlock +generateBasicBlock ((label, instructions, 0), name) = do + tmp <- mapM generateInstruction (appendName instructions name) return $ BasicBlock (Name $ "l_" ++ show label) (concat tmp) $ terminator 0 -generateBasicBlock (label, instructions, jumpLabel) = do - tmp <- mapM generateInstruction $ filterInstrs instructions +generateBasicBlock ((label, instructions, jumpLabel), name) = do + tmp <- mapM generateInstruction (appendName instructions name) i <- gets count case filter isJunction instructions of [Junction junctionLabel] -> return $ BasicBlock (Name $ "l_" ++ show label) (concat tmp) $ condbranch junctionLabel i @@ -641,30 +669,116 @@ metadata' = [] } - -generateBasicBlocks :: [(Int, [Lexeme], Int)] -> Codegen [BasicBlock] -generateBasicBlocks = mapM generateBasicBlock +-- |Generate all basic blocks for a function. +generateBasicBlocks :: [(Int, [Lexeme], Int)] -> String -> Codegen [BasicBlock] +generateBasicBlocks lexemes name = mapM generateBasicBlock (appendName lexemes name) --- generate function definition from AST +-- |Generate a function definition from an AST. +-- +-- At the beginning of each function, we create a block with lable "entry". +-- In this block we create the symbol table and jump then to "l_1", the first +-- regular block in each function. +-- The first pattern-matching is for lambda functions generateFunction :: AST -> GlobalCodegen Definition generateFunction (name, lexemes) = do dict <- gets dict - return $ GlobalDefinition $ Global.functionDefaults { - Global.name = Name name, - Global.returnType = IntegerType 32, - Global.basicBlocks = execCodegen dict $ generateBasicBlocks lexemes - } + return $ GlobalDefinition + (if "!" `isInfixOf` name then + Global.functionDefaults { + Global.name = Name name, + Global.returnType = IntegerType 32, + Global.parameters = ( [ Parameter (PointerType (NamedTypeReference $ Name + "struct.table") (AddrSpace 0)) (Name "t") [] ], False ), + Global.basicBlocks = concat ( + return ( BasicBlock (Name "entry") [ + Name "table_alloc" := LLVM.General.AST.Call { + isTailCall = False, + callingConvention = C, + returnAttributes = [], + function = Right $ ConstantOperand $ GlobalReference $ Name "malloc", + arguments = [(ConstantOperand $ Int 64 24, [])], + functionAttributes = [], + metadata = [] + }, + Name "table" := LLVM.General.AST.BitCast { + Instruction.operand0 = LocalReference $ Name "table_alloc", + Instruction.type' = PointerType (NamedTypeReference $ Name "struct.table") (AddrSpace 0), + metadata = [] + }, + Name "" := LLVM.General.AST.Call { + isTailCall = False, + callingConvention = C, + returnAttributes = [], + function = Right $ ConstantOperand $ GlobalReference $ Name "initialise", + arguments = [(LocalReference $ Name "table", [])], + functionAttributes = [], + metadata = [] + }, + Name "" := LLVM.General.AST.Call { + isTailCall = False, + callingConvention = C, + returnAttributes = [], + function = Right $ ConstantOperand $ GlobalReference $ Name "copy_symbol_table", + arguments = [(LocalReference $ Name "t", []), (LocalReference $ Name "table", [])], + functionAttributes = [], + metadata = [] + }] + ( Do Br { + dest = Name "l_1", + metadata' = []} )) + : [execCodegen dict $ generateBasicBlocks lexemes name]) + } + else + Global.functionDefaults { + Global.name = Name name, + Global.returnType = IntegerType 32, + Global.basicBlocks = concat ( + return ( BasicBlock (Name "entry") [ + Name "table_alloc" := LLVM.General.AST.Call { + isTailCall = False, + callingConvention = C, + returnAttributes = [], + function = Right $ ConstantOperand $ GlobalReference $ Name "malloc", + arguments = [(ConstantOperand $ Int 64 24, [])], + functionAttributes = [], + metadata = [] + }, + Name "table" := LLVM.General.AST.BitCast { + Instruction.operand0 = LocalReference $ Name "table_alloc", + Instruction.type' = PointerType (NamedTypeReference $ Name "struct.table") (AddrSpace 0), + metadata = [] + }, + Name "" := LLVM.General.AST.Call { + isTailCall = False, + callingConvention = C, + returnAttributes = [], + function = Right $ ConstantOperand $ GlobalReference $ Name "initialise", + arguments = [(LocalReference $ Name "table", [])], + functionAttributes = [], + metadata = [] + }] + ( Do Br { + dest = Name "l_1", + metadata' = []} )) + : [execCodegen dict $ generateBasicBlocks lexemes name]) + }) + +-- |Create a new local variable (?). fresh :: Codegen Word fresh = do i <- gets count modify $ \s -> s { count = 1 + i } return $ i + 1 --- generate list of LLVM Definitions from list of ASTs +-- |Generate list of LLVM Definitions from list of ASTs generateFunctions :: [AST] -> GlobalCodegen [Definition] generateFunctions = mapM generateFunction +-- |Generate a global definition for a constant. +-- +-- This is an unnamed, global constant, i. e. it has a numeric name +-- like '@0'. generateGlobalDefinition :: Integer -> Global -> Definition generateGlobalDefinition index def = GlobalDefinition def { Global.name = UnName $ fromInteger index, @@ -673,21 +787,66 @@ Global.hasUnnamedAddr = True } --- TODO find a more elegant way to solve this -generateGlobalDefinitionVar :: Integer -> Global -> Definition +-- |Generate a global definition for a variable name. +-- +-- Such definitions are used to pass variable names to +-- LLVM backend functions like 'pop_into()'. +generateGlobalDefinitionVar :: Integer -> Global -> Definition generateGlobalDefinitionVar i def = GlobalDefinition def { - Global.initializer = Just (Undef VoidType) + Global.isConstant = True, + Global.linkage = Internal, + Global.hasUnnamedAddr = True } --- entry point into module -- -process :: IDT.SemAna2InterCode -> IDT.InterCode2CodeOpt -process (IDT.ISI input) = IDT.IIC $ generateModule $ constants ++ variables ++ - [ underflowCheck, IntermediateCode.print, crash, finish, inputFunc, - eofCheck, push, pop, peek, add, sub, rem1, mul, div1, streq, strlen, strapp, - popInt, equal, greater, popInto, pushFrom ] ++ generateFunctionsFoo input +-- |Entry point into module. +process :: IDT.SemAna2InterCode -> IDT.InterCode2Backend +process (IDT.ISI input) = IDT.IIB $ generateModule $ constants ++ variables ++ + [ + stackElementTypeDef, + structTable, + lambdaElement, + underflowCheck, + FunctionDeclarations.print, + crash, + start, + finish, + inputFunc, + eofCheck, + pushStringCpy, + pop, + peek, + add, + sub, + rem1, + mul, + div1, + streq, + strlen, + strapp, + strcut, + popInt, + equal, + greater, + popInto, + pushFrom, + popBool, + initialiseSymbolTable, + malloc, + type1, + copySymbolTable, + pushLambda, + getLambda, + popLambda, + getTable, + listPushNil, + listCons, + listBreakup + ] ++ codegen input where constants = zipWith generateGlobalDefinition [0..] $ generateConstants input variables = zipWith generateGlobalDefinitionVar [0..] $ generateVariables input - d = fromList $ zipWith foo [0..] $ getAllCons input - foo index (Constant s) = (s, (length s, index)) --TODO rename foo to something meaningful e.g. createSymTable - generateFunctionsFoo input = execGlobalCodegen d $ generateFunctions input + constantPool = fromList $ zipWith createConstantPoolEntry [0..] $ getAllCons input + createConstantPoolEntry index (Constant s) = (s, (length s, index)) + codegen input = execGlobalCodegen constantPool $ generateFunctions input + +-- vim:ts=2 sw=2 et diff --git a/src/RailCompiler/Lexer.hs b/src/RailCompiler/Lexer.hs --- a/src/RailCompiler/Lexer.hs +++ b/src/RailCompiler/Lexer.hs @@ -26,88 +26,71 @@ -- * Utility functions fromAST, toAST, -- * Editor functions - step, parse, IP(IP), posx, posy, start, crash, turnaround, junctionturns, lambdadirs , move , current, RelDirection(Forward) + Direction (N, NE, E, SE, S, SW, W, NW), + step, parse, IP(IP), dir, posx, posy, count, start, crash, turnaround, junctionturns, lambdadirs , move , current, RelDirection(Forward), funcname ) where -- imports -- import InterfaceDT as IDT import ErrorHandling as EH + import Data.Maybe import Data.List - import Text.Printf - - -- |Modified 'IDT.LexNode' with an additional identifier for nodes - -- to check whether we have circles in the graph. - -- - -- The identifier is the last element of the tuple and contains - -- the following sub-elements, in this order: - -- - -- * When we visited this node, at which X position did we start to parse its lexeme? - -- * When we visited this node, at which Y position did we start to parse its lexeme? - -- * When we visited this node, from which direction did we come? - type PreLexNode = (Int, IDT.Lexeme, Int, (Int, Int, Direction)) - -- |An absolute direction. - data Direction = N | NE | E | SE | S | SW | W | NW deriving (Eq, Show) - -- |A relative direction. - data RelDirection = Left | Forward | Right deriving (Eq, Show) - -- |Instruction pointer consisting of position and an orientation. - data IP = - IP { - -- |Number of processed characters since start of current function. - count :: Int, - -- |Current X position. - posx :: Int, - -- |Current Y position. - posy :: Int, - -- |Current 'Direction'. - dir :: Direction, - -- |Determines if the instruction pointer is on a left or right path of a Junction - path :: RelDirection - } - deriving (Show) - - instance Eq IP - where - (==) ipl ipr = posx ipl == posx ipr && posy ipl == posy ipr && dir ipl == dir ipr + import AST + import InstructionPointer + import qualified Data.Map as Map -- functions -- -- |Process preprocessor output into a list of function ASTs. -- + -- -- Raises 'error's on invalid input; see 'ErrorHandling' for a list of error messages. process :: IDT.PreProc2Lexer -- ^Preprocessor output (a list of lists of strings; i. e. a list of functions -- in their line representation). -> IDT.Lexer2SynAna -- ^A list of ASTs, each describing a single function. - process (IDT.IPL input) = IDT.ILS $ concatMap processfn input + process (IDT.IPL input) = IDT.ILS $ map (\(x, _) -> processfn x) input -- |Process a single function. processfn :: IDT.Grid2D -- ^The lines representing the function. - -> [IDT.Graph] -- ^A graph of nodes representing the function. + -> IDT.Graph -- ^A graph of nodes representing the function. -- There may be more functions because of lambdas. - processfn [x] = [(funcname x, [(1, Start, 0)])] -- oneliners are illegal; follower == 0 will - -- lead to a crash, which is what we want. - processfn code@(x:xs) = if head x /= '$' then [(funcname x, [(1, Start, 0)])] else [(funcname x, finalize (head nxs) [])] + processfn code + | Map.size code < 2 = emptyfunc -- oneliners are illegal; follower == 0 will + -- lead to a crash, which is what we want. + | Map.size firstline == 0 || fromJust (Map.lookup 0 firstline) /= '$' = emptyfunc + | otherwise = (func, finalize (head nxs)) where - (nxs, _) = nodes code [[(1, Start, 0, (0, 0, SE))]] start + emptyfunc = (func, [(1, Start, 0)]) + firstline = fromJust (Map.lookup 0 code) + func = case funcname code of + (Prelude.Left name) -> name + (Prelude.Right err) -> error err + (nxs, _) = nodes code [[(1, Start, 0)]] start -- |Get the name of the given function. - -- - -- TODO: Note that this will crash the entire program if there is - -- no function name. - funcname :: String -- ^A line containing the function declaration, - -- e. g. @$ \'main\'@. - -> String -- ^The function name. - funcname line - | null line || length (elemIndices '\'' line) < 2 = error EH.strFunctionNameMissing - | otherwise = takeWhile (/='\'') $ tail $ dropWhile (/='\'') line + funcname :: IDT.Grid2D -> Either String String + funcname code + | isNothing (Map.lookup 0 code) = Prelude.Right EH.strFunctionNameMissing + | otherwise = helper (tostring 0 line) + where + line = fromJust (Map.lookup 0 code) + tostring i line + | isNothing (Map.lookup i line) = if i > Map.size line then "" else tostring (i+1) line + | otherwise = fromJust (Map.lookup i line):tostring (i+1) line + helper line + | null line || length (elemIndices '\'' line) < 2 || null fn = Prelude.Right EH.strFunctionNameMissing + | not $ null $ fn `intersect` "'{}()!" = Prelude.Right EH.strInvalidFuncName + | otherwise = Prelude.Left fn + where fn = takeWhile (/='\'') $ tail $ dropWhile (/='\'') line -- |Get the nodes for the given function. nodes :: IDT.Grid2D -- ^Lines representing the function. - -> [[PreLexNode]] -- ^Current graph representing the function. + -> [[IDT.LexNode]] -- ^Current graph representing the function. -- Initialize with @[[(1, Start, 0, (0, 0, SE))]]@. -> IP -- ^Current instruction pointer. -- Initialize with @'start'@. - -> ([[PreLexNode]], IP) -- ^Final graph for the function and the new instruction pointer. + -> ([[IDT.LexNode]], IP) -- ^Final graph for the function and the new instruction pointer. nodes code list ip | current code tempip == ' ' = (list, tempip) -- If we are not finished yet, this will -- automatically lead to a @@ -115,13 +98,13 @@ -- a leading node without a follower -- (follower == 0) because it is -- not modified here at all. - | otherwise = if endless then (endlesslist, crash) else nodes code newlist newip - where - -- This checks if we have e. g. two reflectors that "bounce" the IP between them - -- endlessly. - endless = count ip > sum (map length code) - endlesslist = (newnode, NOP, newnode, (-1, -1, SE)) `prepend` update list (path ip) newnode - newnode = sum (map length list) + 1 + | endless = (endlesslist, crashfrom ip) + | otherwise = nodes code newlist newip + where + -- This checks if we have e. g. two reflectors that "bounce" the IP between them endlessly. + endless = count ip > 8 * Map.size (fromJust (Map.lookup 0 code)) * Map.size (fromJust (Map.lookup 0 code)) + endlesslist = (newnode, NOP, newnode) `prepend` update list (path ip) newnode + newnode = nodecount ip + 1 prepend newx (x:xs) = (newx:x):xs tempip = step code ip (newlist, newip) = handle code list tempip @@ -129,65 +112,55 @@ -- |Helper function for 'nodes': Handle the creation of the next 'PreLexNode' -- for the current function. handle :: IDT.Grid2D -- ^Line representation of input function. - -> [[PreLexNode]] -- ^Current list of nodes. + -> [[IDT.LexNode]] -- ^Current list of nodes. -> IP -- ^Current instruction pointer. - -> ([[PreLexNode]], IP) -- ^New node list and new instruction pointer. + -> ([[IDT.LexNode]], IP) -- ^New node list and new instruction pointer. handle code list ip = helper code list newip lexeme where (lexeme, newip) = parse code ip helper _ list ip Nothing = (list, ip) helper code list ip (Just lexeme) - | knownat > 0 = (update list (path ip) knownat, crash) - | lexeme == Finish = (newlist, crash) - | isjunction lexeme = (merge final, crash) - | otherwise = (newlist, ip{count = 0}) + | knownat > 0 = (update list (path ip) knownat, crashfrom ip) + | lexeme == Finish = (newlist, crashfrom newip) + | isattributed lexeme = (merge final, crashfrom finip) + | otherwise = (newlist, newip) where - knownat = visited list ip - newnode = sum (map length list) + 1 - newlist = (newnode, lexeme, 0, (posx ip, posy ip, dir ip)) `prepend` update list (path ip) newnode + knownat = visited ip + newnode = nodecount ip + 1 + newlist = (newnode, lexeme, 0) `prepend` update list (path ip) newnode + newip = nodeadd ip newnode prepend newx (x:xs) = (newx:x):xs - isjunction (Junction _) = True - isjunction _ = False - final = fst $ nodes code ([]:temp) trueip - temp = fst $ nodes code ([]:newlist) falseip - (falseip, trueip) = junctionturns code ip + isattributed (Junction _) = True + isattributed (Lambda _) = True + isattributed _ = False + (final, finip) = nodes code ([]:tempnodes) (ipmerge trueip tempip) + (tempnodes, tempip) = nodes code ([]:newlist) (ipmerge falseip newip) + (falseip, trueip) = if current code ip == '&' then lambdadirs ip else junctionturns code ip - - -- |Shift a node by the given amount. May be positive or negative. - -- This is used by 'toGraph' and 'fromGraph' to shift all nodes by 1 or -1, respectively, - -- which is done because the portable text representation of the graph does not include - -- a leading "Start" node with ID 1 -- instead, the node with ID 1 is the first "real" - -- graph node. In other words, when exporting to the text representation, the "Start" - -- node is removed and all other nodes are "shifted" by -1 using this function. When - -- importing, a "Start" node is added and all nodes are shifted by 1. - offset :: Int -- ^Amount to shift node by. - -> IDT.LexNode -- ^Node to operate on. - -> IDT.LexNode -- ^Shifted node. - offset c (node, lexeme, 0) = (node + c, lexeme, 0) - offset c (node, lexeme, following) = (node + c, lexeme, following + c) - -- |Change the following node of the first (i. e. "last", since the list is reversed) -- node in the graph. - update :: [[PreLexNode]] -- ^The graph to operate on. + update :: [[IDT.LexNode]] -- ^The graph to operate on. -> RelDirection -- ^Turn taken on last Junctions -> Int -- ^ID of new follower to set for the first node in the list. - -> [[PreLexNode]] -- ^Resulting graph. + -> [[IDT.LexNode]] -- ^Resulting graph. update list@(x:xs) dir following - | null x && startsjunction xs && dir == Lexer.Left = helpera list following - | null x && not (null xs) && startsjunction (tail xs) && dir == Lexer.Right = x:head xs:helper (head (tail xs)) following:tail (tail xs) + | null x && startsattributed xs && dir == InstructionPointer.Left = helpera list following + | null x && not (null xs) && startsattributed (tail xs) && dir == InstructionPointer.Right = x:head xs:helper (head (tail xs)) following:tail (tail xs) | null x = list | otherwise = helper x following:xs where - helper ((node, lexeme, _, location):xs) following = (node, lexeme, following, location):xs - helpera (x:(((node, _, following, location):xs):xss)) attribute = x:(((node, Junction attribute, following, location):xs):xss) - startsjunction (((_, Junction _, _, _):_):_) = True - startsjunction _ = False + helper ((node, lexeme, _):xs) following = (node, lexeme, following):xs + helpera (x:(((node, Junction _, following):xs):xss)) attribute = x:(((node, Junction attribute, following):xs):xss) + helpera (x:(((node, Lambda _, following):xs):xss)) attribute = x:(((node, Lambda attribute, following):xs):xss) + startsattributed (((_, Junction _, _):_):_) = True + startsattributed (((_, Lambda _, _):_):_) = True + startsattributed _ = False -- merges splitted graphs (e.g. Junction) -- x3 is the graph until the special node appeared -- x2 is the graph that will result in the special attribute -- x1 is the graph that will become the follower - merge :: [[PreLexNode]] -> [[PreLexNode]] + merge :: [[IDT.LexNode]] -> [[IDT.LexNode]] merge (x1:x2:x3:xs) = (x1 ++ x2 ++ x3):xs -- |Move the instruction pointer a single step. @@ -196,464 +169,17 @@ -> IP -- ^New instruction pointer. step code ip | forward `elem` fval = move ip Forward - | left `elem` lval && right `elem` rval = crash - | left `elem` lval = move ip Lexer.Left - | right `elem` rval = move ip Lexer.Right - | otherwise = crash + | left `elem` lval && right `elem` rval = crashfrom ip + | left `elem` lval = move ip InstructionPointer.Left + | right `elem` rval = move ip InstructionPointer.Right + | otherwise = crashfrom ip where (left, forward, right) = adjacent code ip (lval, fval, rval) = valids code ip - -- |Collect characters until a condition is met while moving in the current direction. - stepwhile :: IDT.Grid2D -- ^Line representation of current function. - -> IP -- ^Current instruction pointer. - -> (Char -> Bool) -- ^Function: Should return True if collection should stop. - -- Gets the current Char as an argument. - -> (String, IP) -- ^Collected characters and the new instruction pointer. - stepwhile code ip fn - | not (fn curchar) = ("", ip) - | not (moveable code ip Forward) = error EH.strMissingClosingBracket - | otherwise = (curchar:resstring, resip) - where - curchar = current code ip - (resstring, resip) = stepwhile code (move ip Forward) fn - - -- |Checks if the instruction pointer can be moved without leaving the grid - moveable :: IDT.Grid2D -- ^Line representation of current function - -> IP -- ^Current instruction pointer - -> RelDirection -- ^Where to move to - -> Bool -- ^Whether or not the move could be made - moveable code ip reldir - | null code = False - | newy < 0 || newy >= length code = False - | dir ip `elem` [W, E] && (newx < 0 || newx >= length line) = False - | otherwise = True - where - (newy, newx) = posdir ip reldir - line = code!!newy - - -- |Read a string constant and handle escape sequences like \n. - -- Raises an error on invalid escape sequences and badly formatted constants. - readconstant :: IDT.Grid2D -- ^Current function in line representation - -> IP -- ^Current instruction pointer - -> Char -- ^Opening string delimiter, e. g. '[' - -> Char -- ^Closing string delimiter, e. g. ']' - -> (String, IP) -- ^The processed constant and the new instruction pointer - readconstant code ip startchar endchar - | curchar == startchar = error EH.strNestedOpenBracket - | curchar == endchar = ("", ip) - | not (moveable code ip Forward) = error EH.strMissingClosingBracket - | otherwise = (newchar:resstring, resip) - where - curchar = current code ip - (newchar, newip) = processescape - (resstring, resip) = readconstant code newip startchar endchar - - -- This does the actual work and converts the escape sequence - -- (if there is no escape sequence at the current position, do - -- nothing and pass the current Char through). - processescape :: (Char, IP) - processescape - | curchar /= '\\' = (curchar, move ip Forward) - | esctrail /= '\\' = error EH.strNonSymmetricEscape - | otherwise = case escsym of - '\\' -> ('\\', escip) - '[' -> ('[', escip) - ']' -> (']', escip) - 'n' -> ('\n', escip) - 't' -> ('\t', escip) - _ -> error $ printf EH.strUnhandledEscape escsym - where - [escsym, esctrail] = lookahead code ip 2 - -- Points to the character after the trailing backslash - escip = skip code ip 3 - - -- |Lookahead n characters in the current direction. - lookahead :: IDT.Grid2D -- ^Line representation of current function - -> IP -- ^Current instruction pointer - -> Int -- ^How many characters of lookahead to produce? - -> String -- ^n characters of lookahead - lookahead code ip 0 = [] - lookahead code ip n = current code newip : lookahead code newip (n-1) - where - newip = move ip Forward - - -- |Skip n characters in the current direction and return the new IP. - skip :: IDT.Grid2D -- ^Line representation of current function - -> IP -- ^Current instruction pointer - -> Int -- ^How many characters to skip? If 1, this is the same - -- as doing "move ip Forward". - -> IP -- ^New instruction pointer - skip code ip n = foldl (\x _ -> move x Forward) ip [1..n] - - -- |Move the instruction pointer in a relative direction. - move :: IP -- ^Current instruction pointer. - -> RelDirection -- ^Relative direction to move in. - -> IP -- ^New instruction pointer. - move ip reldir = ip{count = newcount, posx = newx, posy = newy, dir = absolute ip reldir} - where - (newy, newx) = posdir ip reldir - newcount = count ip + 1 - - -- |Get the 'Char' at the current position of the instruction pointer. - current :: IDT.Grid2D -- ^Line representation of the current function. - -> IP -- ^Current instruction pointer. - -> Char -- ^'Char' at the current IP position. - current code ip = charat code (posy ip, posx ip) - - -- |Get the 'Char' at the next position of the instruction pointer - next :: IDT.Grid2D -> IP -> Char - next code ip = current code $ move ip Forward - - -- |Get adjacent (left secondary, primary, right secondary) - -- symbols for the current IP position. - adjacent :: IDT.Grid2D -- ^Line representation of the current function. - -> IP -- ^Current instruction pointer. - -> (Char, Char, Char) -- ^Adjacent (left secondary, primary, right secondary) symbols - adjacent code ip - | current code ip `elem` turnblocked = (' ', charat code (posdir ip Forward), ' ') - | otherwise = (charat code (posdir ip Lexer.Left), charat code (posdir ip Forward), charat code (posdir ip Lexer.Right)) - - -- returns instruction pointers turned for (False, True) - junctionturns :: IDT.Grid2D -> IP -> (IP, IP) - junctionturns code ip = tuplecheck $ tuplemove $ addpath $ turning (current code ip) ip - where - tuplecheck (ipl, ipr) = (if current code ipl == primary ipl then ipl else crash, if current code ipr == primary ipr then ipr else crash) - tuplemove (ipl, ipr) = (move ipl Forward, move ipr Forward) - addpath (ipl, ipr) = (ipl{path = Lexer.Left}, ipr{path = Lexer.Right}) - turning char ip - | char == '<' = case dir ip of - E -> (ip{dir = NE}, ip{dir = SE}) - SW -> (ip{dir = SE}, ip{dir = W}) - NW -> (ip{dir = W}, ip{dir = NE}) - _ -> (crash, crash) - | char == '>' = case dir ip of - W -> (ip{dir = SW}, ip{dir = NW}) - SE -> (ip{dir = E}, ip{dir = SW}) - NE -> (ip{dir = NW}, ip{dir = E}) - _ -> (crash, crash) - | char == '^' = case dir ip of - S -> (ip{dir = SE}, ip{dir = SW}) - NE -> (ip{dir = N}, ip{dir = SE}) - NW -> (ip{dir = SW}, ip{dir = N}) - _ -> (crash, crash) - | char == 'v' = case dir ip of - N -> (ip{dir = NW}, ip{dir = NE}) - SE -> (ip{dir = NE}, ip{dir = S}) - SW -> (ip{dir = S}, ip{dir = NW}) - _ -> (crash, crash) - | otherwise = (ip, ip) - - -- returns insturction pointers turned for (Lambda, Reflected) - lambdadirs :: IP -> (IP, IP) - lambdadirs ip = (ip, turnaround ip) - - -- make a 180° turn on instruction pointer - turnaround :: IP -> IP - turnaround ip = ip{dir = absolute ip{dir = absolute ip{dir = absolute ip{dir = absolute ip Lexer.Left} Lexer.Left} Lexer.Left} Lexer.Left} - - -- |Returns 'Char' at given position, @\' \'@ if position is invalid. - charat :: IDT.Grid2D -- ^Line representation of current function. - -> (Int, Int) -- ^Position as (x, y) coordinate. - -> Char -- ^'Char' at given position. - charat code _ | null code = ' ' - charat code (y, _) | y < 0 || y >= length code = ' ' - charat code (y, x) - | x < 0 || x >= length line = ' ' - | otherwise = line!!x - where - line = code!!y - - -- |Get the position of a specific heading. - posdir :: IP -- ^Current instruction pointer. - -> RelDirection -- ^Current relative direction. - -> (Int, Int) -- ^New position that results from the given relative movement. - posdir ip reldir = posabsdir ip (absolute ip reldir) - - -- |Get the position of an absolute direction. - posabsdir :: IP -- ^Current instruction pointer. - -> Direction -- ^Current absolute direction. - -> (Int, Int) -- ^New position that results from the given absolute movement. - posabsdir ip N = (posy ip - 1, posx ip) - posabsdir ip NE = (posy ip - 1, posx ip + 1) - posabsdir ip E = (posy ip, posx ip + 1) - posabsdir ip SE = (posy ip + 1, posx ip + 1) - posabsdir ip S = (posy ip + 1, posx ip) - posabsdir ip SW = (posy ip + 1, posx ip - 1) - posabsdir ip W = (posy ip, posx ip - 1) - posabsdir ip NW = (posy ip - 1, posx ip - 1) - - -- |Convert a relative direction into a relative one. - absolute :: IP -- ^Current instruction pointer. - -> RelDirection -- ^Relative direction to convert. - -> Direction -- ^Equivalent absolute direction. - absolute x Forward = dir x - absolute (IP {dir=N}) Lexer.Left = NW - absolute (IP {dir=N}) Lexer.Right = NE - absolute (IP {dir=NE}) Lexer.Left = N - absolute (IP {dir=NE}) Lexer.Right = E - absolute (IP {dir=E}) Lexer.Left = NE - absolute (IP {dir=E}) Lexer.Right = SE - absolute (IP {dir=SE}) Lexer.Left = E - absolute (IP {dir=SE}) Lexer.Right = S - absolute (IP {dir=S}) Lexer.Left = SE - absolute (IP {dir=S}) Lexer.Right = SW - absolute (IP {dir=SW}) Lexer.Left = S - absolute (IP {dir=SW}) Lexer.Right = W - absolute (IP {dir=W}) Lexer.Left = SW - absolute (IP {dir=W}) Lexer.Right = NW - absolute (IP {dir=NW}) Lexer.Left = W - absolute (IP {dir=NW}) Lexer.Right = N - - -- |Get the next lexeme at the current position. - parse :: IDT.Grid2D -- ^Line representation of current function. - -> IP -- ^Current instruction pointer. - -> (Maybe IDT.Lexeme, IP) -- ^Resulting lexeme (if any) and - -- the new instruction pointer. - parse code ip = junctioncheck $ case current code ip of - 'b' -> (Just Boom, ip) - 'e' -> (Just EOF, ip) - 'i' -> (Just Input, ip) - 'o' -> (Just Output, ip) - 'u' -> (Just Underflow, ip) - '?' -> (Just RType, ip) - 'a' -> (Just Add1, ip) - 'd' -> (Just Divide, ip) - 'm' -> (Just Multiply, ip) - 'r' -> (Just Remainder, ip) - 's' -> (Just Subtract, ip) - '0' -> (Just (Constant "0"), ip) - '1' -> (Just (Constant "1"), ip) - '2' -> (Just (Constant "2"), ip) - '3' -> (Just (Constant "3"), ip) - '4' -> (Just (Constant "4"), ip) - '5' -> (Just (Constant "5"), ip) - '6' -> (Just (Constant "6"), ip) - '7' -> (Just (Constant "7"), ip) - '8' -> (Just (Constant "8"), ip) - '9' -> (Just (Constant "9"), ip) - 'c' -> (Just Cut, ip) - 'p' -> (Just Append, ip) - 'z' -> (Just Size, ip) - 'n' -> (Just Nil, ip) - ':' -> (Just Cons, ip) - '~' -> (Just Breakup, ip) - 'f' -> (Just (Constant "0"), ip) - 't' -> (Just (Constant "1"), ip) - 'g' -> (Just Greater, ip) - 'q' -> (Just Equal, ip) - '$' -> (Just Start, ip) - '#' -> (Just Finish, ip) - '.' -> (Just NOP, ip) - 'v' -> (Just (Junction 0), ip) - '^' -> (Just (Junction 0), ip) - '>' -> (Just (Junction 0), ip) - '<' -> (Just (Junction 0), ip) - '[' -> let (string, newip) = readconstant code tempip '[' ']' in (Just (Constant string), newip) - ']' -> let (string, newip) = readconstant code tempip ']' '[' in (Just (Constant string), newip) - '{' -> let (string, newip) = stepwhile code tempip (/= '}') in (Just (Call string), newip) - '}' -> let (string, newip) = stepwhile code tempip (/= '{') in (Just (Call string), newip) - '(' -> let (string, newip) = stepwhile code tempip (/= ')') in (pushpop string, newip) - ')' -> let (string, newip) = stepwhile code tempip (/= '(') in (pushpop string, newip) - _ -> (Nothing, turn (current code ip) ip) - where - junctioncheck (Nothing, ip) - | current code ip `elem` "+x*" && next code ip `elem` "v^<>" = (Nothing, crash) - | forward == ' ' && (left == current code ip || right == current code ip) = (Nothing, crash) - | forward == ' ' && (left `elem` "v^<>+x*" || right `elem` "v^<>+x*") = (Nothing, crash) - | otherwise = (Nothing, ip) - where - (left, forward, right) = adjacent code ip - junctioncheck (lexeme, ip) - | next code ip `elem` "v^<>" = (lexeme, crash) - | otherwise = (lexeme, ip) - turn '@' ip = turnaround ip - turn '|' ip - | dir ip `elem` [NW, N, NE] = ip{dir = N} - | dir ip `elem` [SW, S, SE] = ip{dir = S} - turn '/' ip - | dir ip `elem` [N, NE, E] = ip{dir = NE} - | dir ip `elem` [S, SW, W] = ip{dir = SW} - turn '-' ip - | dir ip `elem` [NE, E, SE] = ip{dir = E} - | dir ip `elem` [SW, S, NW] = ip{dir = W} - turn '\\' ip - | dir ip `elem` [W, NW, N] = ip{dir = NW} - | dir ip `elem` [E, SE, S] = ip{dir = SE} - turn _ ip = ip - tempip = move ip Forward - pushpop string - | string == "" = Just (Push string) - | head string == '!' && last string == '!' = Just (Pop (tail $ init string)) - | otherwise = Just (Push string) - - -- |Get ID of the node that has been already visited using the current IP - -- (direction and coordinates). - visited :: [[PreLexNode]] -- ^List of nodes to check. - -> IP -- ^Instruction pointer to use. - -> Int -- ^ID of visited node or 0 if none. - visited [] _ = 0 - visited (x:xs) ip = let res = helper x ip in if res > 0 then res else visited xs ip - where - helper [] _ = 0 - helper ((id, _, _, (x, y, d)):xs) ip - | x == posx ip && y == posy ip && d == dir ip = id - | otherwise = helper xs ip - - -- |Convert a list of 'PreLexNode's into a list of 'IDT.LexNode's. - finalize :: [PreLexNode] -- ^'PreLexNode's to convert. - -> [IDT.LexNode] -- ^Accumulator. Initialize with @[]@. - -> [IDT.LexNode] -- ^Resulting list of 'IDT.PreLexNode's. - finalize [] result = result - finalize ((node, lexeme, following, _):xs) result = finalize xs ((node, lexeme, following):result) - - -- |Initial value for the instruction pointer at the start of a function. - start :: IP - start = IP 0 0 0 SE Forward - - -- |An instruction pointer representing a "crash" (fatal error). - crash :: IP - crash = IP 0 (-1) (-1) NW Forward - - -- what is the primary rail for the given direction? - -- mainly used to check if junctions turn away correctly - primary :: IP -> Char - primary ip - | dir ip `elem` [N, S] = '|' - | dir ip `elem` [E, W] = '-' - | dir ip `elem` [NE, SW] = '/' - | dir ip `elem` [NW, SE] = '\\' - - -- |Return valid chars for movement depending on the current direction. - valids :: IDT.Grid2D -- ^Line representation of current function. - -> IP -- ^Current instruction pointer. - -> (String, String, String) -- ^Tuple consisting of: - -- - -- * Valid characters for movement to the (relative) left. - -- * Valid characters for movement in the (relative) forward direction. - -- * Valid characters for movement to the (relative) right. - valids code ip = tripleinvert (commandchars ++ dirinvalid ip ++ finvalid ip{dir = absolute ip Lexer.Left}, finvalid ip, commandchars ++ dirinvalid ip ++ finvalid ip{dir = absolute ip Lexer.Right}) - where - tripleinvert (l, f, r) = (filter (`notElem` l) everything, filter (`notElem` f) everything, filter (`notElem` r) everything) - finvalid ip = dirinvalid ip ++ crossinvalid ip -- illegal to move forward - dirinvalid ip -- illegal without crosses - | dir ip `elem` [E, W] = "|" - | dir ip `elem` [NE, SW] = "\\" - | dir ip `elem` [N, S] = "-" - | dir ip `elem` [NW, SE] = "/" - | otherwise = "" - crossinvalid ip -- illegal crosses - | dir ip `elem` [N, E, S, W] = "x" - | otherwise = "+" - cur = current code ip - everything = "+\\/x|-" ++ always - always = "^v<>*@{}[]()" ++ commandchars - - -- list of chars that are commands in rail - commandchars :: String - commandchars = "abcdefgimnopqrstuz:~0123456789?#" - - -- list of chars which do not allow any turning - turnblocked :: String - turnblocked = "$*+x" ++ commandchars - - -- |Convert a graph/AST into a portable text representation. - -- See also 'fromGraph'. - fromAST :: IDT.Lexer2SynAna -- ^Input graph/AST/forest. - -> String -- ^Portable text representation of the AST: - -- - -- Each function is represented by its own section. A section has a header - -- and content; it continues either until the next section, a blank line or - -- the end of the file, whichever comes first. - -- - -- A section header consists of a single line containing the name of the function, - -- enclosed in square brackets, e. g. @[function_name]@. There cannot be any whitespace - -- before the opening bracket. - -- - -- The section content consists of zero or more non-blank lines containing exactly - -- three records delimited by a semicolon @;@. Each line describes a node and contains - -- the following records, in this order: - -- - -- * The node ID (numeric), e. g. @1@. - -- * The Rail lexeme, e. g. @o@ or @[constant]@ etc. Note that track lexemes like - -- @-@ or @+@ are not included in the graph. Multi-character lexemes like constants - -- may include semicolons, so you need to parse them correctly! In other words, you need - -- to take care of lines like @1;[some ; constant];2@. - -- * Node ID of the follower node, e. g. @2@. May be @0@ if there is no next node. - fromAST (IDT.ILS graph) = unlines $ map fromGraph graph - - -- |Convert a portable text representation of a graph into a concrete graph representation. - -- See also 'toGraph'. See 'fromAST' for a specification of the portable text representation. - toAST :: String -- ^Portable text representation. See 'fromAST'. - -> IDT.Lexer2SynAna -- ^Output graph. - toAST input = IDT.ILS (map toGraph $ splitfunctions input) - - -- |Convert an 'IDT.Graph' for a single function to a portable text representation. - -- See 'fromAST' for a specification of the representation. - -- - -- TODO: Currently, this apparently crashes the program on invalid input. More sensible error handling? - -- At least a nice error message would be nice. - fromGraph :: IDT.Graph -- ^Input graph. - -> String -- ^Text representation. - fromGraph (funcname, nodes) = unlines $ ("["++funcname++"]"):tail (map (fromLexNode . offset (-1)) nodes) - where - fromLexNode :: IDT.LexNode -> String - fromLexNode (id, lexeme, follower) = show id ++ ";" ++ fromLexeme lexeme ++ ";" ++ show follower ++ optional lexeme - fromLexeme :: IDT.Lexeme -> String - fromLexeme Boom = "b" - fromLexeme EOF = "e" - fromLexeme Input = "i" - fromLexeme Output = "o" - fromLexeme Underflow = "u" - fromLexeme RType = "?" - fromLexeme (Constant string) = "["++string++"]" - fromLexeme (Push string) = "("++string++")" - fromLexeme (Pop string) = "(!"++string++"!)" - fromLexeme (Call string) = "{"++string++"}" - fromLexeme Add1 = "a" - fromLexeme Divide = "d" - fromLexeme Multiply = "m" - fromLexeme Remainder = "r" - fromLexeme Subtract = "s" - fromLexeme Cut = "c" - fromLexeme Append = "p" - fromLexeme Size = "z" - fromLexeme Nil = "n" - fromLexeme Cons = ":" - fromLexeme Breakup = "~" - fromLexeme Greater = "g" - fromLexeme Equal = "q" - fromLexeme Start = "$" - fromLexeme Finish = "#" - fromLexeme (Junction _) = "v" - fromLexeme NOP = "." - optional (Junction follow) = ';' : show follow - optional _ = ";0" - - -- |Split a portable text representation of multiple function graphs (a forest) into separate - -- text representations of each function graph. - splitfunctions :: String -- ^Portable text representation of the forest. - -> [[String]] -- ^List of lists, each being a list of lines making up a separate function graph. - splitfunctions = groupBy (\_ y -> null y || head y /= '[') . filter (not . null) . lines - - -- |Convert a portable text representation of a single function into an 'IDT.Graph'. - -- Raises 'error's on invalid input (see 'ErrorHandling'). - toGraph :: [String] -- ^List of lines making up the text representation of the function. - -> IDT.Graph -- ^Graph describing the function. - toGraph lns = (init $ tail $ head lns, (1, Start, 2):map (offset 1) (nodes $ tail lns)) - where - nodes [] = [] - nodes (ln:lns) = (read id, fixedlex, read follower):nodes lns - where - (id, other) = span (/=';') ln - (lex, ip) = parse [other] $ IP 0 1 0 E Forward - (follower, attribute) = span (/=';') (drop (2 + posx ip) other) - fixedlex - | isJunction lex = Junction (read $ tail attribute) - | otherwise = fromJust lex - fromJust Nothing = error $ printf EH.shrLineNoLexeme ln - fromJust (Just x) = x - isJunction (Just (Junction _)) = True - isJunction _ = False + -- |Brings it into right order + finalize :: [IDT.LexNode] -- ^'LexNode's to convert. + -> [IDT.LexNode] -- ^Resulting list of 'IDT.LexNode's. + finalize = reverse -- vim:ts=2 sw=2 et diff --git a/src/RailCompiler/Main.hs b/src/RailCompiler/Main.hs deleted file mode 100644 --- a/src/RailCompiler/Main.hs +++ /dev/null @@ -1,117 +0,0 @@ -{- | -Module : Main.hs -Description : . -Maintainer : (c) Christopher Pockrandt, Nicolas Lehmann, Tobias Kranz -License : MIT - -Stability : stable - -Entrypoint of the rail2llvm-compiler. Contains main-function. - -See also: ---https://www.haskell.org/ghc/docs/7.8.2/html/libraries/base-4.7.0.0/System-Console-GetOpt.html ---http://leiffrenzel.de/papers/commandline-options-in-haskell.html (Outdated!) - --} -module Main( main ) where - --- imports -- -import System.Environment -import System.Exit -import System.Console.GetOpt -import Data.Maybe( fromMaybe ) -import InterfaceDT as IDT -import qualified Preprocessor as PreProc -import qualified Lexer -import qualified SyntacticalAnalysis as SynAna -import qualified SemanticalAnalysis as SemAna -import qualified IntermediateCode as InterCode -import qualified CodeOptimization as CodeOpt -import qualified Backend - --- defining the option settings for the main-function -data Options = Options { - optInput :: IO String, - optOutput :: String -> IO (), - optASTOutput :: String -> IO (), - compile :: Bool, - impAST :: Bool, - expAST :: Bool - } - --- default Options -defaultOptions :: Options -defaultOptions = Options { - optInput = getContents, - optOutput = putStr, - optASTOutput = putStr, - compile = False, - impAST = False, - expAST = False - - } - --- usageInfo -options :: [OptDescr (Options -> IO Options)] -options = [ - --Option ['V'] ["version"] (NoArg showVersion) "show version number", - Option "h" ["help" ] (NoArg showHelp ) "display Help Text", - Option "i" ["input" ] (ReqArg setInput "FILE" ) "input file (don't set to use stdin')", - Option "o" ["output" ] (ReqArg setOutput "FILE" ) "output file (don't set to use stdout')", - Option "c" ["compile" ] (NoArg setCompile ) "compile 'rail' to 'llvm'", - Option [ ] ["exportAST"] (OptArg setExpAST "FILE" ) "export frontend AST (don't offer a File to use stdout) \n(dont set with --importAST)", - Option [ ] ["importAST"] (NoArg setImpAST ) "import frontend AST and compile to llvm\nautosets -c \n(set input via -i; (dont set with --exportAST)\n\nset -c with --exportAST and get both: the AST and the llvm code" - ] - --- output for the help-function -showHelp _ = do - putStrLn "rail2llvm--haskell-compiler (development version)" - putStr "https://github.com/SWP-Ubau-SoSe2014-Haskell/SWPSoSe14\n\n" - putStr $ usageInfo "Usage: main [OPTION...]" options - exitSuccess - --- options-getter for optional output for exprotAST -getOut (Just arg) = writeFile arg -getOut Nothing = putStr - --- options-setters -setInput arg opt = return opt { optInput = readFile arg } -setOutput arg opt = return opt { optOutput = writeFile arg } -setExpAST arg opt = return opt { optASTOutput = getOut arg, expAST = True} -setImpAST opt = return opt { impAST = True, compile = True } -setCompile opt = return opt { compile = True } - --- main-function -- -main = do args <- getArgs - let (actions,nonOpts,msgs) = getOpt RequireOrder options args - -- intercept errors - if msgs /= [] - then error $ concat msgs ++ usageInfo "Usage: main [OPTION...]" options - -- unrecognized arguments error - else if nonOpts /= [] - then error $ "unrecognized arguments: " ++ unwords nonOpts ++ "\nUsage: For basic information, try the `--help' option." - else do opts <- foldl (>>=) (return defaultOptions) actions - -- option aliases - let Options { optInput = input, optOutput = output, optASTOutput = outputAST, compile = cmpl, impAST = imp, expAST = exp} = opts - inputWithoutIO <- input - -- importAST and exportAST can't be set together (error) - if imp && exp - then do error "No export of the imported AST (Usage: For basic information, try the `--help' option.)'" - exitSuccess - -- compile a file - else if cmpl - then do let transform (IBO x) = x - -- compile an imported AST to a LLVM-file - if imp - then transform (Backend.process . CodeOpt.process . InterCode.process . SemAna.process . SynAna.process . Lexer.toAST $ inputWithoutIO) >>= output - -- compile a RAIL-file to an AST as an export-file - else if exp - then do outputAST (Lexer.fromAST . Lexer.process . PreProc.process $ IIP inputWithoutIO) - transform (Backend.process . CodeOpt.process . InterCode.process . SemAna.process . SynAna.process . Lexer.process . PreProc.process $ IIP inputWithoutIO) >>= output - -- compile a RAIL-file to a LLVM-file - else transform (Backend.process . CodeOpt.process . InterCode.process . SemAna.process . SynAna.process . Lexer.process . PreProc.process $ IIP inputWithoutIO) >>= output - -- exportAST (without compiling it to llvm) - else if exp - then outputAST (Lexer.fromAST . Lexer.process . PreProc.process $ IIP inputWithoutIO) - -- missing argument error - else error "Error. Set atleast -c or --importAST or --exportAST." diff --git a/src/RailCompiler/Preprocessor.hs b/src/RailCompiler/Preprocessor.hs --- a/src/RailCompiler/Preprocessor.hs +++ b/src/RailCompiler/Preprocessor.hs @@ -18,29 +18,51 @@ -- imports -- import InterfaceDT as IDT - import ErrorHandling as EH + import ErrorHandling as EH import Data.List + import Control.Arrow + import qualified Data.Map as Map -- functions -- process :: IDT.Input2PreProc -> IDT.PreProc2Lexer process (IDT.IIP input) = IDT.IPL output where - output = (groupFunctionsToGrid2Ds . removeLines . lines) input + output = map (Control.Arrow.first convert . Control.Arrow.first maximize) groups + groups = (groupFunctions . removeLines . lines) input + convert :: [String] -> Grid2D + convert code = Map.fromList $ zip [0..] (map (Map.fromList . zip [0..]) code) + + -- |Makes the first line as long as max(max(lines),#lines) + -- this is useful for the lexer to determine an upper bound for empty endless loops + maximize :: [String] -> [String] + maximize [] = [] + maximize (x:xs) = stretchto (max maxlines maxcols) x:xs + where + stretchto count line = take count (line ++ repeat ' ') + maxlines = maximum $ map length (x:xs) + maxcols = length (x:xs) + -- |Return False iff the first character is a dollar sign. notStartingWithDollar :: String -> Bool notStartingWithDollar x = null x || head x /= '$' -- |Removes all leading strings from list until first string begins with a -- dollar sign. - removeLines :: Grid2D -> Grid2D + removeLines :: [String] -> ([String], Int) removeLines grid - | null result = error noStartSymbolFound - | otherwise = result + | null $ fst $ result grid 0 = error noStartSymbolFound + | otherwise = result grid 0 where - result = dropWhile notStartingWithDollar grid + result grid n + | null grid = (grid, n) + | not $ notStartingWithDollar $ head grid = (grid, n) + | otherwise = result (tail grid) (n + 1) -- |Puts every rail function/program into its on grid such that the dollar -- sign is the first character in the first line. - groupFunctionsToGrid2Ds :: Grid2D -> [Grid2D] - groupFunctionsToGrid2Ds = groupBy (\_ y -> notStartingWithDollar y) + groupFunctions :: ([String], Int) -> [([String], Int)] + groupFunctions ([], _) = [] + groupFunctions (grid, offset) = (head grid:func, offset):groupFunctions (other, offset + 1 + length func) + where + (func, other) = span notStartingWithDollar $ tail grid diff --git a/src/RailCompiler/SemanticalAnalysis.hs b/src/RailCompiler/SemanticalAnalysis.hs --- a/src/RailCompiler/SemanticalAnalysis.hs +++ b/src/RailCompiler/SemanticalAnalysis.hs @@ -16,19 +16,57 @@ -- imports -- import InterfaceDT as IDT import ErrorHandling as EH + import Data.List -- functions -- process :: IDT.SynAna2SemAna -> IDT.SemAna2InterCode process (IDT.ISS input) + | null input = error EH.strEmptyProgram + | duplicatefunctions input = error EH.strDuplicateFunctions | nomain input = error EH.strMainMissing - | otherwise = IDT.ISI (map check input) + | not (all validfollowers input) = error EH.strUnknownNode + | otherwise = IDT.ISI (concatMap splitlambda $ map check input) + -- splits lambdas into own functions + splitlambda :: IDT.AST -> [IDT.AST] + splitlambda func@(funcname, paths) = func : lambdafuncs 1 + where + lambdafuncs offset + | offset > maximum (fst (getids func)) = [] + | islambda offset = (funcname ++ "!" ++ show offset, (1, [NOP], offset):tail paths):lambdafuncs (offset + 1) + | otherwise = lambdafuncs (offset + 1) + islambda x = any (\(_, lex, _) -> Lambda x `elem` lex) paths + + -- checks if there are unknown followers + validfollowers :: IDT.AST -> Bool + validfollowers ast = null subset + where + (ids, followers) = getids ast + subset = nub followers \\ ids + + -- gets a tuple of (ids, followers) to check if there are unknown followers + getids :: IDT.AST -> ([Int], [Int]) + getids (_, nodes) = unzip (getnodeids nodes) + where + getnodeids [] = [] + getnodeids ((id, nodes, follow):xs) = (0, junctionattribute nodes):(id, follow):getnodeids xs + junctionattribute nodes = case last nodes of + (Junction attribute) -> attribute + _ -> 0 + -- looking for a main function nomain :: [IDT.AST] -> Bool - nomain [] = True - nomain ((name, _):xs) - | name == "main" = False - | otherwise = nomain xs + nomain input = "main" `notElem` allfunctions input + + -- checking if there are two or more functions with the same name + duplicatefunctions :: [IDT.AST] -> Bool + duplicatefunctions input = length functions > length (nub functions) + where functions = allfunctions input + + -- getting a list of every function + allfunctions :: [IDT.AST] -> [String] + allfunctions [] = [] + allfunctions ((name, _):xs) = name:allfunctions xs -- this will return the exact same input if it's valid and will error otherwise check :: IDT.AST -> IDT.AST @@ -37,13 +75,15 @@ -- this will return the exact same input if it's valid and will error otherwise checknode :: (Int, [Lexeme], Int) -> (Int, [Lexeme], Int) checknode (id, lexeme, following) - | following == 0 && not (last lexeme `elem` [Finish, Boom] || isvalidjunction (last lexeme)) = error EH.strInvalidMovement + | following == 0 && not (last lexeme `elem` [Finish, Boom] || isinvalidjunction (last lexeme)) = error EH.strInvalidMovement | otherwise = (id, map checklexeme lexeme, following) where - isvalidjunction (Junction x) = x /= 0 - isvalidjunction _ = False + isinvalidjunction (Junction x) = x == 0 + isinvalidjunction _ = False -- this will return the exact same input if it's valid and will error otherwise checklexeme :: Lexeme -> Lexeme checklexeme (Junction 0) = error EH.strInvalidMovement + checklexeme (Push "") = error EH.strInvalidVarName + checklexeme (Pop "") = error EH.strInvalidVarName checklexeme lexeme = lexeme diff --git a/src/RailCompiler/SyntacticalAnalysis.hs b/src/RailCompiler/SyntacticalAnalysis.hs --- a/src/RailCompiler/SyntacticalAnalysis.hs +++ b/src/RailCompiler/SyntacticalAnalysis.hs @@ -1,7 +1,7 @@ {- | Module : SyntacticalAnalysis.hs Description : . -Copyright : (c) Kristin Knorr, Marcus Hoffmann +Maintainer : (c) Kristin Knorr, Marcus Hoffmann License : MIT Stability : stable @@ -18,52 +18,60 @@ -- imports -- import InterfaceDT as IDT import ErrorHandling as EH + import Data.Maybe + import qualified Data.Map as Map -- functions -- process :: IDT.Lexer2SynAna -> IDT.SynAna2SemAna process (IDT.ILS input) = IDT.ISS output where - output = map (\(x, y)->(x, pathes y (startNodes y))) input + output = map (\(x, y)->(x, pathes (mapify y Map.empty) (startNodes y))) input + mapify :: [(Int, Lexeme, Int)] -> Map.Map Int (Lexeme, Int) -> Map.Map Int (Lexeme, Int) + mapify [] map = map + mapify ((id, lexeme, follower):xs) map = mapify xs (Map.insert id (lexeme, follower) map) + -- |generates all pathes of a graph - pathes :: [IDT.LexNode] -> [Int] -> [(Int, [Lexeme], Int)] - pathes xs ys = map (\x-> findPath x xs ys) ys + pathes :: Map.Map Int (Lexeme, Int) -> [Int] -> [(Int, [Lexeme], Int)] + pathes _ [] = [] + pathes xs ys + | Map.size xs == 0 = [] + | otherwise = map (\x-> findPath x xs ys) ys -- |generates one path depending on initial node - findPath :: Int -> [IDT.LexNode] -> [Int] -> (Int, [Lexeme], Int) + findPath :: Int -> Map.Map Int (Lexeme, Int) -> [Int] -> (Int, [Lexeme], Int) findPath x xs ys = genPath x (generate x xs) where genPath :: Int -> [(Lexeme, Int)] -> (Int, [Lexeme], Int) genPath pathID leFoList = (pathID, map fst leFoList, (snd.last) leFoList) - generate :: Int -> [IDT.LexNode] -> [(Lexeme, Int)] - generate v = genElem . head . filter (\y -> fst' y == v) - genElem :: IDT.LexNode -> [(Lexeme, Int)] - genElem (nodeID, lex, fol) + generate :: Int -> Map.Map Int (Lexeme, Int) -> [(Lexeme, Int)] + generate v map = genElem $ fromJust $ Map.lookup v map + genElem :: (Lexeme, Int) -> [(Lexeme, Int)] + genElem (lex, fol) |elem fol ys || fol==0 = [(lex, fol)] |otherwise = (lex, fol) : generate fol xs + -- |fetch triple components + fst' :: (a, b, c) -> a + fst' (x, _, _) = x + -- |generates a list of all nodes, which are needed to be initial nodes of path: -- 1 as functionstart; conditional jmp; indegree > 1 startNodes :: [IDT.LexNode] -> [Int] +-- startNodes xs = error (show (Map.toList (nodeCount xs Map.empty))) +-- startNodes xs = error (show (fst' (head xs):(Map.keys $ Map.filter (/= 1) $ nodeCount xs Map.empty))) startNodes [] = [] - startNodes xs = 1:[x | x <- [2..(length xs)], isJunct0 x xs || (inDeg x xs > 1) || isJunct1 x xs] + startNodes xs = fst' (head xs):filter (/=0) (Map.keys $ Map.filter (/= 1) $ nodeCount xs Map.empty) where - isJunct0 :: Int -> [IDT.LexNode] -> Bool - isJunct0 x = any (\y -> Junction x == snd' y) - isJunct1 :: Int -> [IDT.LexNode] -> Bool - isJunct1 x = any (\y -> isJunct (snd' y) && x == trd' y) - isJunct :: Lexeme -> Bool - isJunct (Junction x) = True - isJunct _ = False - inDeg :: Int -> [IDT.LexNode] -> Int - inDeg x = length . filter (\y-> trd' y==x) - - -- |fetch triple components - fst' :: (a, b, c) -> a - fst' (x, _, _) = x - - snd' :: (a, b, c) -> b - snd' (_, x, _) = x - - trd' :: (a, b, c) -> c - trd' (_, _, x) = x + -- result type: [(ID, Count)] + nodeCount :: [IDT.LexNode] -> Map.Map Int Int -> Map.Map Int Int + nodeCount [] res = res + -- we WANT junctions to be at the very end + nodeCount ((_, Junction x, y):xs) res = nodeCount xs $ incCount (incCount res x 2) y 2 + nodeCount ((_, Lambda x, y):xs) res = nodeCount xs $ incCount (incCount res x 2) y 1 + nodeCount ((_, _, y):xs) res = nodeCount xs $ incCount res y 1 + -- update the count + incCount :: Map.Map Int Int -> Int -> Int-> Map.Map Int Int + incCount map id count + | Map.member id map = Map.adjust (count +) id map + | otherwise = Map.insert id count map diff --git a/src/RailCompiler/TypeDefinitions.hs b/src/RailCompiler/TypeDefinitions.hs new file mode 100644 --- /dev/null +++ b/src/RailCompiler/TypeDefinitions.hs @@ -0,0 +1,66 @@ +{- | +Module : TpyeDefinitions.hs +Description : type definitions for intermediate code generation +Maintainer : Philipp Borgers, Tilman Blumenbach, Lyudmila Vaseva, Sascha Zinke, + Maximilian Claus, Michal Ajchman, Nicolas Lehmann, Tudor Soroceanu +License : MIT +Stability : unstable + +All type definitions live here. + +-} + +module TypeDefinitions where + +import LLVM.General.AST +import LLVM.General.AST.AddrSpace + +-- |Opaque type definition for the stack_element struct, defined in stack.ll. +stackElementTypeDef :: Definition +stackElementTypeDef = TypeDefinition (Name "stack_element") Nothing + +-- |Pointer type for 'i8*' used e.g. as "string" pointer +bytePointerType :: Type +bytePointerType = PointerType { + pointerReferent = IntegerType 8, + pointerAddrSpace = AddrSpace 0 +} + +-- |Pointer type for 'i8**' used as variable pointer +bytePointerTypeVar :: Type +bytePointerTypeVar = PointerType { + pointerReferent = PointerType { + pointerReferent = IntegerType 8, + pointerAddrSpace = AddrSpace 0 + }, + pointerAddrSpace = AddrSpace 0 +} + +-- |Pointer type: %stack_element* (see stack.ll). +stackElementPointerType :: Type +stackElementPointerType = PointerType { + pointerReferent = NamedTypeReference $ Name "stack_element", + pointerAddrSpace = AddrSpace 0 +} + +-- |Struct declaration for the symbol table +structTable :: Definition +structTable = TypeDefinition (Name "struct.table") + (Just $ StructureType False + [ PointerType (IntegerType 8) (AddrSpace 0), + PointerType (NamedTypeReference $ Name "stack_element") (AddrSpace 0), + PointerType (NamedTypeReference $ Name "struct.table") (AddrSpace 0)]) + +functionReturnLambda :: Type +functionReturnLambda = FunctionType { + resultType = IntegerType 32, + argumentTypes = [ PointerType (NamedTypeReference $ Name "struct.table") + (AddrSpace 0)], + isVarArg = False +} + +lambdaElement :: Definition +lambdaElement = TypeDefinition (Name "lambda_element") + (Just $ StructureType False + [ PointerType (PointerType functionReturnLambda (AddrSpace 0)) (AddrSpace 0), + PointerType (NamedTypeReference $ Name "struct.table") (AddrSpace 0)]) diff --git a/src/RailCompiler/cmp.ll b/src/RailCompiler/cmp.ll new file mode 100644 --- /dev/null +++ b/src/RailCompiler/cmp.ll @@ -0,0 +1,379 @@ +; Module : LLVM backend - comparison functions +; Description : Contains LLVM functions for integer/float comparison. +; Maintainers : Sascha Zinke, Tudor Soroceanu +; License : MIT +; +; These comparison functions are used by our LLVM backend and operate directly +; on the stack -- see stack.ll. + +@err_numeric = external global [56 x i8] +@err_type = external global [14 x i8] +@err_zero = external global [18 x i8] +@popped = external global [13 x i8] +@true = external global [2 x i8] +@false = external global [2 x i8] + +%stack_element = type opaque +%struct.stack_elem = type { i32, %union.anon } +%union.anon = type { i8* } + +declare i8* @stack_element_get_data(%stack_element* %element) +declare i8 @stack_element_get_type(%stack_element*) +declare void @stack_element_unref(%stack_element* %element) +declare i32 @get_stack_elem(i8*, %struct.stack_elem*) +declare %stack_element* @push_string_ptr(i8* %str) +declare %stack_element* @push_string_cpy(i8* %str) +declare %stack_element* @pop_struct() +declare signext i32 @printf(i8*, ...) +declare void @push_float(double) +declare void @underflow_assert() +declare i32 @strcmp(i8*, i8*) +declare void @push_int(i64) +declare i8* @pop_string() +declare void @crash(i1) +declare i1 @list_equal(%stack_element*, %stack_element*) + +@main.number_a = private unnamed_addr constant [4 x i8] c"abc\00" +@main.number_b = private unnamed_addr constant [4 x i8] c"adc\00" + +define i32 @main_cmp() { + ; push two numbers on the stack + %number0 = getelementptr [4 x i8]* @main.number_a, i64 0, i64 0 + %number1 = getelementptr [4 x i8]* @main.number_b, i64 0, i64 0 + + call %stack_element* @push_string_cpy(i8* %number0) + call %stack_element* @push_string_cpy(i8* %number1) + + call void @equal() + %result = call i8* @pop_string() + call i32 (i8*, ...)* @printf(i8* getelementptr inbounds ([13 x i8]* + @popped, i32 0, i32 0), i8* %result) + + ret i32 0 +} + + +;############################################################################## +; equal +;############################################################################## + + +; Check if the topmost stack elements are equal. +; +; Pushes true onto the stack if the elements are equal and false +; otherwise. +; +; Crashes the program on errors (prints an appropriate error message). +define void @equal() { + %struct_a = call %stack_element* @pop_struct() + %struct_b = call %stack_element* @pop_struct() + %are_equal = call i1 @do_equal(%stack_element* %struct_a, %stack_element* %struct_b) + + br i1 %are_equal, label %push_true, label %push_false + +push_true: + call %stack_element* @push_string_cpy(i8* getelementptr inbounds( + [2 x i8]* @true, i64 0, i64 0)) + br label %done + +push_false: + call %stack_element* @push_string_cpy(i8* getelementptr inbounds( + [2 x i8]* @false, i64 0, i64 0)) + br label %done + +done: + call void(%stack_element*)* @stack_element_unref(%stack_element* %struct_a) + call void(%stack_element*)* @stack_element_unref(%stack_element* %struct_b) + ret void +} + +; Perform the actual equality check. +; +; Returns 1 if the stack elements are equal or 0 otherwise. +; +; Crashes the program on errors (prints an appropriate error message). +define i1 @do_equal(%stack_element* %struct_a, %stack_element* %struct_b) { + ; return value of this function + %func_result = alloca i1, align 4 + + %new_elem_a = alloca %struct.stack_elem, align 8 + %new_elem_b = alloca %struct.stack_elem, align 8 + + ; Get data and type of first element. + %number_a = call i8*(%stack_element*)* @stack_element_get_data( + %stack_element* %struct_a) + %stack_type_a = call i8 @stack_element_get_type(%stack_element* %struct_a) + + ; Get data and type of second element. + %number_b = call i8*(%stack_element*)* @stack_element_get_data( + %stack_element* %struct_b) + %stack_type_b = call i8 @stack_element_get_type(%stack_element* %struct_b) + + ; The spec says that two elements of different types are always unequal. + %equal_stack_types = icmp eq i8 %stack_type_a, %stack_type_b + br i1 %equal_stack_types, label %check_stack_type, label %exit_with_false + +check_stack_type: + ; Same stack element type, so it does not matter which of the two types + ; we use in the switch statement. + switch i8 %stack_type_a, label %exit_with_invalid_type + [ + i8 0, label %get_stack_elem_a + i8 1, label %compare_lists + ] + +get_stack_elem_a: + ; get type of number_a + %ret_a = call i32 @get_stack_elem(i8* %number_a, %struct.stack_elem* %new_elem_a) + %is_zero_a = icmp slt i32 %ret_a, 0 + br i1 %is_zero_a, label %exit_with_numeric_failure, label %get_stack_elem_b + +get_stack_elem_b: + ; get type of number_b + %ret_b = call i32 @get_stack_elem(i8* %number_b, %struct.stack_elem* %new_elem_b) + %is_zero_b = icmp slt i32 %ret_b, 0 + br i1 %is_zero_b, label %exit_with_numeric_failure, label %get_types + +get_types: + ; type of a + %type_a_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_a, i32 0, i32 0 + %type_a = load i32* %type_a_ptr, align 4 + %val_a_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_a, i32 0, i32 1 + + ; type of b + %type_b_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_b, i32 0, i32 0 + %type_b = load i32* %type_b_ptr, align 4 + %val_b_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_b, i32 0, i32 1 + + switch i32 %type_a, label %exit_with_invalid_type [ + i32 1, label %assume_b_int + i32 2, label %assume_b_float + i32 3, label %assume_b_string] + +;############################################################################## +; list comparison +;############################################################################## + +compare_lists: + %lists_are_equal = call i1 @list_equal(%stack_element* %struct_a, %stack_element* %struct_b) + br i1 %lists_are_equal, label %exit_with_true, label %exit_with_false + +;############################################################################## +; integer comparison +;############################################################################## + +assume_b_int: + ; check whether it is 1 (aka INT). + %is_int_b = icmp eq i32 %type_b, 1 + br i1 %is_int_b, label %cmp_int, label %exit_with_invalid_type + +cmp_int: + ; get new_elem_a.ival that contains the casted integer value + %ival_a_cast = bitcast %union.anon* %val_a_ptr to i32* + %ival_a = load i32* %ival_a_cast, align 4 + + ; get new_elem_b.ival that contains the casted integer value + %ival_b_cast = bitcast %union.anon* %val_b_ptr to i32* + %ival_b = load i32* %ival_b_cast, align 4 + + ; the actual comparison + %equal_int = icmp eq i32 %ival_a, %ival_b + br i1 %equal_int, label %exit_with_true, label %exit_with_false + +;############################################################################## +; floating point comparison +;############################################################################## + +assume_b_float: + ; check whether it is 2 (aka FLOAT). + %is_float_b = icmp eq i32 %type_b, 2 + br i1 %is_float_b, label %cmp_float, label %exit_with_invalid_type + +cmp_float: + ; get new_elem_a.fval that contains the float value + %fval_a_cast = bitcast %union.anon* %val_a_ptr to float* + %fval_a = load float* %fval_a_cast, align 4 + + ; get new_elem_b.fval that contains the float value + %fval_b_cast = bitcast %union.anon* %val_b_ptr to float* + %fval_b = load float* %fval_b_cast, align 4 + + %equal_float = fcmp oeq float %fval_a, %fval_b + br i1 %equal_float, label %exit_with_true, label %exit_with_false + +;############################################################################## +; string comparison +;############################################################################## + +assume_b_string: + ; check whether it is 3 (aka STRING). + %is_string_b = icmp eq i32 %type_b, 3 + br i1 %is_string_b, label %cmp_str, label %exit_with_invalid_type + +cmp_str: + %equal_string = call i32 @strcmp(i8* %number_a, i8* %number_b) + %is_equal = icmp eq i32 %equal_string, 0 + br i1 %is_equal, label %exit_with_true, label %exit_with_false + + + + + +exit_with_numeric_failure: + call %stack_element* @push_string_cpy(i8* getelementptr inbounds( + [56 x i8]* @err_numeric, i64 0, i64 0)) + br label %exit_with_failure + +exit_with_invalid_type: + call %stack_element* @push_string_cpy(i8* getelementptr inbounds( + [14 x i8]* @err_type, i64 0, i64 0)) + br label %exit_with_failure + +exit_with_failure: + call void @crash(i1 0) + ret i1 1 + +exit_with_true: + store i1 1, i1* %func_result + br label %exit + +exit_with_false: + store i1 0, i1* %func_result + br label %exit + +exit: + %result = load i1* %func_result + ret i1 %result +} + +;############################################################################## +; greater +;############################################################################## + +define i32 @greater(){ + ; return value of this function + %func_result = alloca i32, align 4 + + %new_elem_a = alloca %struct.stack_elem, align 8 + %new_elem_b = alloca %struct.stack_elem, align 8 + + ; get top of stack + call void @underflow_assert() + %struct_a = call %stack_element*()* @pop_struct() + %number_a = call i8*(%stack_element*)* @stack_element_get_data( + %stack_element* %struct_a) + + ; get second top of stack + call void @underflow_assert() + %struct_b = call %stack_element*()* @pop_struct() + %number_b = call i8*(%stack_element*)* @stack_element_get_data( + %stack_element* %struct_b) + + ; get type of number_a + %ret_a = call i32 @get_stack_elem(i8* %number_a, %struct.stack_elem* %new_elem_a) + %is_zero_a = icmp slt i32 %ret_a, 0 + br i1 %is_zero_a, label %exit_with_numeric_failure, label %get_stack_elem_b + +get_stack_elem_b: + ; get type of number_b + %ret_b = call i32 @get_stack_elem(i8* %number_b, %struct.stack_elem* %new_elem_b) + %is_zero_b = icmp slt i32 %ret_b, 0 + br i1 %is_zero_b, label %exit_with_numeric_failure, label %get_types + +get_types: + ; type of a + %type_a_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_a, i32 0, i32 0 + %type_a = load i32* %type_a_ptr, align 4 + %val_a_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_a, i32 0, i32 1 + + ; type of b + %type_b_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_b, i32 0, i32 0 + %type_b = load i32* %type_b_ptr, align 4 + %val_b_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_b, i32 0, i32 1 + + switch i32 %type_a, label %exit_with_invalid_type [ + i32 1, label %assume_b_int + i32 2, label %assume_b_float] + + ;############################################################################## +; integer greater +;############################################################################## + +assume_b_int: + ; check whether it is 1 (aka INT). + %is_int_b = icmp eq i32 %type_b, 1 + br i1 %is_int_b, label %cmp_int, label %exit_with_invalid_type + +cmp_int: + ; get new_elem_a.ival that contains the casted integer value + %ival_a_cast = bitcast %union.anon* %val_a_ptr to i32* + %ival_a = load i32* %ival_a_cast, align 4 + + ; get new_elem_b.ival that contains the casted integer value + %ival_b_cast = bitcast %union.anon* %val_b_ptr to i32* + %ival_b = load i32* %ival_b_cast, align 4 + + ; the actual comparison + %greater_int = icmp sgt i32 %ival_a, %ival_b + br i1 %greater_int, label %exit_with_true, label %exit_with_false + +;############################################################################## +; floating point multiplication +;############################################################################## + +assume_b_float: + ; check whether it is 2 (aka FLOAT). + %is_float_b = icmp eq i32 %type_b, 2 + br i1 %is_float_b, label %cmp_float, label %exit_with_invalid_type + +cmp_float: + ; get new_elem_a.fval that contains the float value + %fval_a_cast = bitcast %union.anon* %val_a_ptr to float* + %fval_a = load float* %fval_a_cast, align 4 + + ; get new_elem_b.fval that contains the float value + %fval_b_cast = bitcast %union.anon* %val_b_ptr to float* + %fval_b = load float* %fval_b_cast, align 4 + + ; prevent division by zero + %greater_float = fcmp ogt float %fval_a, %fval_b + br i1 %greater_float, label %exit_with_true, label %exit_with_false + +exit_with_numeric_failure: + call %stack_element* @push_string_cpy(i8* getelementptr inbounds( + [56 x i8]* @err_numeric, i64 0, i64 0)) + br label %exit_with_failure + +exit_with_invalid_type: + call %stack_element* @push_string_cpy(i8* getelementptr inbounds( + [14 x i8]* @err_type, i64 0, i64 0)) + br label %exit_with_failure + +exit_with_failure: + call void(%stack_element*)* @stack_element_unref(%stack_element* %struct_a) + call void(%stack_element*)* @stack_element_unref(%stack_element* %struct_b) + call void @crash(i1 0) + br label %exit + +exit_with_true: + call %stack_element* @push_string_cpy(i8* getelementptr inbounds( + [2 x i8]* @true, i64 0, i64 0)) + br label %exit_with_success + +exit_with_false: + call %stack_element* @push_string_cpy(i8* getelementptr inbounds( + [2 x i8]* @false, i64 0, i64 0)) + br label %exit_with_success + +exit_with_success: + store i32 0, i32* %func_result + br label %exit + +exit: + call void(%stack_element*)* @stack_element_unref(%stack_element* %struct_a) + call void(%stack_element*)* @stack_element_unref(%stack_element* %struct_b) + %result = load i32* %func_result + ret i32 %result +} + +; vim:ts=2 sw=2 et diff --git a/src/RailCompiler/linked_stack.ll b/src/RailCompiler/linked_stack.ll new file mode 100644 --- /dev/null +++ b/src/RailCompiler/linked_stack.ll @@ -0,0 +1,630 @@ +; Module : LLVM backend - linked stack implementation/reference counting +; Description : Contains our linked stack implementation and its reference counting +; routines. +; Maintainers : Tilman Blumenbach et al. +; License : MIT +; +; These functions are used by our LLVM backend and most of them operate directly on +; the stack. Many also directly crash (in Rail terms: properly exit) the program. + + +; Types + +; A "real" stack element that is stored on the stack -- but only +; indirectly, see %stack_wrapper. +; +; The fields are: +; * i8 dataType: Type of the data stored in dataPtr. +; * 0 means string. dataPtr points to a null-terminated string. +; * 1 means list. Note that there is no seperate type for empty lists, +; those are represented with type == 1 and dataPtr == null. +; For non-empty lists, dataPtr points to another stack_wrapper which +; is the head of the (linked) list. +; * 2 means lambda. +; * void *dataPtr: Points to type-specific data. May be null. +; * i32 refCount: The element's reference count. When this reaches 0, the element +; is free'd. +%stack_element = type { i8, i8*, i32 } + +; A "volatile", non-reused stack element wrapper which is used for the +; actual stack elements, i. e. the stack is a linked list of this type. +; +; This also double as a list element since lists need to be +; able to store all the types that can be pushed onto the stack. +; +; This struct contains two pointers which point (in this order): +; a) to the real %stack_element in question (first member) and +; b) to the next %stack_wrapper element in the linked list that makes up +; the stack (second member). +; +; This is all needed because e. g. Rail variables can be used to +; push the same %stack_element onto the stack multiple times -- while +; the data and the reference count need to be shared by all these +; %stack_element structs, they need to have different nextElement pointers +; (so that the linked list can be a proper linked list). This wrapper type +; solves that issue by introducing yet another layer of abstraction, allowing +; us to reference the same %stack_element multiple times, while keeping a proper +; linked list. +%stack_wrapper = type { %stack_element*, %stack_wrapper* } + +; Definitions for lambda push and pop +; The first Element is a pointer to the lambda funtion, the second is a +; pointer to the symbol table for the lambda +%struct.table = type { i8*, %stack_element*, %struct.table* } +%lambda_element = type {i32 (%struct.table*)**, %struct.table*} + +; Global variables +@stack = global %stack_wrapper* null ; Linked list of stack_element structs. +@stack_size = global i64 0 ; Current number of elements on the stack. + + +; Constants +@err_type_mismatch = private unnamed_addr constant [16 x i8] c"Type mismatch!\0A\00" +@err_unhandled_type = private unnamed_addr constant [30 x i8] c"Cannot unref unhandled type!\0A\00" +@err_not_bool = private unnamed_addr constant [29 x i8] c"Stack value was not 0 or 1!\0A\00" +@err_empty_list = private unnamed_addr constant [13 x i8] c"Empty list!\0A\00" +@err_num_conv = constant [42 x i8] c"Cannot convert stack element to integer!\0A\00" +@type_string = unnamed_addr constant [7 x i8] c"string\00" +@type_lambda = unnamed_addr constant [7 x i8] c"lambda\00" +@type_list = unnamed_addr constant [5 x i8] c"list\00" +@type_nil = unnamed_addr constant [4 x i8] c"nil\00" + +; External declarations + +; C standard library variables/functions +declare void @free(i8*) +declare i8* @malloc(i16 zeroext) ; void *malloc(size_t) and size_t is 16 bits long (SIZE_MAX) +declare signext i32 @snprintf(i8*, ...) +declare signext i32 @strtol(i8*, i8**, i32 signext) +declare i8* @xcalloc(i16 zeroext, i16 zeroext) +declare i8* @xstrdup(i8*) + +; Own external LLVM variables/functions +@float_to_str = external global [3 x i8] +@int_to_str = external global [3 x i8] + +declare void @crash(i1) +declare void @underflow_assert() +declare void @list_unref_elements(%stack_element*) + + +; Function definitions + +; Get number of element on the stack +define i64 @stack_get_size() { + %sz = load i64* @stack_size + ret i64 %sz +} + +; Creates a new stack_element with a reference count of 1. +define %stack_element* @stack_element_new(i8 %dataType, i8* %dataPtr) { + ; How many bytes do we need to allocate for a single stack element struct? + ; getelementptr abuse taken from: + ; http://nondot.org/sabre/LLVMNotes/SizeOf-OffsetOf-VariableSizedStructs.txt + %elem_size0 = getelementptr %stack_element* null, i32 1 + %elem_size1 = ptrtoint %stack_element* %elem_size0 to i16 + + ; Now we can allocate the memory. + %element0 = call i8* @xcalloc(i16 1, i16 %elem_size1) + %element1 = bitcast i8* %element0 to %stack_element* + + ; %element1 now can be treated like an element struct. Yay! + call void @stack_element_set_type(%stack_element* %element1, i8 %dataType) + call void @stack_element_set_data(%stack_element* %element1, i8* %dataPtr) + + ; Finally, increment the reference count so that it is exactly 1. + call void @stack_element_ref(%stack_element* %element1) + + ; That's it! + ret %stack_element* %element1 +} + +; Decrement refcount of stack element +; If new refcount is zero, free the stack element and it's data +define void @stack_element_unref(%stack_element* %element) { + %refcount = call i32(%stack_element*)* @stack_element_get_refcount(%stack_element* %element) + %refcount_1 = sub i32 %refcount, 1 + %cond = icmp eq i32 %refcount_1, 0 + br i1 %cond, label %free_data, label %update_refcount + +free_data: + %data = call i8* @stack_element_get_data(%stack_element* %element) + %type = call i8 @stack_element_get_type(%stack_element* %element) + switch i8 %type, label %unhandled_type + [ + i8 0, label %free_string + i8 1, label %free_list + i8 2, label %free_lambda + ] + +unhandled_type: + %err_unhandled_type = getelementptr [30 x i8]* @err_unhandled_type, i8 0, i8 0 + call %stack_element* @push_string_cpy(i8* %err_unhandled_type) + call void @crash(i1 0) + ret void + +free_string: + call void @free(i8* %data) + br label %free_element + +free_list: + call void @list_unref_elements(%stack_element* %element) + br label %free_element + +free_lambda: + call void @free(i8* %data) + br label %free_element + +free_element: + %mem = bitcast %stack_element* %element to i8* + call void @free(i8* %mem) + br label %finished + +update_refcount: + call void(%stack_element*, i32)* @stack_element_set_refcount(%stack_element* %element, i32 %refcount_1) + br label %finished + +finished: + ret void +} + +; free() a stack element and optionally, free the data it contains as well +; (i. e. the memory pointed to by the dataPtr member). +; +; Returns the dataPtr if %free_data == 1 and null otherwise. +; +; TODO: This should probably decrement the reference count and only do something +; if it is 0 after decrementing. +define i8* @stack_element_free(%stack_element* %element, i1 %free_data) { +top: + %data = call i8* @stack_element_get_data(%stack_element* %element) + br i1 %free_data, label %do_free_data, label %free_stack_struct + +do_free_data: + ; TODO: Check type here and free lists (type 1) correctly, i. e. iteratively. + ; (Or rather: Decrement the reference count of each list element) + call void @free(i8* %data) + + br label %free_stack_struct + +free_stack_struct: + %ret = phi i8* [ %data, %top ], [ null, %do_free_data ] + + %mem = bitcast %stack_element* %element to i8* + call void @free(i8* %mem) + + ret i8* %ret +} + +; Increment the reference count of a stack_element. +define void @stack_element_ref(%stack_element* %element) { + %refCount = call i32 @stack_element_get_refcount(%stack_element* %element) + %newRefCount = add i32 %refCount, 1 + call void @stack_element_set_refcount(%stack_element* %element, i32 %newRefCount) + + ret void +} + +; Get the type of the data in a stack_element struct. +; +; See the definition of %stack_element for a description of +; possible type values. +define i8 @stack_element_get_type(%stack_element* %element) { + ; dataType is member #0 + %dataType0 = getelementptr %stack_element* %element, i32 0, i32 0 + %dataType1 = load i8* %dataType0 + ret i8 %dataType1 +} + +; Set the type of the data in a stack_element struct. +; +; See the definition of %stack_element for a description of +; possible type values. +define void @stack_element_set_type(%stack_element* %element, i8 %type) { + ; dataType is member #0 + %dataTypeDestPtr = getelementptr %stack_element* %element, i32 0, i32 0 + store i8 %type, i8* %dataTypeDestPtr + + ret void +} + +; Get the raw, uncasted data pointer of a stack_element struct. +; +; Crashes the program on errors. +define i8* @stack_element_get_data(%stack_element* %element) { + ; dataPtr is member #1 + %dataPtr0 = getelementptr %stack_element* %element, i32 0, i32 1 + %dataPtr1 = load i8** %dataPtr0 + ret i8* %dataPtr1 +} + +; Get data from stack as an in integer numeral +define i64 @stack_element_get_int_data(%stack_element* %element) { + ; Make sure we are operating on a string. + call void @stack_element_assert_type(%stack_element* %element, i8 0) + + ; get raw data... + %data = call i8*(%stack_element*)* @stack_element_get_data(%stack_element* %element) + + ; ...and convert it to an integer/long. + %endptrptr = alloca i8* + store i8* null, i8** %endptrptr + %int0 = call i32 @strtol(i8* %data, i8** %endptrptr, i32 10) + %int1 = sext i32 %int0 to i64 + + ; Was everything converted? + %endptr = load i8** %endptrptr + %not_null0 = icmp ne i8* %endptr, null + br i1 %not_null0, label %error_check, label %okay + +error_check: + ; Need to check if the first byte is 0, i. e. if everything + ; up to the terminating null byte has been converted. + %first_byte = load i8* %endptr + %not_null1 = icmp ne i8 %first_byte, 0 + br i1 %not_null1, label %bail_out, label %okay + +bail_out: + ; Error -- crash! + %msg = getelementptr [42 x i8]* @err_num_conv, i8 0, i8 0 + call %stack_element* @push_string_cpy(i8* %msg) + call void @crash(i1 0) + + ret i64 -1 + +okay: + ret i64 %int1 +} + +; Set the raw data pointer of a stack_element struct. +define void @stack_element_set_data(%stack_element* %element, i8* %data) { + ; dataPtr is member #1 + %dataPtr = getelementptr %stack_element* %element, i32 0, i32 1 + store i8* %data, i8** %dataPtr + + ret void +} + +; Set the reference count of a stack_element struct. +define void @stack_element_set_refcount(%stack_element* %element, i32 %refCount) { + ; refCount is member #2 + %refCountDestPtr = getelementptr %stack_element* %element, i32 0, i32 2 + store i32 %refCount, i32* %refCountDestPtr + + ret void +} + +; Get the reference count of a stack_element struct. +define i32 @stack_element_get_refcount(%stack_element* %element) { + ; refCount is member #2 + %refCount0 = getelementptr %stack_element* %element, i32 0, i32 2 + %refCount1 = load i32* %refCount0 + + ret i32 %refCount1 +} + +; Create a new %stack_wrapper struct. +define %stack_wrapper* @stack_wrapper_new(%stack_element* %stackElementPtr, %stack_wrapper* %nextWrapperPtr) { + ; How many bytes do we need to allocate for a single stack wrapper struct? + ; getelementptr abuse taken from: + ; http://nondot.org/sabre/LLVMNotes/SizeOf-OffsetOf-VariableSizedStructs.txt + %wrap_size0 = getelementptr %stack_wrapper* null, i32 1 + %wrap_size1 = ptrtoint %stack_wrapper* %wrap_size0 to i16 + + ; Now we can allocate the memory. + %wrapper0 = call i8* @xcalloc(i16 1, i16 %wrap_size1) + %wrapper1 = bitcast i8* %wrapper0 to %stack_wrapper* + + ; %wrapper1 now can be treated like a wrapper struct. + call void @stack_wrapper_set_element(%stack_wrapper* %wrapper1, %stack_element* %stackElementPtr) + call void @stack_wrapper_set_next(%stack_wrapper* %wrapper1, %stack_wrapper* %nextWrapperPtr) + + ; That's it! + ret %stack_wrapper* %wrapper1 +} + +; Free a %stack_wrapper struct. +; +; Does not free the %stack_element struct hidden by the wrapper. +define void @stack_wrapper_free(%stack_wrapper* %wrapper) { + %mem = bitcast %stack_wrapper* %wrapper to i8* + call void @free(i8* %mem) + + ret void +} + +; Get the "real" %stack_element behind a stack_wrapper struct. +define %stack_element* @stack_wrapper_get_element(%stack_wrapper* %wrapper) { + ; stackElementPtr is member #0 + %stackElement0 = getelementptr %stack_wrapper* %wrapper, i32 0, i32 0 + %stackElement1 = load %stack_element** %stackElement0 + + ret %stack_element* %stackElement1 +} + +; Set the "real" %stack_element behind a stack_wrapper struct. +define void @stack_wrapper_set_element(%stack_wrapper* %wrapper, %stack_element* %element) { + ; stackElementPtr is member #0 + %stackElementPtr = getelementptr %stack_wrapper* %wrapper, i32 0, i32 0 + store %stack_element* %element, %stack_element** %stackElementPtr + + ret void +} + +; Get the "next wrapper" pointer of a stack_wrapper struct. +define %stack_wrapper* @stack_wrapper_get_next(%stack_wrapper* %wrapper) { + ; nextWrapperPtr is member #1 + %nextWrapper0 = getelementptr %stack_wrapper* %wrapper, i32 0, i32 1 + %nextWrapper1 = load %stack_wrapper** %nextWrapper0 + + ret %stack_wrapper* %nextWrapper1 +} + +; Set the "next wrapper" pointer of a stack_wrapper struct. +define void @stack_wrapper_set_next(%stack_wrapper* %wrapper, %stack_wrapper* %next) { + ; nextWrapperPtr is member #1 + %nextPtr = getelementptr %stack_wrapper* %wrapper, i32 0, i32 1 + store %stack_wrapper* %next, %stack_wrapper** %nextPtr + + ret void +} + +; Assert that the data in the stack_element has the passed type. +; +; If the types do not match, crash the program with an appropriate error message. +; This actually checks if the dataType member is equal to %want_type. +define void @stack_element_assert_type(%stack_element* %element, i8 %want_type) { + %actual_type = call i8 @stack_element_get_type(%stack_element* %element) + %is_valid = icmp eq i8 %actual_type, %want_type + br i1 %is_valid, label %valid_type, label %invalid_type + +valid_type: + ; All good. Do nothing. + ret void + +invalid_type: + ; Bail out! + %err_type_mismatch = getelementptr [16 x i8]* @err_type_mismatch, i8 0, i8 0 + call %stack_element* @push_string_cpy(i8* %err_type_mismatch) + call void @crash(i1 0) + + ret void +} + +; Assert that the data in the stack_element is a non-empty list. +; +; Crashes the program if the assertion fails. +define void @stack_element_assert_is_non_empty_list(%stack_element* %element) { + ; Type 1 is list. + call void @stack_element_assert_type(%stack_element* %element, i8 1) + + %data = call i8* @stack_element_get_data(%stack_element* %element) + %is_null = icmp eq i8* %data, null + br i1 %is_null, label %l_empty_list, label %l_non_empty_list + +l_empty_list: + ; Bad. Crash. + %err_empty_list = getelementptr [13 x i8]* @err_empty_list, i8 0, i8 0 + call %stack_element* @push_string_cpy(i8* %err_empty_list) + call void @crash(i1 0) + + ret void + +l_non_empty_list: + ; All good. + ret void +} + +; Get (but do not remove) the topmost %stack_wrapper struct. +; +; Crashes the program if the stack is empty. +define %stack_wrapper* @peek_wrapper() { + ; 1. Make sure we can peek something. + call void @underflow_assert() + + ; 2. Do the actual peek. + %stack = load %stack_wrapper** @stack + + ret %stack_wrapper* %stack +} + +; Pop a stack_element struct from the stack. +define %stack_element* @pop_struct() { + ; 1. Pop the stack and get the topmost wrapper. + %stack = call %stack_wrapper* @peek_wrapper() + %next = call %stack_wrapper* @stack_wrapper_get_next(%stack_wrapper* %stack) + store %stack_wrapper* %next, %stack_wrapper** @stack + + ; Get the wrapped stack_element and free the wrapper. + %element = call %stack_element* @stack_wrapper_get_element(%stack_wrapper* %stack) + call void @stack_wrapper_free(%stack_wrapper* %stack) + + ; 2. Decrement the stack size. + %stack_size0 = load i64* @stack_size + %stack_size1 = sub i64 %stack_size0, 1 + store i64 %stack_size1, i64* @stack_size + + ; 3. That's it! + ret %stack_element* %element +} + +; Push a stack_element struct onto the stack +define void @push_struct(%stack_element* %element) { + ; 1. Push new element by creating and pushing a new wrapper, + ; updating its "next" pointer to the first element of the current stack. + ; + ; NB: Do NOT use peek_wrapper() here since that will crash the program + ; if the stack is empty -- making it impossible to push a struct + ; onto the empty stack. + %curr_head = load %stack_wrapper** @stack + %new_head = call %stack_wrapper* @stack_wrapper_new(%stack_element* %element, %stack_wrapper* %curr_head) + store %stack_wrapper* %new_head, %stack_wrapper** @stack + + ; 2. Increment stack size. + %stack_size0 = call i64 @stack_get_size() + %stack_size1 = add i64 %stack_size0, 1 + store i64 %stack_size1, i64* @stack_size + + ret void +} + +; Pop a string from the stack. +; +; Crashes if the type of the topmost element is not "string". +; +; XXX: THIS IS A LEGACY FUNCTION. DO NOT USE IT IN NEW CODE. +; New code should use proper reference counting. +define i8* @pop_string() { + ; 1. Pop the stack. + %stack = call %stack_element* @pop_struct() + + ; 2. Is the type string? If not, crash. + call void @stack_element_assert_type(%stack_element* %stack, i8 0) + + ; 3. It's a string, everything is fine. Extract the string. + %buf = call i8* @stack_element_get_data(%stack_element* %stack) + + ; 4. Finally, free the stack element. + call i8* @stack_element_free(%stack_element* %stack, i1 0) + + ret i8 *%buf +} + +; Push a string onto the stack, creating a new stack_element struct +; with a reference count of 1. +; +; The string must already be allocated _ON THE HEAP_. +define %stack_element* @push_string_ptr(i8* %str) { + ; 1. Create and push a new stack_element. + ; NB: Stack size is incremented by push_struct(). + %elem = call %stack_element* @stack_element_new(i8 0, i8* %str) + call void @push_struct(%stack_element* %elem) + + ; 2. That's it! + ret %stack_element* %elem +} + +; strdup() a string and push it onto the stack, creating a new stack_element struct +; with a reference count of 1. +define %stack_element* @push_string_cpy(i8* %str) { + %str_copied = call i8* @xstrdup(i8* %str) + %ret = call %stack_element* @push_string_ptr(i8* %str_copied) + + ret %stack_element* %ret +} + +; pops element from stack and converts to integer +; returns the element, in case of error crashes the program +define i64 @pop_int() { + ; Get top element of stack. + %top = call %stack_element* @pop_struct() + + ; Now convert it to an int. + %int = call i64 @stack_element_get_int_data(%stack_element* %top) + + ; Decrement refcount and return + call void @stack_element_unref(%stack_element* %top) + ret i64 %int +} + +define i64 @pop_bool(){ + ;pop an int element from stack + %top = call i64 @pop_int() + + ;check whether it is 0 or 1 + switch i64 %top, label %error [ i64 0, label %its_bool + i64 1, label %its_bool ] + +error: + ; Bail out! + %err_not_bool = getelementptr [29 x i8]* @err_not_bool, i8 0, i8 0 + call %stack_element* @push_string_cpy(i8* %err_not_bool) + call void @crash(i1 0) + ret i64 -1 + +its_bool: + ret i64 %top +} + +define void @push_int(i64 %top_int) +{ + ; allocate memory to store string in + ; TODO: Make sure this is free()'d at _some_ point during + ; program execution. + %buffer_addr = call i8* @malloc(i16 128) + %to_str_ptr = getelementptr [3 x i8]* @int_to_str, i64 0, i64 0 + + ; convert to string + call i32(i8*, ...)* @snprintf( + i8* %buffer_addr, i16 128, i8* %to_str_ptr, i64 %top_int) + + ; push on stack + call %stack_element* @push_string_ptr(i8* %buffer_addr) + + ret void +} + +define void @push_float(double %top_float) +{ + ; allocate memory to store string in + ; TODO: Make sure this is free()'d at _some_ point during + ; program execution. + %buffer_addr = call i8* @malloc(i16 128) + %to_str_ptr = getelementptr [3 x i8]* @float_to_str, i64 0, i64 0 + + ; convert to string + call i32(i8*, ...)* @snprintf( + i8* %buffer_addr, i16 128, i8* %to_str_ptr, double %top_float) + + ; push on stack + call %stack_element* @push_string_ptr(i8* %buffer_addr) + + ret void +} + +; takes a function pointer and a table pointer and pushes both as a struct onto the stack +define void @push_lambda(i32 (%struct.table*)** %function_ptr, %struct.table* %table_ptr) +{ + %l = call i8* @malloc(i16 16) + %l_ptr = bitcast i8* %l to %lambda_element* + ; store function pointer + %l_ptr_func = getelementptr inbounds %lambda_element* %l_ptr, i32 0, i32 0 + store i32 (%struct.table*)** %function_ptr, i32 (%struct.table*)*** %l_ptr_func + ; store tablre pointer + %l_ptr_table = getelementptr inbounds %lambda_element* %l_ptr, i32 0, i32 1 + store %struct.table* %table_ptr, %struct.table** %l_ptr_table + + ; push element onto the stack + %l_elem = call %stack_element* @stack_element_new(i8 2, i8* %l) + call void @push_struct(%stack_element* %l_elem) + ret void +} + +; pops form stack and checks if stack_element is a lambda +; returns a pointer to the lambda element +define %lambda_element* @pop_lambda() +{ + %l_elem = call %stack_element* @pop_struct() + + ; check if struct is a lambda, if not crash + call void @stack_element_assert_type(%stack_element* %l_elem, i8 2) + + %l_ptr = call i8* @stack_element_get_data(%stack_element* %l_elem) + %l_ptr_bitcast = bitcast i8* %l_ptr to %lambda_element* + ret %lambda_element* %l_ptr_bitcast +} + +; returns the pointer to the lambda function +define i32 (%struct.table*)* @get_lambda_pointer(%lambda_element* %l){ + %l_func_ptr = getelementptr inbounds %lambda_element* %l, i32 0, i32 0 + %l_func = load i32 (%struct.table*)*** %l_func_ptr + %l_func2 = load i32 (%struct.table*)** %l_func + ret i32 (%struct.table*)* %l_func2 +} + +; returns the pointer to the lambda symbol table +define %struct.table* @get_lambda_table(%lambda_element* %l){ + %l_table_ptr = getelementptr inbounds %lambda_element* %l, i32 0, i32 1 + %l_table = load %struct.table** %l_table_ptr + ret %struct.table* %l_table +} diff --git a/src/RailCompiler/list.ll b/src/RailCompiler/list.ll new file mode 100644 --- /dev/null +++ b/src/RailCompiler/list.ll @@ -0,0 +1,214 @@ +; Module : LLVM backend - list implementation +; Description : Contains our list implementation - based on a linked list (and in fact +; uses the same data structures as our linked stack). +; Maintainers : Tilman Blumenbach et al. +; License : MIT +; +; Lists are implemented as linked lists of stack_wrapper elements, i. e. just like our +; normal linked stack. The data type "list" is represented as a stack_element with type +; 1 and a data pointer pointing to the head of the aforementioned stack_wrapper linked list. +; Thus, an empty list is a stack_element with type 1 and a null data pointer. + + +; Types + +; Types defined in linked_stack.ll. +%stack_element = type opaque +%stack_wrapper = type opaque + + +; External declarations + +; Own external LLVM variables/functions +declare %stack_element* @stack_element_new(i8, i8*) +declare void @stack_element_unref(%stack_element*) +declare void @stack_element_set_data(%stack_element*, i8*) +declare i8* @stack_element_get_data(%stack_element*) +declare %stack_wrapper* @stack_wrapper_new(%stack_element*, %stack_wrapper*) +declare void @stack_wrapper_free(%stack_wrapper*) +declare %stack_element* @stack_wrapper_get_element(%stack_wrapper*) +declare %stack_wrapper* @stack_wrapper_get_next(%stack_wrapper*) +declare void @push_struct(%stack_element*) +declare %stack_element* @pop_struct() +declare void @stack_element_assert_type(%stack_element*, i8) +declare void @stack_element_assert_is_non_empty_list(%stack_element*) +declare i1 @do_equal(%stack_element* %struct_a, %stack_element*) + + +; Function definitions + +; Create a new, empty list (also called "nil") with a refcount of 1. +define %stack_element* @list_new() { + ; Type 1 is reserved for the "list" type. + ; Empty lists are simply stack_element structs with a null data pointer. + %elm = call %stack_element* @stack_element_new(i8 1, i8* null) + ret %stack_element* %elm +} + +; Decrement the refcount of each element of a list. +; +; This does not free the stack_element which holds the list itself. +; That one is free'd by stack_element_unref(). +define void @list_unref_elements(%stack_element* %list) { +top: + %head_wrapper0 = call i8* @stack_element_get_data(%stack_element* %list) + %head_wrapper1 = bitcast i8* %head_wrapper0 to %stack_wrapper* + br label %free_list_elements + +free_list_elements: + %curr_wrapper = phi %stack_wrapper* [ %head_wrapper1, %top ], [ %next_wrapper, %free_one_list_element ] + + %is_null = icmp eq %stack_wrapper* %curr_wrapper, null + br i1 %is_null, label %done, label %free_one_list_element + +free_one_list_element: + %next_wrapper = call %stack_wrapper* @stack_wrapper_get_next(%stack_wrapper* %curr_wrapper) + %elm = call %stack_element* @stack_wrapper_get_element(%stack_wrapper* %curr_wrapper) + call void @stack_element_unref(%stack_element* %elm) + call void @stack_wrapper_free(%stack_wrapper* %curr_wrapper) + + br label %free_list_elements + +done: + ; Nothing to do since the list is empty. + ret void +} + +; Prepend a stack_element to a list (also called "cons"). +; +; Returns its first parameter. +define %stack_element* @list_prepend(%stack_element* %list, %stack_element* %element) { + ; A list contains a stack_wrapper as its data. This is the wrapped head of the list. + %head_wrapper0 = call i8* @stack_element_get_data(%stack_element* %list) + %head_wrapper1 = bitcast i8* %head_wrapper0 to %stack_wrapper* + + ; Now create a new wrapper for the element we want to prepend. + %new_head_wrapper = call %stack_wrapper* @stack_wrapper_new(%stack_element* %element, %stack_wrapper* %head_wrapper1) + + ; This is the new list head, so store it in the topmost stack_element. + %data = bitcast %stack_wrapper* %new_head_wrapper to i8* + call void @stack_element_set_data(%stack_element* %list, i8* %data) + + ; That's it! + ret %stack_element* %list +} + +; Pop the head off a non-empty list. +define %stack_element* @list_pop(%stack_element* %list) { + ; Get the top stack_wrapper of the list. + %head_wrapper0 = call i8* @stack_element_get_data(%stack_element* %list) + %head_wrapper1 = bitcast i8* %head_wrapper0 to %stack_wrapper* + + ; Get the contents of the wrapper. + %top_elm = call %stack_element* @stack_wrapper_get_element(%stack_wrapper* %head_wrapper1) + + ; What's the new head of the list? + %new_head0 = call %stack_wrapper* @stack_wrapper_get_next(%stack_wrapper* %head_wrapper1) + %new_head1 = bitcast %stack_wrapper* %new_head0 to i8* + call void @stack_element_set_data(%stack_element* %list, i8* %new_head1) + + ; Now we can free the old topmost wrapper. + call void @stack_wrapper_free(%stack_wrapper* %head_wrapper1) + + ; That's it! + ret %stack_element* %top_elm +} + +; Compare two lists. +; +; Returns 1 if both lists are equal or 0 otherwise. +; +; Crashes the program on errors (prints an appropriate error message). +define i1 @list_equal(%stack_element* %list_a, %stack_element* %list_b) { +top: + ; Get the top stack_wrappers of both lists. + %head_wrapper_a0 = call i8* @stack_element_get_data(%stack_element* %list_a) + %head_wrapper_a1 = bitcast i8* %head_wrapper_a0 to %stack_wrapper* + + %head_wrapper_b0 = call i8* @stack_element_get_data(%stack_element* %list_b) + %head_wrapper_b1 = bitcast i8* %head_wrapper_b0 to %stack_wrapper* + + br label %compare_lists + +compare_lists: + %curr_wrapper_a = phi %stack_wrapper* [ %head_wrapper_a1, %top ], [ %next_wrapper_a, %compare_elements ] + %curr_wrapper_b = phi %stack_wrapper* [ %head_wrapper_b1, %top ], [ %next_wrapper_b, %compare_elements ] + + ; If at least one wrapper is null, we may either have reached the end + ; of BOTH lists (which means that they are equal) or one list is shorter + ; than the other, which means that they are NOT equal. + %wrapper_a_is_null = icmp eq %stack_wrapper* %curr_wrapper_a, null + %wrapper_b_is_null = icmp eq %stack_wrapper* %curr_wrapper_b, null + %at_least_one_null = or i1 %wrapper_a_is_null, %wrapper_b_is_null + br i1 %at_least_one_null, label %null_check, label %compare_elements + +null_check: + ; If both wrappers are null, we are finished and the lists are equal. + ; Otherwise one list is shorter than the other and the lists are NOT + ; equal. + %both_null = icmp eq %stack_wrapper* %curr_wrapper_a, %curr_wrapper_b + br i1 %both_null, label %end_equal, label %end_not_equal + +compare_elements: + ; We have two elements which are both not null, so we can compare them. + ; Set next pointers: + %next_wrapper_a = call %stack_wrapper* @stack_wrapper_get_next(%stack_wrapper* %curr_wrapper_a) + %next_wrapper_b = call %stack_wrapper* @stack_wrapper_get_next(%stack_wrapper* %curr_wrapper_b) + + ; Get the wrapped stack elements. + %elm_a = call %stack_element* @stack_wrapper_get_element(%stack_wrapper* %curr_wrapper_a) + %elm_b = call %stack_element* @stack_wrapper_get_element(%stack_wrapper* %curr_wrapper_b) + + ; Now we can do the actual comparison. + %are_equal = call i1 @do_equal(%stack_element* %elm_a, %stack_element* %elm_b) + ; If the elements are equal, check the next pair, else exit. + br i1 %are_equal, label %compare_lists, label %end_not_equal + +end_equal: + ret i1 1 + +end_not_equal: + ret i1 0 +} + + +; Convenience functions for use in generated code. + +; Push nil (an empty list) onto the stack. +define void @gen_list_push_nil() { + %list = call %stack_element* @list_new() + call void @push_struct(%stack_element* %list) + ret void +} + +; Prepend the topmost element to the list, which is the stack element after +; the topmost element, and push the resulting list. +define void @gen_list_cons() { + %elm_to_prepend = call %stack_element* @pop_struct() + %list = call %stack_element* @pop_struct() + + ; Make sure %list is a list. + call void @stack_element_assert_type(%stack_element* %list, i8 1) + + ; Now we can prepend the element to the list... + call %stack_element* @list_prepend(%stack_element* %list, %stack_element* %elm_to_prepend) + + ; ...and push the list again. + call void @push_struct(%stack_element* %list) + + ret void +} + +define void @gen_list_breakup() { + %list = call %stack_element* @pop_struct() + call void @stack_element_assert_is_non_empty_list(%stack_element* %list) + + ; Now pop the topmost list element. + %top = call %stack_element* @list_pop(%stack_element* %list) + + ; Now we can push the list and its former first element again. + call void @push_struct(%stack_element* %list) + call void @push_struct(%stack_element* %top) + + ret void +} diff --git a/src/RailCompiler/math.ll b/src/RailCompiler/math.ll new file mode 100644 --- /dev/null +++ b/src/RailCompiler/math.ll @@ -0,0 +1,670 @@ +; Module : LLVM backend - general math functions +; Description : Contains LLVM functions for mathematical operations like addition etc. +; Maintainers : Sascha Zinke +; License : MIT +; +; These functions are used by our LLVM backend and operate directly on the stack -- +; see stack.ll. + +@err_numeric = external global [56 x i8] +@err_type = external global [14 x i8] +@err_zero = external global [18 x i8] +@popped = external global [13 x i8] + +%stack_element = type opaque +%struct.stack_elem = type { i32, %union.anon } +%union.anon = type { i8* } + +declare i8* @stack_element_get_data(%stack_element* %element) +declare void @stack_element_unref(%stack_element* %element) +declare i32 @get_stack_elem(i8*, %struct.stack_elem*) +declare %stack_element* @push_string_ptr(i8* %str) +declare %stack_element* @push_string_cpy(i8* %str) +declare %stack_element* @pop_struct() +declare signext i32 @printf(i8*, ...) +declare void @push_float(double) +declare void @underflow_assert() +declare void @push_int(i64) +declare i8* @pop_string() +declare void @crash(i1) + +@main.number_b = private unnamed_addr constant [4 x i8] c"3.0\00" +@main.number_a = private unnamed_addr constant [4 x i8] c"0.0\00" + +define i32 @main_math() { + ; push two numbers on the stack + %number0 = getelementptr [4 x i8]* @main.number_a, i64 0, i64 0 + %number1 = getelementptr [4 x i8]* @main.number_b, i64 0, i64 0 + + call %stack_element* @push_string_cpy(i8* %number0) + call %stack_element* @push_string_cpy(i8* %number1) + + call i32 @div() + %result = call i8* @pop_string() + call i32 (i8*, ...)* @printf(i8* getelementptr inbounds ([13 x i8]* + @popped, i32 0, i32 0), i8* %result) + + ret i32 0 +} + +define i32 @mult() { + ; return value of this function + %func_result = alloca i32, align 4 + + ; allocate memory on stack to hold our structures that contains the type + ; of stack element and its casted value + %new_elem_a = alloca %struct.stack_elem, align 8 + %new_elem_b = alloca %struct.stack_elem, align 8 + + ; get top of stack + call void @underflow_assert() + %struct_a = call %stack_element*()* @pop_struct() + %number_a = call i8*(%stack_element*)* @stack_element_get_data( + %stack_element* %struct_a) + + ; get second top of stack + call void @underflow_assert() + %struct_b = call %stack_element*()* @pop_struct() + %number_b = call i8*(%stack_element*)* @stack_element_get_data( + %stack_element* %struct_b) + + ; get type of number_a + %ret_a = call i32 @get_stack_elem(i8* %number_a, %struct.stack_elem* %new_elem_a) + %is_zero_a = icmp slt i32 %ret_a, 0 + br i1 %is_zero_a, label %exit_with_numeric_failure, label %get_stack_elem_b + +get_stack_elem_b: + ; get type of number_b + %ret_b = call i32 @get_stack_elem(i8* %number_b, %struct.stack_elem* %new_elem_b) + %is_zero_b = icmp slt i32 %ret_b, 0 + br i1 %is_zero_b, label %exit_with_numeric_failure, label %get_types + +get_types: + ; type of a + %type_a_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_a, i32 0, i32 0 + %type_a = load i32* %type_a_ptr, align 4 + %val_a_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_a, i32 0, i32 1 + + ; type of b + %type_b_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_b, i32 0, i32 0 + %type_b = load i32* %type_b_ptr, align 4 + %val_b_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_b, i32 0, i32 1 + + switch i32 %type_a, label %exit_with_invalid_type [ + i32 1, label %assume_b_int + i32 2, label %assume_b_float] + +;############################################################################## +; integer multiplication +;############################################################################## + +assume_b_int: + ; check whether it is 1 (aka INT). + %is_int_b = icmp eq i32 %type_b, 1 + br i1 %is_int_b, label %mult_int, label %exit_with_invalid_type + +mult_int: + ; get new_elem_a.ival that contains the casted integer value + %ival_a_cast = bitcast %union.anon* %val_a_ptr to i64* + %ival_a = load i64* %ival_a_cast, align 4 + + ; get new_elem_b.ival that contains the casted integer value + %ival_b_cast = bitcast %union.anon* %val_b_ptr to i64* + %ival_b = load i64* %ival_b_cast, align 4 + + ; add the two integers and store result on the stack + %ires = mul i64 %ival_a, %ival_b + call void(i64)* @push_int(i64 %ires) + br label %exit_with_success + +;############################################################################## +; floating point multiplication +;############################################################################## + +assume_b_float: + ; check whether it is 2 (aka FLOAT). + %is_float_b = icmp eq i32 %type_b, 2 + br i1 %is_float_b, label %mult_float, label %exit_with_invalid_type + +mult_float: + ; get new_elem_a.fval that contains the float value + %fval_a_cast = bitcast %union.anon* %val_a_ptr to float* + %fval_a = load float* %fval_a_cast, align 4 + %fval_a_d = fpext float %fval_a to double + + ; get new_elem_b.fval that contains the float value + %fval_b_cast = bitcast %union.anon* %val_b_ptr to float* + %fval_b = load float* %fval_b_cast, align 4 + %fval_b_d = fpext float %fval_b to double + + ; mult the two floats and store result on the stack + %fres= fmul double %fval_a_d, %fval_b_d + call void(double)* @push_float(double %fres) + br label %exit_with_success + +exit_with_success: + store i32 0, i32* %func_result + br label %exit + +exit_with_numeric_failure: + call %stack_element* @push_string_cpy(i8* getelementptr inbounds( + [56 x i8]* @err_numeric, i64 0, i64 0)) + br label %exit_with_failure + +exit_with_invalid_type: + call %stack_element* @push_string_cpy(i8* getelementptr inbounds( + [14 x i8]* @err_type, i64 0, i64 0)) + br label %exit_with_failure + +exit_with_failure: + call void(%stack_element*)* @stack_element_unref(%stack_element* %struct_a) + call void(%stack_element*)* @stack_element_unref(%stack_element* %struct_b) + call void @crash(i1 0) + br label %exit + +exit: + call void(%stack_element*)* @stack_element_unref(%stack_element* %struct_a) + call void(%stack_element*)* @stack_element_unref(%stack_element* %struct_b) + %result = load i32* %func_result + ret i32 %result +} + +define i32 @rem() { + ; return value of this function + %func_result = alloca i32, align 4 + + ; allocate memory on stack to hold our structures that contains the type + ; of stack element and its casted value + %new_elem_a = alloca %struct.stack_elem, align 8 + %new_elem_b = alloca %struct.stack_elem, align 8 + + ; get top of stack + call void @underflow_assert() + %struct_a = call %stack_element*()* @pop_struct() + %number_a = call i8*(%stack_element*)* @stack_element_get_data( + %stack_element* %struct_a) + + ; get second top of stack + call void @underflow_assert() + %struct_b = call %stack_element*()* @pop_struct() + %number_b = call i8*(%stack_element*)* @stack_element_get_data( + %stack_element* %struct_b) + + ; get type of number_a + %ret_a = call i32 @get_stack_elem(i8* %number_a, %struct.stack_elem* %new_elem_a) + %is_zero_a = icmp slt i32 %ret_a, 0 + br i1 %is_zero_a, label %exit_with_numeric_failure, label %get_stack_elem_b + +get_stack_elem_b: + ; get type of number_b + %ret_b = call i32 @get_stack_elem(i8* %number_b, %struct.stack_elem* %new_elem_b) + %is_zero_b = icmp slt i32 %ret_b, 0 + br i1 %is_zero_b, label %exit_with_numeric_failure, label %get_types + +get_types: + ; type of a + %type_a_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_a, i32 0, i32 0 + %type_a = load i32* %type_a_ptr, align 4 + %val_a_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_a, i32 0, i32 1 + + ; type of b + %type_b_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_b, i32 0, i32 0 + %type_b = load i32* %type_b_ptr, align 4 + %val_b_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_b, i32 0, i32 1 + + switch i32 %type_a, label %exit_with_invalid_type [ + i32 1, label %assume_b_int + i32 2, label %assume_b_float] + +;############################################################################## +; integer remainder +;############################################################################## + +assume_b_int: + %is_int_b = icmp eq i32 %type_b, 1 + br i1 %is_int_b, label %rem_int, label %exit_with_invalid_type + +rem_int: + ; get new_elem_a.ival that contains the casted integer value + %ival_a_cast = bitcast %union.anon* %val_a_ptr to i32* + %ival_a = load i32* %ival_a_cast, align 4 + + ; get new_elem_b.ival that contains the casted integer value + %ival_b_cast = bitcast %union.anon* %val_b_ptr to i32* + %ival_b = load i32* %ival_b_cast, align 4 + + ; add the two integers and store result on the stack + %ires = srem i32 %ival_a, %ival_b + %lres = sext i32 %ires to i64 + call void(i64)* @push_int(i64 %lres) + br label %exit_with_success + +;############################################################################## +; floating point remainder +;############################################################################## + +assume_b_float: + %is_float_b = icmp eq i32 %type_b, 2 + br i1 %is_float_b, label %rem_float, label %exit_with_invalid_type + +rem_float: + ; get new_elem_a.fval that contains the float value + %fval_a_cast = bitcast %union.anon* %val_a_ptr to float* + %fval_a = load float* %fval_a_cast, align 4 + %fval_a_d = fpext float %fval_a to double + + ; get new_elem_b.fval that contains the float value + %fval_b_cast = bitcast %union.anon* %val_b_ptr to float* + %fval_b = load float* %fval_b_cast, align 4 + %fval_b_d = fpext float %fval_b to double + + ; rem the two floats and store result on the stack + %fres= frem double %fval_a_d, %fval_b_d + call void(double)* @push_float(double %fres) + br label %exit_with_success + +exit_with_success: + store i32 0, i32* %func_result + br label %exit + +exit_with_numeric_failure: + call %stack_element* @push_string_cpy(i8* getelementptr inbounds( + [56 x i8]* @err_numeric, i64 0, i64 0)) + br label %exit_with_failure + +exit_with_invalid_type: + call %stack_element* @push_string_cpy(i8* getelementptr inbounds( + [14 x i8]* @err_type, i64 0, i64 0)) + br label %exit_with_failure + +exit_with_failure: + call void(%stack_element*)* @stack_element_unref(%stack_element* %struct_a) + call void(%stack_element*)* @stack_element_unref(%stack_element* %struct_b) + call void @crash(i1 0) + br label %exit + +exit: + call void(%stack_element*)* @stack_element_unref(%stack_element* %struct_a) + call void(%stack_element*)* @stack_element_unref(%stack_element* %struct_b) + %result = load i32* %func_result + ret i32 %result +} + +define i32 @sub() { + ; return value of this function + %func_result = alloca i32, align 4 + + ; allocate memory on stack to hold our structures that contains the type + ; of stack element and its casted value + %new_elem_a = alloca %struct.stack_elem, align 8 + %new_elem_b = alloca %struct.stack_elem, align 8 + + ; get top of stack + call void @underflow_assert() + %struct_b = call %stack_element*()* @pop_struct() + %number_b = call i8*(%stack_element*)* @stack_element_get_data( + %stack_element* %struct_b) + + ; get second top of stack + call void @underflow_assert() + %struct_a = call %stack_element*()* @pop_struct() + %number_a = call i8*(%stack_element*)* @stack_element_get_data( + %stack_element* %struct_a) + + ; get type of number_a + %ret_a = call i32 @get_stack_elem(i8* %number_a, %struct.stack_elem* %new_elem_a) + %is_zero_a = icmp slt i32 %ret_a, 0 + br i1 %is_zero_a, label %exit_with_numeric_failure, label %get_stack_elem_b + +get_stack_elem_b: + ; get type of number_b + %ret_b = call i32 @get_stack_elem(i8* %number_b, %struct.stack_elem* %new_elem_b) + %is_zero_b = icmp slt i32 %ret_b, 0 + br i1 %is_zero_b, label %exit_with_numeric_failure, label %get_types + +get_types: + ; type of a + %type_a_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_a, i32 0, i32 0 + %type_a = load i32* %type_a_ptr, align 4 + %val_a_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_a, i32 0, i32 1 + + ; type of b + %type_b_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_b, i32 0, i32 0 + %type_b = load i32* %type_b_ptr, align 4 + %val_b_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_b, i32 0, i32 1 + + switch i32 %type_a, label %exit_with_invalid_type [ + i32 1, label %assume_b_int + i32 2, label %assume_b_float] + +;############################################################################## +; integer subtraction +;############################################################################## + +assume_b_int: + %is_int_b = icmp eq i32 %type_b, 1 + br i1 %is_int_b, label %sub_int, label %exit_with_invalid_type + +sub_int: + ; get new_elem_a.ival that contains the casted integer value + %ival_a_cast = bitcast %union.anon* %val_a_ptr to i64* + %ival_a = load i64* %ival_a_cast, align 4 + + ; get new_elem_b.ival that contains the casted integer value + %ival_b_cast = bitcast %union.anon* %val_b_ptr to i64* + %ival_b = load i64* %ival_b_cast, align 4 + + ; add the two integers and store result on the stack + %ires = sub i64 %ival_a, %ival_b + call void(i64)* @push_int(i64 %ires) + br label %exit_with_success + +;############################################################################## +; floating point subtraction +;############################################################################## + +assume_b_float: + %is_float_b = icmp eq i32 %type_b, 2 + br i1 %is_float_b, label %sub_float, label %exit_with_invalid_type + +sub_float: + ; get new_elem_a.fval that contains the float value + %fval_a_cast = bitcast %union.anon* %val_a_ptr to float* + %fval_a = load float* %fval_a_cast, align 4 + %fval_a_d = fpext float %fval_a to double + + ; get new_elem_b.fval that contains the float value + %fval_b_cast = bitcast %union.anon* %val_b_ptr to float* + %fval_b = load float* %fval_b_cast, align 4 + %fval_b_d = fpext float %fval_b to double + + ; sub the two floats and store result on the stack + %fres= fsub double %fval_a_d, %fval_b_d + call void(double)* @push_float(double %fres) + br label %exit_with_success + +exit_with_success: + store i32 0, i32* %func_result + br label %exit + +exit_with_numeric_failure: + call %stack_element* @push_string_cpy(i8* getelementptr inbounds( + [56 x i8]* @err_numeric, i64 0, i64 0)) + br label %exit_with_failure + +exit_with_invalid_type: + call %stack_element* @push_string_cpy(i8* getelementptr inbounds( + [14 x i8]* @err_type, i64 0, i64 0)) + br label %exit_with_failure + +exit_with_failure: + call void(%stack_element*)* @stack_element_unref(%stack_element* %struct_a) + call void(%stack_element*)* @stack_element_unref(%stack_element* %struct_b) + call void @crash(i1 0) + br label %exit + +exit: + call void(%stack_element*)* @stack_element_unref(%stack_element* %struct_a) + call void(%stack_element*)* @stack_element_unref(%stack_element* %struct_b) + %result = load i32* %func_result + ret i32 %result +} + +define i32 @add() { + ; return value of this function + %func_result = alloca i32, align 4 + + ; allocate memory on stack to hold our structures that contains the type + ; of stack element and its casted value + %new_elem_a = alloca %struct.stack_elem, align 8 + %new_elem_b = alloca %struct.stack_elem, align 8 + + ; get top of stack + call void @underflow_assert() + %struct_a = call %stack_element*()* @pop_struct() + %number_a = call i8*(%stack_element*)* @stack_element_get_data( + %stack_element* %struct_a) + + ; get second top of stack + call void @underflow_assert() + %struct_b = call %stack_element*()* @pop_struct() + %number_b = call i8*(%stack_element*)* @stack_element_get_data( + %stack_element* %struct_b) + + ; get type of number_a + %ret_a = call i32 @get_stack_elem(i8* %number_a, %struct.stack_elem* %new_elem_a) + %is_zero_a = icmp slt i32 %ret_a, 0 + br i1 %is_zero_a, label %exit_with_numeric_failure, label %get_stack_elem_b + +get_stack_elem_b: + ; get type of number_b + %ret_b = call i32 @get_stack_elem(i8* %number_b, %struct.stack_elem* %new_elem_b) + %is_zero_b = icmp slt i32 %ret_b, 0 + br i1 %is_zero_b, label %exit_with_numeric_failure, label %get_types + +get_types: + ; type of a + %type_a_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_a, i32 0, i32 0 + %type_a = load i32* %type_a_ptr, align 4 + %val_a_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_a, i32 0, i32 1 + + ; type of b + %type_b_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_b, i32 0, i32 0 + %type_b = load i32* %type_b_ptr, align 4 + %val_b_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_b, i32 0, i32 1 + switch i32 %type_a, label %exit_with_invalid_type [ + i32 1, label %assume_b_int + i32 2, label %assume_b_float] + +;############################################################################## +; integer addition +;############################################################################## + +assume_b_int: + %is_int_b = icmp eq i32 %type_b, 1 + br i1 %is_int_b, label %add_int, label %exit_with_invalid_type + +add_int: + ; get new_elem_a.ival that contains the casted integer value + %ival_a_cast = bitcast %union.anon* %val_a_ptr to i64* + %ival_a = load i64* %ival_a_cast, align 4 + + ; get new_elem_b.ival that contains the casted integer value + %ival_b_cast = bitcast %union.anon* %val_b_ptr to i64* + %ival_b = load i64* %ival_b_cast, align 4 + + ; add the two integers and store result on the stack + %ires = add i64 %ival_a, %ival_b + call void(i64)* @push_int(i64 %ires) + br label %exit_with_success + +;############################################################################## +; floating point addition +;############################################################################## + +assume_b_float: + %is_float_b = icmp eq i32 %type_b, 2 + br i1 %is_float_b, label %add_float, label %exit_with_invalid_type + +add_float: + ; get new_elem_a.fval that contains the float value + %fval_a_cast = bitcast %union.anon* %val_a_ptr to float* + %fval_a = load float* %fval_a_cast, align 4 + %fval_a_d = fpext float %fval_a to double + + ; get new_elem_b.fval that contains the float value + %fval_b_cast = bitcast %union.anon* %val_b_ptr to float* + %fval_b = load float* %fval_b_cast, align 4 + %fval_b_d = fpext float %fval_b to double + + ; add the two floats and store result on the stack + %fres= fadd double %fval_a_d, %fval_b_d + call void(double)* @push_float(double %fres) + br label %exit_with_success + +exit_with_numeric_failure: + call %stack_element* @push_string_cpy(i8* getelementptr inbounds( + [56 x i8]* @err_numeric, i64 0, i64 0)) + br label %exit_with_failure + +exit_with_invalid_type: + call %stack_element* @push_string_cpy(i8* getelementptr inbounds( + [14 x i8]* @err_type, i64 0, i64 0)) + br label %exit_with_failure + +exit_with_failure: + call void(%stack_element*)* @stack_element_unref(%stack_element* %struct_a) + call void(%stack_element*)* @stack_element_unref(%stack_element* %struct_b) + call void @crash(i1 0) + br label %exit + +exit_with_success: + store i32 0, i32* %func_result + br label %exit + +exit: + call void(%stack_element*)* @stack_element_unref(%stack_element* %struct_a) + call void(%stack_element*)* @stack_element_unref(%stack_element* %struct_b) + %result = load i32* %func_result + ret i32 %result +} + +define i32 @div() { + ; return value of this function + %func_result = alloca i32, align 4 + + ; allocate memory on stack to hold our structures that contains the type + ; of stack element and its casted value + %new_elem_a = alloca %struct.stack_elem, align 8 + %new_elem_b = alloca %struct.stack_elem, align 8 + + ; get top of stack + call void @underflow_assert() + %struct_b = call %stack_element*()* @pop_struct() + %number_b = call i8*(%stack_element*)* @stack_element_get_data( + %stack_element* %struct_b) + + ; get second top of stack + call void @underflow_assert() + %struct_a = call %stack_element*()* @pop_struct() + %number_a = call i8*(%stack_element*)* @stack_element_get_data( + %stack_element* %struct_a) + + ; get type of number_a + %ret_a = call i32 @get_stack_elem(i8* %number_a, %struct.stack_elem* %new_elem_a) + %is_zero_a = icmp slt i32 %ret_a, 0 + br i1 %is_zero_a, label %exit_with_numeric_failure, label %get_stack_elem_b + +get_stack_elem_b: + ; get type of number_b + %ret_b = call i32 @get_stack_elem(i8* %number_b, %struct.stack_elem* %new_elem_b) + %is_zero_b = icmp slt i32 %ret_b, 0 + br i1 %is_zero_b, label %exit_with_numeric_failure, label %get_types + +get_types: + ; type of a + %type_a_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_a, i32 0, i32 0 + %type_a = load i32* %type_a_ptr, align 4 + %val_a_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_a, i32 0, i32 1 + + ; type of b + %type_b_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_b, i32 0, i32 0 + %type_b = load i32* %type_b_ptr, align 4 + %val_b_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_b, i32 0, i32 1 + + switch i32 %type_a, label %exit_with_invalid_type [ + i32 1, label %assume_b_int + i32 2, label %assume_b_float] + + +;############################################################################## +; integer division +;############################################################################## + +assume_b_int: + %is_int_b = icmp eq i32 %type_b, 1 + br i1 %is_int_b, label %div_int, label %exit_with_invalid_type + +div_int: + ; get new_elem_a.ival that contains the casted integer value + %ival_a_cast = bitcast %union.anon* %val_a_ptr to i32* + %ival_a = load i32* %ival_a_cast, align 4 + + ; get new_elem_b.ival that contains the casted integer value + %ival_b_cast = bitcast %union.anon* %val_b_ptr to i32* + %ival_b = load i32* %ival_b_cast, align 4 + + ; prevent division by zero + %div_by_zero = icmp eq i32 %ival_b, 0 + br i1 %div_by_zero, label %exit_with_zero, label %div_int_ok + +div_int_ok: + ; divide the two integers and store result on the stack + %ires = sdiv i32 %ival_a, %ival_b + %lres = sext i32 %ires to i64 + + call void(i64)* @push_int(i64 %lres) + br label %exit_with_success + +;############################################################################## +; floating point division +;############################################################################## + +assume_b_float: + %is_float_b = icmp eq i32 %type_b, 2 + br i1 %is_float_b, label %div_float, label %exit_with_invalid_type + +div_float: + ; get new_elem_a.fval that contains the float value + %fval_a_cast = bitcast %union.anon* %val_a_ptr to float* + %fval_a = load float* %fval_a_cast, align 4 + %fval_a_d = fpext float %fval_a to double + + ; get new_elem_b.fval that contains the float value + %fval_b_cast = bitcast %union.anon* %val_b_ptr to float* + %fval_b = load float* %fval_b_cast, align 4 + + ; prevent division by zero + %div_by_zero_f = fcmp oeq float %fval_b, 0.0 + br i1 %div_by_zero_f, label %exit_with_zero, label %div_float_ok + +div_float_ok: + ; divide the two floats and store result on the stack + %fval_b_d = fpext float %fval_b to double + %fres= fdiv double %fval_a_d, %fval_b_d + call void(double)* @push_float(double %fres) + br label %exit_with_success + +exit_with_success: + store i32 0, i32* %func_result + br label %exit + +exit_with_numeric_failure: + call %stack_element* @push_string_cpy(i8* getelementptr inbounds( + [56 x i8]* @err_numeric, i64 0, i64 0)) + br label %exit_with_failure + +exit_with_zero: + call %stack_element* @push_string_cpy(i8* getelementptr inbounds( + [18 x i8]* @err_zero, i64 0, i64 0)) + br label %exit_with_failure + +exit_with_invalid_type: + call %stack_element* @push_string_cpy(i8* getelementptr inbounds( + [14 x i8]* @err_type, i64 0, i64 0)) + br label %exit_with_failure + +exit_with_failure: + call void(%stack_element*)* @stack_element_unref(%stack_element* %struct_a) + call void(%stack_element*)* @stack_element_unref(%stack_element* %struct_b) + call void @crash(i1 0) + br label %exit + +exit: + call void(%stack_element*)* @stack_element_unref(%stack_element* %struct_a) + call void(%stack_element*)* @stack_element_unref(%stack_element* %struct_b) + %result = load i32* %func_result + ret i32 %result +} + + diff --git a/src/RailCompiler/stack.ll b/src/RailCompiler/stack.ll --- a/src/RailCompiler/stack.ll +++ b/src/RailCompiler/stack.ll @@ -1,1398 +1,552 @@ -@stack = global [1000 x i8*] undef ; stack containing pointers to i8 -@sp = global i64 0 ; global stack pointer (or rather: current number of elements) -@lookahead = global i32 -1 ; current lookahead for input from stdin. - ; -1 means no lookahead done yet. - - -; Constants -@to_str = private unnamed_addr constant [3 x i8] c"%i\00" -@true = global [2 x i8] c"1\00" -@false = global [2 x i8] c"0\00" -@printf_str_fmt = private unnamed_addr constant [3 x i8] c"%s\00" -@crash_cust_str_fmt = private unnamed_addr constant [24 x i8] c"Crash: Custom error: %s\00" -@err_stack_underflow = private unnamed_addr constant [18 x i8] c"Stack underflow!\0A\00" -@err_eof = private unnamed_addr constant [9 x i8] c"At EOF!\0A\00" -@err_type = private unnamed_addr constant [14 x i8] c"Invalid type!\00" -@err_zero = private unnamed_addr constant [18 x i8] c"Division by zero!\00" - - -; External declarations -%FILE = type opaque - -@stderr = external global %FILE* - -declare signext i32 @atol(i8*) -declare i64 @strtol(i8*, i8**, i32 ) -declare signext i32 @snprintf(i8*, ...) -declare signext i32 @printf(i8*, ...) -declare signext i32 @fprintf(%FILE*, i8*, ...) -declare float @strtof(i8*, i8**) -declare signext i32 @getchar() -declare i8* @malloc(i16 zeroext) ; void *malloc(size_t) and size_t is 16 bits long (SIZE_MAX) -declare i8* @calloc(i16 zeroext, i16 zeroext) -declare void @exit(i32 signext) - - -; Debugging stuff -@pushing = private unnamed_addr constant [14 x i8] c"Pushing [%s]\0A\00" -@popped = private unnamed_addr constant [13 x i8] c"Popped [%s]\0a\00" -@msg = private unnamed_addr constant [5 x i8] c"msg\0a\00" - - -@int_to_str = private unnamed_addr constant [3 x i8] c"%i\00" -@float_to_str = private unnamed_addr constant [3 x i8] c"%f\00" - -;typedef enum {INT = 1, FLOAT = 2, STRING = 3} elem_type; -;struct stack_elem { -; elem_type type; -; union { -; int ival; -; float fval; -; char *sval; -; }; -;}; -%struct.stack_elem = type { i32, %union.anon } -%union.anon = type { i8* } - - -@.str = private unnamed_addr constant [33 x i8] c"call int add with a=%i and b=%i\0A\00", align 1 -@.str1 = private unnamed_addr constant [35 x i8] c"call float add with a=%f and b=%f\0A\00", align 1 -@.str2 = private unnamed_addr constant [15 x i8] c"failed to add\0A\00", align 1 - - - -; Function definitions - -; Get number of element on the stack -define i64 @stack_get_size() { - %sp = load i64* @sp - ret i64 %sp -} - -; Push the stack size onto the stack -define void @underflow_check() { - %stack_size = call i64 @stack_get_size() - call void @push_int(i64 %stack_size) - ret void -} - -; Exit the program if stack is empty (prints error to stderr). -define void @underflow_assert() { - %stack_size = call i64 @stack_get_size() - %stack_empty = icmp eq i64 %stack_size, 0 - br i1 %stack_empty, label %uas_crash, label %uas_okay - -uas_crash: - %err = getelementptr [18 x i8]* @err_stack_underflow, i8 0, i8 0 - %stderr = load %FILE** @stderr - call i32(%FILE*, i8*, ...)* @fprintf(%FILE* %stderr, i8* %err) - call void @exit(i32 1) - - ret void - -uas_okay: - ret void -} - -; Pop stack and print result string -define void @print() { - ; TODO: Check if the top stack element is a string and crash if it is not. - call void @underflow_assert() - - %fmt = getelementptr [3 x i8]* @printf_str_fmt, i8 0, i8 0 - %val = call i8* @pop() - call i32(i8*, ...)* @printf(i8* %fmt, i8* %val) - - ret void -} - -; Pop stack, print result string to stderr and exit the program. -define void @crash(i1 %is_custom_error) { - ; TODO: Check if the top stack element is a string and crash if it is not. - call void @underflow_assert() - - br i1 %is_custom_error, label %custom_error, label %raw_error - -custom_error: - %cust_fmt = getelementptr [24 x i8]* @crash_cust_str_fmt, i8 0, i8 0 - br label %end - -raw_error: - %raw_fmt = getelementptr [3 x i8]* @printf_str_fmt, i8 0, i8 0 - br label %end - -end: - %fmt = phi i8* [%raw_fmt, %raw_error], [%cust_fmt, %custom_error] - %val = call i8* @pop() - %stderr = load %FILE** @stderr - call i32(%FILE*, i8*, ...)* @fprintf(%FILE* %stderr, i8* %fmt, i8* %val) - - ; Now, crash! - call void @exit(i32 1) - - ret void -} - -; Get a byte of input from stdin and push it. -; Crashes the program on errors. -define void @input() { - %read = call i32 @input_get() - %err = icmp slt i32 %read, 0 - br i1 %err, label %error, label %push - -error: - %at_eof = getelementptr [9 x i8]* @err_eof, i64 0, i64 0 - call void @push(i8* %at_eof) - call void @crash(i1 0) - ret void - -push: - %byte = trunc i32 %read to i8 - %buffer_addr = call i8* @calloc(i16 1, i16 2) - store i8 %byte, i8* %buffer_addr - call void @push(i8* %buffer_addr) - - ret void -} - -; Get a byte of input from stdin. Returns < 0 on error. -; This can be used together with input_peek(). -define i32 @input_get() { - %lookahead = load i32* @lookahead - %need_read = icmp slt i32 %lookahead, 0 - br i1 %need_read, label %ig_read, label %ig_lookahead - -ig_lookahead: - store i32 -1, i32* @lookahead - ret i32 %lookahead - -ig_read: - %read = call i32 @getchar() - ret i32 %read -} - -; Peek a byte of input from stdin. Returns < 0 on error. -; Successive calls to this function without interspersed calls -; to input_read() return the same value. -define i32 @input_peek() { - %read = call i32 @input_get() - store i32 %read, i32* @lookahead - ret i32 %read -} - -; If stdin is at EOF, push 1, else 0. -define void @eof_check() { - %peek = call i32 @input_peek() - %is_eof = icmp slt i32 %peek, 0 - br i1 %is_eof, label %at_eof, label %not_at_eof - -at_eof: - %true = getelementptr [2 x i8]* @true, i8 0, i8 0 - call void @push(i8* %true) - ret void - -not_at_eof: - %false = getelementptr [2 x i8]* @false, i8 0, i8 0 - call void @push(i8* %false) - - ret void -} - -define void @push(i8* %str_ptr) { - ; dereferencing @sp by loading value into memory - %sp = load i64* @sp - - ; get position on the stack, the stack pointer points to. this is the top of - ; the stack. - ; nice getelementptr FAQ: http://llvm.org/docs/GetElementPtr.html - ; value of pointer type, index, field - %top = getelementptr [1000 x i8*]* @stack, i8 0, i64 %sp - - ; the contents of memory are updated to contain %str_ptr at the location - ; specified by the %addr operand - store i8* %str_ptr, i8** %top - - ; increase stack pointer to point to new free, top of stack - %newsp = add i64 %sp, 1 - store i64 %newsp, i64* @sp - - ret void -} - -; pops element from stack and converts in integer -; returns the element, in case of error undefined -define i64 @pop_int(){ - ; pop - %top = call i8* @pop() - - ; convert to int, check for error - %top_int0 = call i32 @atol(i8* %top) - %top_int1 = sext i32 %top_int0 to i64 - - ; return - ret i64 %top_int1 -} - -define void @push_float(double %top_float) -{ - ; allocate memory to store string in - ; TODO: Make sure this is free()'d at _some_ point during - ; program execution. - %buffer_addr = call i8* @malloc(i16 128) - %to_str_ptr = getelementptr [3 x i8]* @float_to_str, i64 0, i64 0 - - ; convert to string - call i32(i8*, ...)* @snprintf( - i8* %buffer_addr, i16 128, i8* %to_str_ptr, double %top_float) - - ; push on stack - call void(i8*)* @push(i8* %buffer_addr) - - ret void -} - -define void @push_int(i64 %top_int) -{ - ; allocate memory to store string in - ; TODO: Make sure this is free()'d at _some_ point during - ; program execution. - %buffer_addr = call i8* @malloc(i16 128) - %to_str_ptr = getelementptr [3 x i8]* @int_to_str, i64 0, i64 0 - - ; convert to string - call i32(i8*, ...)* @snprintf( - i8* %buffer_addr, i16 128, i8* %to_str_ptr, i64 %top_int) - - ; push on stack - call void(i8*)* @push(i8* %buffer_addr) - - ret void -} - -define i32 @mult() { - ; return value of this function - %func_result = alloca i32, align 4 - - ; allocate memory on stack to hold our structures that contains the type - ; of stack element and its casted value - %new_elem_a = alloca %struct.stack_elem, align 8 - %new_elem_b = alloca %struct.stack_elem, align 8 - - ; get top of stack - call void @underflow_assert() - %number_a = call i8* @pop() - - ; get second top of stack - call void @underflow_assert() - %number_b = call i8* @pop() - - ; get type of number_a - %ret_a = call i32 @get_stack_elem(i8* %number_a, %struct.stack_elem* %new_elem_a) - %is_zero_a = icmp slt i32 %ret_a, 0 - br i1 %is_zero_a, label %exit_with_failure, label %get_type_b - -;############################################################################## -; integer multiplication -;############################################################################## - -get_type_b: - ; get type of number_b - %ret_b = call i32 @get_stack_elem(i8* %number_b, %struct.stack_elem* %new_elem_b) - %is_zero_b = icmp slt i32 %ret_b, 0 - br i1 %is_zero_b, label %exit_with_failure, label %type_check_a_int - -type_check_a_int: - ; first, load the new_elem_a.type element. check whether it is 1 (aka INT). - %type_a_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_a, i32 0, i32 0 - %type_a = load i32* %type_a_ptr, align 4 - %is_int_a = icmp eq i32 %type_a, 1 - br i1 %is_int_a, label %type_check_b_int, label %type_check_a_float - -type_check_b_int: - ; first, load the new_elem_b.type element. check whether it is 1 (aka INT). - %type_b_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_b, i32 0, i32 0 - %type_b = load i32* %type_b_ptr, align 4 - %is_int_b = icmp eq i32 %type_b, 1 - br i1 %is_int_b, label %add_int, label %type_check_a_float - -add_int: - ; get new_elem_a.ival that contains the casted integer value - %ival_a_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_a, i32 0, i32 1 - %ival_a_cast = bitcast %union.anon* %ival_a_ptr to i64* - %ival_a = load i64* %ival_a_cast, align 4 - - ; get new_elem_b.ival that contains the casted integer value - %ival_b_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_b, i32 0, i32 1 - %ival_b_cast = bitcast %union.anon* %ival_b_ptr to i64* - %ival_b = load i64* %ival_b_cast, align 4 - - ; add the two integers and store result on the stack - %ires = mul i64 %ival_a, %ival_b - call void(i64)* @push_int(i64 %ires) - br label %exit_with_success - -;############################################################################## -; floating point multiplication -;############################################################################## - -type_check_a_float: - %ftype_a_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_a, i32 0, i32 0 - %ftype_a = load i32* %ftype_a_ptr, align 4 - %is_float_a = icmp eq i32 %ftype_a, 2 - br i1 %is_float_a, label %type_check_b_float, label %exit_with_invalid_type - -type_check_b_float: - %ftype_b_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_b, i32 0, i32 0 - %ftype_b = load i32* %ftype_b_ptr, align 4 - %is_float_b = icmp eq i32 %ftype_b, 2 - br i1 %is_float_b, label %mult_float, label %exit_with_invalid_type - -mult_float: - ; get new_elem_a.fval that contains the float value - %fval_a_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_a, i32 0, i32 1 - %fval_a_cast = bitcast %union.anon* %fval_a_ptr to float* - %fval_a = load float* %fval_a_cast, align 4 - %fval_a_d = fpext float %fval_a to double - - ; get new_elem_b.fval that contains the float value - %fval_b_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_b, i32 0, i32 1 - %fval_b_cast = bitcast %union.anon* %fval_b_ptr to float* - %fval_b = load float* %fval_b_cast, align 4 - %fval_b_d = fpext float %fval_b to double - - ; sub the two floats and store result on the stack - %fres= fmul double %fval_a_d, %fval_b_d - call void(double)* @push_float(double %fres) - br label %exit_with_success - -exit_with_success: - store i32 0, i32* %func_result - br label %exit - -exit_with_invalid_type: - call void(i8*)* @push(i8* getelementptr inbounds( - [14 x i8]* @err_type, i64 0, i64 0)) - br label %exit_with_failure - -exit_with_failure: - store i32 -1, i32* %func_result - br label %exit - -exit: - %result = load i32* %func_result - ret i32 %result -} - -define i32 @rem() { - ; return value of this function - %func_result = alloca i32, align 4 - - ; allocate memory on stack to hold our structures that contains the type - ; of stack element and its casted value - %new_elem_a = alloca %struct.stack_elem, align 8 - %new_elem_b = alloca %struct.stack_elem, align 8 - - ; get top of stack - call void @underflow_assert() - %number_a = call i8* @pop() - - ; get second top of stack - call void @underflow_assert() - %number_b = call i8* @pop() - - ; get type of number_a - %ret_a = call i32 @get_stack_elem(i8* %number_a, %struct.stack_elem* %new_elem_a) - %is_zero_a = icmp slt i32 %ret_a, 0 - br i1 %is_zero_a, label %exit_with_failure, label %get_type_b - -;############################################################################## -; integer remainder -;############################################################################## - -get_type_b: - ; get type of number_b - %ret_b = call i32 @get_stack_elem(i8* %number_b, %struct.stack_elem* %new_elem_b) - %is_zero_b = icmp slt i32 %ret_b, 0 - br i1 %is_zero_b, label %exit_with_failure, label %type_check_a_int - -type_check_a_int: - ; first, load the new_elem_a.type element. check whether it is 1 (aka INT). - %type_a_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_a, i32 0, i32 0 - %type_a = load i32* %type_a_ptr, align 4 - %is_int_a = icmp eq i32 %type_a, 1 - br i1 %is_int_a, label %type_check_b_int, label %type_check_a_float - -type_check_b_int: - ; first, load the new_elem_b.type element. check whether it is 1 (aka INT). - %type_b_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_b, i32 0, i32 0 - %type_b = load i32* %type_b_ptr, align 4 - %is_int_b = icmp eq i32 %type_b, 1 - br i1 %is_int_b, label %rem_int, label %type_check_a_float - -rem_int: - ; get new_elem_a.ival that contains the casted integer value - %ival_a_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_a, i32 0, i32 1 - %ival_a_cast = bitcast %union.anon* %ival_a_ptr to i32* - %ival_a = load i32* %ival_a_cast, align 4 - - ; get new_elem_b.ival that contains the casted integer value - %ival_b_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_b, i32 0, i32 1 - %ival_b_cast = bitcast %union.anon* %ival_b_ptr to i32* - %ival_b = load i32* %ival_b_cast, align 4 - - ; add the two integers and store result on the stack - %ires = srem i32 %ival_a, %ival_b - %lres = sext i32 %ires to i64 - call void(i64)* @push_int(i64 %lres) - br label %exit_with_success - -;############################################################################## -; floating point remainder -;############################################################################## - -type_check_a_float: - %ftype_a_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_a, i32 0, i32 0 - %ftype_a = load i32* %ftype_a_ptr, align 4 - %is_float_a = icmp eq i32 %ftype_a, 2 - br i1 %is_float_a, label %type_check_b_float, label %exit_with_invalid_type - -type_check_b_float: - %ftype_b_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_b, i32 0, i32 0 - %ftype_b = load i32* %ftype_b_ptr, align 4 - %is_float_b = icmp eq i32 %ftype_b, 2 - br i1 %is_float_b, label %rem_float, label %exit_with_invalid_type - -rem_float: - ; get new_elem_a.fval that contains the float value - %fval_a_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_a, i32 0, i32 1 - %fval_a_cast = bitcast %union.anon* %fval_a_ptr to float* - %fval_a = load float* %fval_a_cast, align 4 - %fval_a_d = fpext float %fval_a to double - - ; get new_elem_b.fval that contains the float value - %fval_b_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_b, i32 0, i32 1 - %fval_b_cast = bitcast %union.anon* %fval_b_ptr to float* - %fval_b = load float* %fval_b_cast, align 4 - %fval_b_d = fpext float %fval_b to double - - ; sub the two floats and store result on the stack - %fres= frem double %fval_a_d, %fval_b_d - call void(double)* @push_float(double %fres) - br label %exit_with_success - -exit_with_success: - store i32 0, i32* %func_result - br label %exit - -exit_with_invalid_type: - call void(i8*)* @push(i8* getelementptr inbounds( - [14 x i8]* @err_type, i64 0, i64 0)) - br label %exit_with_failure - -exit_with_failure: - store i32 -1, i32* %func_result - br label %exit - -exit: - %result = load i32* %func_result - ret i32 %result -} - -define i32 @sub() { - ; return value of this function - %func_result = alloca i32, align 4 - - ; allocate memory on stack to hold our structures that contains the type - ; of stack element and its casted value - %new_elem_a = alloca %struct.stack_elem, align 8 - %new_elem_b = alloca %struct.stack_elem, align 8 - - ; get top of stack - call void @underflow_assert() - %number_a = call i8* @pop() - - ; get second top of stack - call void @underflow_assert() - %number_b = call i8* @pop() - - ; get type of number_a - %ret_a = call i32 @get_stack_elem(i8* %number_a, %struct.stack_elem* %new_elem_a) - %is_zero_a = icmp slt i32 %ret_a, 0 - br i1 %is_zero_a, label %exit_with_failure, label %get_type_b - -;############################################################################## -; integer subtraction -;############################################################################## - -get_type_b: - ; get type of number_b - %ret_b = call i32 @get_stack_elem(i8* %number_b, %struct.stack_elem* %new_elem_b) - %is_zero_b = icmp slt i32 %ret_b, 0 - br i1 %is_zero_b, label %exit_with_failure, label %type_check_a_int - -type_check_a_int: - ; first, load the new_elem_a.type element. check whether it is 1 (aka INT). - %type_a_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_a, i32 0, i32 0 - %type_a = load i32* %type_a_ptr, align 4 - %is_int_a = icmp eq i32 %type_a, 1 - br i1 %is_int_a, label %type_check_b_int, label %type_check_a_float - -type_check_b_int: - ; first, load the new_elem_b.type element. check whether it is 1 (aka INT). - %type_b_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_b, i32 0, i32 0 - %type_b = load i32* %type_b_ptr, align 4 - %is_int_b = icmp eq i32 %type_b, 1 - br i1 %is_int_b, label %sub_int, label %type_check_a_float - -sub_int: - ; get new_elem_a.ival that contains the casted integer value - %ival_a_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_a, i32 0, i32 1 - %ival_a_cast = bitcast %union.anon* %ival_a_ptr to i64* - %ival_a = load i64* %ival_a_cast, align 4 - - ; get new_elem_b.ival that contains the casted integer value - %ival_b_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_b, i32 0, i32 1 - %ival_b_cast = bitcast %union.anon* %ival_b_ptr to i64* - %ival_b = load i64* %ival_b_cast, align 4 - - ; add the two integers and store result on the stack - %ires = sub i64 %ival_a, %ival_b - call void(i64)* @push_int(i64 %ires) - br label %exit_with_success - -;############################################################################## -; floating point subtraction -;############################################################################## - -type_check_a_float: - %ftype_a_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_a, i32 0, i32 0 - %ftype_a = load i32* %ftype_a_ptr, align 4 - %is_float_a = icmp eq i32 %ftype_a, 2 - br i1 %is_float_a, label %type_check_b_float, label %exit_with_invalid_type - -type_check_b_float: - %ftype_b_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_b, i32 0, i32 0 - %ftype_b = load i32* %ftype_b_ptr, align 4 - %is_float_b = icmp eq i32 %ftype_b, 2 - br i1 %is_float_b, label %sub_float, label %exit_with_invalid_type - -sub_float: - ; get new_elem_a.fval that contains the float value - %fval_a_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_a, i32 0, i32 1 - %fval_a_cast = bitcast %union.anon* %fval_a_ptr to float* - %fval_a = load float* %fval_a_cast, align 4 - %fval_a_d = fpext float %fval_a to double - - ; get new_elem_b.fval that contains the float value - %fval_b_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_b, i32 0, i32 1 - %fval_b_cast = bitcast %union.anon* %fval_b_ptr to float* - %fval_b = load float* %fval_b_cast, align 4 - %fval_b_d = fpext float %fval_b to double - - ; sub the two floats and store result on the stack - %fres= fsub double %fval_a_d, %fval_b_d - call void(double)* @push_float(double %fres) - br label %exit_with_success - -exit_with_success: - store i32 0, i32* %func_result - br label %exit - -exit_with_invalid_type: - call void(i8*)* @push(i8* getelementptr inbounds( - [14 x i8]* @err_type, i64 0, i64 0)) - br label %exit_with_failure - -exit_with_failure: - store i32 -1, i32* %func_result - br label %exit - -exit: - %result = load i32* %func_result - ret i32 %result -} - -define i32 @add() { - ; return value of this function - %func_result = alloca i32, align 4 - - ; allocate memory on stack to hold our structures that contains the type - ; of stack element and its casted value - %new_elem_a = alloca %struct.stack_elem, align 8 - %new_elem_b = alloca %struct.stack_elem, align 8 - - ; get top of stack - call void @underflow_assert() - %number_a = call i8* @pop() - - ; get second top of stack - call void @underflow_assert() - %number_b = call i8* @pop() - - ; get type of number_a - %ret_a = call i32 @get_stack_elem(i8* %number_a, %struct.stack_elem* %new_elem_a) - %is_zero_a = icmp slt i32 %ret_a, 0 - br i1 %is_zero_a, label %exit_with_failure, label %get_type_b - -;############################################################################## -; integer addition -;############################################################################## - -get_type_b: - ; get type of number_b - %ret_b = call i32 @get_stack_elem(i8* %number_b, %struct.stack_elem* %new_elem_b) - %is_zero_b = icmp slt i32 %ret_b, 0 - br i1 %is_zero_b, label %exit_with_failure, label %type_check_a_int - -type_check_a_int: - ; first, load the new_elem_a.type element. check whether it is 1 (aka INT). - %type_a_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_a, i32 0, i32 0 - %type_a = load i32* %type_a_ptr, align 4 - %is_int_a = icmp eq i32 %type_a, 1 - br i1 %is_int_a, label %type_check_b_int, label %type_check_a_float - -type_check_b_int: - ; first, load the new_elem_b.type element. check whether it is 1 (aka INT). - %type_b_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_b, i32 0, i32 0 - %type_b = load i32* %type_b_ptr, align 4 - %is_int_b = icmp eq i32 %type_b, 1 - br i1 %is_int_b, label %add_int, label %type_check_a_float - -add_int: - ; get new_elem_a.ival that contains the casted integer value - %ival_a_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_a, i32 0, i32 1 - %ival_a_cast = bitcast %union.anon* %ival_a_ptr to i64* - %ival_a = load i64* %ival_a_cast, align 4 - - ; get new_elem_b.ival that contains the casted integer value - %ival_b_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_b, i32 0, i32 1 - %ival_b_cast = bitcast %union.anon* %ival_b_ptr to i64* - %ival_b = load i64* %ival_b_cast, align 4 - - ; add the two integers and store result on the stack - %ires = add i64 %ival_a, %ival_b - call void(i64)* @push_int(i64 %ires) - br label %exit_with_success - -;############################################################################## -; floating point addition -;############################################################################## - -type_check_a_float: - %ftype_a_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_a, i32 0, i32 0 - %ftype_a = load i32* %ftype_a_ptr, align 4 - %is_float_a = icmp eq i32 %ftype_a, 2 - br i1 %is_float_a, label %type_check_b_float, label %exit_with_invalid_type - -type_check_b_float: - %ftype_b_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_b, i32 0, i32 0 - %ftype_b = load i32* %ftype_b_ptr, align 4 - %is_float_b = icmp eq i32 %ftype_b, 2 - br i1 %is_float_b, label %add_float, label %exit_with_invalid_type - -add_float: - ; get new_elem_a.fval that contains the float value - %fval_a_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_a, i32 0, i32 1 - %fval_a_cast = bitcast %union.anon* %fval_a_ptr to float* - %fval_a = load float* %fval_a_cast, align 4 - %fval_a_d = fpext float %fval_a to double - - ; get new_elem_b.fval that contains the float value - %fval_b_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_b, i32 0, i32 1 - %fval_b_cast = bitcast %union.anon* %fval_b_ptr to float* - %fval_b = load float* %fval_b_cast, align 4 - %fval_b_d = fpext float %fval_b to double - - ; add the two floats and store result on the stack - %fres= fadd double %fval_a_d, %fval_b_d - call void(double)* @push_float(double %fres) - br label %exit_with_success - -exit_with_success: - store i32 0, i32* %func_result - br label %exit - -exit_with_invalid_type: - call void(i8*)* @push(i8* getelementptr inbounds( - [14 x i8]* @err_type, i64 0, i64 0)) - br label %exit_with_failure - -exit_with_failure: - store i32 -1, i32* %func_result - br label %exit - -exit: - %result = load i32* %func_result - ret i32 %result -} - -define void @sub_int() { - ; get top of stack - %top_1 = call i64()* @pop_int() - - ; get second top of stack - %top_2 = call i64()* @pop_int() - - ; sub the two values - %res = sub i64 %top_1, %top_2 - - ; store result on stack - call void(i64)* @push_int(i64 %res) - - ret void -} - -define i32 @div() { - ; return value of this function - %func_result = alloca i32, align 4 - - ; allocate memory on stack to hold our structures that contains the type - ; of stack element and its casted value - %new_elem_a = alloca %struct.stack_elem, align 8 - %new_elem_b = alloca %struct.stack_elem, align 8 - - ; get top of stack - call void @underflow_assert() - %number_a = call i8* @pop() - - ; get second top of stack - call void @underflow_assert() - %number_b = call i8* @pop() - - ; get type of number_a - %ret_a = call i32 @get_stack_elem(i8* %number_a, %struct.stack_elem* %new_elem_a) - %is_zero_a = icmp slt i32 %ret_a, 0 - br i1 %is_zero_a, label %exit_with_failure, label %get_type_b - -;############################################################################## -; integer division -;############################################################################## - -get_type_b: - ; get type of number_b - %ret_b = call i32 @get_stack_elem(i8* %number_b, %struct.stack_elem* %new_elem_b) - %is_zero_b = icmp slt i32 %ret_b, 0 - br i1 %is_zero_b, label %exit_with_failure, label %type_check_a_int - -type_check_a_int: - ; first, load the new_elem_a.type element. check whether it is 1 (aka INT). - %type_a_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_a, i32 0, i32 0 - %type_a = load i32* %type_a_ptr, align 4 - %is_int_a = icmp eq i32 %type_a, 1 - br i1 %is_int_a, label %type_check_b_int, label %type_check_a_float - -type_check_b_int: - ; first, load the new_elem_b.type element. check whether it is 1 (aka INT). - %type_b_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_b, i32 0, i32 0 - %type_b = load i32* %type_b_ptr, align 4 - %is_int_b = icmp eq i32 %type_b, 1 - br i1 %is_int_b, label %div_int, label %type_check_a_float - -div_int: - ; get new_elem_a.ival that contains the casted integer value - %ival_a_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_a, i32 0, i32 1 - %ival_a_cast = bitcast %union.anon* %ival_a_ptr to i32* - %ival_a = load i32* %ival_a_cast, align 4 - - ; get new_elem_b.ival that contains the casted integer value - %ival_b_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_b, i32 0, i32 1 - %ival_b_cast = bitcast %union.anon* %ival_b_ptr to i32* - %ival_b = load i32* %ival_b_cast, align 4 - - ; prevent division by zero - %div_by_zero = icmp eq i32 %ival_b, 0 - br i1 %div_by_zero, label %exit_with_zero, label %div_int_ok - -div_int_ok: - ; divide the two integers and store result on the stack - %ires = sdiv i32 %ival_a, %ival_b - %lres = sext i32 %ires to i64 - - call void(i64)* @push_int(i64 %lres) - br label %exit_with_success - -;############################################################################## -; floating point division -;############################################################################## - -type_check_a_float: - %ftype_a_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_a, i32 0, i32 0 - %ftype_a = load i32* %ftype_a_ptr, align 4 - %is_float_a = icmp eq i32 %ftype_a, 2 - br i1 %is_float_a, label %type_check_b_float, label %exit_with_invalid_type - -type_check_b_float: - %ftype_b_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_b, i32 0, i32 0 - %ftype_b = load i32* %ftype_b_ptr, align 4 - %is_float_b = icmp eq i32 %ftype_b, 2 - br i1 %is_float_b, label %div_float, label %exit_with_invalid_type - -div_float: - ; get new_elem_a.fval that contains the float value - %fval_a_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_a, i32 0, i32 1 - %fval_a_cast = bitcast %union.anon* %fval_a_ptr to float* - %fval_a = load float* %fval_a_cast, align 4 - %fval_a_d = fpext float %fval_a to double - - ; get new_elem_b.fval that contains the float value - %fval_b_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_b, i32 0, i32 1 - %fval_b_cast = bitcast %union.anon* %fval_b_ptr to float* - %fval_b = load float* %fval_b_cast, align 4 - - ; prevent division by zero - %div_by_zero_f = fcmp oeq float %fval_b, 0.0 - br i1 %div_by_zero_f, label %exit_with_zero, label %div_float_ok - -div_float_ok: - ; divide the two floats and store result on the stack - %fval_b_d = fpext float %fval_b to double - %fres= fdiv double %fval_a_d, %fval_b_d - call void(double)* @push_float(double %fres) - br label %exit_with_success - -exit_with_success: - store i32 0, i32* %func_result - br label %exit - -exit_with_zero: - call void(i8*)* @push(i8* getelementptr inbounds( - [18 x i8]* @err_zero, i64 0, i64 0)) - br label %exit_with_failure - -exit_with_invalid_type: - call void(i8*)* @push(i8* getelementptr inbounds( - [14 x i8]* @err_type, i64 0, i64 0)) - br label %exit_with_failure - -exit_with_failure: - store i32 -1, i32* %func_result - br label %exit - -exit: - %result = load i32* %func_result - ret i32 %result -} - - - -@main.number_a = private unnamed_addr constant [4 x i8] c"-57\00" -@main.number_b = private unnamed_addr constant [4 x i8] c"-58\00" - -define i32 @main_div() { - ; push two numbers on the stack - %number0 = getelementptr [4 x i8]* @main.number_a, i64 0, i64 0 - %number1 = getelementptr [4 x i8]* @main.number_b, i64 0, i64 0 - - call void(i8*)* @push(i8* %number0) - call void(i8*)* @push(i8* %number1) - - call i32 @div() - %result = call i8* @pop() - call i32 (i8*, ...)* @printf(i8* getelementptr inbounds ([13 x i8]* - @popped, i32 0, i32 0), i8* %result) - - ret i32 0 -} - -define i32 @main_equal() { - ; push two numbers on the stack - %number0 = getelementptr [4 x i8]* @main.number_a, i64 0, i64 0 - %number1 = getelementptr [4 x i8]* @main.number_b, i64 0, i64 0 - - call void(i8*)* @push(i8* %number0) - call void(i8*)* @push(i8* %number1) - - call i32 @equal() - %result = call i8* @pop() - call i32 (i8*, ...)* @printf(i8* getelementptr inbounds ([13 x i8]* - @popped, i32 0, i32 0), i8* %result) - - ret i32 0 -} - - -define i8* @peek() { - %sp = load i64* @sp - %top_of_stack = sub i64 %sp, 1 - %addr = getelementptr [1000 x i8*]* @stack, i8 0, i64 %top_of_stack - %val = load i8** %addr - ret i8* %val -} - -define i8* @pop() { - %val = call i8*()* @peek() - %sp = load i64* @sp - %top_of_stack = sub i64 %sp, 1 - store i64 %top_of_stack, i64* @sp - ret i8* %val -} - -; TODO: free alloated space of input strings -define void @strapp() { -entry: - %str2 = call i8*()* @pop() - %str1 = call i8*()* @pop() - - ; compute length of input strings (TODO: maybe isolate strlen function for this purpose) - call void(i8*)* @push(i8* %str1) - call void()* @strlen() - %len_str1 = call i64()* @pop_int() - call void(i8*)* @push(i8* %str2) - call void()* @strlen() - %len_str2 = call i64()* @pop_int() - - ; allocate space for result string - %len_result_1 = add i64 %len_str1, %len_str2 - %len_result_2 = add i64 %len_result_1, 1 - %len_result_3 = trunc i64 %len_result_2 to i16 - %result = call i8* @malloc(i16 %len_result_3) - - ; copy first string - br label %loop1 -loop1: - %i = phi i64 [0, %entry], [ %next_i, %loop1 ] - %next_i = add i64 %i, 1 - %addr = getelementptr i8* %str1, i64 %i - %c = load i8* %addr - %result_addr = getelementptr i8* %result, i64 %i - store i8 %c, i8* %result_addr - %cond = icmp eq i8 %c, 0 - br i1 %cond, label %finished, label %loop1 -finished: - ; copy second string - br label %loop2 -loop2: - %j = phi i64 [0, %finished], [ %next_j, %loop2 ] - %next_j = add i64 %j, 1 - %addr2 = getelementptr i8* %str2, i64 %j - %c2 = load i8* %addr2 - %k = add i64 %j, %len_str1 - %result_addr2 = getelementptr i8* %result, i64 %k - store i8 %c2, i8* %result_addr2 - %cond2 = icmp eq i8 %c2, 0 - br i1 %cond2, label %finished2, label %loop2 -finished2: - call void(i8*)* @push(i8* %result) - ret void -} - -define void @strlen() { -entry: - %str = call i8*()* @pop() - br label %loop -loop: - %i = phi i64 [1, %entry ], [ %next_i, %loop ] - %next_i = add i64 %i, 1 - %addr = getelementptr i8* %str, i64 %i - %c = load i8* %addr - %cond = icmp eq i8 %c, 0 - br i1 %cond, label %finished, label %loop -finished: - call void(i64)* @push_int(i64 %i) - ret void -} - -define void @streq() { -entry: - %str1 = call i8*()* @pop() - %str2 = call i8*()* @pop() - br label %loop -loop: - ; the phi instruction says that coming from the 'entry' label i is 1 - ; otherwise (coming from 'cont') i will be 'next_i' - %i = phi i64 [ 1, %entry ], [ %next_i, %cont ] - - ; the the actual character - %addr1 = getelementptr i8* %str1, i64 %i - %addr2 = getelementptr i8* %str2, i64 %i - %c1 = load i8* %addr1 - %c2 = load i8* %addr2 - - ; if equal, jump to next character otherwise jump to 'fail' - %cond = icmp eq i8 %c1, %c2 - br i1 %cond, label %cont, label %fail - -cont: - %next_i = add i64 %i, 1 - %cond2 = icmp eq i8 %c1, 0 - br i1 %cond2, label %success, label %loop -success: - %t = getelementptr [2 x i8]* @true, i64 0, i64 0 - call void(i8*)* @push(i8* %t) - ret void -fail: - %f = getelementptr [2 x i8]* @false, i64 0, i64 0 - call void(i8*)* @push(i8* %f) - ret void -} - -define i32 @finish(){ - ret i32 0 -} - -;############################################################################## -; equal -;############################################################################## - -define i32 @equal(){ - ; return value of this function - %func_result = alloca i32, align 4 - - %new_elem_a = alloca %struct.stack_elem, align 8 - %new_elem_b = alloca %struct.stack_elem, align 8 - - ; get top - call void @underflow_assert() - %number_a = call i8* @pop() - - ; get top-1 - call void @underflow_assert() - %number_b = call i8* @pop() - - ; get type of number_a - %ret_a = call i32 @get_stack_elem(i8* %number_a, %struct.stack_elem* %new_elem_a) - %is_zero_a = icmp slt i32 %ret_a, 0 - br i1 %is_zero_a, label %exit_with_failure, label %get_type_b - -get_type_b: - ; get type of number_b - %ret_b = call i32 @get_stack_elem(i8* %number_b, %struct.stack_elem* %new_elem_b) - %is_zero_b = icmp slt i32 %ret_b, 0 - br i1 %is_zero_b, label %exit_with_failure, label %type_check_a_int - -type_check_a_int: - ; first, load the new_elem_a.type element. check whether it is 1 (aka INT). - %type_a_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_a, i32 0, i32 0 - %type_a = load i32* %type_a_ptr, align 4 - %is_int_a = icmp eq i32 %type_a, 1 - br i1 %is_int_a, label %type_check_b_int, label %type_check_a_float - -type_check_b_int: - ; first, load the new_elem_b.type element. check whether it is 1 (aka INT). - %type_b_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_b, i32 0, i32 0 - %type_b = load i32* %type_b_ptr, align 4 - %is_int_b = icmp eq i32 %type_b, 1 - br i1 %is_int_b, label %cmp_int, label %type_check_a_float - -cmp_int: - ; get new_elem_a.ival that contains the casted integer value - %ival_a_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_a, i32 0, i32 1 - %ival_a_cast = bitcast %union.anon* %ival_a_ptr to i32* - %ival_a = load i32* %ival_a_cast, align 4 - - ; get new_elem_b.ival that contains the casted integer value - %ival_b_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_b, i32 0, i32 1 - %ival_b_cast = bitcast %union.anon* %ival_b_ptr to i32* - %ival_b = load i32* %ival_b_cast, align 4 - - ; the actual comparison - %equal_int = icmp eq i32 %ival_a, %ival_b - br i1 %equal_int, label %exit_with_true, label %exit_with_false - -type_check_a_float: - %ftype_a_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_a, i32 0, i32 0 - %ftype_a = load i32* %ftype_a_ptr, align 4 - %is_float_a = icmp eq i32 %ftype_a, 2 - br i1 %is_float_a, label %type_check_b_float, label %exit_with_invalid_type - -type_check_b_float: - %ftype_b_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_b, i32 0, i32 0 - %ftype_b = load i32* %ftype_b_ptr, align 4 - %is_float_b = icmp eq i32 %ftype_b, 2 - br i1 %is_float_b, label %cmp_float, label %exit_with_invalid_type - -cmp_float: - ; get new_elem_a.fval that contains the float value - %fval_a_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_a, i32 0, i32 1 - %fval_a_cast = bitcast %union.anon* %fval_a_ptr to float* - %fval_a = load float* %fval_a_cast, align 4 - - ; get new_elem_b.fval that contains the float value - %fval_b_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_b, i32 0, i32 1 - %fval_b_cast = bitcast %union.anon* %fval_b_ptr to float* - %fval_b = load float* %fval_b_cast, align 4 - - ; prevent division by zero - %equal_float = fcmp oeq float %fval_a, %fval_b - br i1 %equal_float, label %exit_with_true, label %exit_with_false - - -exit_with_invalid_type: - call void(i8*)* @push(i8* getelementptr inbounds( - [14 x i8]* @err_type, i64 0, i64 0)) - br label %exit_with_failure - -exit_with_true: - call void(i8*)* @push(i8* getelementptr inbounds( - [2 x i8]* @true, i64 0, i64 0)) - br label %exit_with_success - -exit_with_false: - call void(i8*)* @push(i8* getelementptr inbounds( - [2 x i8]* @false, i64 0, i64 0)) - br label %exit_with_success - -exit_with_failure: - store i32 -1, i32* %func_result - br label %exit - -exit_with_success: - store i32 0, i32* %func_result - br label %exit - -exit: - %result = load i32* %func_result - ret i32 %result - -} - -;############################################################################## -; greater -;############################################################################## - -define i32 @greater(){ - ; return value of this function - %func_result = alloca i32, align 4 - - %new_elem_a = alloca %struct.stack_elem, align 8 - %new_elem_b = alloca %struct.stack_elem, align 8 - - ; get top - call void @underflow_assert() - %number_a = call i8* @pop() - - ; get top-1 - call void @underflow_assert() - %number_b = call i8* @pop() - - ; get type of number_a - %ret_a = call i32 @get_stack_elem(i8* %number_a, %struct.stack_elem* %new_elem_a) - %is_zero_a = icmp slt i32 %ret_a, 0 - br i1 %is_zero_a, label %exit_with_failure, label %get_type_b - -get_type_b: - ; get type of number_b - %ret_b = call i32 @get_stack_elem(i8* %number_b, %struct.stack_elem* %new_elem_b) - %is_zero_b = icmp slt i32 %ret_b, 0 - br i1 %is_zero_b, label %exit_with_failure, label %type_check_a_int - -type_check_a_int: - ; first, load the new_elem_a.type element. check whether it is 1 (aka INT). - %type_a_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_a, i32 0, i32 0 - %type_a = load i32* %type_a_ptr, align 4 - %is_int_a = icmp eq i32 %type_a, 1 - br i1 %is_int_a, label %type_check_b_int, label %type_check_a_float - -type_check_b_int: - ; first, load the new_elem_b.type element. check whether it is 1 (aka INT). - %type_b_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_b, i32 0, i32 0 - %type_b = load i32* %type_b_ptr, align 4 - %is_int_b = icmp eq i32 %type_b, 1 - br i1 %is_int_b, label %cmp_int, label %type_check_a_float - -cmp_int: - ; get new_elem_a.ival that contains the casted integer value - %ival_a_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_a, i32 0, i32 1 - %ival_a_cast = bitcast %union.anon* %ival_a_ptr to i32* - %ival_a = load i32* %ival_a_cast, align 4 - - ; get new_elem_b.ival that contains the casted integer value - %ival_b_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_b, i32 0, i32 1 - %ival_b_cast = bitcast %union.anon* %ival_b_ptr to i32* - %ival_b = load i32* %ival_b_cast, align 4 - - ; the actual comparison - %greater_int = icmp sgt i32 %ival_a, %ival_b - br i1 %greater_int, label %exit_with_true, label %exit_with_false - -type_check_a_float: - %ftype_a_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_a, i32 0, i32 0 - %ftype_a = load i32* %ftype_a_ptr, align 4 - %is_float_a = icmp eq i32 %ftype_a, 2 - br i1 %is_float_a, label %type_check_b_float, label %exit_with_invalid_type - -type_check_b_float: - %ftype_b_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_b, i32 0, i32 0 - %ftype_b = load i32* %ftype_b_ptr, align 4 - %is_float_b = icmp eq i32 %ftype_b, 2 - br i1 %is_float_b, label %cmp_float, label %exit_with_invalid_type - -cmp_float: - ; get new_elem_a.fval that contains the float value - %fval_a_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_a, i32 0, i32 1 - %fval_a_cast = bitcast %union.anon* %fval_a_ptr to float* - %fval_a = load float* %fval_a_cast, align 4 - - ; get new_elem_b.fval that contains the float value - %fval_b_ptr = getelementptr inbounds %struct.stack_elem* %new_elem_b, i32 0, i32 1 - %fval_b_cast = bitcast %union.anon* %fval_b_ptr to float* - %fval_b = load float* %fval_b_cast, align 4 - - ; prevent division by zero - %greater_float = fcmp ogt float %fval_a, %fval_b - br i1 %greater_float, label %exit_with_true, label %exit_with_false - - -exit_with_invalid_type: - call void(i8*)* @push(i8* getelementptr inbounds( - [14 x i8]* @err_type, i64 0, i64 0)) - br label %exit_with_failure - -exit_with_true: - call void(i8*)* @push(i8* getelementptr inbounds( - [2 x i8]* @true, i64 0, i64 0)) - br label %exit_with_success - -exit_with_false: - call void(i8*)* @push(i8* getelementptr inbounds( - [2 x i8]* @false, i64 0, i64 0)) - br label %exit_with_success - -exit_with_failure: - store i32 -1, i32* %func_result - br label %exit - -exit_with_success: - store i32 0, i32* %func_result - br label %exit - -exit: - %result = load i32* %func_result - ret i32 %result - -} - - -; Popping a pointer from the stack into a variable -define void @pop_into(i8** %var_ptr) { - call void @underflow_assert() - %val_ptr = call i8* @pop() - store i8* %val_ptr, i8** %var_ptr - ret void -} - -; Pushing a pointer from a variable onto the stack -define void @push_from(i8** %var_ptr) { - %val = load i8** %var_ptr - call void @push (i8* %val) - ret void -} - -; Function Attrs: nounwind uwtable -; Takes a string, determines the type it is representing and returns the -; corresponding stack element structure. -define i32 @get_stack_elem(i8* %string, %struct.stack_elem* %elem) #0 { - %1 = alloca i32, align 4 - %2 = alloca i8*, align 8 - %3 = alloca %struct.stack_elem*, align 8 - %pEnd = alloca i8*, align 8 - %new_long = alloca i64, align 8 - %new_float = alloca float, align 4 - store i8* %string, i8** %2, align 8 - store %struct.stack_elem* %elem, %struct.stack_elem** %3, align 8 - %4 = load i8** %2, align 8 - %5 = call i64 @strtol(i8* %4, i8** %pEnd, i32 10) #2 - store i64 %5, i64* %new_long, align 8 - %6 = load i8** %pEnd, align 8 - %7 = load i8* %6, align 1 - %8 = sext i8 %7 to i32 - %9 = icmp eq i32 %8, 0 - br i1 %9, label %10, label %18 - -;