1-- SPDX-FileCopyrightText: 2025-2026 Sören Tempel <soeren+git@soeren-tempel.net>2--3-- SPDX-License-Identifier: GPL-3.0-only45module Parser where67import Data.Map (Map)8import Data.Map qualified as Map9import Language.QBE.Parser (dataDef, funcDef, typeDef)10import Language.QBE.Types11import Test.Tasty12import Test.Tasty.HUnit13import Text.ParserCombinators.Parsec qualified as P1415blkMap :: [Block] -> Map BlockIdent Block16blkMap = Map.fromList . map (\b -> (label b, b))1718------------------------------------------------------------------------1920typeTests :: TestTree21typeTests =22 testGroup23 "Aggregate Type Definition"24 [ testCase "Opaque type with alignment" $25 let v = TypeDef (UserIdent "opaque") (Just 16) (AOpaque 32)26 in parse "type :opaque = align 16 { 32 }" @?= Right v,27 testCase "Regular empty type" $28 let v = TypeDef (UserIdent "empty") Nothing (ARegular [])29 in parse "type :empty = {}" @?= Right v,30 testCase "Regular type with multiple fields" $31 let f = [(SExtType (Base Single), Nothing), (SExtType (Base Single), Nothing)]32 v = TypeDef (UserIdent "twofloats") Nothing (ARegular f)33 in parse "type :twofloats = { s, s }" @?= Right v,34 testCase "Regular type with trailing whitespaces" $35 let f = [(SExtType Byte, Nothing), (SExtType (Base Word), Just 100)]36 v = TypeDef (UserIdent "abyteandmanywords") Nothing (ARegular f)37 in parse "type :abyteandmanywords = { b, w 100 }" @?= Right v,38 testCase "Union type with multiple fields" $39 let f = [[(SExtType Byte, Nothing)], [(SExtType (Base Single), Nothing)]]40 v = TypeDef (UserIdent "un9") Nothing (AUnion f)41 in parse "type :un9 = { { b } { s } }" @?= Right v,42 testCase "Union type with multiple nested fields" $43 let f =44 [ [(SExtType (Base Long), Nothing), (SExtType (Base Single), Nothing)],45 [(SExtType (Base Word), Nothing), (SExtType (Base Long), Nothing)]46 ]47 v = TypeDef (UserIdent "un9") Nothing (AUnion f)48 in parse "type :un9 = { { l, s } { w, l } }" @?= Right v,49 testCase "Type definition with trailing comma" $50 let f = [(SExtType (Base Single), Nothing), (SExtType (Base Single), Nothing)]51 v = TypeDef (UserIdent "twofloats") Nothing (ARegular f)52 in parse "type :twofloats = { s, s, }" @?= Right v53 ]54 where55 parse :: String -> Either P.ParseError TypeDef56 parse = P.parse typeDef ""5758dataTests :: TestTree59dataTests =60 testGroup61 "Data Definition"62 [ testCase "Data definition with zero fill" $63 let v = DataDef [] (GlobalIdent "foo") Nothing [OZeroFill 42]64 in parse "data $foo = { z 42 }" @?= Right v,65 testCase "Data definition with empty value" $66 let v = DataDef [] (GlobalIdent "foo") Nothing []67 in parse "data $foo = {}" @?= Right v,68 testCase "Data definition without optional spaces" $69 let v = DataDef [] (GlobalIdent "foo") Nothing [OZeroFill 42]70 in parse "data $foo={z 42}" @?= Right v,71 testCase "Data definition with newlines as spaces" $72 let v = DataDef [] (GlobalIdent "foo") Nothing [OZeroFill 42]73 in parse "data\n$foo={z\n42}" @?= Right v,74 testCase "Data definition with comments" $75 let v = DataDef [] (GlobalIdent "foo") Nothing [OZeroFill 42]76 in parse "data\n#test\n$foo={z\n#foo\n42}" @?= Right v,77 testCase "Data definition with comments and whitespaces" $78 let v = DataDef [] (GlobalIdent "foo") Nothing [OZeroFill 42]79 in parse "data\n#test1 \n #test2\n$foo={z\n#foo\n42}" @?= Right v,80 testCase "Data definition with linkage" $81 let v = DataDef [LExport] (GlobalIdent "foo") Nothing [OZeroFill 42]82 in parse "export data $foo = { z 42 }" @?= Right v,83 testCase "Data definition with linkage, newlines, and comments" $84 let v = DataDef [LExport, LThread] (GlobalIdent "foo") Nothing [OZeroFill 42]85 in parse "export\nthread\n#foo\ndata $foo = { z 42 }" @?= Right v,86 testCase "Data definition with types" $87 let w = [DConst (Number 23), DConst (Number 42)]88 v = DataDef [] (GlobalIdent "bar") Nothing [OItem (Base Word) w]89 in parse "data $bar = { w 23 42 }" @?= Right v,90 testCase "An object containing two 64-bit fields" $91 let o =92 [ OItem (Base Long) [DConst (Number 0xffffffffffffffff)],93 OItem (Base Long) [DConst (Number 23)]94 ]95 v = DataDef [] (GlobalIdent "c") Nothing o96 in parse "data $c = { l -1, l 23 }" @?= Right v,97 testCase "Data definition with specified alignment and linkage" $98 let v = DataDef [LExport] (GlobalIdent "b") (Just 8) [OZeroFill 1000]99 in parse "export data $b = align 8 { z 1000 }" @?= Right v,100 testCase "Data definition with linkage section and string escape sequences" $101 let v = DataDef [LSection "f\\oo\\\"bar" Nothing] (GlobalIdent "b") (Just 8) [OZeroFill 1]102 in parse "section \"f\\oo\\\"bar\" data $b =align 8 {z 1}" @?= Right v,103 testCase "Data definition with symbol offset" $104 let v = DataDef {linkage = [], name = GlobalIdent "b", align = Just 8, objs = [OItem (Base Long) [DSymOff (GlobalIdent "s") 1]]}105 in parse "data $b = align 8 { l $s + 1 }" @?= Right v,106 testCase "Data definition with symbol offset and without whitespaces" $107 let v = DataDef {linkage = [], name = GlobalIdent "b", align = Just 8, objs = [OItem (Base Long) [DSymOff (GlobalIdent "s") 1]]}108 in parse "data $b = align 8 {l $s+1}" @?= Right v,109 testCase "Data definition with symbol but without offset" $110 let v = DataDef {linkage = [], name = GlobalIdent "b", align = Just 8, objs = [OItem (Base Long) [DConst (Global (GlobalIdent "s"))]]}111 in parse "data $b = align 8 {l $s}" @?= Right v,112 testCase "Data definition with octal character sequence" $113 let v = DataDef {linkage = [], name = GlobalIdent "b", align = Just 1, objs = [OItem Byte [DString "f\too\NUL"]]}114 in parse "data $b = align 1 { b \"f\\011oo\\000\" }" @?= Right v,115 testCase "Data definition with trailing comma" $116 let v = DataDef {linkage = [], name = GlobalIdent "b", align = Just 1, objs = [OItem Byte [DConst (Number 1)], OItem Byte [DConst (Number 2)]]}117 in parse "data $b = align 1 { b 1, b 2,}" @?= Right v118 ]119 where120 parse :: String -> Either P.ParseError DataDef121 parse = P.parse dataDef ""122123funcTests :: TestTree124funcTests =125 testGroup126 "Function Definition"127 [ testCase "Minimal function definition" $128 let p = [Regular (ABase Word) (LocalIdent "argc")]129 b = [Block {label = BlockIdent "start", phi = [], stmt = [], term = Return Nothing}]130 f = FuncDef [] (GlobalIdent "main") (BlockIdent "start") Nothing p $ blkMap b131 in parse "function $main(w %argc) {\n@start\nret\n}" @?= Right f,132 testCase "Function definition with load instruction" $133 let s = [Assign (LocalIdent "v") Word (Load (LBase Word) (VLocal $ LocalIdent "addr"))]134 b = [Block {label = BlockIdent "begin", phi = [], stmt = s, term = Return Nothing}]135 f = FuncDef [] (GlobalIdent "main") (BlockIdent "begin") Nothing [] $ blkMap b136 in parse "function $main() {\n@begin\n%v =w loadw %addr\nret\n}" @?= Right f,137 testCase "Function definition with linkage and return type" $138 let p = [Regular (ABase Long) (LocalIdent "v")]139 b = [Block {label = BlockIdent "start", phi = [], stmt = [], term = Return Nothing}]140 f = FuncDef [LExport, LThread] (GlobalIdent "example") (BlockIdent "start") (Just (ABase Word)) p $ blkMap b141 in parse "export\nthread function w $example(l %v) {\n@start\nret\n}" @?= Right f,142 testCase "Function definition with section linkage" $143 let p = [Regular (ABase Long) (LocalIdent "v")]144 b = [Block {label = BlockIdent "start", phi = [], stmt = [], term = Return Nothing}]145 f = FuncDef [LSection "foo" Nothing] (GlobalIdent "bla") (BlockIdent "start") (Just (ABase Word)) p $ blkMap b146 in parse "section \"foo\"\nfunction w $bla(l %v) {\n@start\nret\n}" @?= Right f,147 testCase "Function definition with subword return type" $148 let b = [Block {label = BlockIdent "here", phi = [], stmt = [], term = Halt}]149 f = FuncDef [] (GlobalIdent "f") (BlockIdent "here") (Just (ASubWordType SignedHalf)) [] $ blkMap b150 in parse "function sh $f() {\n@here\nhlt\n}" @?= Right f,151 testCase "Function definition with comments" $152 let p = [Regular (ABase Long) (LocalIdent "v")]153 b = [Block {label = BlockIdent "start", phi = [], stmt = [], term = Return Nothing}]154 f = FuncDef [LSection "foo" (Just "bar")] (GlobalIdent "bla") (BlockIdent "start") (Just (ABase Word)) p $ blkMap b155 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,156 testCase "Function definition with comparison instruction" $157 let c = CompareInt IWord ISlt (VConst (Const (Number 23))) (VConst (Const (Number 42)))158 b = [Block {label = BlockIdent "start", phi = [], stmt = [Assign (LocalIdent "res") Word c], term = Return Nothing}]159 f = FuncDef [] (GlobalIdent "f") (BlockIdent "start") Nothing [] $ blkMap b160 in parse "function $f() {\n@start\n%res =w csltw 23, 42\nret\n}" @?= Right f,161 testCase "Function definition with extend instruction" $162 let c = Ext ExtSignedWord (VConst (Const (Number 42)))163 b = [Block {label = BlockIdent "start", phi = [], stmt = [Assign (LocalIdent "res") Word c], term = Return Nothing}]164 f = FuncDef [] (GlobalIdent "f") (BlockIdent "start") Nothing [] $ blkMap b165 in parse "function $f() {\n@start\n%res =w extsw 42\nret\n}" @?= Right f,166 testCase "Function definition with fallthrough block" $167 let b1 = Block {label = BlockIdent "b1", phi = [], stmt = [], term = Jump (BlockIdent "b2")}168 b2 = Block {label = BlockIdent "b2", phi = [], stmt = [], term = Return Nothing}169 f = FuncDef [] (GlobalIdent "f") (BlockIdent "b1") Nothing [] $ blkMap [b1, b2]170 in parse "function $f() {\n@b1\n@b2\nret\n}" @?= Right f,171 testCase "Block with phi instrunction" $172 let v1 = VConst (Const (Number 1))173 v2 = VConst (Const (Number 2))174 p1 = Phi (LocalIdent "v") Word $ Map.fromList [(BlockIdent "b1", v1), (BlockIdent "b2", v2)]175 b1 = Block {label = BlockIdent "b1", phi = [], stmt = [], term = Jump (BlockIdent "b2")}176 b2 = Block {label = BlockIdent "b2", phi = [], stmt = [], term = Jump (BlockIdent "b3")}177 b3 = Block {label = BlockIdent "b3", phi = [p1], stmt = [], term = Return Nothing}178 fn = FuncDef [] (GlobalIdent "f") (BlockIdent "b1") Nothing [] $ blkMap [b1, b2, b3]179 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,180 testCase "Call instruction with integer literal value" $181 let c = Call Nothing (VConst (Const $ Global (GlobalIdent "foo"))) [ArgReg (ABase Word) (VConst (Const (Number 42)))]182 b = [Block {label = BlockIdent "s", phi = [], stmt = [c], term = Return Nothing}]183 f = FuncDef [] (GlobalIdent "f") (BlockIdent "s") Nothing [] $ blkMap b184 in parse "function $f() {\n@s\ncall $foo(w 42)\nret\n}" @?= Right f,185 testCase "Unary neg instruction" $186 let i1 = Assign (LocalIdent "r") Word $ Neg (VConst (Const (Number 1)))187 i2 = Assign (LocalIdent "r") Word $ Neg (VLocal $ LocalIdent "r")188 b = Block {label = BlockIdent "s", phi = [], stmt = [i1, i2], term = Halt}189 f = FuncDef [] (GlobalIdent "f") (BlockIdent "s") Nothing [] $ blkMap [b]190 in parse "function $f() {\n@s\n%r =w neg 1\n%r =w neg %r\nhlt\n}" @?= Right f,191 testCase "cast instruction" $192 let c = Assign (LocalIdent "r") Word $ Cast (VLocal $ LocalIdent "f")193 b = Block {label = BlockIdent "s", phi = [], stmt = [c], term = Halt}194 f = FuncDef [] (GlobalIdent "f") (BlockIdent "s") Nothing [Regular (ABase Single) (LocalIdent "f")] $ blkMap [b]195 in parse "function $f(s %f) {\n@s\n%r =w cast %f\nhlt\n}" @?= Right f,196 testCase "trunc instruction" $197 let c = Assign (LocalIdent "r") Single $ TruncDouble (VLocal $ LocalIdent "d")198 b = Block {label = BlockIdent "s", phi = [], stmt = [c], term = Halt}199 f = FuncDef [] (GlobalIdent "f") (BlockIdent "s") Nothing [Regular (ABase Double) (LocalIdent "d")] $ blkMap [b]200 in parse "function $f(d %d) {\n@s\n%r =s truncd %d\nhlt\n}" @?= Right f,201 testCase "exts instruction" $202 let c = Assign (LocalIdent "d") Double $ Ext ExtSingle (VLocal $ LocalIdent "s")203 b = Block {label = BlockIdent "s", phi = [], stmt = [c], term = Halt}204 f = FuncDef [] (GlobalIdent "f") (BlockIdent "s") Nothing [Regular (ABase Single) (LocalIdent "s")] $ blkMap [b]205 in parse "function $f(s %s) {\n@s\n%d =d exts %s\nhlt\n}" @?= Right f,206 testCase "float literals" $207 let c = Assign (LocalIdent "f.1") Single (Copy $ VConst (Const $ SFP 2.0))208 b = Block {label = BlockIdent "start", phi = [], stmt = [c, c, c, c], term = Halt}209 f = FuncDef [] (GlobalIdent "f") (BlockIdent "start") Nothing [] $ blkMap [b]210 in parse211 "function $f() { \n\212 \@start\n\213 \%f.1 =s copy s_2\n\214 \%f.1 =s copy s_2.\n\215 \%f.1 =s copy s_2.0\n\216 \%f.1 =s copy s_2.000000\n\217 \hlt\n\218 \}"219 @?= Right f,220 testCase "float to int conversions" $221 let c1 = Assign (LocalIdent "w.1") Word (FloatToInt FSingle True (VLocal $ LocalIdent "s"))222 c2 = Assign (LocalIdent "w.2") Word (FloatToInt FSingle False (VLocal $ LocalIdent "s"))223 c3 = Assign (LocalIdent "w.3") Word (FloatToInt FDouble True (VLocal $ LocalIdent "d"))224 c4 = Assign (LocalIdent "w.4") Word (FloatToInt FDouble False (VLocal $ LocalIdent "d"))225 b = Block {label = BlockIdent "start", phi = [], stmt = [c1, c2, c3, c4], term = Halt}226 f = FuncDef [] (GlobalIdent "f") (BlockIdent "start") Nothing [Regular (ABase Single) (LocalIdent "s"), Regular (ABase Double) (LocalIdent "d")] $ blkMap [b]227 in parse228 "function $f(s %s, d %d) { \n\229 \@start\n\230 \%w.1 =w stosi %s\n\231 \%w.2 =w stoui %s\n\232 \%w.3 =w dtosi %d\n\233 \%w.4 =w dtoui %d\n\234 \hlt\n\235 \}"236 @?= Right f,237 testCase "int to float conversions" $238 let c1 = Assign (LocalIdent "f.1") Single (IntToFloat IWord True (VLocal $ LocalIdent "w"))239 c2 = Assign (LocalIdent "f.2") Single (IntToFloat IWord False (VLocal $ LocalIdent "w"))240 c3 = Assign (LocalIdent "f.3") Double (IntToFloat ILong True (VLocal $ LocalIdent "l"))241 c4 = Assign (LocalIdent "f.4") Double (IntToFloat ILong False (VLocal $ LocalIdent "l"))242 b = Block {label = BlockIdent "start", phi = [], stmt = [c1, c2, c3, c4], term = Halt}243 f = FuncDef [] (GlobalIdent "f") (BlockIdent "start") Nothing [Regular (ABase Word) (LocalIdent "w"), Regular (ABase Long) (LocalIdent "l")] $ blkMap [b]244 in parse245 "function $f(w %w, l %l) { \n\246 \@start\n\247 \%f.1 =s swtof %w\n\248 \%f.2 =s uwtof %w\n\249 \%f.3 =d sltof %l\n\250 \%f.4 =d ultof %l\n\251 \hlt\n\252 \}"253 @?= Right f,254 testCase "floating point comparision" $255 let c1 = Assign (LocalIdent "w.1") Word $ CompareFloat FDouble FOrd (VLocal $ LocalIdent "lhs") (VLocal $ LocalIdent "rhs")256 c2 = Assign (LocalIdent "w.2") Word $ CompareFloat FSingle FOrd (VLocal $ LocalIdent "lhs") (VLocal $ LocalIdent "rhs")257 c3 = Assign (LocalIdent "w.3") Word $ CompareFloat FDouble FLe (VLocal $ LocalIdent "lhs") (VLocal $ LocalIdent "rhs")258 c4 = Assign (LocalIdent "w.4") Word $ CompareFloat FDouble FLt (VLocal $ LocalIdent "lhs") (VLocal $ LocalIdent "rhs")259 c5 = Assign (LocalIdent "w.5") Word $ CompareFloat FDouble FGe (VLocal $ LocalIdent "lhs") (VLocal $ LocalIdent "rhs")260 c6 = Assign (LocalIdent "w.6") Word $ CompareFloat FDouble FGt (VLocal $ LocalIdent "lhs") (VLocal $ LocalIdent "rhs")261 b = Block {label = BlockIdent "start", phi = [], stmt = [c1, c2, c3, c4, c5, c6], term = Halt}262 f = FuncDef [] (GlobalIdent "f") (BlockIdent "start") Nothing [Regular (ABase Double) (LocalIdent "lhs"), Regular (ABase Double) (LocalIdent "rhs")] $ blkMap [b]263 in parse264 "function $f(d %lhs, d %rhs) { \n\265 \@start\n\266 \%w.1 =w cod %lhs, %rhs\n\267 \%w.2 =w cos %lhs, %rhs\n\268 \%w.3 =w cled %lhs, %rhs\n\269 \%w.4 =w cltd %lhs, %rhs\n\270 \%w.5 =w cged %lhs, %rhs\n\271 \%w.6 =w cgtd %lhs, %rhs\n\272 \hlt\n\273 \}"274 @?= Right f,275 testCase "variadic function" $276 let c0 = Volatile (VAStart $ VLocal (LocalIdent "ap"))277 c1 = Assign (LocalIdent ".1") Word $ VAArg (VLocal $ LocalIdent "ap")278 b = Block {label = BlockIdent "start", phi = [], stmt = [c0, c1], term = Halt}279 f = FuncDef [] (GlobalIdent "f") (BlockIdent "start") Nothing [Regular (ABase Word) (LocalIdent "w"), Variadic] $ blkMap [b]280 in parse281 "function $f(w %w, ...) { \n\282 \@start\n\283 \vastart %ap\n\284 \%.1 =w vaarg %ap\n\285 \hlt\n\286 \}"287 @?= Right f,288 testCase "debug information" $289 let s1 = Volatile (DBGLoc 1 2 Nothing)290 s2 = Volatile (DBGLoc 23 42 $ Just 1337)291 b = Block {label = BlockIdent "start", phi = [], stmt = [s1, s2], term = Halt}292 f = FuncDef [] (GlobalIdent "main") (BlockIdent "start") Nothing [] $ blkMap [b]293 in parse294 "function $main() { \n\295 \@start\n\296 \dbgloc 1, 2\n\297 \dbgloc 23, 42, 1337\n\298 \hlt\n\299 \}"300 @?= Right f301 ]302 where303 parse :: String -> Either P.ParseError FuncDef304 parse = P.parse funcDef ""305306mkParser :: TestTree307mkParser =308 testGroup309 "Tests for the QBE parser"310 [typeTests, dataTests, funcTests]