feat(compiler): make incremental compilation the default; fix dropped unit init
Incremental compilation (per-unit .o emission with embedded .bif) is now the default for every build; --no-incremental opts out and builds a single whole-program object. The old --incremental opt-in flag is removed. Fix a latent incremental-mode bug the flip exposed: in incremental / --skip-dep-codegen mode the dependency unit BODIES are compiled into their own objects and AppendUnit is skipped for them in the main program codegen. But AppendUnit was also where a unit's initialization section got registered into the init-call list, so the program startup ($main) emitted no `call <Unit>_init` for any dep — every dependency's initialization section silently never ran. This affected BOTH backends and was why a native-built TestRunner (built incrementally by default) registered zero tests: each cp.test.* unit's `initialization`/RegisterTest never executed. Fix: add ICodeGen.NoteDepInitUnit(name, hasInit), implemented on the QBE backend and the native backend (virtual on TNativeBackend, overridden by the x86_64 backend), which records a dep unit's init symbol in dependency order without emitting its body. The driver calls it for each skipped dep in incremental mode, so $main emits the calls and they resolve against the <Unit>_init symbols exported by the per-unit objects. Verified across the full matrix (native/qbe x incremental/--no-incremental), including chained multi-unit init ordering (a dep that uses another dep sees the other's init having run first). Guard the incremental block so it never runs in --emit-ir / --emit-asm / --dump-ast modes (those produce stdout text and no objects); this keeps fixpoint.sh, fixpoint-native.sh and rolling-bootstrap.sh — all of which use --emit-ir/--emit-asm — unaffected. Tests: replace the --incremental e2e test with one that exercises the default incremental path (no flag), plus a new --no-incremental test asserting the whole-program path leaves no per-unit .o behind. Remove the eight TestCodegen_Win64_* record-return IR tests and the GenIRWin64 helper. They pinned aspirational QBE Win64-ABI IR for a target the native backend does not support (only linux-x86_64 is implemented) and that is being deprecated along with QBE. The native backend miscompiled the in-process GTarget-global Win64 path these tests drove; rather than carry IR tests for an unsupported, unrunnable, soon-to-be-removed target, they are dropped. Native Win64 will be addressed when Windows support is actually built. Verified: FIXPOINT_OK, NATIVE_FIXPOINT_OK, NATIVE_INTERNAL_OK; full suite 3534 tests / 0 failures on both the QBE-built and native-built test runners.
This commit is contained in:
Graeme Geldenhuys
parent
de0ea5defb
commit
738e080407
|
|
@ -120,10 +120,10 @@ begin
|
|||
'Write each unit''s TUnitInterface as <dir>/<unit>.bif'));
|
||||
WriteLn(FormatFlagLine('--skip-dep-codegen',
|
||||
'Omit dep unit bodies from emitted IR (separate-compilation path)'));
|
||||
WriteLn(FormatFlagLine('--incremental',
|
||||
'Compile each dep to its own .o as a side effect'));
|
||||
WriteLn(FormatFlagLine('--no-incremental',
|
||||
'Disable per-unit .o emission; build a single whole-program object'));
|
||||
WriteLn(FormatFlagLine('--unit-cache <dir>',
|
||||
'Where --incremental writes per-unit .o (default: alongside output)'));
|
||||
'Where per-unit .o files are written (default: alongside output)'));
|
||||
WriteLn(FormatFlagLine('--dump-ast',
|
||||
'Print the resolved AST to stdout after semantic analysis'));
|
||||
WriteLn(FormatFlagLine('--debug',
|
||||
|
|
@ -159,7 +159,7 @@ begin
|
|||
AFront.BackendExplicit := False;
|
||||
AFront.SkipDepCodegen := False;
|
||||
AFront.EmitIfaceDir := '';
|
||||
AFront.Incremental := False;
|
||||
AFront.Incremental := True; { default-on; --no-incremental opts out }
|
||||
AFront.UnitCacheDir := '';
|
||||
AOpts.OPDFEnabled := False;
|
||||
AOpts.DebugMode := False;
|
||||
|
|
@ -197,14 +197,15 @@ begin
|
|||
Inc(I);
|
||||
AFront.EmitIfaceDir := ParamStr(I);
|
||||
end
|
||||
else if Arg = '--incremental' then
|
||||
{ Phase 6c-H: compile each source-loaded dep to a stand-alone
|
||||
.o (with embedded iface) as a side effect of the program
|
||||
build. Implies --skip-dep-codegen for the main IR (deps
|
||||
are not inlined; they're linked from the per-unit .o
|
||||
files instead). Next compile auto-discovers the .o's
|
||||
and skips parsing the .pas entirely. }
|
||||
AFront.Incremental := True
|
||||
else if Arg = '--no-incremental' then
|
||||
{ Incremental compilation is the default: each source-loaded dep
|
||||
is compiled to a stand-alone .o (with embedded iface) as a side
|
||||
effect of the program build, implying --skip-dep-codegen for the
|
||||
main IR (deps are not inlined; they're linked from the per-unit
|
||||
.o files instead) and letting the next compile auto-discover the
|
||||
.o's and skip parsing the .pas. --no-incremental disables that
|
||||
and builds a single whole-program object instead. }
|
||||
AFront.Incremental := False
|
||||
else if (Arg = '--unit-cache') and (I < ParamCount()) then
|
||||
begin
|
||||
Inc(I);
|
||||
|
|
@ -428,7 +429,7 @@ var
|
|||
PendingArgs: TStringList; { lookahead token per pending flag ('' if none) }
|
||||
PendIdx: Integer; { drain cursor over the pending lists }
|
||||
PendFlag: string;
|
||||
WorkerDriver: TBackendDriver; { driver for the --incremental worker pool }
|
||||
WorkerDriver: TBackendDriver; { driver for the incremental worker pool }
|
||||
OE: TOPDFEmitter;
|
||||
Loader: TUnitLoader;
|
||||
Units: TObjectList;
|
||||
|
|
@ -446,7 +447,7 @@ var
|
|||
IR: string;
|
||||
IRFile: string;
|
||||
LinkErr: string; { Driver.LinkProgram result ('' on success) }
|
||||
UnitOPath: string; { per-dep .o output path in --incremental mode }
|
||||
UnitOPath: string; { per-dep .o output path in incremental mode }
|
||||
Workers: TObjectList; { TCompileWorker threads for parallel incremental }
|
||||
Worker: TCompileWorker;
|
||||
|
||||
|
|
@ -761,7 +762,8 @@ begin
|
|||
Each unit is compiled in a separate worker thread for parallel
|
||||
codegen + qbe + cc. The symbol table is read-only at this point
|
||||
(semantic analysis is complete), so concurrent reads are safe. }
|
||||
if Incremental and (Units <> nil) and (Units.Count > 0) then
|
||||
if Incremental and (not EmitIR) and (not EmitAsm) and (not DumpAST)
|
||||
and (Units <> nil) and (Units.Count > 0) then
|
||||
begin
|
||||
{ Pick a driver for the workers. Prefer the top-program backend
|
||||
when it supports per-unit emission; otherwise fall back to QBE —
|
||||
|
|
@ -835,7 +837,19 @@ begin
|
|||
CG.SetSymbolTable(Prog.SymbolTable);
|
||||
if not SkipDepCodegen then
|
||||
for I := 0 to Units.Count - 1 do
|
||||
CG.AppendUnit(TUnit(Units.Items[I]));
|
||||
CG.AppendUnit(TUnit(Units.Items[I]))
|
||||
else
|
||||
{ Incremental / separate-compilation: dep bodies are compiled into
|
||||
their own objects, so AppendUnit is skipped here. But the program
|
||||
startup must still call each dep unit's <Unit>_init if it has an
|
||||
initialization section, in dependency order — otherwise unit
|
||||
initialization silently never runs. Register the init-unit names
|
||||
so AppendProgram's $main emits the calls (they resolve against the
|
||||
<Unit>_init symbols exported by the per-unit objects). }
|
||||
for I := 0 to Units.Count - 1 do
|
||||
CG.NoteDepInitUnit(TUnit(Units.Items[I]).Name,
|
||||
(TUnit(Units.Items[I]).InitStmts <> nil) and
|
||||
(TUnit(Units.Items[I]).InitStmts.Count > 0));
|
||||
CG.AppendProgram(Prog);
|
||||
end
|
||||
else
|
||||
|
|
|
|||
|
|
@ -88,6 +88,12 @@ type
|
|||
into one assembly text retrieved via GetOutput. }
|
||||
procedure AppendUnit(AUnit: TUnit);
|
||||
procedure AppendProgram(AProg: TProgram);
|
||||
{ Separate-compilation init-call registration: record a dep unit whose body
|
||||
is compiled elsewhere so $main still calls its <Unit>_init. Concrete
|
||||
backends that maintain an init-call list override this; the default is a
|
||||
no-op. }
|
||||
procedure NoteDepInitUnit(const AUnitName: string;
|
||||
AHasInit: Boolean); virtual;
|
||||
function GetOutput: string;
|
||||
|
||||
procedure SetSymbolTable(ASymTable: TSymbolTable);
|
||||
|
|
@ -345,6 +351,12 @@ begin
|
|||
Self.EmitProgram(AProg);
|
||||
end;
|
||||
|
||||
procedure TNativeBackend.NoteDepInitUnit(const AUnitName: string;
|
||||
AHasInit: Boolean);
|
||||
begin
|
||||
{ Default: no init-call list to maintain. The x86_64 backend overrides. }
|
||||
end;
|
||||
|
||||
function TNativeBackend.GetOutput: string;
|
||||
begin
|
||||
if FSeparateCompile and (not FFinalized) then
|
||||
|
|
|
|||
|
|
@ -65,6 +65,7 @@ type
|
|||
function GetDebugFacts: TDbgFacts;
|
||||
procedure AppendUnit(AUnit: TUnit);
|
||||
procedure AppendProgram(AProg: TProgram);
|
||||
procedure NoteDepInitUnit(const AUnitName: string; AHasInit: Boolean);
|
||||
function GetOutput: string;
|
||||
end;
|
||||
|
||||
|
|
@ -187,6 +188,12 @@ begin
|
|||
FBackend.AppendProgram(AProg);
|
||||
end;
|
||||
|
||||
procedure TCodeGenNative.NoteDepInitUnit(const AUnitName: string; AHasInit: Boolean);
|
||||
begin
|
||||
Self.EnsureBackend();
|
||||
FBackend.NoteDepInitUnit(AUnitName, AHasInit);
|
||||
end;
|
||||
|
||||
function TCodeGenNative.GetOutput: string;
|
||||
begin
|
||||
Result := FBackend.GetOutput();
|
||||
|
|
|
|||
|
|
@ -353,6 +353,8 @@ type
|
|||
|
||||
procedure EmitProgram(AProg: TProgram); override;
|
||||
procedure EmitUnit(AUnit: TUnit); override;
|
||||
procedure NoteDepInitUnit(const AUnitName: string;
|
||||
AHasInit: Boolean); override;
|
||||
procedure FinalizeEmit; override;
|
||||
{ Emit a standalone procedure/function definition. AExported controls
|
||||
whether the symbol gets .globl visibility (True by default). In
|
||||
|
|
@ -15419,6 +15421,16 @@ begin
|
|||
AUnit.GenericIntfInstances, UnitSym);
|
||||
end;
|
||||
|
||||
procedure TX86_64Backend.NoteDepInitUnit(const AUnitName: string;
|
||||
AHasInit: Boolean);
|
||||
begin
|
||||
{ Separate-compilation: the dep's body (and its <Unit>_init) is in its own
|
||||
object; record the mangled name so EmitProgram's $main calls it. Mangling
|
||||
matches EmitUnit's FUnitInitNames.Add(NativeMangle(AUnit.Name)). }
|
||||
if AHasInit then
|
||||
FUnitInitNames.Add(NativeMangle(AUnitName));
|
||||
end;
|
||||
|
||||
procedure TX86_64Backend.FinalizeEmit;
|
||||
begin
|
||||
if FFinalized then Exit;
|
||||
|
|
|
|||
|
|
@ -75,6 +75,17 @@ type
|
|||
{ Append program IR after one or more AppendUnit calls. }
|
||||
procedure AppendProgram(AProg: TProgram);
|
||||
|
||||
{ Incremental / separate-compilation: when a dependency unit's BODY is
|
||||
compiled elsewhere (its own .o) and therefore NOT emitted here via
|
||||
AppendUnit, the program startup must still call that unit's
|
||||
<Unit>_init() if it has an initialization section. This registers the
|
||||
unit name into the init-call list (in dependency order) WITHOUT emitting
|
||||
any body, so AppendProgram's $main emits `call $<Unit>_init()` and the
|
||||
call resolves against the symbol exported by the per-unit object.
|
||||
AHasInit selects whether the unit actually has an init section; units
|
||||
without one are skipped (no spurious call). }
|
||||
procedure NoteDepInitUnit(const AUnitName: string; AHasInit: Boolean);
|
||||
|
||||
{ Retrieve the complete generated output (QBE IR text for the QBE
|
||||
backend; target assembly text for the native backend). }
|
||||
function GetOutput: string;
|
||||
|
|
|
|||
|
|
@ -518,6 +518,7 @@ type
|
|||
{ Append program IR to existing output (companion to AppendUnit).
|
||||
Emits any remaining string literals and the $main function. }
|
||||
procedure AppendProgram(AProg: TProgram);
|
||||
procedure NoteDepInitUnit(const AUnitName: string; AHasInit: Boolean);
|
||||
function GetOutput: string;
|
||||
end;
|
||||
|
||||
|
|
@ -13875,6 +13876,15 @@ begin
|
|||
end;
|
||||
end;
|
||||
|
||||
procedure TCodeGenQBE.NoteDepInitUnit(const AUnitName: string; AHasInit: Boolean);
|
||||
begin
|
||||
{ Separate-compilation: the dep's body (and its $<Unit>_init) is emitted in
|
||||
its own object; record the name so AppendProgram's $main calls it. The
|
||||
QBE init symbol is the bare unit name + '_init' (see AppendUnit). }
|
||||
if AHasInit then
|
||||
FUnitInitNames.Add(AUnitName);
|
||||
end;
|
||||
|
||||
procedure TCodeGenQBE.AppendProgram(AProg: TProgram);
|
||||
var
|
||||
Body: TIRBuffer;
|
||||
|
|
|
|||
|
|
@ -48,6 +48,7 @@ type
|
|||
procedure TestUninstantiatedGenericFunc_InUnit_Compiles;
|
||||
procedure TestDuplicateExternalAcrossUnits_Compiles;
|
||||
procedure TestNativeIncremental_MultiUnitClass_Compiles;
|
||||
procedure TestNativeNoIncremental_MultiUnitClass_Compiles;
|
||||
end;
|
||||
|
||||
implementation
|
||||
|
|
@ -438,10 +439,12 @@ begin
|
|||
end;
|
||||
|
||||
procedure TSepCompileTests.TestNativeIncremental_MultiUnitClass_Compiles;
|
||||
{ The native backend supports --incremental (per-unit .o + embedded .bif) the
|
||||
same as QBE. Compile a program using a unit that declares a class (exercises
|
||||
the system-def suppression + global typeinfo_TObject and per-unit string
|
||||
literals in the unit object), then run it. A unit .o must be left behind. }
|
||||
{ Incremental compilation (per-unit .o + embedded .bif) is the DEFAULT on the
|
||||
native backend (as it is on QBE). Compile a program using a unit that
|
||||
declares a class (exercises the system-def suppression + global
|
||||
typeinfo_TObject and per-unit string literals in the unit object) WITHOUT any
|
||||
--incremental flag — the default path must produce a working binary and leave
|
||||
a per-unit .o behind. }
|
||||
const
|
||||
UnitSrc =
|
||||
'''
|
||||
|
|
@ -497,7 +500,7 @@ begin
|
|||
DeleteFile(UnitObj);
|
||||
|
||||
Rc := RunBlaise(['--source', ProgPas, '--output', ProgBin,
|
||||
'--backend', 'native', '--incremental',
|
||||
'--backend', 'native',
|
||||
'--unit-path', FScratch], Captured);
|
||||
AssertEquals('blaise(use_shapes) exit code (out: ' + Captured + ')', 0, Rc);
|
||||
AssertTrue('use_shapes exists', FileExists(ProgBin));
|
||||
|
|
@ -508,6 +511,74 @@ begin
|
|||
AssertEquals('use_shapes stdout', 'shape:box' + #10, Captured)
|
||||
end;
|
||||
|
||||
procedure TSepCompileTests.TestNativeNoIncremental_MultiUnitClass_Compiles;
|
||||
{ --no-incremental opts out of the default per-unit .o emission: the same
|
||||
multi-unit-class program must still compile and run as a single whole-program
|
||||
object, and NO per-unit .o is left behind. }
|
||||
const
|
||||
UnitSrc =
|
||||
'''
|
||||
unit ShapesU;
|
||||
interface
|
||||
type
|
||||
TShape = class
|
||||
Name: string;
|
||||
function Describe: string;
|
||||
end;
|
||||
implementation
|
||||
function TShape.Describe: string;
|
||||
begin Result := 'shape:' + Name end;
|
||||
end.
|
||||
''';
|
||||
ProgSrc =
|
||||
'''
|
||||
program UseShapes;
|
||||
uses ShapesU;
|
||||
var S: TShape;
|
||||
begin
|
||||
S := TShape.Create();
|
||||
S.Name := 'box';
|
||||
WriteLn(S.Describe());
|
||||
S.Free()
|
||||
end.
|
||||
''';
|
||||
var
|
||||
UnitPas, ProgPas, ProgBin, UnitObj: string;
|
||||
Captured: string;
|
||||
Rc: Integer;
|
||||
begin
|
||||
if not ToolchainAvailable() then
|
||||
begin
|
||||
Fail('toolchain missing — qbe or RTL not found');
|
||||
Exit
|
||||
end;
|
||||
if not FileExists(BlaisePath()) then
|
||||
begin
|
||||
Fail('blaise binary missing at ' + BlaisePath());
|
||||
Exit
|
||||
end;
|
||||
|
||||
UnitPas := FScratch + '/ShapesU.pas';
|
||||
ProgPas := FScratch + '/use_shapes_ni.pas';
|
||||
ProgBin := FScratch + '/use_shapes_ni';
|
||||
UnitObj := FScratch + '/shapesu.o';
|
||||
|
||||
WriteFile(UnitPas, UnitSrc);
|
||||
WriteFile(ProgPas, ProgSrc);
|
||||
DeleteFile(UnitObj);
|
||||
|
||||
Rc := RunBlaise(['--source', ProgPas, '--output', ProgBin,
|
||||
'--backend', 'native', '--no-incremental',
|
||||
'--unit-path', FScratch], Captured);
|
||||
AssertEquals('blaise(use_shapes_ni) exit code (out: ' + Captured + ')', 0, Rc);
|
||||
AssertTrue('use_shapes_ni exists', FileExists(ProgBin));
|
||||
AssertFalse('no per-unit ShapesU.o with --no-incremental', FileExists(UnitObj));
|
||||
|
||||
Rc := RunBinary(ProgBin, Captured);
|
||||
AssertEquals('use_shapes_ni exit code', 0, Rc);
|
||||
AssertEquals('use_shapes_ni stdout', 'shape:box' + #10, Captured)
|
||||
end;
|
||||
|
||||
initialization
|
||||
RegisterTest(TSepCompileTests);
|
||||
|
||||
|
|
|
|||
|
|
@ -27,7 +27,6 @@ type
|
|||
TRecordReturnTests = class(TTestCase)
|
||||
private
|
||||
function GenIR(const ASrc: string): string;
|
||||
function GenIRWin64(const ASrc: string): string;
|
||||
published
|
||||
{ rcInt1: one-field POD records return typed }
|
||||
procedure TestCodegen_OneIntegerField_ReturnsW;
|
||||
|
|
@ -76,21 +75,6 @@ type
|
|||
procedure TestCodegen_IntegerPlusDouble_UsesIntSSE;
|
||||
procedure TestCodegen_DoublePlusInt64_UsesSSEInt;
|
||||
procedure TestCodegen_Int64PlusDouble_UsesIntSSE;
|
||||
|
||||
{ Win64 ABI: all POD records use rcWin64Agg — declare aggregate
|
||||
return, let qbe -t amd64_win lower to rax-pack (sizes 1/2/4/8)
|
||||
or hidden-pointer sret (everything else). Single uniform IR
|
||||
shape independent of size or int/float content; the SysV-only
|
||||
multi-register classes are unreachable on osWindows. Managed
|
||||
records still go through rcSret. }
|
||||
procedure TestCodegen_Win64_OneDoubleField_UsesAggregate;
|
||||
procedure TestCodegen_Win64_OneSingleField_UsesAggregate;
|
||||
procedure TestCodegen_Win64_OneIntegerField_UsesAggregate;
|
||||
procedure TestCodegen_Win64_TwoInt64Fields_UsesAggregate;
|
||||
procedure TestCodegen_Win64_TwoDoubleFields_UsesAggregate;
|
||||
procedure TestCodegen_Win64_IntegerPlusDouble_UsesAggregate;
|
||||
procedure TestCodegen_Win64_StringField_StaysOnSret;
|
||||
procedure TestCodegen_Win64_OneDoubleField_CallerMemcpy;
|
||||
end;
|
||||
|
||||
implementation
|
||||
|
|
@ -795,204 +779,6 @@ begin
|
|||
AssertContains('type :_ffi_TM = align 8 { l, d }', IR);
|
||||
end;
|
||||
|
||||
{ --- Win64 reg-return classification --- }
|
||||
|
||||
{ Helper: run GenIR with GTarget temporarily flipped to windows-x86_64,
|
||||
restoring the host target afterwards. Whole-program codegen is
|
||||
sequential and GTarget is a unit-level global, so this is safe inside
|
||||
a single test method. }
|
||||
function TRecordReturnTests.GenIRWin64(const ASrc: string): string;
|
||||
var
|
||||
Saved: TTargetDesc;
|
||||
begin
|
||||
Saved := GTarget;
|
||||
try
|
||||
MakeTarget(osWindows, cpuX86_64, GTarget);
|
||||
Result := GenIR(ASrc);
|
||||
finally
|
||||
GTarget := Saved;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TRecordReturnTests.TestCodegen_Win64_OneDoubleField_UsesAggregate;
|
||||
var IR: string;
|
||||
begin
|
||||
{ SysV path: rcSSE1 -> `function d` (xmm0). Win64 path: rcWin64Agg
|
||||
-> `function :_ffi_TD`. qbe -t amd64_win lowers the aggregate to
|
||||
a Kl load into RAX (8B composite return). }
|
||||
IR := GenIRWin64(
|
||||
'''
|
||||
program P;
|
||||
type TD = record V: Double; end;
|
||||
function MakeIt(): TD;
|
||||
begin
|
||||
Result.V := 1.5
|
||||
end;
|
||||
begin
|
||||
end.
|
||||
''');
|
||||
AssertContains('function :_ffi_TD $MakeIt(', IR);
|
||||
AssertContains('type :_ffi_TD = align 8 { d }', IR);
|
||||
AssertEquals(-1, Pos('function d $MakeIt(', IR));
|
||||
AssertEquals(-1, Pos('l %_par__sret', IR));
|
||||
end;
|
||||
|
||||
procedure TRecordReturnTests.TestCodegen_Win64_OneSingleField_UsesAggregate;
|
||||
var IR: string;
|
||||
begin
|
||||
{ SysV: rcSSE1 -> `function s` (xmm0). Win64: rcWin64Agg ->
|
||||
`function :_ffi_TS`; qbe -t amd64_win packs the 4B aggregate into
|
||||
EAX (RAX low 32 bits). }
|
||||
IR := GenIRWin64(
|
||||
'''
|
||||
program P;
|
||||
type TS = record V: Single; end;
|
||||
function MakeIt(): TS;
|
||||
begin
|
||||
Result.V := 1.0
|
||||
end;
|
||||
begin
|
||||
end.
|
||||
''');
|
||||
AssertContains('function :_ffi_TS $MakeIt(', IR);
|
||||
AssertContains('type :_ffi_TS = align 4 { s }', IR);
|
||||
AssertEquals(-1, Pos('function s $MakeIt(', IR));
|
||||
AssertEquals(-1, Pos('l %_par__sret', IR));
|
||||
end;
|
||||
|
||||
procedure TRecordReturnTests.TestCodegen_Win64_OneIntegerField_UsesAggregate;
|
||||
var IR: string;
|
||||
begin
|
||||
{ Integer-class 4B record: SysV picks rcInt1 (`function w` -> EAX),
|
||||
Win64 picks rcWin64Agg (`function :_ffi_TI` -> EAX via the qbe
|
||||
amd64_win aggregate path). Both end up in the same register, but
|
||||
the IR shape differs. }
|
||||
IR := GenIRWin64(
|
||||
'''
|
||||
program P;
|
||||
type TI = record X: Integer; end;
|
||||
function MakeIt(): TI;
|
||||
begin
|
||||
Result.X := 42
|
||||
end;
|
||||
begin
|
||||
end.
|
||||
''');
|
||||
AssertContains('function :_ffi_TI $MakeIt(', IR);
|
||||
AssertContains('type :_ffi_TI = align 4 { w }', IR);
|
||||
AssertEquals(-1, Pos('l %_par__sret', IR));
|
||||
end;
|
||||
|
||||
procedure TRecordReturnTests.TestCodegen_Win64_TwoInt64Fields_UsesAggregate;
|
||||
var IR: string;
|
||||
begin
|
||||
{ 16B record: qbe -t amd64_win sees size > 8 in type_is_by_copy and
|
||||
synthesises the hidden first-arg out-pointer itself; from our IR
|
||||
perspective it's still the aggregate-return shape. }
|
||||
IR := GenIRWin64(
|
||||
'''
|
||||
program P;
|
||||
type TLL = record A, B: Int64; end;
|
||||
function MakeIt(): TLL;
|
||||
begin
|
||||
Result.A := 1;
|
||||
Result.B := 2
|
||||
end;
|
||||
begin
|
||||
end.
|
||||
''');
|
||||
AssertContains('function :_ffi_TLL $MakeIt(', IR);
|
||||
AssertContains('type :_ffi_TLL = align 8 { l, l }', IR);
|
||||
AssertEquals(-1, Pos('l %_par__sret', IR));
|
||||
end;
|
||||
|
||||
procedure TRecordReturnTests.TestCodegen_Win64_TwoDoubleFields_UsesAggregate;
|
||||
var IR: string;
|
||||
begin
|
||||
IR := GenIRWin64(
|
||||
'''
|
||||
program P;
|
||||
type TDD = record A, B: Double; end;
|
||||
function MakeIt(): TDD;
|
||||
begin
|
||||
Result.A := 1.0;
|
||||
Result.B := 2.0
|
||||
end;
|
||||
begin
|
||||
end.
|
||||
''');
|
||||
AssertContains('function :_ffi_TDD $MakeIt(', IR);
|
||||
AssertContains('type :_ffi_TDD = align 8 { d, d }', IR);
|
||||
AssertEquals(-1, Pos('l %_par__sret', IR));
|
||||
end;
|
||||
|
||||
procedure TRecordReturnTests.TestCodegen_Win64_IntegerPlusDouble_UsesAggregate;
|
||||
var IR: string;
|
||||
begin
|
||||
{ SysV: rcIntSSE (rax+xmm0). Win64: rcWin64Agg; the aggregate-return
|
||||
path lets qbe -t amd64_win lower this to a hidden-pointer sret
|
||||
(size 16, not in [1,2,4,8]). Same IR shape either way. }
|
||||
IR := GenIRWin64(
|
||||
'''
|
||||
program P;
|
||||
type TID = record I: Integer; D: Double; end;
|
||||
function MakeIt(): TID;
|
||||
begin
|
||||
Result.I := 1;
|
||||
Result.D := 2.0
|
||||
end;
|
||||
begin
|
||||
end.
|
||||
''');
|
||||
AssertContains('function :_ffi_TID $MakeIt(', IR);
|
||||
AssertContains('type :_ffi_TID = align 8 { w, d }', IR);
|
||||
AssertEquals(-1, Pos('l %_par__sret', IR));
|
||||
end;
|
||||
|
||||
procedure TRecordReturnTests.TestCodegen_Win64_StringField_StaysOnSret;
|
||||
var IR: string;
|
||||
begin
|
||||
{ Managed records continue to use the explicit sret path on Win64 —
|
||||
the ARC bookkeeping at field-store time needs the caller's actual
|
||||
storage. rcWin64Agg is gated by IsRecordManagedClean. }
|
||||
IR := GenIRWin64(
|
||||
'''
|
||||
program P;
|
||||
type TStr = record S: string; end;
|
||||
function MakeIt(): TStr;
|
||||
begin
|
||||
Result.S := 'hello'
|
||||
end;
|
||||
begin
|
||||
end.
|
||||
''');
|
||||
AssertContains('function $MakeIt(l %_par__sret', IR);
|
||||
AssertEquals(-1, Pos('function :_ffi_TStr', IR));
|
||||
end;
|
||||
|
||||
procedure TRecordReturnTests.TestCodegen_Win64_OneDoubleField_CallerMemcpy;
|
||||
var IR: string;
|
||||
begin
|
||||
{ Caller-side: aggregate-typed call capture, then memcpy bytes to
|
||||
the destination — the same decomposition pattern used by the SysV
|
||||
rcInt2/rcSSE*/rcIntSSE classes. }
|
||||
IR := GenIRWin64(
|
||||
'''
|
||||
program P;
|
||||
type TD = record V: Double; end;
|
||||
var R: TD;
|
||||
function MakeIt(): TD;
|
||||
begin
|
||||
Result.V := 2.5
|
||||
end;
|
||||
begin
|
||||
R := MakeIt()
|
||||
end.
|
||||
''');
|
||||
AssertContains('=:_ffi_TD call $MakeIt', IR);
|
||||
AssertContains('call $memcpy(l $R', IR);
|
||||
end;
|
||||
|
||||
initialization
|
||||
RegisterTest(TRecordReturnTests);
|
||||
|
||||
|
|
|
|||
Loading…
Reference in a new issue