Add basic turnt setup

.kakrc

@@ -1,9 +1,10 @@
-hook -once -group eoc global KakBegin .* %{
+set global makecmd 'cabal build'
-    repl-buffer-new racket -i
+#hook -once -group eoc global KakBegin .* %{
-    repl-buffer-send-text "(require xrepl)
+#    repl-buffer-new racket -i
-"
+#    repl-buffer-send-text "(require xrepl)
-%}
+#"
-
+#%}
-define-command xrepl-enter %{
+#
-    repl-buffer-send-text ",en %val{buffile}"
+#define-command xrepl-enter %{
-}
+#    repl-buffer-send-text ",en %val{buffile}"
+#}

Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

bin/Parse.hs

@@ -0,0 +1,17 @@
+module Main where
+
+import Data.Either (isRight)
+import qualified Data.ByteString.Lazy as B
+import System.Exit
+import Bril
+
+main :: IO ()
+main = do
+    json <- B.getContents
+    let parsed = parseBrilJSON json
+    if isRight parsed
+       then do
+           B.putStr json
+           exitWith ExitSuccess
+        else
+            exitWith (ExitFailure 1)

bril-sources/add.json

@@ -0,0 +1,37 @@
+{
+"functions": [
+    {
+      "instrs": [
+        {
+          "dest": "v0",
+          "op": "const",
+          "type": "int",
+          "value": 1
+        },
+        {
+          "dest": "v1",
+          "op": "const",
+          "type": "int",
+          "value": 2
+        },
+        {
+          "args": [
+            "v0",
+            "v1"
+          ],
+          "dest": "v2",
+          "op": "add",
+          "type": "int"
+        },
+        {
+          "args": [
+            "v2"
+          ],
+          "op": "print"
+        }
+      ],
+      "name": "main"
+    }
+  ]
+}
+

eoc.cabal

@@ -0,0 +1,58 @@
+cabal-version:       2.0
+-- Initial package description 'eoc.cabal' generated by 'cabal init'.  For
+-- further documentation, see http://haskell.org/cabal/users-guide/
+
+name:                eoc
+version:             0.1.0.0
+-- synopsis:
+-- description:
+-- bug-reports:
+-- license:
+license-file:        LICENSE
+author:              Enrico Lumetti
+maintainer:          enrico.lumetti@gmail.com
+-- copyright:
+-- category:
+build-type:          Simple
+extra-source-files:  README.md
+
+library eoc-lib
+    exposed-modules: Eoc, Bril, Bril.CFG
+    hs-source-dirs: lib
+    build-depends:
+        base >=4.13 && <4.18,
+        text >= 2.0,
+        aeson >= 2.2,
+        sorted-list ^>= 0.2,
+        bytestring ^>= 0.11,
+        scientific ^>= 0.3,
+        containers ^>= 0.6.7
+  default-language: Haskell2010
+  default-extensions: DeriveGeneric, OverloadedStrings
+
+executable parse
+  main-is:             bin/Parse.hs
+  -- other-modules:
+  -- other-extensions:
+  build-depends:
+      base >=4.13 && <4.18,
+      bytestring ^>= 0.11,
+      eoc-lib
+  -- hs-source-dirs:
+  default-language:    Haskell2010
+  default-extensions: DeriveGeneric, OverloadedStrings
+
+test-suite tests
+    type: exitcode-stdio-1.0
+    main-is: Main.hs
+    build-depends:
+        base >=4.13 && <4.18,
+        HUnit >=1.6,
+        QuickCheck ^>=2.15,
+        eoc-lib,
+        text >= 2.0,
+        aeson >= 2.2
+    hs-source-dirs: tests
+    default-language: Haskell2010
+    default-extensions: DeriveGeneric, OverloadedStrings
+

lib/Bril.hs

@@ -0,0 +1,297 @@
+module Bril (
+    Function (..), Type (..), Value (..), InstrOperation (..), FunctionArg (..), Program (..),
+    Instruction (..),
+    parseValue,
+    parseBrilFromPath, parseBrilJSON,
+    )where
+
+import Data.Aeson (FromJSON, ToJSON, parseJSON, toJSON, object, withObject, withText, withBool, withScientific, (.:), (.:?), (.=), (.?=), eitherDecode)
+import Data.Aeson.Types (Parser, modifyFailure)
+import qualified Data.Aeson (Value, Object, Key)
+import Data.Aeson.KeyMap
+import Data.Int (Int64)
+import qualified Data.Text as T
+import Data.Text.Read (Reader, signed, decimal)
+import Data.SortedList
+import Data.Maybe (fromMaybe, isJust)
+import Data.Scientific (isInteger, toBoundedInteger)
+
+import qualified Data.ByteString.Lazy as LB
+
+data Program = Program { programFns :: [Function] }
+    deriving (Show, Eq)
+
+type VarName = String
+type FuncName = String
+
+data Function = Function {
+        functionName :: FuncName,
+        returnType :: Maybe Type,
+        functionArgs :: [FunctionArg],
+        instructions :: [Instruction]
+    } deriving (Show, Eq)
+
+data Type = Int | Bool
+    deriving (Show, Eq)
+data Value = IntValue Int64 | BoolValue Bool
+    deriving (Eq, Show)
+
+data FunctionArg = FunctionArg {
+        argName :: VarName,
+        argType :: Type
+    } deriving (Show, Eq)
+
+data Instruction =
+    Label String
+  | LiteralInstr {
+        value :: Value,
+        dest :: VarName
+    }
+  | ValueInstr {
+       op :: InstrOperation,
+       type_ :: Type,
+       dest :: VarName,
+       args :: [VarName],
+       funcs :: [FuncName],
+       labels :: [String]
+     }
+   | EffectInstr {
+        op :: InstrOperation,
+        args :: [VarName],
+        funcs :: [FuncName],
+        labels :: [String]
+     }
+   deriving (Show, Eq)
+
+data InstrOperation =
+    Add | Mul | Sub | Div | Eq | Lt | Gt | Le | Ge | Not | And | Or |
+    Jmp | Br | Call | Ret | Id | Print | Nop | Phi
+   deriving (Eq)
+
+data Arity =
+    Arity Int Int Int -- min, max, labels arity
+  | VarArgs
+   deriving (Eq, Show)
+
+valueOps = toSortedList ([
+        "add", "mul", "sub", "div", "eq", "lt", "gt", "le", "ge", "not", "and", "or", "id"
+    ] :: [T.Text])
+
+effectOps = toSortedList ([
+        "nop", "call", "jmp", "br", "print", "ret"
+    ] :: [T.Text])
+
+arity instr
+    | instr `elem` [Add, Mul, Sub, Div, Eq, Lt, Gt, Le, Ge, And, Or] = Arity 2 2 0
+    | instr `elem` [Id, Not] = Arity 1 1 0
+    | instr == Ret  = Arity 0 1 0
+    | instr == Jmp = Arity 0 0 1
+    | instr == Br = Arity 1 1 2
+    | instr == Nop = Arity 0 0 0
+    | otherwise = VarArgs
+
+checkArity :: InstrOperation -> [b] -> [c] -> Bool
+checkArity instr args labels =
+    case arity instr of
+        Arity n m l ->
+            (((length args) >= n) && ((length args) <= m)) && ((length labels) == l)
+        VarArgs -> True
+
+instrFromString s
+    | s == "add" = Add
+    | s == "sub" = Sub
+    | s == "mul" = Mul
+    | s == "eq" = Eq
+    | s == "lt" = Lt
+    | s == "gt" = Gt
+    | s == "le" = Le
+    | s == "ge" = Ge
+    | s == "not" = Not
+    | s == "and" = And
+    | s == "or" = Or
+    | s == "jmp" = Jmp
+    | s == "br" = Br
+    | s == "ret" = Ret
+    | s == "call" = Call
+    | s == "print" = Print
+    | s == "id" = Id
+    | s == "nop" = Nop
+    | otherwise = error "wrong instruction name"
+
+instance Show InstrOperation where
+    show op = case op of
+        Add   -> "add"
+        Sub   -> "sub"
+        Mul   -> "mul"
+        Eq    -> "eq"
+        Lt    -> "lt"
+        Gt    -> "gt"
+        Le    -> "le"
+        Ge    -> "ge"
+        Not   -> "not"
+        And   -> "and"
+        Or    -> "or"
+        Jmp   -> "jmp"
+        Br    -> "br"
+        Ret   -> "ret"
+        Call  -> "call"
+        Print -> "print"
+        Id    -> "id"
+        Nop   -> "nop"
+
+
+optionalArrayField :: FromJSON a => Data.Aeson.Object -> Data.Aeson.Key -> Parser [a]
+optionalArrayField v field =
+    ((v .:? field) >>= (return . fromMaybe []))
+
+
+instance FromJSON Program  where
+    parseJSON = withObject "Program" $ \v -> Program
+        <$> v .: "functions"
+
+instance FromJSON Function where
+    parseJSON = withObject "Function" $ \v -> Function
+        <$> v .: "name"
+        <*> v .:? "type"
+        <*> v `optionalArrayField` "args"
+        <*> v .: "instrs"
+
+instance FromJSON Instruction where
+    parseJSON = withObject "Instruction" $ \v ->
+        if (Data.Aeson.KeyMap.member "label" v)
+            then Label <$> v .: "label"
+            else do
+                op <- (v .: "op") :: Parser T.Text
+                parseInstr op v
+     where
+        parseInstr op
+            | op == "const" = parseLiteralInstr
+            | op `elemOrd` valueOps = parseValueInstr op
+            | op `elemOrd` effectOps = parseEffectInstr op
+            | otherwise = const $ fail ("Invalid op: " ++ (T.unpack op))
+        parseLiteralInstr v = do
+            type_ <- (v .: "type") :: Parser Type
+            LiteralInstr
+                <$> ((v .: "value") >>= (parseValue type_))
+                <*> v .: "dest"
+        parseValueInstr op v = do
+            dest  <- (v .: "dest") :: Parser VarName
+            args  <- (v `optionalArrayField` "args") :: Parser [VarName]
+            labels  <- (v `optionalArrayField` "labels") :: Parser [VarName]
+            funcs  <- (v `optionalArrayField` "funcs") :: Parser [VarName]
+            let instr = instrFromString op
+            if not (checkArity instr args labels)
+                then fail $ unexpectedArityError op args labels
+                else ValueInstr
+                    <$> return instr
+                    <*> v .: "type"
+                    <*> v .: "dest"
+                    <*> return args
+                    <*> return funcs
+                    <*> return labels
+        parseEffectInstr op v = do
+            args  <- (v `optionalArrayField` "args") :: Parser [VarName]
+            labels  <- (v `optionalArrayField` "labels") :: Parser [VarName]
+            funcs  <- (v `optionalArrayField` "funcs") :: Parser [VarName]
+            dest <- (v .:? "dest") :: Parser (Maybe VarName)
+            if (op == "call") && ((length funcs) /= 1)
+                then fail $ "call op must have exactly one entry in \"funcs\""
+                else if (isJust dest) && (op == "call")
+                    then parseValueInstr op v
+                    else do
+                        let instr = instrFromString op
+                        if not (checkArity instr args labels)
+                            then fail $ unexpectedArityError op args labels
+                            else EffectInstr
+                                <$> return instr
+                                <*> return args
+                                <*> return funcs
+                                <*> return labels
+
+        unexpectedArityError op args labels =
+            "wrong arity for " ++ (T.unpack op) ++ ": got " ++ (show (length args)) ++ ", " ++ (show (length labels))
+
+instance FromJSON FunctionArg where
+    parseJSON = withObject "FunctionArg" $ \v -> FunctionArg
+        <$> v .: "name"
+        <*> v .: "type"
+
+instance FromJSON Type where
+    parseJSON = withText "Type" $ \v ->
+        case v of
+             "int" -> return Int
+             "bool" -> return Bool
+             _ -> fail "wrong type"
+
+parseValue :: Type -> Data.Aeson.Value -> Parser Value
+parseValue Bool =
+    withBool "BoolValue" (return . BoolValue)
+
+parseValue Int =
+    withScientific "IntValue" $ \v ->
+        if (not (isInteger v))
+            then fail $ "Invalid integer literal: " ++ (show v)
+            else do
+                let num = toBoundedInteger v :: Maybe Int64
+                case num of
+                    (Just n) -> return $ IntValue n
+                    _ -> fail $ "Integer exceeds int64: " ++ (show v)
+
+          
+
+parseBrilJSON text = (eitherDecode text :: Either String Program)
+
+parseBrilFromPath path = do
+    contents <- LB.readFile path
+    return $ parseBrilJSON contents
+
+instance ToJSON Type where
+    toJSON Bool = toJSON ("bool" :: T.Text)
+    toJSON Int = toJSON ("int" :: T.Text)
+
+instance ToJSON FunctionArg  where
+    toJSON (FunctionArg argName argType) = object [
+            "name" .= argName,
+            "type" .= argType
+        ]
+
+instance ToJSON Value  where
+    toJSON (IntValue val) = toJSON val
+    toJSON (BoolValue val) = toJSON val
+
+instance ToJSON Instruction where
+    toJSON (Label name) = object [ "label" .= name ]
+    toJSON (LiteralInstr value dest) = object [
+            "op" .= ("const" :: T.Text),
+            "dest" .= dest,
+            "type" .= case value of
+                (IntValue _) -> Int
+                (BoolValue _) -> Bool,
+            "value" .= value
+        ]
+    toJSON (EffectInstr op args funcs labels) = object [
+            "op" .= (show op),
+            "args" .= args,
+            "funcs" .= funcs,
+            "labels" .= labels
+        ]
+    toJSON (ValueInstr op type_ dest args funcs labels) = object [
+            "op" .= (show op),
+            "dest" .= dest,
+            "type" .= type_,
+            "args" .= args,
+            "funcs" .= funcs,
+            "labels" .= labels
+        ]
+
+instance ToJSON Function where
+    toJSON (Function name type_ args instrs) = object $ [
+            "name" .= name,
+            "args" .= args,
+            "instrs" .= instrs
+        ] ++ case type_ of
+            Nothing -> []
+            (Just t) -> ["type" .= t]
+
+instance ToJSON Program where
+    toJSON (Program functions) = object [ "functions" .= functions ]

lib/Bril/CFG.hs

@@ -0,0 +1,85 @@
+module Bril.CFG (BasicBlock, CFG, createCFG) where
+
+import Bril
+import qualified Data.Map.Strict as Map
+
+data BasicBlock = BasicBlock {
+        instrs :: [Instruction],
+        incoming :: [String]
+    }
+   deriving (Show)
+
+data CFG = CFG {
+        cfgBlocks :: Map.Map String BasicBlock,
+        cfgStart :: String
+    }
+   deriving (Show)
+
+createCFG :: [Instruction] -> CFG
+createCFG instrs =
+    let
+        (initCFG, firstLabel) = initializeCFG $ addFallthroughJmp $ splitBBs $ addInitialLabel instrs
+        cfgBlocks' = foldr processBB (cfgBlocks initCFG) (Map.keys (cfgBlocks initCFG))
+    in
+        CFG cfgBlocks' firstLabel
+    where
+        processBB :: String -> Map.Map String BasicBlock -> Map.Map String BasicBlock
+        processBB label m = addBBJumps label (outgoingCFGLabels m label) m
+        addBBJumps :: String -> [String] -> Map.Map String BasicBlock -> Map.Map String BasicBlock
+        addBBJumps bblockLabel incomingLabels m = Map.adjust (addLabels incomingLabels) bblockLabel m
+        addLabels :: [String] -> BasicBlock -> BasicBlock
+        addLabels labels (BasicBlock instrs incoming) = (BasicBlock instrs (incoming ++ labels))
+
+initializeCFG :: [([Instruction], String)] -> (CFG, String)
+initializeCFG instrs =
+    let mappedBlocks = foldr mapBlock Map.empty instrs -- Map.fromList $ map swap instrs
+        firstLabel = snd . head $ instrs
+    in (CFG mappedBlocks firstLabel, firstLabel)
+    where
+        mapBlock (instrs, label) m = Map.insert label (BasicBlock instrs []) m
+
+addFallthroughJmp :: [([Instruction], String)] -> [([Instruction], String)]
+addFallthroughJmp blocks =
+    let blocks' = map addJumpToNextBB $ zip blocks $ tail $ map snd blocks
+    in blocks' ++ [last blocks]
+    where
+        addJumpToNextBB (block@(instrs, label), nextLabel)
+            -- TODO: handle empty instrs
+            | isJump (last instrs) = block
+            | otherwise = (instrs ++ [EffectInstr Jmp [] [] [nextLabel]], label)
+
+splitBBs :: [Instruction] -> [([Instruction], String)]
+splitBBs instrs = zip (tail basicBlocks) labels
+    where
+        (basicBlocks, labels) = foldr splitBBs' ([[]], []) instrs
+        splitBBs' instr (bblocks, labels)
+                | isLabel instr = ([] : bblocks, (labelName instr) : labels)
+                | isJump instr = ([instr] : (tail bblocks) , labels)
+                | otherwise = ((instr : (head bblocks)) : (tail bblocks), labels)
+
+addInitialLabel :: [Instruction] -> [Instruction]
+addInitialLabel instrs@(firstInstr : instrs')
+    | isLabel firstInstr = instrs
+    | otherwise = (Label "@start") : instrs
+addInitialLabel [] = []
+
+labelName (Label name) = name
+isLabel instr = case instr of
+    (Label _) -> True
+    _ -> False
+    
+isJump instr = case instr of
+    (EffectInstr op _ _ _) -> op == Jmp || op == Br
+    _ -> False
+
+outgoingCFGLabels :: Map.Map String BasicBlock -> String -> [String]
+outgoingCFGLabels m label =
+    case Map.lookup label m of
+        Just bb -> outgoingLabels bb
+        _ -> []
+
+outgoingLabels :: BasicBlock -> [String]
+outgoingLabels (BasicBlock instrs _) =
+    let (EffectInstr lastOp _ _ labels) = last instrs
+    in labels
+

lib/Eoc.hs

@@ -0,0 +1,2 @@
+module Eoc where
+

run-tests.sh

@@ -0,0 +1,3 @@
+#!/bin/sh
+
+turnt bril-sources/*.json

tests/Main.hs

@@ -0,0 +1,115 @@
+module Main where
+
+import qualified Bril as B
+import qualified Bril.CFG as BCFG
+import Data.Aeson (eitherDecode, decode, encode, toJSON, parseJSON, Result(..))
+import Data.Aeson.Types (parse)
+import Data.Text
+import Data.Maybe
+import Data.Either
+import Data.Function ((&))
+import Control.Exception (try)
+
+import Test.HUnit
+import qualified Test.QuickCheck as QC
+import qualified System.Exit as Exit
+ 
+testTypes :: Test
+testTypes = TestCase $ do
+    assertEqual "int type" (decode "\"int\"" :: Maybe B.Type) (Just B.Int)
+    assertEqual "bool type" (decode "\"bool\"" :: Maybe B.Type) (Just B.Bool)
+
+testLiterals :: Test
+testLiterals = TestCase $ do
+    assertEqual "true literal"
+        (parseLiteral B.Bool True) (Success $ B.BoolValue True)
+    assertEqual "false literal"
+        (parseLiteral B.Bool False) (Success $ B.BoolValue False)
+
+    assertEqual "int literal"
+        (parseLiteral B.Int (1434 :: Int)) (Success $ B.IntValue 1434)
+    assertEqual "wrong int literal"
+        (parseLiteral B.Int (100000000000000000000 :: Integer))
+        (Error "Integer exceeds int64: 1.0e20")
+    assertEqual "wrong int literal"
+        (parseLiteral B.Int (123.5 :: Double)) (Error "Invalid integer literal: 123.5")
+
+    where
+        parseLiteral type_ x = (parse (B.parseValue type_) (toJSON x))
+
+testInstrs :: Test
+testInstrs = TestCase $ do
+    assertEqual "add instr"
+        (eitherDecode "{\"op\": \"add\", \"type\": \"int\", \"dest\": \"x\", \"args\": [\"a\", \"b\"]}")
+        (Right $ B.ValueInstr B.Add B.Int "x" ["a", "b"] [] [])
+
+    assertEqual "sub instr"
+        (decode "{\"op\": \"sub\", \"type\": \"int\", \"dest\": \"x\", \"args\": [\"a\", \"b\"]}")
+        (Just $ B.ValueInstr B.Sub B.Int "x" ["a", "b"] [] [])
+
+    assertEqual "wrong instr"
+        (eitherDecode "{\"op\": \"wrnog\", \"type\": \"int\", \"dest\": \"x\", \"args\": [\"a\", \"b\"]}")
+        (Left "Error in $: Invalid op: wrnog" :: Either String B.Instruction)
+
+    assertEqual "wrong arity"
+        (eitherDecode "{\"op\": \"add\", \"type\": \"int\", \"dest\": \"x\", \"args\": [\"b\"]}")
+        (Left "Error in $: wrong arity for add: got 1, 0" :: Either String B.Instruction)
+
+    assertEqual "wrong label arity"
+        (eitherDecode "{\"op\": \"add\", \"type\": \"int\", \"dest\": \"x\", \"args\": [\"a\", \"b\"], \"labels\": [\"a\"]}")
+        (Left "Error in $: wrong arity for add: got 2, 1" :: Either String B.Instruction)
+
+    assertEqual "parse effect call"
+        (eitherDecode "{\"op\": \"call\", \"args\": [\"a\", \"b\"], \"funcs\": [\"a\"]}")
+        (Right $ B.EffectInstr B.Call ["a", "b"] ["a"] [])
+
+    assertEqual "parse value call"
+        (eitherDecode "{\"op\": \"call\", \"type\": \"bool\", \"dest\": \"z\", \"args\": [\"a\", \"b\"], \"funcs\": [\"a\"]}")
+        (Right $ B.ValueInstr B.Call B.Bool "z" ["a", "b"] ["a"] [])
+
+    assertEqual "parse invalid call"
+        (eitherDecode "{\"op\": \"call\", \"type\": \"bool\", \"dest\": \"z\", \"args\": [\"a\", \"b\"], \"funcs\": []}")
+        (Left "Error in $: call op must have exactly one entry in \"funcs\"" :: Either String B.Instruction)
+
+    assertEqual "parse jmp"
+        (eitherDecode "{\"op\": \"jmp\", \"labels\": [\"a\"]}")
+        (Right $ B.EffectInstr B.Jmp [] [] ["a"])
+
+    assertEqual "parse br"
+        (eitherDecode "{\"op\": \"br\", \"labels\": [\"a\", \"b\"], \"args\": [\"z\"]}")
+        (Right $ B.EffectInstr B.Br ["z"] [] ["a", "b"])
+
+    assertEqual "parse id"
+        (eitherDecode "{\"op\": \"id\", \"dest\": \"a\", \"type\": \"bool\", \"args\": [\"b\"]}")
+        (Right $ B.ValueInstr B.Id B.Bool "a" ["b"] [] [])
+
+    assertEqual "parse label"
+        (eitherDecode "{\"label\": \"test\"}")
+        (Right $ B.Label "test")
+
+testProgramFromFiles :: Test
+testProgramFromFiles = TestCase $ do
+    res <- try $ (B.parseBrilFromPath "bril-sources/add.json") :: IO (Either IOError (Either String B.Program))
+    case res of
+        (Right parseResult) -> assertBool "parse add.json" $ isRight parseResult
+        _ -> assertFailure "cannot open file"
+
+prop_InvariantBrilSerialization :: B.Program -> Bool
+prop_InvariantBrilSerialization program =
+    (decode (encode program)) == (Just program)
+
+
+tests :: Test
+tests = TestList [
+        TestLabel "bril parser: type" testTypes,
+        TestLabel "bril parser: literal" testLiterals,
+        TestLabel "bril parser: instruction" testInstrs,
+        TestLabel "bril parser: parse files" testProgramFromFiles
+    ]
+ 
+main :: IO ()
+main = do
+    result <- runTestTT tests
+
+    -- QC.quickCheck prop_InvariantBrilSerialization
+    if failures result > 0 then Exit.exitFailure else Exit.exitSuccess

turnt.toml

@@ -0,0 +1 @@
+command = "cabal run -v0 parse < {filename}"