298 lines
9.2 KiB
Haskell
298 lines
9.2 KiB
Haskell
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
|
|
Nop -> "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"
|
|
|
|
|
|
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 ]
|