1-- SPDX-FileCopyrightText: 2025 Sören Tempel <soeren+git@soeren-tempel.net>2--3-- SPDX-License-Identifier: GPL-3.0-only45module Parser where67import qualified Data.Map as Map8import Language.QBE.Parser (dataDef, funcDef, typeDef)9import Language.QBE.Types10import Test.Tasty11import Test.Tasty.HUnit12import qualified Text.ParserCombinators.Parsec as P1314typeTests :: TestTree15typeTests =16 testGroup17 "Aggregate Type Definition"18 [ testCase "Opaque type with alignment" $19 let v = TypeDef (UserIdent "opaque") (Just 16) (AOpaque 32)20 in parse "type :opaque = align 16 { 32 }" @?= Right v,21 testCase "Regular empty type" $22 let v = TypeDef (UserIdent "empty") Nothing (ARegular [])23 in parse "type :empty = {}" @?= Right v,24 testCase "Regular type with multiple fields" $25 let f = [(SExtType (Base Single), Nothing), (SExtType (Base Single), Nothing)]26 v = TypeDef (UserIdent "twofloats") Nothing (ARegular f)27 in parse "type :twofloats = { s, s }" @?= Right v,28 testCase "Regular type with trailing whitespaces" $29 let f = [(SExtType Byte, Nothing), (SExtType (Base Word), Just 100)]30 v = TypeDef (UserIdent "abyteandmanywords") Nothing (ARegular f)31 in parse "type :abyteandmanywords = { b, w 100 }" @?= Right v,32 testCase "Union type with multiple fields" $33 let f = [[(SExtType Byte, Nothing)], [(SExtType (Base Single), Nothing)]]34 v = TypeDef (UserIdent "un9") Nothing (AUnion f)35 in parse "type :un9 = { { b } { s } }" @?= Right v,36 testCase "Union type with multiple nested fields" $37 let f =38 [ [(SExtType (Base Long), Nothing), (SExtType (Base Single), Nothing)],39 [(SExtType (Base Word), Nothing), (SExtType (Base Long), Nothing)]40 ]41 v = TypeDef (UserIdent "un9") Nothing (AUnion f)42 in parse "type :un9 = { { l, s } { w, l } }" @?= Right v,43 testCase "Type definition with trailing comma" $44 let f = [(SExtType (Base Single), Nothing), (SExtType (Base Single), Nothing)]45 v = TypeDef (UserIdent "twofloats") Nothing (ARegular f)46 in parse "type :twofloats = { s, s, }" @?= Right v47 ]48 where49 parse :: String -> Either P.ParseError TypeDef50 parse = P.parse typeDef ""5152dataTests :: TestTree53dataTests =54 testGroup55 "Data Definition"56 [ testCase "Data definition with zero fill" $57 let v = DataDef [] (GlobalIdent "foo") Nothing [OZeroFill 42]58 in parse "data $foo = { z 42 }" @?= Right v,59 testCase "Data definition with empty value" $60 let v = DataDef [] (GlobalIdent "foo") Nothing []61 in parse "data $foo = {}" @?= Right v,62 testCase "Data definition without optional spaces" $63 let v = DataDef [] (GlobalIdent "foo") Nothing [OZeroFill 42]64 in parse "data $foo={z 42}" @?= Right v,65 testCase "Data definition with newlines as spaces" $66 let v = DataDef [] (GlobalIdent "foo") Nothing [OZeroFill 42]67 in parse "data\n$foo={z\n42}" @?= Right v,68 testCase "Data definition with comments" $69 let v = DataDef [] (GlobalIdent "foo") Nothing [OZeroFill 42]70 in parse "data\n#test\n$foo={z\n#foo\n42}" @?= Right v,71 testCase "Data definition with comments and whitespaces" $72 let v = DataDef [] (GlobalIdent "foo") Nothing [OZeroFill 42]73 in parse "data\n#test1 \n #test2\n$foo={z\n#foo\n42}" @?= Right v,74 testCase "Data definition with linkage" $75 let v = DataDef [LExport] (GlobalIdent "foo") Nothing [OZeroFill 42]76 in parse "export data $foo = { z 42 }" @?= Right v,77 testCase "Data definition with linkage, newlines, and comments" $78 let v = DataDef [LExport, LThread] (GlobalIdent "foo") Nothing [OZeroFill 42]79 in parse "export\nthread\n#foo\ndata $foo = { z 42 }" @?= Right v,80 testCase "Data definition with types" $81 let w = [DConst (Number 23), DConst (Number 42)]82 v = DataDef [] (GlobalIdent "bar") Nothing [OItem (Base Word) w]83 in parse "data $bar = { w 23 42 }" @?= Right v,84 testCase "An object containing two 64-bit fields" $85 let o =86 [ OItem (Base Long) [DConst (Number 0xffffffffffffffff)],87 OItem (Base Long) [DConst (Number 23)]88 ]89 v = DataDef [] (GlobalIdent "c") Nothing o90 in parse "data $c = { l -1, l 23 }" @?= Right v,91 testCase "Data definition with specified alignment and linkage" $92 let v = DataDef [LExport] (GlobalIdent "b") (Just 8) [OZeroFill 1000]93 in parse "export data $b = align 8 { z 1000 }" @?= Right v,94 testCase "Data definition with linkage section and string escape sequences" $95 let v = DataDef [LSection "f\\oo\\\"bar" Nothing] (GlobalIdent "b") (Just 8) [OZeroFill 1]96 in parse "section \"f\\oo\\\"bar\" data $b =align 8 {z 1}" @?= Right v,97 testCase "Data definition with symbol offset" $98 let v = DataDef {linkage = [], name = GlobalIdent "b", align = Just 8, objs = [OItem (Base Long) [DSymOff (GlobalIdent "s") 1]]}99 in parse "data $b = align 8 { l $s + 1 }" @?= Right v,100 testCase "Data definition with symbol offset and without whitespaces" $101 let v = DataDef {linkage = [], name = GlobalIdent "b", align = Just 8, objs = [OItem (Base Long) [DSymOff (GlobalIdent "s") 1]]}102 in parse "data $b = align 8 {l $s+1}" @?= Right v,103 testCase "Data definition with symbol but without offset" $104 let v = DataDef {linkage = [], name = GlobalIdent "b", align = Just 8, objs = [OItem (Base Long) [DConst (Global (GlobalIdent "s"))]]}105 in parse "data $b = align 8 {l $s}" @?= Right v,106 testCase "Data definition with octal character sequence" $107 let v = DataDef {linkage = [], name = GlobalIdent "b", align = Just 1, objs = [OItem Byte [DString "f\too\NUL"]]}108 in parse "data $b = align 1 { b \"f\\011oo\\000\" }" @?= Right v,109 testCase "Data definition with trailing comma" $110 let v = DataDef {linkage = [], name = GlobalIdent "b", align = Just 1, objs = [OItem Byte [DConst (Number 1)], OItem Byte [DConst (Number 2)]]}111 in parse "data $b = align 1 { b 1, b 2,}" @?= Right v112 ]113 where114 parse :: String -> Either P.ParseError DataDef115 parse = P.parse dataDef ""116117funcTests :: TestTree118funcTests =119 testGroup120 "Function Definition"121 [ testCase "Minimal function definition" $122 let p = [Regular (ABase Word) (LocalIdent "argc")]123 b = [Block {label = BlockIdent "start", phi = [], stmt = [], term = Return Nothing}]124 f = FuncDef [] (GlobalIdent "main") Nothing p b125 in parse "function $main(w %argc) {\n@start\nret\n}" @?= Right f,126 testCase "Function definition with load instruction" $127 let s = [Assign (LocalIdent "v") Word (Load (LBase Word) (VLocal $ LocalIdent "addr"))]128 b = [Block {label = BlockIdent "begin", phi = [], stmt = s, term = Return Nothing}]129 f = FuncDef [] (GlobalIdent "main") Nothing [] b130 in parse "function $main() {\n@begin\n%v =w loadw %addr\nret\n}" @?= Right f,131 testCase "Function definition with linkage and return type" $132 let p = [Regular (ABase Long) (LocalIdent "v")]133 b = [Block {label = BlockIdent "start", phi = [], stmt = [], term = Return Nothing}]134 f = FuncDef [LExport, LThread] (GlobalIdent "example") (Just (ABase Word)) p b135 in parse "export\nthread function w $example(l %v) {\n@start\nret\n}" @?= Right f,136 testCase "Function definition with section linkage" $137 let p = [Regular (ABase Long) (LocalIdent "v")]138 b = [Block {label = BlockIdent "start", phi = [], stmt = [], term = Return Nothing}]139 f = FuncDef [LSection "foo" Nothing] (GlobalIdent "bla") (Just (ABase Word)) p b140 in parse "section \"foo\"\nfunction w $bla(l %v) {\n@start\nret\n}" @?= Right f,141 testCase "Function definition with subword return type" $142 let b = [Block {label = BlockIdent "here", phi = [], stmt = [], term = Halt}]143 f = FuncDef [] (GlobalIdent "f") (Just (ASubWordType SignedHalf)) [] b144 in parse "function sh $f() {\n@here\nhlt\n}" @?= Right f,145 testCase "Function definition with comments" $146 let p = [Regular (ABase Long) (LocalIdent "v")]147 b = [Block {label = BlockIdent "start", phi = [], stmt = [], term = Return Nothing}]148 f = FuncDef [LSection "foo" (Just "bar")] (GlobalIdent "bla") (Just (ABase Word)) p b149 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,150 testCase "Function definition with comparison instruction" $151 let c = CompareInt IWord ISlt (VConst (Const (Number 23))) (VConst (Const (Number 42)))152 b = [Block {label = BlockIdent "start", phi = [], stmt = [Assign (LocalIdent "res") Word c], term = Return Nothing}]153 f = FuncDef [] (GlobalIdent "f") Nothing [] b154 in parse "function $f() {\n@start\n%res =w csltw 23, 42\nret\n}" @?= Right f,155 testCase "Function definition with extend instruction" $156 let c = Ext ExtSignedWord (VConst (Const (Number 42)))157 b = [Block {label = BlockIdent "start", phi = [], stmt = [Assign (LocalIdent "res") Word c], term = Return Nothing}]158 f = FuncDef [] (GlobalIdent "f") Nothing [] b159 in parse "function $f() {\n@start\n%res =w extsw 42\nret\n}" @?= Right f,160 testCase "Function definition with fallthrough block" $161 let b1 = Block {label = BlockIdent "b1", phi = [], stmt = [], term = Jump (BlockIdent "b2")}162 b2 = Block {label = BlockIdent "b2", phi = [], stmt = [], term = Return Nothing}163 f = FuncDef [] (GlobalIdent "f") Nothing [] [b1, b2]164 in parse "function $f() {\n@b1\n@b2\nret\n}" @?= Right f,165 testCase "Block with phi instrunction" $166 let v1 = VConst (Const (Number 1))167 v2 = VConst (Const (Number 2))168 p1 = Phi (LocalIdent "v") Word $ Map.fromList [(BlockIdent "b1", v1), (BlockIdent "b2", v2)]169 b1 = Block {label = BlockIdent "b1", phi = [], stmt = [], term = Jump (BlockIdent "b2")}170 b2 = Block {label = BlockIdent "b2", phi = [], stmt = [], term = Jump (BlockIdent "b3")}171 b3 = Block {label = BlockIdent "b3", phi = [p1], stmt = [], term = Return Nothing}172 fn = FuncDef [] (GlobalIdent "f") Nothing [] [b1, b2, b3]173 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,174 testCase "Call instruction with integer literal value" $175 let c = Call Nothing (VConst (Const $ Global (GlobalIdent "foo"))) [ArgReg (ABase Word) (VConst (Const (Number 42)))]176 b = [Block {label = BlockIdent "s", phi = [], stmt = [c], term = Return Nothing}]177 f = FuncDef [] (GlobalIdent "f") Nothing [] b178 in parse "function $f() {\n@s\ncall $foo(w 42)\nret\n}" @?= Right f,179 testCase "Unary neg instruction" $180 let i1 = Assign (LocalIdent "r") Word $ Neg (VConst (Const (Number 1)))181 i2 = Assign (LocalIdent "r") Word $ Neg (VLocal $ LocalIdent "r")182 b = Block {label = BlockIdent "s", phi = [], stmt = [i1, i2], term = Halt}183 f = FuncDef [] (GlobalIdent "f") Nothing [] [b]184 in parse "function $f() {\n@s\n%r =w neg 1\n%r =w neg %r\nhlt\n}" @?= Right f,185 testCase "cast instruction" $186 let c = Assign (LocalIdent "r") Word $ Cast (VLocal $ LocalIdent "f")187 b = Block {label = BlockIdent "s", phi = [], stmt = [c], term = Halt}188 f = FuncDef [] (GlobalIdent "f") Nothing [Regular (ABase Single) (LocalIdent "f")] [b]189 in parse "function $f(s %f) {\n@s\n%r =w cast %f\nhlt\n}" @?= Right f,190 testCase "trunc instruction" $191 let c = Assign (LocalIdent "r") Single $ TruncDouble (VLocal $ LocalIdent "d")192 b = Block {label = BlockIdent "s", phi = [], stmt = [c], term = Halt}193 f = FuncDef [] (GlobalIdent "f") Nothing [Regular (ABase Double) (LocalIdent "d")] [b]194 in parse "function $f(d %d) {\n@s\n%r =s truncd %d\nhlt\n}" @?= Right f,195 testCase "exts instruction" $196 let c = Assign (LocalIdent "d") Double $ Ext ExtSingle (VLocal $ LocalIdent "s")197 b = Block {label = BlockIdent "s", phi = [], stmt = [c], term = Halt}198 f = FuncDef [] (GlobalIdent "f") Nothing [Regular (ABase Single) (LocalIdent "s")] [b]199 in parse "function $f(s %s) {\n@s\n%d =d exts %s\nhlt\n}" @?= Right f,200 testCase "float to int conversions" $201 let c1 = Assign (LocalIdent "w.1") Word (FloatToInt FSingle True (VLocal $ LocalIdent "s"))202 c2 = Assign (LocalIdent "w.2") Word (FloatToInt FSingle False (VLocal $ LocalIdent "s"))203 c3 = Assign (LocalIdent "w.3") Word (FloatToInt FDouble True (VLocal $ LocalIdent "d"))204 c4 = Assign (LocalIdent "w.4") Word (FloatToInt FDouble False (VLocal $ LocalIdent "d"))205 b = Block {label = BlockIdent "start", phi = [], stmt = [c1, c2, c3, c4], term = Halt}206 f = FuncDef [] (GlobalIdent "f") Nothing [Regular (ABase Single) (LocalIdent "s"), Regular (ABase Double) (LocalIdent "d")] [b]207 in parse208 "function $f(s %s, d %d) { \n\209 \@start\n\210 \%w.1 =w stosi %s\n\211 \%w.2 =w stoui %s\n\212 \%w.3 =w dtosi %d\n\213 \%w.4 =w dtoui %d\n\214 \hlt\n\215 \}"216 @?= Right f,217 testCase "int to float conversions" $218 let c1 = Assign (LocalIdent "f.1") Single (IntToFloat IWord True (VLocal $ LocalIdent "w"))219 c2 = Assign (LocalIdent "f.2") Single (IntToFloat IWord False (VLocal $ LocalIdent "w"))220 c3 = Assign (LocalIdent "f.3") Double (IntToFloat ILong True (VLocal $ LocalIdent "l"))221 c4 = Assign (LocalIdent "f.4") Double (IntToFloat ILong False (VLocal $ LocalIdent "l"))222 b = Block {label = BlockIdent "start", phi = [], stmt = [c1, c2, c3, c4], term = Halt}223 f = FuncDef [] (GlobalIdent "f") Nothing [Regular (ABase Word) (LocalIdent "w"), Regular (ABase Long) (LocalIdent "l")] [b]224 in parse225 "function $f(w %w, l %l) { \n\226 \@start\n\227 \%f.1 =s swtof %w\n\228 \%f.2 =s uwtof %w\n\229 \%f.3 =d sltof %l\n\230 \%f.4 =d ultof %l\n\231 \hlt\n\232 \}"233 @?= Right f,234 testCase "floating point comparision" $235 let c1 = Assign (LocalIdent "w.1") Word $ CompareFloat FDouble FOrd (VLocal $ LocalIdent "lhs") (VLocal $ LocalIdent "rhs")236 c2 = Assign (LocalIdent "w.2") Word $ CompareFloat FSingle FOrd (VLocal $ LocalIdent "lhs") (VLocal $ LocalIdent "rhs")237 c3 = Assign (LocalIdent "w.3") Word $ CompareFloat FDouble FLe (VLocal $ LocalIdent "lhs") (VLocal $ LocalIdent "rhs")238 c4 = Assign (LocalIdent "w.4") Word $ CompareFloat FDouble FLt (VLocal $ LocalIdent "lhs") (VLocal $ LocalIdent "rhs")239 c5 = Assign (LocalIdent "w.5") Word $ CompareFloat FDouble FGe (VLocal $ LocalIdent "lhs") (VLocal $ LocalIdent "rhs")240 c6 = Assign (LocalIdent "w.6") Word $ CompareFloat FDouble FGt (VLocal $ LocalIdent "lhs") (VLocal $ LocalIdent "rhs")241 b = Block {label = BlockIdent "start", phi = [], stmt = [c1, c2, c3, c4, c5, c6], term = Halt}242 f = FuncDef [] (GlobalIdent "f") Nothing [Regular (ABase Double) (LocalIdent "lhs"), Regular (ABase Double) (LocalIdent "rhs")] [b]243 in parse244 "function $f(d %lhs, d %rhs) { \n\245 \@start\n\246 \%w.1 =w cod %lhs, %rhs\n\247 \%w.2 =w cos %lhs, %rhs\n\248 \%w.3 =w cled %lhs, %rhs\n\249 \%w.4 =w cltd %lhs, %rhs\n\250 \%w.5 =w cged %lhs, %rhs\n\251 \%w.6 =w cgtd %lhs, %rhs\n\252 \hlt\n\253 \}"254 @?= Right f255 ]256 where257 parse :: String -> Either P.ParseError FuncDef258 parse = P.parse funcDef ""259260mkParser :: TestTree261mkParser =262 testGroup263 "Tests for the QBE parser"264 [typeTests, dataTests, funcTests]