-- SPDX-FileCopyrightText: 2025-2026 Sören Tempel <soeren+git@soeren-tempel.net>
--
-- SPDX-License-Identifier: GPL-3.0-only
module Parser where
import Data.Map (Map)
import Data.Map qualified as Map
import Language.QBE.Parser (dataDef, funcDef, typeDef)
import Language.QBE.Types
import Test.Tasty
import Test.Tasty.HUnit
import Text.ParserCombinators.Parsec qualified as P
blkMap :: [Block] -> Map BlockIdent Block
blkMap = Map.fromList . map (\b -> (label b, b))
------------------------------------------------------------------------
typeTests :: TestTree
typeTests =
testGroup
"Aggregate Type Definition"
[ testCase "Opaque type with alignment" $
let v = TypeDef (UserIdent "opaque") (Just 16) (AOpaque 32)
in parse "type :opaque = align 16 { 32 }" @?= Right v,
testCase "Regular empty type" $
let v = TypeDef (UserIdent "empty") Nothing (ARegular [])
in parse "type :empty = {}" @?= Right v,
testCase "Regular type with multiple fields" $
let f = [(SExtType (Base Single), Nothing), (SExtType (Base Single), Nothing)]
v = TypeDef (UserIdent "twofloats") Nothing (ARegular f)
in parse "type :twofloats = { s, s }" @?= Right v,
testCase "Regular type with trailing whitespaces" $
let f = [(SExtType Byte, Nothing), (SExtType (Base Word), Just 100)]
v = TypeDef (UserIdent "abyteandmanywords") Nothing (ARegular f)
in parse "type :abyteandmanywords = { b, w 100 }" @?= Right v,
testCase "Union type with multiple fields" $
let f = [[(SExtType Byte, Nothing)], [(SExtType (Base Single), Nothing)]]
v = TypeDef (UserIdent "un9") Nothing (AUnion f)
in parse "type :un9 = { { b } { s } }" @?= Right v,
testCase "Union type with multiple nested fields" $
let f =
[ [(SExtType (Base Long), Nothing), (SExtType (Base Single), Nothing)],
[(SExtType (Base Word), Nothing), (SExtType (Base Long), Nothing)]
]
v = TypeDef (UserIdent "un9") Nothing (AUnion f)
in parse "type :un9 = { { l, s } { w, l } }" @?= Right v,
testCase "Type definition with trailing comma" $
let f = [(SExtType (Base Single), Nothing), (SExtType (Base Single), Nothing)]
v = TypeDef (UserIdent "twofloats") Nothing (ARegular f)
in parse "type :twofloats = { s, s, }" @?= Right v
]
where
parse :: String -> Either P.ParseError TypeDef
parse = P.parse typeDef ""
dataTests :: TestTree
dataTests =
testGroup
"Data Definition"
[ testCase "Data definition with zero fill" $
let v = DataDef [] (GlobalIdent "foo") Nothing [OZeroFill 42]
in parse "data $foo = { z 42 }" @?= Right v,
testCase "Data definition with empty value" $
let v = DataDef [] (GlobalIdent "foo") Nothing []
in parse "data $foo = {}" @?= Right v,
testCase "Data definition without optional spaces" $
let v = DataDef [] (GlobalIdent "foo") Nothing [OZeroFill 42]
in parse "data $foo={z 42}" @?= Right v,
testCase "Data definition with newlines as spaces" $
let v = DataDef [] (GlobalIdent "foo") Nothing [OZeroFill 42]
in parse "data\n$foo={z\n42}" @?= Right v,
testCase "Data definition with comments" $
let v = DataDef [] (GlobalIdent "foo") Nothing [OZeroFill 42]
in parse "data\n#test\n$foo={z\n#foo\n42}" @?= Right v,
testCase "Data definition with comments and whitespaces" $
let v = DataDef [] (GlobalIdent "foo") Nothing [OZeroFill 42]
in parse "data\n#test1 \n #test2\n$foo={z\n#foo\n42}" @?= Right v,
testCase "Data definition with linkage" $
let v = DataDef [LExport] (GlobalIdent "foo") Nothing [OZeroFill 42]
in parse "export data $foo = { z 42 }" @?= Right v,
testCase "Data definition with linkage, newlines, and comments" $
let v = DataDef [LExport, LThread] (GlobalIdent "foo") Nothing [OZeroFill 42]
in parse "export\nthread\n#foo\ndata $foo = { z 42 }" @?= Right v,
testCase "Data definition with types" $
let w = [DConst (Number 23), DConst (Number 42)]
v = DataDef [] (GlobalIdent "bar") Nothing [OItem (Base Word) w]
in parse "data $bar = { w 23 42 }" @?= Right v,
testCase "An object containing two 64-bit fields" $
let o =
[ OItem (Base Long) [DConst (Number 0xffffffffffffffff)],
OItem (Base Long) [DConst (Number 23)]
]
v = DataDef [] (GlobalIdent "c") Nothing o
in parse "data $c = { l -1, l 23 }" @?= Right v,
testCase "Data definition with specified alignment and linkage" $
let v = DataDef [LExport] (GlobalIdent "b") (Just 8) [OZeroFill 1000]
in parse "export data $b = align 8 { z 1000 }" @?= Right v,
testCase "Data definition with linkage section and string escape sequences" $
let v = DataDef [LSection "f\\oo\\\"bar" Nothing] (GlobalIdent "b") (Just 8) [OZeroFill 1]
in parse "section \"f\\oo\\\"bar\" data $b =align 8 {z 1}" @?= Right v,
testCase "Data definition with symbol offset" $
let v = DataDef {linkage = [], name = GlobalIdent "b", align = Just 8, objs = [OItem (Base Long) [DSymOff (GlobalIdent "s") 1]]}
in parse "data $b = align 8 { l $s + 1 }" @?= Right v,
testCase "Data definition with symbol offset and without whitespaces" $
let v = DataDef {linkage = [], name = GlobalIdent "b", align = Just 8, objs = [OItem (Base Long) [DSymOff (GlobalIdent "s") 1]]}
in parse "data $b = align 8 {l $s+1}" @?= Right v,
testCase "Data definition with symbol but without offset" $
let v = DataDef {linkage = [], name = GlobalIdent "b", align = Just 8, objs = [OItem (Base Long) [DConst (Global (GlobalIdent "s"))]]}
in parse "data $b = align 8 {l $s}" @?= Right v,
testCase "Data definition with octal character sequence" $
let v = DataDef {linkage = [], name = GlobalIdent "b", align = Just 1, objs = [OItem Byte [DString "f\too\NUL"]]}
in parse "data $b = align 1 { b \"f\\011oo\\000\" }" @?= Right v,
testCase "Data definition with trailing comma" $
let v = DataDef {linkage = [], name = GlobalIdent "b", align = Just 1, objs = [OItem Byte [DConst (Number 1)], OItem Byte [DConst (Number 2)]]}
in parse "data $b = align 1 { b 1, b 2,}" @?= Right v
]
where
parse :: String -> Either P.ParseError DataDef
parse = P.parse dataDef ""
funcTests :: TestTree
funcTests =
testGroup
"Function Definition"
[ testCase "Minimal function definition" $
let p = [Regular (ABase Word) (LocalIdent "argc")]
b = [Block {label = BlockIdent "start", phi = [], stmt = [], term = Return Nothing}]
f = FuncDef [] (GlobalIdent "main") (BlockIdent "start") Nothing p $ blkMap b
in parse "function $main(w %argc) {\n@start\nret\n}" @?= Right f,
testCase "Function definition with load instruction" $
let s = [Assign (LocalIdent "v") Word (Load (LBase Word) (VLocal $ LocalIdent "addr"))]
b = [Block {label = BlockIdent "begin", phi = [], stmt = s, term = Return Nothing}]
f = FuncDef [] (GlobalIdent "main") (BlockIdent "begin") Nothing [] $ blkMap b
in parse "function $main() {\n@begin\n%v =w loadw %addr\nret\n}" @?= Right f,
testCase "Function definition with linkage and return type" $
let p = [Regular (ABase Long) (LocalIdent "v")]
b = [Block {label = BlockIdent "start", phi = [], stmt = [], term = Return Nothing}]
f = FuncDef [LExport, LThread] (GlobalIdent "example") (BlockIdent "start") (Just (ABase Word)) p $ blkMap b
in parse "export\nthread function w $example(l %v) {\n@start\nret\n}" @?= Right f,
testCase "Function definition with section linkage" $
let p = [Regular (ABase Long) (LocalIdent "v")]
b = [Block {label = BlockIdent "start", phi = [], stmt = [], term = Return Nothing}]
f = FuncDef [LSection "foo" Nothing] (GlobalIdent "bla") (BlockIdent "start") (Just (ABase Word)) p $ blkMap b
in parse "section \"foo\"\nfunction w $bla(l %v) {\n@start\nret\n}" @?= Right f,
testCase "Function definition with subword return type" $
let b = [Block {label = BlockIdent "here", phi = [], stmt = [], term = Halt}]
f = FuncDef [] (GlobalIdent "f") (BlockIdent "here") (Just (ASubWordType SignedHalf)) [] $ blkMap b
in parse "function sh $f() {\n@here\nhlt\n}" @?= Right f,
testCase "Function definition with comments" $
let p = [Regular (ABase Long) (LocalIdent "v")]
b = [Block {label = BlockIdent "start", phi = [], stmt = [], term = Return Nothing}]
f = FuncDef [LSection "foo" (Just "bar")] (GlobalIdent "bla") (BlockIdent "start") (Just (ABase Word)) p $ blkMap b
in parse "section \"foo\" \"bar\"\n#test\nfunction w $bla(l %v) {\n#foo\n@start\n# bar \nret\n#bllubbb\n#bllaaa\n}" @?= Right f,
testCase "Function definition with comparison instruction" $
let c = CompareInt IWord ISlt (VConst (Const (Number 23))) (VConst (Const (Number 42)))
b = [Block {label = BlockIdent "start", phi = [], stmt = [Assign (LocalIdent "res") Word c], term = Return Nothing}]
f = FuncDef [] (GlobalIdent "f") (BlockIdent "start") Nothing [] $ blkMap b
in parse "function $f() {\n@start\n%res =w csltw 23, 42\nret\n}" @?= Right f,
testCase "Function definition with extend instruction" $
let c = Ext ExtSignedWord (VConst (Const (Number 42)))
b = [Block {label = BlockIdent "start", phi = [], stmt = [Assign (LocalIdent "res") Word c], term = Return Nothing}]
f = FuncDef [] (GlobalIdent "f") (BlockIdent "start") Nothing [] $ blkMap b
in parse "function $f() {\n@start\n%res =w extsw 42\nret\n}" @?= Right f,
testCase "Function definition with fallthrough block" $
let b1 = Block {label = BlockIdent "b1", phi = [], stmt = [], term = Jump (BlockIdent "b2")}
b2 = Block {label = BlockIdent "b2", phi = [], stmt = [], term = Return Nothing}
f = FuncDef [] (GlobalIdent "f") (BlockIdent "b1") Nothing [] $ blkMap [b1, b2]
in parse "function $f() {\n@b1\n@b2\nret\n}" @?= Right f,
testCase "Block with phi instrunction" $
let v1 = VConst (Const (Number 1))
v2 = VConst (Const (Number 2))
p1 = Phi (LocalIdent "v") Word $ Map.fromList [(BlockIdent "b1", v1), (BlockIdent "b2", v2)]
b1 = Block {label = BlockIdent "b1", phi = [], stmt = [], term = Jump (BlockIdent "b2")}
b2 = Block {label = BlockIdent "b2", phi = [], stmt = [], term = Jump (BlockIdent "b3")}
b3 = Block {label = BlockIdent "b3", phi = [p1], stmt = [], term = Return Nothing}
fn = FuncDef [] (GlobalIdent "f") (BlockIdent "b1") Nothing [] $ blkMap [b1, b2, b3]
in parse "function $f() {\n@b1\njmp @b2\n@b2\njmp @b3\n@b3\n%v =w phi @b1 1, @b2 2\nret\n}" @?= Right fn,
testCase "Call instruction with integer literal value" $
let c = Call Nothing (VConst (Const $ Global (GlobalIdent "foo"))) [ArgReg (ABase Word) (VConst (Const (Number 42)))]
b = [Block {label = BlockIdent "s", phi = [], stmt = [c], term = Return Nothing}]
f = FuncDef [] (GlobalIdent "f") (BlockIdent "s") Nothing [] $ blkMap b
in parse "function $f() {\n@s\ncall $foo(w 42)\nret\n}" @?= Right f,
testCase "Unary neg instruction" $
let i1 = Assign (LocalIdent "r") Word $ Neg (VConst (Const (Number 1)))
i2 = Assign (LocalIdent "r") Word $ Neg (VLocal $ LocalIdent "r")
b = Block {label = BlockIdent "s", phi = [], stmt = [i1, i2], term = Halt}
f = FuncDef [] (GlobalIdent "f") (BlockIdent "s") Nothing [] $ blkMap [b]
in parse "function $f() {\n@s\n%r =w neg 1\n%r =w neg %r\nhlt\n}" @?= Right f,
testCase "cast instruction" $
let c = Assign (LocalIdent "r") Word $ Cast (VLocal $ LocalIdent "f")
b = Block {label = BlockIdent "s", phi = [], stmt = [c], term = Halt}
f = FuncDef [] (GlobalIdent "f") (BlockIdent "s") Nothing [Regular (ABase Single) (LocalIdent "f")] $ blkMap [b]
in parse "function $f(s %f) {\n@s\n%r =w cast %f\nhlt\n}" @?= Right f,
testCase "trunc instruction" $
let c = Assign (LocalIdent "r") Single $ TruncDouble (VLocal $ LocalIdent "d")
b = Block {label = BlockIdent "s", phi = [], stmt = [c], term = Halt}
f = FuncDef [] (GlobalIdent "f") (BlockIdent "s") Nothing [Regular (ABase Double) (LocalIdent "d")] $ blkMap [b]
in parse "function $f(d %d) {\n@s\n%r =s truncd %d\nhlt\n}" @?= Right f,
testCase "exts instruction" $
let c = Assign (LocalIdent "d") Double $ Ext ExtSingle (VLocal $ LocalIdent "s")
b = Block {label = BlockIdent "s", phi = [], stmt = [c], term = Halt}
f = FuncDef [] (GlobalIdent "f") (BlockIdent "s") Nothing [Regular (ABase Single) (LocalIdent "s")] $ blkMap [b]
in parse "function $f(s %s) {\n@s\n%d =d exts %s\nhlt\n}" @?= Right f,
testCase "float literals" $
let c = Assign (LocalIdent "f.1") Single (Copy $ VConst (Const $ SFP 2.0))
b = Block {label = BlockIdent "start", phi = [], stmt = [c, c, c, c], term = Halt}
f = FuncDef [] (GlobalIdent "f") (BlockIdent "start") Nothing [] $ blkMap [b]
in parse
"function $f() { \n\
\@start\n\
\%f.1 =s copy s_2\n\
\%f.1 =s copy s_2.\n\
\%f.1 =s copy s_2.0\n\
\%f.1 =s copy s_2.000000\n\
\hlt\n\
\}"
@?= Right f,
testCase "float to int conversions" $
let c1 = Assign (LocalIdent "w.1") Word (FloatToInt FSingle True (VLocal $ LocalIdent "s"))
c2 = Assign (LocalIdent "w.2") Word (FloatToInt FSingle False (VLocal $ LocalIdent "s"))
c3 = Assign (LocalIdent "w.3") Word (FloatToInt FDouble True (VLocal $ LocalIdent "d"))
c4 = Assign (LocalIdent "w.4") Word (FloatToInt FDouble False (VLocal $ LocalIdent "d"))
b = Block {label = BlockIdent "start", phi = [], stmt = [c1, c2, c3, c4], term = Halt}
f = FuncDef [] (GlobalIdent "f") (BlockIdent "start") Nothing [Regular (ABase Single) (LocalIdent "s"), Regular (ABase Double) (LocalIdent "d")] $ blkMap [b]
in parse
"function $f(s %s, d %d) { \n\
\@start\n\
\%w.1 =w stosi %s\n\
\%w.2 =w stoui %s\n\
\%w.3 =w dtosi %d\n\
\%w.4 =w dtoui %d\n\
\hlt\n\
\}"
@?= Right f,
testCase "int to float conversions" $
let c1 = Assign (LocalIdent "f.1") Single (IntToFloat IWord True (VLocal $ LocalIdent "w"))
c2 = Assign (LocalIdent "f.2") Single (IntToFloat IWord False (VLocal $ LocalIdent "w"))
c3 = Assign (LocalIdent "f.3") Double (IntToFloat ILong True (VLocal $ LocalIdent "l"))
c4 = Assign (LocalIdent "f.4") Double (IntToFloat ILong False (VLocal $ LocalIdent "l"))
b = Block {label = BlockIdent "start", phi = [], stmt = [c1, c2, c3, c4], term = Halt}
f = FuncDef [] (GlobalIdent "f") (BlockIdent "start") Nothing [Regular (ABase Word) (LocalIdent "w"), Regular (ABase Long) (LocalIdent "l")] $ blkMap [b]
in parse
"function $f(w %w, l %l) { \n\
\@start\n\
\%f.1 =s swtof %w\n\
\%f.2 =s uwtof %w\n\
\%f.3 =d sltof %l\n\
\%f.4 =d ultof %l\n\
\hlt\n\
\}"
@?= Right f,
testCase "floating point comparision" $
let c1 = Assign (LocalIdent "w.1") Word $ CompareFloat FDouble FOrd (VLocal $ LocalIdent "lhs") (VLocal $ LocalIdent "rhs")
c2 = Assign (LocalIdent "w.2") Word $ CompareFloat FSingle FOrd (VLocal $ LocalIdent "lhs") (VLocal $ LocalIdent "rhs")
c3 = Assign (LocalIdent "w.3") Word $ CompareFloat FDouble FLe (VLocal $ LocalIdent "lhs") (VLocal $ LocalIdent "rhs")
c4 = Assign (LocalIdent "w.4") Word $ CompareFloat FDouble FLt (VLocal $ LocalIdent "lhs") (VLocal $ LocalIdent "rhs")
c5 = Assign (LocalIdent "w.5") Word $ CompareFloat FDouble FGe (VLocal $ LocalIdent "lhs") (VLocal $ LocalIdent "rhs")
c6 = Assign (LocalIdent "w.6") Word $ CompareFloat FDouble FGt (VLocal $ LocalIdent "lhs") (VLocal $ LocalIdent "rhs")
b = Block {label = BlockIdent "start", phi = [], stmt = [c1, c2, c3, c4, c5, c6], term = Halt}
f = FuncDef [] (GlobalIdent "f") (BlockIdent "start") Nothing [Regular (ABase Double) (LocalIdent "lhs"), Regular (ABase Double) (LocalIdent "rhs")] $ blkMap [b]
in parse
"function $f(d %lhs, d %rhs) { \n\
\@start\n\
\%w.1 =w cod %lhs, %rhs\n\
\%w.2 =w cos %lhs, %rhs\n\
\%w.3 =w cled %lhs, %rhs\n\
\%w.4 =w cltd %lhs, %rhs\n\
\%w.5 =w cged %lhs, %rhs\n\
\%w.6 =w cgtd %lhs, %rhs\n\
\hlt\n\
\}"
@?= Right f,
testCase "variadic function" $
let c0 = Volatile (VAStart $ VLocal (LocalIdent "ap"))
c1 = Assign (LocalIdent ".1") Word $ VAArg (VLocal $ LocalIdent "ap")
b = Block {label = BlockIdent "start", phi = [], stmt = [c0, c1], term = Halt}
f = FuncDef [] (GlobalIdent "f") (BlockIdent "start") Nothing [Regular (ABase Word) (LocalIdent "w"), Variadic] $ blkMap [b]
in parse
"function $f(w %w, ...) { \n\
\@start\n\
\vastart %ap\n\
\%.1 =w vaarg %ap\n\
\hlt\n\
\}"
@?= Right f,
testCase "debug information" $
let s1 = Volatile (DBGLoc 1 2 Nothing)
s2 = Volatile (DBGLoc 23 42 $ Just 1337)
b = Block {label = BlockIdent "start", phi = [], stmt = [s1, s2], term = Halt}
f = FuncDef [] (GlobalIdent "main") (BlockIdent "start") Nothing [] $ blkMap [b]
in parse
"function $main() { \n\
\@start\n\
\dbgloc 1, 2\n\
\dbgloc 23, 42, 1337\n\
\hlt\n\
\}"
@?= Right f
]
where
parse :: String -> Either P.ParseError FuncDef
parse = P.parse funcDef ""
mkParser :: TestTree
mkParser =
testGroup
"Tests for the QBE parser"
[typeTests, dataTests, funcTests]