From ff2d73f70de14605c350b37b3b5a8587f8724a92 Mon Sep 17 00:00:00 2001 From: Andrew Haines Date: Wed, 24 Jun 2026 18:16:56 -0400 Subject: [PATCH] fix(codegen): convert integer to float on class-field stores MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit A store into a Double or Single class field never converted an integer right-hand side to floating point, on either backend: * QBE never emitted swtof/sltof — the field-store paths only handled integer widening (w->l) and float-width adjustment (s<->d). An Int64 or Integer RHS was deposited into the float slot as raw integer bits; on the explicit-field path QBE rejected the `stored` of an integer SSA value, and on the implicit-Self path a hardcoded `storel` silently wrote garbage. * The native x86-64 backend converted an integer RHS to a DOUBLE in %xmm0 (cvtsi2sdq) but then stored it into a Single field with a bare movss — writing only the low 32 bits of the double, i.e. garbage. A Single field needs the value narrowed (cvtsd2ss) first; the Double field happened to work. Both backends now promote/convert to the field's width. QBE: swtof/sltof for an integer RHS plus exts/truncd for a float-width mismatch, in EmitFieldAssignment and the implicit-Self field branch of EmitAssignment. Native: an EmitXmm0WidthAdjust after EmitExprToXmm0 in both the TFieldAssignment and implicit-Self float field-store paths, narrowing a Double/integer RHS to the Single field width before the movss. Tests: cp.test.codegen IR assertions for the Self.Field, bare-field and Single targets; cp.test.e2e.classes2 end-to-end coverage of Int64->Double and Integer->Single through both Self.Field and bare implicit-Self forms, verified on QBE and native. --- .../pascal/blaise.codegen.native.x86_64.pas | 10 ++ .../src/main/pascal/blaise.codegen.qbe.pas | 92 +++++++++++++++---- compiler/src/test/pascal/cp.test.codegen.pas | 66 +++++++++++++ .../src/test/pascal/cp.test.e2e.classes2.pas | 50 ++++++++++ 4 files changed, 200 insertions(+), 18 deletions(-) diff --git a/compiler/src/main/pascal/blaise.codegen.native.x86_64.pas b/compiler/src/main/pascal/blaise.codegen.native.x86_64.pas index 91200a0..100523b 100644 --- a/compiler/src/main/pascal/blaise.codegen.native.x86_64.pas +++ b/compiler/src/main/pascal/blaise.codegen.native.x86_64.pas @@ -10781,6 +10781,10 @@ begin if IsFloatFamily(Asgn.ResolvedLhsType) then begin Self.EmitExprToXmm0(Asgn.Expr); + { Narrow a Double/integer RHS to Single before the movss store + (see the TFieldAssignment float path). } + Self.EmitXmm0WidthAdjust(Asgn.Expr.ResolvedType, + Asgn.ResolvedLhsType.Kind = tySingle); Self.Emit(Format(#9'movq %s, %%rcx', [Self.VarOperand('Self')])); if ISFld.Offset > 0 then Self.Emit(Format(#9'addq $%d, %%rcx', [ISFld.Offset])); @@ -12260,6 +12264,12 @@ begin if IsFloatFamily(FA.FieldInfo.TypeDesc) then begin Self.EmitExprToXmm0(FA.Expr); + { An integer RHS (and any Double sub-expression) lands in %xmm0 as a + DOUBLE; a Single field needs it narrowed (cvtsd2ss) before the movss + store, else only the low 32 bits of the double are written — garbage. + Mirrors the QBE swtof/truncd field-store conversion. } + Self.EmitXmm0WidthAdjust(FA.Expr.ResolvedType, + FA.FieldInfo.TypeDesc.Kind = tySingle); if FA.ObjExpr <> nil then begin Self.Emit(#9'subq $8, %rsp'); diff --git a/compiler/src/main/pascal/blaise.codegen.qbe.pas b/compiler/src/main/pascal/blaise.codegen.qbe.pas index 1e294c2..ce8d52c 100644 --- a/compiler/src/main/pascal/blaise.codegen.qbe.pas +++ b/compiler/src/main/pascal/blaise.codegen.qbe.pas @@ -4051,6 +4051,42 @@ begin QType := QbeTypeOf(ISFld.TypeDesc); if QType = 'w' then EmitLine(Format(' %s %s, %s', [StoreInstrFor(ISFld.TypeDesc), ValTemp, ObjTemp])) + else if (QType = 'd') or (QType = 's') then + begin + { Float-typed field via implicit Self.Field: convert an integer RHS + (swtof/sltof) or adjust float width (exts/truncd) before storing, and + use the float store instruction — never the bare storel below, which + would deposit the raw integer/wrong-width bits into the float slot. } + if (AAssign.Expr.ResolvedType <> nil) and + (QbeTypeOf(AAssign.Expr.ResolvedType) = 'w') and + not AAssign.Expr.ResolvedType.IsFloat() then + begin + ExtTemp := AllocTemp(); + EmitLine(Format(' %s =%s swtof %s', [ExtTemp, QType, ValTemp])); + ValTemp := ExtTemp; + end + else if (AAssign.Expr.ResolvedType <> nil) and + (QbeTypeOf(AAssign.Expr.ResolvedType) = 'l') and + not AAssign.Expr.ResolvedType.IsFloat() then + begin + ExtTemp := AllocTemp(); + EmitLine(Format(' %s =%s sltof %s', [ExtTemp, QType, ValTemp])); + ValTemp := ExtTemp; + end + else if (QType = 's') and (QbeTypeOf(AAssign.Expr.ResolvedType) = 'd') then + begin + ExtTemp := AllocTemp(); + EmitLine(Format(' %s =s truncd %s', [ExtTemp, ValTemp])); + ValTemp := ExtTemp; + end + else if (QType = 'd') and (QbeTypeOf(AAssign.Expr.ResolvedType) = 's') then + begin + ExtTemp := AllocTemp(); + EmitLine(Format(' %s =d exts %s', [ExtTemp, ValTemp])); + ValTemp := ExtTemp; + end; + EmitLine(Format(' %s %s, %s', [StoreInstrFor(ISFld.TypeDesc), ValTemp, ObjTemp])); + end else begin if QbeTypeOf(AAssign.Expr.ResolvedType) = 'w' then @@ -6336,9 +6372,45 @@ begin begin QType := QbeTypeOf(AAssign.FieldInfo.TypeDesc); StoreInstr := StoreInstrFor(AAssign.FieldInfo.TypeDesc); - if QType <> 'w' then + if (QType = 'd') or (QType = 's') then begin - { Sign-extend if the value is word-typed but the field needs l } + { Float-typed field: an integer RHS must be converted (swtof/sltof), + not merely sign-extended — otherwise 'rec.d := i' emits + 'stored , ...', an integer value into a float slot the assembler + rejects. A float RHS of the wrong width is adjusted (exts/truncd). + Mirrors the scalar-variable assignment path. } + if (AAssign.Expr.ResolvedType <> nil) and + (QbeTypeOf(AAssign.Expr.ResolvedType) = 'w') and + not AAssign.Expr.ResolvedType.IsFloat() then + begin + ExtTemp := AllocTemp(); + EmitLine(Format(' %s =%s swtof %s', [ExtTemp, QType, ValTemp])); + ValTemp := ExtTemp; + end + else if (AAssign.Expr.ResolvedType <> nil) and + (QbeTypeOf(AAssign.Expr.ResolvedType) = 'l') and + not AAssign.Expr.ResolvedType.IsFloat() then + begin + ExtTemp := AllocTemp(); + EmitLine(Format(' %s =%s sltof %s', [ExtTemp, QType, ValTemp])); + ValTemp := ExtTemp; + end + else if (QType = 's') and (QbeTypeOf(AAssign.Expr.ResolvedType) = 'd') then + begin + ExtTemp := AllocTemp(); + EmitLine(Format(' %s =s truncd %s', [ExtTemp, ValTemp])); + ValTemp := ExtTemp; + end + else if (QType = 'd') and (QbeTypeOf(AAssign.Expr.ResolvedType) = 's') then + begin + ExtTemp := AllocTemp(); + EmitLine(Format(' %s =d exts %s', [ExtTemp, ValTemp])); + ValTemp := ExtTemp; + end; + end + else if QType <> 'w' then + begin + { Integer/pointer field wider than word: sign-extend a word RHS to l. } if QbeTypeOf(AAssign.Expr.ResolvedType) = 'w' then begin ExtTemp := AllocTemp(); @@ -6346,22 +6418,6 @@ begin ValTemp := ExtTemp; end; end; - { Float-width coercion: real-typed literals and double sub-exprs land - in the SSA as 'd' even when the destination field is a 32-bit - 'Single' ('s'). Without this, 'rec.s := 1.5' emits - 'stores d_1.5, ...' — a type mismatch the assembler rejects. } - if (QType = 's') and (QbeTypeOf(AAssign.Expr.ResolvedType) = 'd') then - begin - ExtTemp := AllocTemp(); - EmitLine(Format(' %s =s truncd %s', [ExtTemp, ValTemp])); - ValTemp := ExtTemp; - end - else if (QType = 'd') and (QbeTypeOf(AAssign.Expr.ResolvedType) = 's') then - begin - ExtTemp := AllocTemp(); - EmitLine(Format(' %s =d exts %s', [ExtTemp, ValTemp])); - ValTemp := ExtTemp; - end; EmitLine(Format(' %s %s, %s', [StoreInstr, ValTemp, Ptr])); end; end; diff --git a/compiler/src/test/pascal/cp.test.codegen.pas b/compiler/src/test/pascal/cp.test.codegen.pas index 7ce0d85..ef91b6f 100644 --- a/compiler/src/test/pascal/cp.test.codegen.pas +++ b/compiler/src/test/pascal/cp.test.codegen.pas @@ -81,6 +81,13 @@ type procedure TestInt64AssignDouble_EmitsSltof; procedure TestIntAssignSingle_EmitsSwtof; + { Integer→float conversion on a CLASS-FIELD store target (not just a + simple variable). Regression: the field-store path emitted a bare + integer store into the float slot. } + procedure TestInt64AssignDoubleField_EmitsSltof; + procedure TestIntAssignSingleField_EmitsSwtof; + procedure TestInt64AssignDoubleFieldBare_EmitsSltof; + { Mixed Single×Double arithmetic } procedure TestSingleMulDouble_PromotesSingleToDouble; procedure TestSingleAddSingle_EmitsSTypedOp; @@ -667,6 +674,65 @@ begin IRContains(IR, 'swtof')); end; +procedure TCodeGenTests.TestInt64AssignDoubleField_EmitsSltof; +var IR: string; +begin + IR := GenerateIR(''' + program P; + type TFoo = class + FD: Double; + procedure SetIt(AValue: Int64); + begin Self.FD := AValue end; + end; + var F: TFoo; + begin + F := TFoo.Create() + end. + '''); + AssertTrue('Int64→Double field store should emit sltof', + IRContains(IR, 'sltof')); + AssertFalse('Int64→Double field store must not bare-store the integer', + IRContains(IR, 'storel %_t2, %_t1')); +end; + +procedure TCodeGenTests.TestIntAssignSingleField_EmitsSwtof; +var IR: string; +begin + IR := GenerateIR(''' + program P; + type TFoo = class + FS: Single; + procedure SetIt(AValue: Integer); + begin Self.FS := AValue end; + end; + var F: TFoo; + begin + F := TFoo.Create() + end. + '''); + AssertTrue('Integer→Single field store should emit swtof', + IRContains(IR, 'swtof')); +end; + +procedure TCodeGenTests.TestInt64AssignDoubleFieldBare_EmitsSltof; +var IR: string; +begin + IR := GenerateIR(''' + program P; + type TFoo = class + FD: Double; + procedure SetIt(AValue: Int64); + begin FD := AValue end; + end; + var F: TFoo; + begin + F := TFoo.Create() + end. + '''); + AssertTrue('Int64→Double bare implicit-Self field store should emit sltof', + IRContains(IR, 'sltof')); +end; + procedure TCodeGenTests.TestSingleMulDouble_PromotesSingleToDouble; var IR: string; begin diff --git a/compiler/src/test/pascal/cp.test.e2e.classes2.pas b/compiler/src/test/pascal/cp.test.e2e.classes2.pas index 00aa662..ed82666 100644 --- a/compiler/src/test/pascal/cp.test.e2e.classes2.pas +++ b/compiler/src/test/pascal/cp.test.e2e.classes2.pas @@ -163,6 +163,13 @@ type stub must complete into the same type so the full class — including its ARC field — compiles and runs correctly. } procedure TestRun_ForwardClass_MutualRefRuns; + + { Implicit Int64/Integer→float conversion when the assignment target is a + class FIELD (both Self.Field and bare implicit-Self forms), for Double + and Single fields. Regression: QBE deposited the raw integer bits into + the float slot; native stored a Double into a Single slot (movss of a + double) without narrowing. } + procedure TestRun_IntToFloatField_Converts; procedure TestRun_SelfIndexedRecordFieldAssign; end; @@ -2327,6 +2334,49 @@ begin AssertEquals('forward-declared TNode field read back', 'hello', Trim(Output)); end; +const + SrcIntToFloatField = + ''' + program Prg; + type + TFoo = class + FD: Double; + FS: Single; + procedure SetD(AValue: Int64); + begin Self.FD := AValue end; { Int64 -> Double, Self.Field } + procedure SetDBare(AValue: Int64); + begin FD := AValue end; { Int64 -> Double, implicit Self } + procedure SetS(AValue: Integer); + begin Self.FS := AValue end; { Integer -> Single, Self.Field } + procedure SetSBare(AValue: Integer); + begin FS := AValue end; { Integer -> Single, implicit Self } + end; + var F: TFoo; + begin + F := TFoo.Create(); + F.SetD(7); + WriteLn(Format('%g', [F.FD])); + F.SetDBare(42); + WriteLn(Format('%g', [F.FD])); + F.SetS(5); + WriteLn(Format('%g', [F.FS])); + F.SetSBare(9); + WriteLn(Format('%g', [F.FS])) + end. + '''; + +procedure TE2EClasses2Tests.TestRun_IntToFloatField_Converts; +var Output: string; RCode: Integer; +begin + if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end; + { All four forms convert the integer to the field's float width — including + Integer->Single, where the native backend had stored a Double into the + 4-byte Single slot. } + AssertTrue('compile+run', CompileAndRun(SrcIntToFloatField, Output, RCode)); + AssertEquals('Int64/Integer→float field stores convert', + '7' + LE + '42' + LE + '5' + LE + '9', Trim(Output)); +end; + initialization RegisterTest(TE2EClasses2Tests);