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 1a936bc..38bdcd2 100644 --- a/compiler/src/main/pascal/blaise.codegen.native.x86_64.pas +++ b/compiler/src/main/pascal/blaise.codegen.native.x86_64.pas @@ -630,6 +630,21 @@ type spilling any overflow to the stack. Returns overflow bytes to clean up after the call. Used by the interface/class sret call emitters. } function EmitSretRegArgs(ASlots, ABase: Integer): Integer; + { Pop already-pushed method-call arg slots (slot 0 pushed first, on top is + the last slot) into the System V argument registers, routing float-family + params to %xmm0.. and everything else to the integer registers starting + at AIntBase (1 when only Self/%rdi is reserved). Mirrors EmitCall's SysV + classification so a Double/Single method or constructor argument lands in + its xmm register instead of being mis-passed in an integer register. } + procedure EmitPopMethodArgsToRegs(AParams, AArgs: TObjectList; + AIntBase: Integer); + { Raise a clear error if a by-value float-family param appears in a call + whose total slots exceed the 6 integer arg registers. The >6-slot + method/ctor overflow emitters use an integer-only flat-slot layout; a + float arg there would be mis-classified into the integer overflow region + instead of an xmm register. The <=6-slot path handles floats correctly + (EmitPopMethodArgsToRegs); only the rare overflow path is unsupported. } + procedure GuardNoFloatInOverflow(AParams: TObjectList; const AWhat: string); { Emit a method-pointer (of-object) call: load Code from offset 0 and Data from offset 8 of the TMethod block at APtrOperand; call Code with Data as Self (%rdi) and the remaining args shifted. } @@ -7794,8 +7809,7 @@ begin for I := 0 to ACall.Args.Count - 1 do Self.PushCallArg(TMethodParam(MD.Params.Items[I]), TASTExpr(ACall.Args.Items[I]), I); - for I := UserSlots - 1 downto 0 do - Self.Emit(#9'popq ' + SysVArg64(I + 1)); + Self.EmitPopMethodArgsToRegs(MD.Params, ACall.Args, 1); Self.Emit(#9'movq %rbx, %rdi'); if ACall.IsMetaclassDispatch and (MD.VTableSlot >= 0) then begin @@ -7816,6 +7830,7 @@ begin HD := TList.Create(); HK := TList.Create(); HTotal := Self.EmitArgHoist(MD.Params, nil, True, '', ACall.Args, HD, HK); + Self.GuardNoFloatInOverflow(MD.Params, 'constructor call'); OverflowSlots := TotalSlots - 6; AllocSz := (((6 * 8 + OverflowSlots * 8) + 15) and (-16)) + 8; CleanUp := AllocSz - 6 * 8; @@ -7959,8 +7974,7 @@ begin else Self.Emit(Format(#9'movq %s, %%r10', [Self.VarOperand('Self')])); - for I := UserSlots - 1 downto 0 do - Self.Emit(#9'popq ' + SysVArg64(I + 1)); + Self.EmitPopMethodArgsToRegs(MD.Params, ACall.Args, 1); Self.Emit(#9'movq %r10, %rdi'); if MD.VTableSlot >= 0 then begin @@ -7994,6 +8008,7 @@ begin Self.EmitRecordCallSretAt(ACall.ObjExpr, '(%rsp)'); Self.Emit(#9'movq %rsp, %rbx'); end; + Self.GuardNoFloatInOverflow(MD.Params, 'method call'); OverflowSlots := TotalSlots - 6; CleanUp := ((OverflowSlots * 8 + 15) and (-16)); AllocSz := 6 * 8 + CleanUp; @@ -8315,6 +8330,19 @@ begin Self.Emit(#9'pushq %rax'); end; end + else if (APar <> nil) and IsFloatFamily(APar.ResolvedType) then + begin + { Float scalar argument: materialise to %xmm0 (handles literals via the + .LF constant path, variables, expressions), adjust to the param's width, + and push its 8-byte bit pattern onto the stack as one slot. The pop loop + (EmitPopMethodArgsToRegs) routes this slot into an xmm argument register + per the SysV ABI instead of an integer register. } + Self.EmitExprToXmm0(AArg); + Self.EmitXmm0WidthAdjust(AArg.ResolvedType, + APar.ResolvedType.Kind = tySingle); + Self.Emit(#9'subq $8, %rsp'); + Self.Emit(#9'movsd %xmm0, 0(%rsp)'); + end else begin Self.EmitExprToEax(AArg); @@ -8449,6 +8477,110 @@ begin Result := OverflowSlots * 8; end; +procedure TX86_64Backend.EmitPopMethodArgsToRegs(AParams, AArgs: TObjectList; + AIntBase: Integer); +var + I, NParams, IntIdx, XmmIdx: Integer; + P: TMethodParam; + PT: TTypeDesc; + IsFloatSlot: TList; { 1 = float (xmm) slot, 0 = integer slot, + in stack-slot order (slot 0 pushed first) } + Dest: TStringList; { target register per slot, parallel to above } + Slots: Integer; +begin + { Determine the param backing each logical arg. AParams may be nil (no + declared params): then every arg is a plain integer slot. } + NParams := 0; + if AParams <> nil then NParams := AParams.Count; + + IsFloatSlot := TList.Create(); + Dest := TStringList.Create(); + try + { Forward pass: one entry per stack slot, in push order (slot 0 first). } + for I := 0 to AArgs.Count - 1 do + begin + P := nil; + if I < NParams then P := TMethodParam(AParams.Items[I]); + PT := nil; + if P <> nil then PT := P.ResolvedType; + if (PT = nil) and (TASTExpr(AArgs.Items[I]).ResolvedType <> nil) then + PT := TASTExpr(AArgs.Items[I]).ResolvedType; + if (P <> nil) and P.IsOpenArray then + begin + IsFloatSlot.Add(0); IsFloatSlot.Add(0); { ptr + high } + end + else if (PT <> nil) and (PT.Kind = tyInterface) and + ((P = nil) or not P.IsVarParam) then + begin + IsFloatSlot.Add(0); IsFloatSlot.Add(0); { obj + itab } + end + else if IsFloatFamily(PT) and ((P = nil) or + (not P.IsVarParam and not P.IsOpenArray)) then + IsFloatSlot.Add(1) { float scalar -> xmm } + else + IsFloatSlot.Add(0); { integer/ptr scalar } + end; + + { Assign a register to each slot in forward order: integers consume the + SysV integer registers from AIntBase, floats consume xmm0.. — the two + sequences advance independently, per SysV. } + IntIdx := AIntBase; + XmmIdx := 0; + for I := 0 to IsFloatSlot.Count - 1 do + begin + if IsFloatSlot.Get(I) = 1 then + begin + Dest.Add(SysVXmmArgRegs[XmmIdx]); + Inc(XmmIdx); + end + else + begin + Dest.Add(Self.SysVArg64(IntIdx)); + Inc(IntIdx); + end; + end; + + { Reverse pass: the top of the stack is the LAST slot. Pop from the last + slot down to slot 0, moving each into its precomputed register. Every + slot is 8 bytes and consumed in turn, so the current slot is always at + 0(%rsp) — a float reads it then raises %rsp by 8, an integer pops it. } + Slots := IsFloatSlot.Count; + for I := Slots - 1 downto 0 do + begin + if IsFloatSlot.Get(I) = 1 then + begin + Self.Emit(Format(#9'movsd 0(%%rsp), %s', [Dest.Strings[I]])); + Self.Emit(#9'addq $8, %rsp'); + end + else + Self.Emit(#9'popq ' + Dest.Strings[I]); + end; + finally + Dest.Free(); + IsFloatSlot.Free(); + end; +end; + +procedure TX86_64Backend.GuardNoFloatInOverflow(AParams: TObjectList; + const AWhat: string); +var + I: Integer; + P: TMethodParam; +begin + if AParams = nil then Exit; + for I := 0 to AParams.Count - 1 do + begin + P := TMethodParam(AParams.Items[I]); + if IsFloatFamily(P.ResolvedType) and not P.IsVarParam and + not P.IsOpenArray then + raise ENativeCodeGenError.Create( + 'native backend: by-value float argument in a ' + AWhat + + ' with more than 6 register slots is not yet supported (the >6-arg ' + + 'overflow path is integer-only); reduce the argument count or pass ' + + 'the float earlier in the list'); + end; +end; + { Emit a TMethodCallStmt (class method call in statement position). Same as EmitMethodCallExpr but for statement nodes. } procedure TX86_64Backend.EmitMethodCallStmt(ACall: TMethodCallStmt); @@ -8493,8 +8625,7 @@ begin for I := 0 to ACall.Args.Count - 1 do Self.PushCallArg(TMethodParam(MD.Params.Items[I]), TASTExpr(ACall.Args.Items[I]), I); - for I := UserSlots - 1 downto 0 do - Self.Emit(#9'popq ' + SysVArg64(I + 1)); + Self.EmitPopMethodArgsToRegs(MD.Params, ACall.Args, 1); Self.Emit(#9'movq %rbx, %rdi'); if MD.VTableSlot >= 0 then begin @@ -8515,6 +8646,7 @@ begin HD := TList.Create(); HK := TList.Create(); HTotal := Self.EmitArgHoist(MD.Params, nil, True, '', ACall.Args, HD, HK); + Self.GuardNoFloatInOverflow(MD.Params, 'constructor call'); OverflowSlots := TotalSlots - 6; AllocSz := (((6 * 8 + OverflowSlots * 8) + 15) and (-16)) + 8; CleanUp := AllocSz - 6 * 8; @@ -8698,12 +8830,12 @@ begin else Self.Emit(Format(#9'movq %s, %%r10', [Self.VarOperand('Self')])); - for I := UserSlots - 1 downto 0 do - Self.Emit(#9'popq ' + SysVArg64(I + 1)); + Self.EmitPopMethodArgsToRegs(MD.Params, ACall.Args, 1); Self.Emit(#9'movq %r10, %rdi'); end else begin + Self.GuardNoFloatInOverflow(MD.Params, 'method call'); OverflowSlots := TotalSlots - 6; CleanUp := ((OverflowSlots * 8 + 15) and (-16)); AllocSz := 6 * 8 + CleanUp; @@ -8820,8 +8952,7 @@ begin end; { Self is the current method's Self slot. } Self.Emit(Format(#9'movq %s, %%r10', [Self.VarOperand('Self')])); - for I := UserSlots - 1 downto 0 do - Self.Emit(#9'popq ' + SysVArg64(I + 1)); + Self.EmitPopMethodArgsToRegs(MD.Params, AArgs, 1); Self.Emit(#9'movq %r10, %rdi'); Self.Emit(#9'callq ' + Sym); Self.EndCallArgs(); @@ -8834,6 +8965,7 @@ begin 6-register prefix so the overflow sits at the callee's [rsp+0..], then static-dispatch to the parent. Mirrors EmitMethodCallStmt's >6 path (the inherited call is always a direct callq, never vtable). } + Self.GuardNoFloatInOverflow(MD.Params, 'inherited call'); OverflowSlots := TotalSlots - 6; CleanUp := ((OverflowSlots * 8 + 15) and (-16)); AllocSz := 6 * 8 + CleanUp; @@ -14533,8 +14665,7 @@ begin { Pop one register per SLOT (interface args occupy two), into the integer registers after %rdi (sret) and %rsi (Self): %rdx, %rcx, %r8, %r9. } - for I := UserSlots - 1 downto 0 do - Self.Emit(#9'popq ' + SysVArg64(I + 2)); + Self.EmitPopMethodArgsToRegs(MD.Params, ACall.Args, 2); { The saved dest sits just below the call frame's hoist region. } Self.Emit(Format(#9'movq %d(%%rsp), %%rdi', [Self.TopFrameTotal()])); if MD.VTableSlot >= 0 then diff --git a/compiler/src/test/pascal/cp.test.e2e.classes2.pas b/compiler/src/test/pascal/cp.test.e2e.classes2.pas index d4f267e..6712375 100644 --- a/compiler/src/test/pascal/cp.test.e2e.classes2.pas +++ b/compiler/src/test/pascal/cp.test.e2e.classes2.pas @@ -54,6 +54,15 @@ type procedure TestRun_Supports_TwoArg_BooleanResult; procedure TestRun_Supports_ThreeArg_AssignsAndCalls; procedure TestRun_ConstructorOverload_PicksCorrectArity; + { Regression: native backend passed float args to methods/constructors via + integer registers instead of the SysV xmm registers — a literal crashed + codegen, a variable silently used the wrong register. } + procedure TestRun_MethodFloatArg_Literal_PassedInXmm; + procedure TestRun_MethodFloatArg_Variable_PassedInXmm; + procedure TestRun_ConstructorFloatArg_Literal_StoredCorrectly; + procedure TestRun_ConstructorFloatArg_Variable_StoredCorrectly; + procedure TestRun_MethodMixedIntFloatString_RegistersInterleave; + procedure TestRun_MethodMultipleFloats_UseXmm0AndXmm1; procedure TestRun_MethodReadsProgramGlobal; procedure TestRun_VarParam_ClassFields_WritebackVisible; { Name-resolution priority for unqualified calls inside a class @@ -1246,6 +1255,90 @@ begin AssertEquals('1-arg constructor body ran', '42' + LE, Output); end; +procedure TE2EClasses2Tests.TestRun_MethodFloatArg_Literal_PassedInXmm; +begin + AssertRunsOnAll( + ''' + program c; + type TX = class procedure Take(d: Double); end; + procedure TX.Take(d: Double); begin WriteLn(d); end; + var x: TX; + begin x := TX.Create(); x.Take(1.5); end. + ''', + '1.5' + LE, 0); +end; + +procedure TE2EClasses2Tests.TestRun_MethodFloatArg_Variable_PassedInXmm; +begin + AssertRunsOnAll( + ''' + program f; + type TX = class procedure Take(d: Double); end; + procedure TX.Take(d: Double); begin WriteLn(d); end; + var x: TX; y: Double; + begin x := TX.Create(); y := 1.5; x.Take(y); end. + ''', + '1.5' + LE, 0); +end; + +procedure TE2EClasses2Tests.TestRun_ConstructorFloatArg_Literal_StoredCorrectly; +begin + AssertRunsOnAll( + ''' + program ctl; + type TN = class V: Double; constructor CreateFloat(d: Double); end; + constructor TN.CreateFloat(d: Double); begin V := d; end; + var n: TN; + begin n := TN.CreateFloat(2.5); WriteLn(n.V); end. + ''', + '2.5' + LE, 0); +end; + +procedure TE2EClasses2Tests.TestRun_ConstructorFloatArg_Variable_StoredCorrectly; +begin + AssertRunsOnAll( + ''' + program ct; + type TN = class V: Double; constructor CreateFloat(d: Double); end; + constructor TN.CreateFloat(d: Double); begin V := d; end; + var n: TN; y: Double; + begin y := 2.5; n := TN.CreateFloat(y); WriteLn(n.V); end. + ''', + '2.5' + LE, 0); +end; + +procedure TE2EClasses2Tests.TestRun_MethodMixedIntFloatString_RegistersInterleave; +begin + { Exercises int + float + string interleaving: the string and Int64 take + integer arg registers, the Double takes an xmm register, independently. } + AssertRunsOnAll( + ''' + program mix; + type TX = class procedure M(const s: string; i: Int64; d: Double); end; + procedure TX.M(const s: string; i: Int64; d: Double); + begin WriteLn('s=', s, ' i=', i, ' d=', d); end; + var x: TX; + begin x := TX.Create(); x.M('hi', 7, 3.5); end. + ''', + 's=hi i=7 d=3.5' + LE, 0); +end; + +procedure TE2EClasses2Tests.TestRun_MethodMultipleFloats_UseXmm0AndXmm1; +begin + { Two Double/Single args must land in distinct xmm registers (xmm0, xmm1), + interleaved with an integer arg that consumes an integer register. } + AssertRunsOnAll( + ''' + program mf; + type TX = class procedure M(a: Double; i: Int64; b: Double; c: Single); end; + procedure TX.M(a: Double; i: Int64; b: Double; c: Single); + begin WriteLn('a=', a, ' i=', i, ' b=', b, ' c=', c); end; + var x: TX; + begin x := TX.Create(); x.M(1.5, 9, 2.5, 3.5); end. + ''', + 'a=1.5 i=9 b=2.5 c=3.5' + LE, 0); +end; + procedure TE2EClasses2Tests.TestRun_MethodReadsProgramGlobal; var Output: string; RCode: Integer; begin diff --git a/compiler/src/test/pascal/cp.test.nativeconstarg.pas b/compiler/src/test/pascal/cp.test.nativeconstarg.pas index 2365e5a..1ddd924 100644 --- a/compiler/src/test/pascal/cp.test.nativeconstarg.pas +++ b/compiler/src/test/pascal/cp.test.nativeconstarg.pas @@ -61,6 +61,10 @@ type { Self is typed as the owning class; value record params present the '_data' shadow slot (the inline copy) so field drilldown works. } procedure TestOpdf_Facts_SelfAndRecordParamTyping; + { Regression: a float argument to an instance method must be marshalled + into an SSE (xmm) argument register per the System V ABI, not an integer + register. Asserts the call site emits movsd into %xmm0. } + procedure TestMethodFloatArg_LoadedIntoXmm; end; implementation @@ -626,6 +630,29 @@ begin CG.Free(); end; +procedure TNativeConstArgTests.TestMethodFloatArg_LoadedIntoXmm; +const + Src = ''' + program P; + type TX = class procedure Take(d: Double); end; + procedure TX.Take(d: Double); begin end; + var x: TX; + begin + x := TX.Create(); + x.Take(1.5) + end. + '''; +var + Asm: string; +begin + Asm := GenAsm(Src); + { The Double argument must reach the SSE arg register, not an integer one. } + AssertTrue('float method arg loaded into %xmm0', + Pos('movsd', Asm) >= 0); + AssertTrue('float method arg targets the SSE arg register', + Pos('%xmm0', Asm) >= 0); +end; + initialization RegisterTest(TNativeConstArgTests);