administrator/blaise
1
0
Fork 0
Code Issues Pull requests Actions Packages Projects Releases Wiki Activity

feat(native): caller-side const-string ARC + unified call-arg hoist region

Browse source 
Port the QBE backend's shape-aware const-string argument convention to
the native x86-64 backend: const params of any kind no longer get the
callee entry-retain/exit-release pair; the caller protects string
arguments by shape (borrowed / consume / pin — see
blaise.codegen.arcshapes.TConstArgMode).  Both backends now share one
convention, which also makes native calls into the QBE-compiled RTL
consistent for const params.

The pin slots live in a unified pre-call hoist region (EmitArgHoist)
shared with open-array literal blocks and — new — the sret buffers of
record-returning call arguments.  Every call path emits the same
region + post-call epilogue (string releases, record-temp field
releases, reclaim) with the call's return registers preserved:
direct calls, method calls (both strategies), constructor calls,
interface dispatch (var flags from TInterfaceTypeDesc mark positions
to skip; shape protection is applied to every string-typed value arg
since const-ness is invisible there), proc-pointer and method-pointer
calls (TProcParamInfo const flags), inherited calls, and the three
sret call paths (dest pointer saved below the region so %rsp-relative
dest operands cannot drift).

The address-taken walkers move to the shared unit
blaise.codegen.arcshapes (QBE IR output is byte-identical); the native
backend rebuilds its borrowed-argument blocklist per function from
them, mirroring the QBE backend's FConstArgUnsafe.

Bugs found by the new tests and the natively-compiled TestRunner,
fixed here (native backend, all pre-existing):
- record-returning calls as arguments interleaved their sret buffer
  between pushed argument slots (garbage args); the hoist fixes this
  and EmitSretArgReleases is gone
- callee prologue copied record/static-array value params via memcpy
  before spilling later argument registers (memcpy clobbered them);
  spills now run in two phases
- >6-slot method calls forwarded var/out params by slot address
  instead of the held pointer (no ParamMode check)
- TStringLiteral ignored IsCharCoerce: S[I] = ',' compared the
  literal's data pointer against the byte
- EmitNarrowToType truncated pointer-shaped values (class casts) to
  32 bits
- IntByteSize defaulted nil/unmapped kinds to 4 bytes (QBE uses 'l');
  forward-class fields loaded half a pointer
- EmitCallIndirect/EmitMethodPtrCall loaded the target into %r10/%r11
  before argument evaluation (caller-saved clobber window)
- EmitCall's push/pop loop used a stale ParamType from the counting
  loop

Tests: cp.test.nativeconstarg (12 asm-level shape tests incl. the
callee-pair flip) and cp.test.e2e.constarg (21 runtime parity tests on
both backends).  Full suite 2903 OK on the working and fixpoint
binaries; FIXPOINT_OK; NATIVE_FIXPOINT_OK; natively-compiled
TestRunner green except two pre-existing generic-template round-trip
failures (bugs.txt).
This commit is contained in:
Graeme Geldenhuys 2026-06-11 04:04:39 +01:00
parent 17c14b37aa
commit 434058ceda
6 changed files with 2252 additions and 507 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

314
compiler/src/main/pascal/blaise.codegen.arcshapes.pas Normal file
View file

@ -0,0 +1,314 @@
{
Blaise - An Object Pascal Compiler
Copyright (c) 2026 Graeme Geldenhuys
SPDX-License-Identifier: Apache-2.0 WITH Swift-exception
Licensed under the Apache License v2.0 with Runtime Library Exception.
See LICENSE file in the project root for full license terms.
}
unit blaise.codegen.arcshapes;
{ Backend-independent ARC shape analysis shared by the QBE and native code
generators.
TConstArgMode classifies how a caller must protect a const-string argument
for the duration of a call once the callee no longer retains const params:
camBorrowed — the argument's buffer is guaranteed to outlive the call
without help (string literals, named consts, plain
non-aliased local variables): emit no ARC ops at all.
camConsume — the argument is a +1 owned temporary (function/method/
getter return): emit no AddRef, ONE release after the
call consumes the temp.
camPin — anything aliasable or unowned (globals, fields, concat
transients, address-taken or captured locals): AddRef
before the call, release after.
CollectAddressTaken walks a function body and returns every local whose
address escapes — via explicit @, or by being passed to a var/out param.
Both backends use it: the QBE backend for mem2reg promotion and the
borrowed-argument blocklist, the native backend for the borrowed-argument
blocklist. }
interface
uses
Classes, SysUtils, uAST;
type
TConstArgMode = (camPin, camBorrowed, camConsume);
procedure CollectAddressTakenExpr(AExpr: TASTExpr; ASet: TStringList);
procedure CollectAddressTakenStmt(AStmt: TASTStmt; ASet: TStringList);
{ Returns a new sorted, case-sensitive, dup-ignoring list; caller frees. }
function CollectAddressTaken(ABlock: TBlock): TStringList;
implementation
procedure CollectAddressTakenExpr(AExpr: TASTExpr; ASet: TStringList);
var
I: Integer;
FC: TFuncCallExpr;
MC: TMethodCallExpr;
FA: TFieldAccessExpr;
Param: TMethodParam;
Arg: TASTExpr;
begin
if AExpr = nil then Exit;
{ @X — explicit address-of }
if AExpr is TAddrOfExpr then
begin
if TAddrOfExpr(AExpr).Expr is TIdentExpr then
ASet.Add(TIdentExpr(TAddrOfExpr(AExpr).Expr).Name);
CollectAddressTakenExpr(TAddrOfExpr(AExpr).Expr, ASet);
Exit;
end;
{ Function call: var params take the address of their actual argument }
if AExpr is TFuncCallExpr then
begin
FC := TFuncCallExpr(AExpr);
if FC.ResolvedDecl <> nil then
begin
for I := 0 to FC.Args.Count - 1 do
begin
Arg := TASTExpr(FC.Args.Items[I]);
if I < TMethodDecl(FC.ResolvedDecl).Params.Count then
begin
Param := TMethodParam(TMethodDecl(FC.ResolvedDecl).Params.Items[I]);
if Param.IsVarParam and (Arg is TIdentExpr) and not TIdentExpr(Arg).IsGlobal then
ASet.Add(TIdentExpr(Arg).Name);
end;
CollectAddressTakenExpr(Arg, ASet);
end;
end
else
for I := 0 to FC.Args.Count - 1 do
CollectAddressTakenExpr(TASTExpr(FC.Args.Items[I]), ASet);
Exit;
end;
{ Method call: same var-param check }
if AExpr is TMethodCallExpr then
begin
MC := TMethodCallExpr(AExpr);
CollectAddressTakenExpr(MC.ObjExpr, ASet);
if MC.ResolvedMethod <> nil then
begin
for I := 0 to MC.Args.Count - 1 do
begin
Arg := TASTExpr(MC.Args.Items[I]);
if I < TMethodDecl(MC.ResolvedMethod).Params.Count then
begin
Param := TMethodParam(TMethodDecl(MC.ResolvedMethod).Params.Items[I]);
if Param.IsVarParam and (Arg is TIdentExpr) and not TIdentExpr(Arg).IsGlobal then
ASet.Add(TIdentExpr(Arg).Name);
end;
CollectAddressTakenExpr(Arg, ASet);
end;
end
else
for I := 0 to MC.Args.Count - 1 do
CollectAddressTakenExpr(TASTExpr(MC.Args.Items[I]), ASet);
Exit;
end;
{ Recurse into common composite expressions }
if AExpr is TBinaryExpr then
begin
CollectAddressTakenExpr(TBinaryExpr(AExpr).Left, ASet);
CollectAddressTakenExpr(TBinaryExpr(AExpr).Right, ASet);
end
else if AExpr is TNotExpr then
CollectAddressTakenExpr(TNotExpr(AExpr).Expr, ASet)
else if AExpr is TFieldAccessExpr then
begin
FA := TFieldAccessExpr(AExpr);
CollectAddressTakenExpr(FA.Base, ASet);
if FA.PropIndexExpr <> nil then
CollectAddressTakenExpr(FA.PropIndexExpr, ASet);
end
else if AExpr is TDerefExpr then
CollectAddressTakenExpr(TDerefExpr(AExpr).Expr, ASet)
else if AExpr is TStringSubscriptExpr then
begin
CollectAddressTakenExpr(TStringSubscriptExpr(AExpr).StrExpr, ASet);
CollectAddressTakenExpr(TStringSubscriptExpr(AExpr).IndexExpr, ASet);
end
else if AExpr is TIsExpr then
CollectAddressTakenExpr(TIsExpr(AExpr).Obj, ASet)
else if AExpr is TAsExpr then
CollectAddressTakenExpr(TAsExpr(AExpr).Obj, ASet)
else if AExpr is TSupportsExpr then
CollectAddressTakenExpr(TSupportsExpr(AExpr).Obj, ASet)
else if AExpr is TArrayLiteralExpr then
for I := 0 to TArrayLiteralExpr(AExpr).Elements.Count - 1 do
CollectAddressTakenExpr(TASTExpr(TArrayLiteralExpr(AExpr).Elements.Items[I]), ASet);
end;
procedure CollectAddressTakenStmt(AStmt: TASTStmt; ASet: TStringList);
var
I: Integer;
TryE: TTryExceptStmt;
TryF: TTryFinallyStmt;
RaiseS: TRaiseStmt;
CaseS: TCaseStmt;
PWrite: TPointerWriteStmt;
SSubA: TStaticSubscriptAssign;
PCall: TProcCall;
MCall: TMethodCallStmt;
ICall: TInheritedCallStmt;
ForS: TForStmt;
begin
if AStmt = nil then Exit;
if AStmt is TCompoundStmt then
begin
for I := 0 to TCompoundStmt(AStmt).Stmts.Count - 1 do
CollectAddressTakenStmt(TASTStmt(TCompoundStmt(AStmt).Stmts.Items[I]), ASet);
end
else if AStmt is TIfStmt then
begin
CollectAddressTakenExpr(TIfStmt(AStmt).Condition, ASet);
CollectAddressTakenStmt(TIfStmt(AStmt).ThenStmt, ASet);
CollectAddressTakenStmt(TIfStmt(AStmt).ElseStmt, ASet);
end
else if AStmt is TWhileStmt then
begin
CollectAddressTakenExpr(TWhileStmt(AStmt).Condition, ASet);
CollectAddressTakenStmt(TWhileStmt(AStmt).Body, ASet);
end
else if AStmt is TRepeatStmt then
begin
CollectAddressTakenExpr(TRepeatStmt(AStmt).Condition, ASet);
CollectAddressTakenStmt(TRepeatStmt(AStmt).Body, ASet);
end
else if AStmt is TForStmt then
begin
ForS := TForStmt(AStmt);
CollectAddressTakenExpr(ForS.StartExpr, ASet);
CollectAddressTakenExpr(ForS.EndExpr, ASet);
CollectAddressTakenStmt(ForS.Body, ASet);
end
else if AStmt is TForInStmt then
begin
CollectAddressTakenExpr(TForInStmt(AStmt).CollExpr, ASet);
CollectAddressTakenStmt(TForInStmt(AStmt).Body, ASet);
end
else if AStmt is TAssignment then
CollectAddressTakenExpr(TAssignment(AStmt).Expr, ASet)
else if AStmt is TFieldAssignment then
CollectAddressTakenExpr(TFieldAssignment(AStmt).Expr, ASet)
else if AStmt is TMethodCallStmt then
begin
MCall := TMethodCallStmt(AStmt);
CollectAddressTakenExpr(MCall.ObjExpr, ASet);
if MCall.ResolvedMethod <> nil then
for I := 0 to MCall.Args.Count - 1 do
begin
if I < TMethodDecl(MCall.ResolvedMethod).Params.Count then
if TMethodParam(TMethodDecl(MCall.ResolvedMethod).Params.Items[I]).IsVarParam and
(TASTExpr(MCall.Args.Items[I]) is TIdentExpr) and
not TIdentExpr(TASTExpr(MCall.Args.Items[I])).IsGlobal then
ASet.Add(TIdentExpr(TASTExpr(MCall.Args.Items[I])).Name);
CollectAddressTakenExpr(TASTExpr(MCall.Args.Items[I]), ASet);
end
else
for I := 0 to MCall.Args.Count - 1 do
CollectAddressTakenExpr(TASTExpr(MCall.Args.Items[I]), ASet);
end
else if AStmt is TProcCall then
begin
PCall := TProcCall(AStmt);
if PCall.ResolvedDecl <> nil then
for I := 0 to PCall.Args.Count - 1 do
begin
if I < TMethodDecl(PCall.ResolvedDecl).Params.Count then
if TMethodParam(TMethodDecl(PCall.ResolvedDecl).Params.Items[I]).IsVarParam and
(TASTExpr(PCall.Args.Items[I]) is TIdentExpr) and
not TIdentExpr(TASTExpr(PCall.Args.Items[I])).IsGlobal then
ASet.Add(TIdentExpr(TASTExpr(PCall.Args.Items[I])).Name);
CollectAddressTakenExpr(TASTExpr(PCall.Args.Items[I]), ASet);
end
else
for I := 0 to PCall.Args.Count - 1 do
CollectAddressTakenExpr(TASTExpr(PCall.Args.Items[I]), ASet);
end
else if AStmt is TInheritedCallStmt then
begin
ICall := TInheritedCallStmt(AStmt);
if ICall.ResolvedMethod <> nil then
for I := 0 to ICall.Args.Count - 1 do
begin
if I < TMethodDecl(ICall.ResolvedMethod).Params.Count then
if TMethodParam(TMethodDecl(ICall.ResolvedMethod).Params.Items[I]).IsVarParam and
(TASTExpr(ICall.Args.Items[I]) is TIdentExpr) and
not TIdentExpr(TASTExpr(ICall.Args.Items[I])).IsGlobal then
ASet.Add(TIdentExpr(TASTExpr(ICall.Args.Items[I])).Name);
CollectAddressTakenExpr(TASTExpr(ICall.Args.Items[I]), ASet);
end
else
for I := 0 to ICall.Args.Count - 1 do
CollectAddressTakenExpr(TASTExpr(ICall.Args.Items[I]), ASet);
end
else if AStmt is TTryFinallyStmt then
begin
TryF := TTryFinallyStmt(AStmt);
CollectAddressTakenStmt(TryF.TryBody, ASet);
CollectAddressTakenStmt(TryF.FinallyBody, ASet);
end
else if AStmt is TTryExceptStmt then
begin
TryE := TTryExceptStmt(AStmt);
CollectAddressTakenStmt(TryE.TryBody, ASet);
for I := 0 to TryE.Handlers.Count - 1 do
CollectAddressTakenStmt(TExceptHandlerClause(TryE.Handlers.Items[I]).Body, ASet);
CollectAddressTakenStmt(TryE.ElseBody, ASet);
CollectAddressTakenStmt(TryE.ExceptBody, ASet);
end
else if AStmt is TRaiseStmt then
begin
RaiseS := TRaiseStmt(AStmt);
CollectAddressTakenExpr(RaiseS.Expr, ASet);
end
else if AStmt is TCaseStmt then
begin
CaseS := TCaseStmt(AStmt);
CollectAddressTakenExpr(CaseS.Selector, ASet);
for I := 0 to CaseS.Branches.Count - 1 do
CollectAddressTakenStmt(TCaseBranch(CaseS.Branches.Items[I]).Stmt, ASet);
CollectAddressTakenStmt(CaseS.ElseStmt, ASet);
end
else if AStmt is TPointerWriteStmt then
begin
PWrite := TPointerWriteStmt(AStmt);
CollectAddressTakenExpr(PWrite.PtrExpr, ASet);
CollectAddressTakenExpr(PWrite.ValExpr, ASet);
end
else if AStmt is TStaticSubscriptAssign then
begin
SSubA := TStaticSubscriptAssign(AStmt);
CollectAddressTakenExpr(SSubA.IndexExpr, ASet);
CollectAddressTakenExpr(SSubA.ValueExpr, ASet);
end
else if (AStmt is TExitStmt) and (TExitStmt(AStmt).ResultAssign <> nil) then
{ Exit(X) carries a synthesised 'Result := X' — walk it. }
CollectAddressTakenStmt(TExitStmt(AStmt).ResultAssign, ASet);
{ TBreakStmt, TContinueStmt, bare TExitStmt — no expressions to walk }
end;
function CollectAddressTaken(ABlock: TBlock): TStringList;
var
I: Integer;
begin
Result := TStringList.Create();
Result.CaseSensitive := True;
Result.Duplicates := dupIgnore;
Result.Sorted := True;
if ABlock = nil then Exit;
for I := 0 to ABlock.Stmts.Count - 1 do
CollectAddressTakenStmt(TASTStmt(ABlock.Stmts.Items[I]), Result);
end;
end.

1046
compiler/src/main/pascal/blaise.codegen.native.x86_64.pas
View file

File diff suppressed because it is too large Load diff

280
compiler/src/main/pascal/blaise.codegen.qbe.pas
View file

@ -17,6 +17,7 @@ interface
uses
SysUtils, StrUtils, Classes, uAST, uSymbolTable, uStrCompat, blaise.codegen,
blaise.codegen.arcshapes,
blaise.codegen.target;
// Raw byte copy used by TIRBuffer — maps to libc memcpy.
@ -26,9 +27,9 @@ procedure _ir_memcpy(Dst, Src: Pointer; N: Int64); external name 'memcpy';
type
ECodeGenError = class(Exception);
{ Caller-side protection mode for a const-string argument — see
ConstArgMode for the classification rules. }
TConstArgMode = (camPin, camBorrowed, camConsume);
{ TConstArgMode — caller-side protection mode for a const-string argument —
now lives in blaise.codegen.arcshapes (shared with the native backend);
see ConstArgMode for the classification rules. }
{ Growable byte buffer for QBE IR output. Replaces TStringList + .Text:
AppendLine writes bytes directly — no per-line string allocation.
@ -188,17 +189,12 @@ type
function IsPromotableKind(AKind: TTypeKind): Boolean;
{ Returns the QBE value type ('w','l','d','s') for a promotable kind. }
function PromotedQType(AKind: TTypeKind; AType: TTypeDesc): string;
{ Collect names of locals in ABlock whose address is taken (var-arg
sites or @X expressions). Result is caller-owned TStringList. }
function CollectAddressTaken(ABlock: TBlock): TStringList;
{ CollectAddressTaken and its stmt/expr walkers live in
blaise.codegen.arcshapes (shared with the native backend). }
{ Returns True if ABlock contains any try/finally or try/except statement
(recursively). Promoted locals are unsafe across setjmp/longjmp. }
function BlockHasTry(ABlock: TBlock): Boolean;
function StmtHasTry(AStmt: TASTStmt): Boolean;
{ Walk a statement tree adding any address-taken local names to ASet. }
procedure CollectAddressTakenStmt(AStmt: TASTStmt; ASet: TStringList);
{ Walk an expression adding any address-taken local names to ASet. }
procedure CollectAddressTakenExpr(AExpr: TASTExpr; ASet: TStringList);
{ Returns True if AName is currently a promoted SSA temp. }
function IsCaptured(const AName: string): Boolean;
function IsPromoted(const AName: string): Boolean;
@ -1411,258 +1407,6 @@ begin
Result := True;
end;
procedure TCodeGenQBE.CollectAddressTakenExpr(AExpr: TASTExpr; ASet: TStringList);
var
I: Integer;
FC: TFuncCallExpr;
MC: TMethodCallExpr;
FA: TFieldAccessExpr;
Param: TMethodParam;
Arg: TASTExpr;
begin
if AExpr = nil then Exit;
{ @X — explicit address-of }
if AExpr is TAddrOfExpr then
begin
if TAddrOfExpr(AExpr).Expr is TIdentExpr then
ASet.Add(TIdentExpr(TAddrOfExpr(AExpr).Expr).Name);
CollectAddressTakenExpr(TAddrOfExpr(AExpr).Expr, ASet);
Exit;
end;
{ Function call: var params take the address of their actual argument }
if AExpr is TFuncCallExpr then
begin
FC := TFuncCallExpr(AExpr);
if FC.ResolvedDecl <> nil then
begin
for I := 0 to FC.Args.Count - 1 do
begin
Arg := TASTExpr(FC.Args.Items[I]);
if I < TMethodDecl(FC.ResolvedDecl).Params.Count then
begin
Param := TMethodParam(TMethodDecl(FC.ResolvedDecl).Params.Items[I]);
if Param.IsVarParam and (Arg is TIdentExpr) and not TIdentExpr(Arg).IsGlobal then
ASet.Add(TIdentExpr(Arg).Name);
end;
CollectAddressTakenExpr(Arg, ASet);
end;
end
else
for I := 0 to FC.Args.Count - 1 do
CollectAddressTakenExpr(TASTExpr(FC.Args.Items[I]), ASet);
Exit;
end;
{ Method call: same var-param check }
if AExpr is TMethodCallExpr then
begin
MC := TMethodCallExpr(AExpr);
CollectAddressTakenExpr(MC.ObjExpr, ASet);
if MC.ResolvedMethod <> nil then
begin
for I := 0 to MC.Args.Count - 1 do
begin
Arg := TASTExpr(MC.Args.Items[I]);
if I < TMethodDecl(MC.ResolvedMethod).Params.Count then
begin
Param := TMethodParam(TMethodDecl(MC.ResolvedMethod).Params.Items[I]);
if Param.IsVarParam and (Arg is TIdentExpr) and not TIdentExpr(Arg).IsGlobal then
ASet.Add(TIdentExpr(Arg).Name);
end;
CollectAddressTakenExpr(Arg, ASet);
end;
end
else
for I := 0 to MC.Args.Count - 1 do
CollectAddressTakenExpr(TASTExpr(MC.Args.Items[I]), ASet);
Exit;
end;
{ Recurse into common composite expressions }
if AExpr is TBinaryExpr then
begin
CollectAddressTakenExpr(TBinaryExpr(AExpr).Left, ASet);
CollectAddressTakenExpr(TBinaryExpr(AExpr).Right, ASet);
end
else if AExpr is TNotExpr then
CollectAddressTakenExpr(TNotExpr(AExpr).Expr, ASet)
else if AExpr is TFieldAccessExpr then
begin
FA := TFieldAccessExpr(AExpr);
CollectAddressTakenExpr(FA.Base, ASet);
if FA.PropIndexExpr <> nil then
CollectAddressTakenExpr(FA.PropIndexExpr, ASet);
end
else if AExpr is TDerefExpr then
CollectAddressTakenExpr(TDerefExpr(AExpr).Expr, ASet)
else if AExpr is TStringSubscriptExpr then
begin
CollectAddressTakenExpr(TStringSubscriptExpr(AExpr).StrExpr, ASet);
CollectAddressTakenExpr(TStringSubscriptExpr(AExpr).IndexExpr, ASet);
end
else if AExpr is TIsExpr then
CollectAddressTakenExpr(TIsExpr(AExpr).Obj, ASet)
else if AExpr is TAsExpr then
CollectAddressTakenExpr(TAsExpr(AExpr).Obj, ASet)
else if AExpr is TSupportsExpr then
CollectAddressTakenExpr(TSupportsExpr(AExpr).Obj, ASet)
else if AExpr is TArrayLiteralExpr then
for I := 0 to TArrayLiteralExpr(AExpr).Elements.Count - 1 do
CollectAddressTakenExpr(TASTExpr(TArrayLiteralExpr(AExpr).Elements.Items[I]), ASet);
end;
procedure TCodeGenQBE.CollectAddressTakenStmt(AStmt: TASTStmt; ASet: TStringList);
var
I: Integer;
TryE: TTryExceptStmt;
TryF: TTryFinallyStmt;
RaiseS: TRaiseStmt;
CaseS: TCaseStmt;
PWrite: TPointerWriteStmt;
SSubA: TStaticSubscriptAssign;
PCall: TProcCall;
MCall: TMethodCallStmt;
ICall: TInheritedCallStmt;
ForS: TForStmt;
begin
if AStmt = nil then Exit;
if AStmt is TCompoundStmt then
begin
for I := 0 to TCompoundStmt(AStmt).Stmts.Count - 1 do
CollectAddressTakenStmt(TASTStmt(TCompoundStmt(AStmt).Stmts.Items[I]), ASet);
end
else if AStmt is TIfStmt then
begin
CollectAddressTakenExpr(TIfStmt(AStmt).Condition, ASet);
CollectAddressTakenStmt(TIfStmt(AStmt).ThenStmt, ASet);
CollectAddressTakenStmt(TIfStmt(AStmt).ElseStmt, ASet);
end
else if AStmt is TWhileStmt then
begin
CollectAddressTakenExpr(TWhileStmt(AStmt).Condition, ASet);
CollectAddressTakenStmt(TWhileStmt(AStmt).Body, ASet);
end
else if AStmt is TRepeatStmt then
begin
CollectAddressTakenExpr(TRepeatStmt(AStmt).Condition, ASet);
CollectAddressTakenStmt(TRepeatStmt(AStmt).Body, ASet);
end
else if AStmt is TForStmt then
begin
ForS := TForStmt(AStmt);
CollectAddressTakenExpr(ForS.StartExpr, ASet);
CollectAddressTakenExpr(ForS.EndExpr, ASet);
CollectAddressTakenStmt(ForS.Body, ASet);
end
else if AStmt is TForInStmt then
begin
CollectAddressTakenExpr(TForInStmt(AStmt).CollExpr, ASet);
CollectAddressTakenStmt(TForInStmt(AStmt).Body, ASet);
end
else if AStmt is TAssignment then
CollectAddressTakenExpr(TAssignment(AStmt).Expr, ASet)
else if AStmt is TFieldAssignment then
CollectAddressTakenExpr(TFieldAssignment(AStmt).Expr, ASet)
else if AStmt is TMethodCallStmt then
begin
MCall := TMethodCallStmt(AStmt);
CollectAddressTakenExpr(MCall.ObjExpr, ASet);
if MCall.ResolvedMethod <> nil then
for I := 0 to MCall.Args.Count - 1 do
begin
if I < TMethodDecl(MCall.ResolvedMethod).Params.Count then
if TMethodParam(TMethodDecl(MCall.ResolvedMethod).Params.Items[I]).IsVarParam and
(TASTExpr(MCall.Args.Items[I]) is TIdentExpr) and
not TIdentExpr(TASTExpr(MCall.Args.Items[I])).IsGlobal then
ASet.Add(TIdentExpr(TASTExpr(MCall.Args.Items[I])).Name);
CollectAddressTakenExpr(TASTExpr(MCall.Args.Items[I]), ASet);
end
else
for I := 0 to MCall.Args.Count - 1 do
CollectAddressTakenExpr(TASTExpr(MCall.Args.Items[I]), ASet);
end
else if AStmt is TProcCall then
begin
PCall := TProcCall(AStmt);
if PCall.ResolvedDecl <> nil then
for I := 0 to PCall.Args.Count - 1 do
begin
if I < TMethodDecl(PCall.ResolvedDecl).Params.Count then
if TMethodParam(TMethodDecl(PCall.ResolvedDecl).Params.Items[I]).IsVarParam and
(TASTExpr(PCall.Args.Items[I]) is TIdentExpr) and
not TIdentExpr(TASTExpr(PCall.Args.Items[I])).IsGlobal then
ASet.Add(TIdentExpr(TASTExpr(PCall.Args.Items[I])).Name);
CollectAddressTakenExpr(TASTExpr(PCall.Args.Items[I]), ASet);
end
else
for I := 0 to PCall.Args.Count - 1 do
CollectAddressTakenExpr(TASTExpr(PCall.Args.Items[I]), ASet);
end
else if AStmt is TInheritedCallStmt then
begin
ICall := TInheritedCallStmt(AStmt);
if ICall.ResolvedMethod <> nil then
for I := 0 to ICall.Args.Count - 1 do
begin
if I < TMethodDecl(ICall.ResolvedMethod).Params.Count then
if TMethodParam(TMethodDecl(ICall.ResolvedMethod).Params.Items[I]).IsVarParam and
(TASTExpr(ICall.Args.Items[I]) is TIdentExpr) and
not TIdentExpr(TASTExpr(ICall.Args.Items[I])).IsGlobal then
ASet.Add(TIdentExpr(TASTExpr(ICall.Args.Items[I])).Name);
CollectAddressTakenExpr(TASTExpr(ICall.Args.Items[I]), ASet);
end
else
for I := 0 to ICall.Args.Count - 1 do
CollectAddressTakenExpr(TASTExpr(ICall.Args.Items[I]), ASet);
end
else if AStmt is TTryFinallyStmt then
begin
TryF := TTryFinallyStmt(AStmt);
CollectAddressTakenStmt(TryF.TryBody, ASet);
CollectAddressTakenStmt(TryF.FinallyBody, ASet);
end
else if AStmt is TTryExceptStmt then
begin
TryE := TTryExceptStmt(AStmt);
CollectAddressTakenStmt(TryE.TryBody, ASet);
for I := 0 to TryE.Handlers.Count - 1 do
CollectAddressTakenStmt(TExceptHandlerClause(TryE.Handlers.Items[I]).Body, ASet);
CollectAddressTakenStmt(TryE.ElseBody, ASet);
CollectAddressTakenStmt(TryE.ExceptBody, ASet);
end
else if AStmt is TRaiseStmt then
begin
RaiseS := TRaiseStmt(AStmt);
CollectAddressTakenExpr(RaiseS.Expr, ASet);
end
else if AStmt is TCaseStmt then
begin
CaseS := TCaseStmt(AStmt);
CollectAddressTakenExpr(CaseS.Selector, ASet);
for I := 0 to CaseS.Branches.Count - 1 do
CollectAddressTakenStmt(TCaseBranch(CaseS.Branches.Items[I]).Stmt, ASet);
CollectAddressTakenStmt(CaseS.ElseStmt, ASet);
end
else if AStmt is TPointerWriteStmt then
begin
PWrite := TPointerWriteStmt(AStmt);
CollectAddressTakenExpr(PWrite.PtrExpr, ASet);
CollectAddressTakenExpr(PWrite.ValExpr, ASet);
end
else if AStmt is TStaticSubscriptAssign then
begin
SSubA := TStaticSubscriptAssign(AStmt);
CollectAddressTakenExpr(SSubA.IndexExpr, ASet);
CollectAddressTakenExpr(SSubA.ValueExpr, ASet);
end
else if (AStmt is TExitStmt) and (TExitStmt(AStmt).ResultAssign <> nil) then
{ Exit(X) carries a synthesised 'Result := X' — walk it. }
CollectAddressTakenStmt(TExitStmt(AStmt).ResultAssign, ASet);
{ TBreakStmt, TContinueStmt, bare TExitStmt — no expressions to walk }
end;
function TCodeGenQBE.StmtHasTry(AStmt: TASTStmt): Boolean;
var
@ -1716,18 +1460,6 @@ begin
end;
end;
function TCodeGenQBE.CollectAddressTaken(ABlock: TBlock): TStringList;
var
I: Integer;
begin
Result := TStringList.Create();
Result.CaseSensitive := True;
Result.Duplicates := dupIgnore;
Result.Sorted := True;
if ABlock = nil then Exit;
for I := 0 to ABlock.Stmts.Count - 1 do
CollectAddressTakenStmt(TASTStmt(ABlock.Stmts.Items[I]), Result);
end;
procedure TCodeGenQBE.EmitVarAllocs(ABlock: TBlock);
var

2
compiler/src/test/pascal/TestRunner.pas
View file

@ -68,6 +68,7 @@ uses
cp.test.stringlistfind,
cp.test.maphash,
cp.test.constarg,
cp.test.nativeconstarg,
cp.test.defaultargs,
cp.test.caseenum,
cp.test.sets,
@ -102,6 +103,7 @@ uses
cp.test.e2e.threading,
cp.test.e2e.openarray,
cp.test.e2e.staticarray,
cp.test.e2e.constarg,
cp.test.multifile,
cp.test.constants,
cp.test.external,

650
compiler/src/test/pascal/cp.test.e2e.constarg.pas Normal file
View file

@ -0,0 +1,650 @@
{
Blaise - An Object Pascal Compiler
Copyright (c) 2026 Graeme Geldenhuys
SPDX-License-Identifier: Apache-2.0 WITH Swift-exception
Licensed under the Apache License v2.0 with Runtime Library Exception.
See LICENSE file in the project root for full license terms.
}
unit cp.test.e2e.constarg;
{ E2E parity tests for const-string argument ARC and call-argument
materialisation, run on BOTH backends (QBE and native).
Two bug families pinned here:
1. Const-string caller protection (native port of the QBE shape-aware
convention): every call path — direct, method, interface dispatch,
proc-pointer, method-pointer, >6-arg, inherited, interface-sret —
must keep an rc=0 concat transient or +1 owned return alive across
the call and free it exactly once afterwards.
2. Record-returning calls as arguments: the native backend interleaved
the callee's sret buffer between pushed argument slots, so the pop
loop read buffer words instead of arguments (garbage values). The
fix hoists record-call arguments into the pre-call region.
3. Indirect calls (proc ptr / method ptr) loaded the target pointer
into %r10/%r11 BEFORE evaluating arguments; an argument containing
a call clobbered them (caller-saved), so the callq jumped wild. }
interface
uses
blaise.testing, cp.test.e2e.base;
type
[Threaded]
TE2EConstArgTests = class(TE2ETestCase)
protected
procedure SetUp; override;
published
procedure TestRun_RecordCallArg_Direct;
procedure TestRun_RecordCallArg_SevenArgs;
procedure TestRun_RecordCallArg_Method;
procedure TestRun_RecordCallArg_ManagedField;
procedure TestRun_ProcPtrArg_ContainsCall;
procedure TestRun_MethodPtrArg_ContainsCall;
procedure TestRun_ConstStr_ConcatDirect;
procedure TestRun_ConstStr_ConcatMethod;
procedure TestRun_ConstStr_ConcatInterface;
procedure TestRun_ConstStr_OwnedReturn;
procedure TestRun_ConstStr_SeventhSlot;
procedure TestRun_ConstStr_ProcPtr;
procedure TestRun_ConstStr_MethodPtr;
procedure TestRun_ConstStr_GlobalReassignedByCallee;
procedure TestRun_ConstStr_VarSiblingAlias;
procedure TestRun_ConstStr_IntfSretArgs;
procedure TestRun_ConstStr_Inherited;
procedure TestRun_ConstStr_BorrowedLocalStillUsable;
procedure TestRun_ConstStr_ConcatOfOwnedReturns;
procedure TestRun_OutStrForward_SevenSlotMethod;
procedure TestRun_CharCoerce_SubscriptCompare;
end;
implementation
procedure TE2EConstArgTests.SetUp;
begin
inherited SetUp();
SetUpScratch('compiler/target/test-e2e-constarg');
end;
const
LE = #10;
SrcRecArgDirect = '''
program P;
type
TR = record
A, B, C: Int64;
end;
function MkRec(): TR;
begin
Result.A := 11;
Result.B := 22;
Result.C := 33;
end;
function UseRec(R: TR; X: Integer): Int64;
begin
Result := R.A + R.C + X;
end;
begin
WriteLn(UseRec(MkRec(), 5));
end.
''';
SrcRecArgSeven = '''
program P;
type
TR = record
A, B, C: Int64;
end;
function MkRec(): TR;
begin
Result.A := 100;
Result.B := 200;
Result.C := 300;
end;
function Use7(A, B, C, D, E, F: Integer; R: TR): Int64;
begin
Result := A + B + C + D + E + F + R.B;
end;
begin
WriteLn(Use7(1, 2, 3, 4, 5, 6, MkRec()));
end.
''';
SrcRecArgMethod = '''
program P;
type
TR = record
A, B: Int64;
end;
TUser = class
public
function Take(R: TR): Int64;
end;
function TUser.Take(R: TR): Int64;
begin
Result := R.A * R.B;
end;
function MkRec(): TR;
begin
Result.A := 6;
Result.B := 7;
end;
var U: TUser;
begin
U := TUser.Create();
WriteLn(U.Take(MkRec()));
end.
''';
SrcRecArgManaged = '''
program P;
type
TR = record
Name: string;
N: Int64;
end;
function MkRec(): TR;
begin
Result.Name := 'rec' + IntToStr(7);
Result.N := 9;
end;
function UseRec(R: TR): string;
begin
Result := R.Name + '/' + IntToStr(R.N);
end;
begin
WriteLn(UseRec(MkRec()));
end.
''';
SrcProcPtrArgCall = '''
program P;
type
TFn = procedure(X: Integer);
procedure Show(X: Integer);
begin
WriteLn(X);
end;
function Bump(X: Integer): Integer;
begin
Result := X + 1;
end;
var F: TFn;
begin
F := @Show;
F(Bump(3));
end.
''';
SrcMethodPtrArgCall = '''
program P;
type
TMeth = procedure(X: Integer) of object;
TObj = class
public
procedure Show(X: Integer);
end;
procedure TObj.Show(X: Integer);
begin
WriteLn(X);
end;
function Bump(X: Integer): Integer;
begin
Result := X + 1;
end;
var
O: TObj;
M: TMeth;
begin
O := TObj.Create();
M := @O.Show;
M(Bump(41));
end.
''';
SrcConcatDirect = '''
program P;
procedure Show(const S: string);
begin
WriteLn(S);
end;
var L: string;
begin
L := IntToStr(42);
Show('v=' + L);
end.
''';
SrcConcatMethod = '''
program P;
type
TPrinter = class
public
procedure Show(const S: string);
end;
procedure TPrinter.Show(const S: string);
begin
WriteLn(S);
end;
var
Pr: TPrinter;
L: string;
begin
Pr := TPrinter.Create();
L := IntToStr(7);
Pr.Show('m=' + L);
end.
''';
SrcConcatInterface = '''
program P;
type
ISink = interface
procedure Put(const S: string);
end;
TSink = class(TObject, ISink)
public
procedure Put(const S: string);
end;
procedure TSink.Put(const S: string);
begin
WriteLn(S);
end;
var
O: TSink;
I: ISink;
L: string;
begin
O := TSink.Create();
I := O;
L := IntToStr(3);
I.Put('i=' + L);
end.
''';
SrcOwnedReturn = '''
program P;
procedure Show(const S: string);
begin
WriteLn(S);
end;
function Mk(): string;
begin
Result := 'mk' + IntToStr(5);
end;
begin
Show(Mk());
end.
''';
SrcSeventhSlot = '''
program P;
procedure Show7(A, B, C, D, E, F: Integer; const S: string);
begin
WriteLn(A + B + C + D + E + F);
WriteLn(S);
end;
var L: string;
begin
L := IntToStr(99);
Show7(1, 2, 3, 4, 5, 6, 's=' + L);
end.
''';
SrcProcPtrConstStr = '''
program P;
type
TFn = procedure(const S: string);
procedure Show(const S: string);
begin
WriteLn(S);
end;
var
F: TFn;
L: string;
begin
F := @Show;
L := IntToStr(8);
F('p=' + L);
end.
''';
SrcMethodPtrConstStr = '''
program P;
type
TMeth = procedure(const S: string) of object;
TObj = class
public
procedure Show(const S: string);
end;
procedure TObj.Show(const S: string);
begin
WriteLn(S);
end;
var
O: TObj;
M: TMeth;
L: string;
begin
O := TObj.Create();
M := @O.Show;
L := IntToStr(4);
M('o=' + L);
end.
''';
SrcGlobalReassign = '''
program P;
var G: string;
procedure Show(const S: string);
begin
G := 'changed';
WriteLn(S);
end;
begin
G := 'orig' + IntToStr(1);
Show(G);
WriteLn(G);
end.
''';
SrcVarSibling = '''
program P;
procedure Swapish(const A: string; var B: string);
begin
B := 'new';
WriteLn(A);
end;
var L: string;
begin
L := 'old' + IntToStr(2);
Swapish(L, L);
WriteLn(L);
end.
''';
SrcIntfSretArgs = '''
program P;
type
IThing = interface
procedure Touch;
end;
TThing = class(TObject, IThing)
public
FTag: string;
procedure Touch;
end;
procedure TThing.Touch;
begin
WriteLn(FTag);
end;
function Wrap(const S: string): IThing;
var
T: TThing;
begin
T := TThing.Create();
T.FTag := S + '!';
Result := T;
end;
var
V: IThing;
L: string;
begin
L := IntToStr(6);
V := Wrap('w=' + L);
V.Touch();
end.
''';
SrcInherited = '''
program P;
type
TBase = class
public
procedure Show(const S: string); virtual;
end;
TChild = class(TBase)
public
procedure Show(const S: string); override;
end;
procedure TBase.Show(const S: string);
begin
WriteLn('base:' + S);
end;
procedure TChild.Show(const S: string);
begin
inherited Show(S + '+kid');
end;
var
C: TChild;
L: string;
begin
C := TChild.Create();
L := IntToStr(5);
C.Show('c=' + L);
end.
''';
SrcBorrowedUsable = '''
program P;
procedure Sink(const S: string);
begin
WriteLn(S);
end;
function Mk(): string;
begin
Result := 'live' + IntToStr(3);
end;
var L: string;
begin
L := Mk();
Sink(L);
WriteLn(L);
end.
''';
SrcConcatOwned = '''
program P;
procedure Show(const S: string);
begin
WriteLn(S);
end;
function MkA(): string;
begin
Result := 'a' + IntToStr(1);
end;
function MkB(): string;
begin
Result := 'b' + IntToStr(2);
end;
begin
Show(MkA() + MkB());
end.
''';
SrcOutStrForward7 = '''
program P;
type
TWorker = class
public
procedure Fill(A, B, C, D, E: Integer; out S: string);
procedure Run(out S: string);
end;
procedure TWorker.Fill(A, B, C, D, E: Integer; out S: string);
begin
S := 'sum=' + IntToStr(A + B + C + D + E);
end;
procedure TWorker.Run(out S: string);
begin
Self.Fill(1, 2, 3, 4, 5, S);
end;
var
W: TWorker;
R: string;
begin
W := TWorker.Create();
W.Run(R);
WriteLn(R);
end.
''';
SrcCharCoerce = '''
program P;
var
S: string;
I, N: Integer;
begin
S := 'a,b,c';
N := 0;
for I := 0 to Length(S) - 1 do
if S[I] = ',' then
N := N + 1;
WriteLn(N);
end.
''';
procedure TE2EConstArgTests.TestRun_RecordCallArg_Direct;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertRunsOnAll(SrcRecArgDirect, '49' + LE, 0);
end;
procedure TE2EConstArgTests.TestRun_RecordCallArg_SevenArgs;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertRunsOnAll(SrcRecArgSeven, '221' + LE, 0);
end;
procedure TE2EConstArgTests.TestRun_RecordCallArg_Method;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertRunsOnAll(SrcRecArgMethod, '42' + LE, 0);
end;
procedure TE2EConstArgTests.TestRun_RecordCallArg_ManagedField;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertRunsOnAll(SrcRecArgManaged, 'rec7/9' + LE, 0);
end;
procedure TE2EConstArgTests.TestRun_ProcPtrArg_ContainsCall;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertRunsOnAll(SrcProcPtrArgCall, '4' + LE, 0);
end;
procedure TE2EConstArgTests.TestRun_MethodPtrArg_ContainsCall;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertRunsOnAll(SrcMethodPtrArgCall, '42' + LE, 0);
end;
procedure TE2EConstArgTests.TestRun_ConstStr_ConcatDirect;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertRunsOnAll(SrcConcatDirect, 'v=42' + LE, 0);
end;
procedure TE2EConstArgTests.TestRun_ConstStr_ConcatMethod;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertRunsOnAll(SrcConcatMethod, 'm=7' + LE, 0);
end;
procedure TE2EConstArgTests.TestRun_ConstStr_ConcatInterface;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertRunsOnAll(SrcConcatInterface, 'i=3' + LE, 0);
end;
procedure TE2EConstArgTests.TestRun_ConstStr_OwnedReturn;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertRunsOnAll(SrcOwnedReturn, 'mk5' + LE, 0);
end;
procedure TE2EConstArgTests.TestRun_ConstStr_SeventhSlot;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertRunsOnAll(SrcSeventhSlot, '21' + LE + 's=99' + LE, 0);
end;
procedure TE2EConstArgTests.TestRun_ConstStr_ProcPtr;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertRunsOnAll(SrcProcPtrConstStr, 'p=8' + LE, 0);
end;
procedure TE2EConstArgTests.TestRun_ConstStr_MethodPtr;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertRunsOnAll(SrcMethodPtrConstStr, 'o=4' + LE, 0);
end;
procedure TE2EConstArgTests.TestRun_ConstStr_GlobalReassignedByCallee;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
{ S must survive the callee's reassignment of G (pin keeps the old buffer
alive until the call returns). }
AssertRunsOnAll(SrcGlobalReassign, 'orig1' + LE + 'changed' + LE, 0);
end;
procedure TE2EConstArgTests.TestRun_ConstStr_VarSiblingAlias;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
{ A aliases L which the callee rewrites through B — A must still read the
old buffer during the call. }
AssertRunsOnAll(SrcVarSibling, 'old2' + LE + 'new' + LE, 0);
end;
procedure TE2EConstArgTests.TestRun_ConstStr_IntfSretArgs;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertRunsOnAll(SrcIntfSretArgs, 'w=6!' + LE, 0);
end;
procedure TE2EConstArgTests.TestRun_ConstStr_Inherited;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertRunsOnAll(SrcInherited, 'base:c=5+kid' + LE, 0);
end;
procedure TE2EConstArgTests.TestRun_ConstStr_BorrowedLocalStillUsable;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertRunsOnAll(SrcBorrowedUsable, 'live3' + LE + 'live3' + LE, 0);
end;
procedure TE2EConstArgTests.TestRun_ConstStr_ConcatOfOwnedReturns;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertRunsOnAll(SrcConcatOwned, 'a1b2' + LE, 0);
end;
procedure TE2EConstArgTests.TestRun_OutStrForward_SevenSlotMethod;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
{ An out-string param forwarded into a >6-slot method call: the native
>6 inline blocks passed the slot's ADDRESS instead of the held pointer
(no ParamMode check), so the callee wrote the result into the caller's
param slot rather than through it. }
AssertRunsOnAll(SrcOutStrForward7, 'sum=15' + LE, 0);
end;
procedure TE2EConstArgTests.TestRun_CharCoerce_SubscriptCompare;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
{ S[I] = ',' — the native backend emitted the literal's data POINTER
instead of honouring IsCharCoerce, so the byte never matched. }
AssertRunsOnAll(SrcCharCoerce, '2' + LE, 0);
end;
initialization
RegisterTest(TE2EConstArgTests);
end.

467
compiler/src/test/pascal/cp.test.nativeconstarg.pas Normal file
View file

@ -0,0 +1,467 @@
{
Blaise - An Object Pascal Compiler
Copyright (c) 2026 Graeme Geldenhuys
SPDX-License-Identifier: Apache-2.0 WITH Swift-exception
Licensed under the Apache License v2.0 with Runtime Library Exception.
See LICENSE file in the project root for full license terms.
}
unit cp.test.nativeconstarg;
{ Assembly-level tests for shape-aware const-string argument handling in the
NATIVE x86-64 backend — the port of the QBE backend's convention (see
cp.test.constarg.pas for the QBE twins and the full classification table).
Native convention after the port:
callee — const params of ANY kind (including string) emit no
entry-retain/exit-release pair.
caller — protects const-string arguments by shape:
borrowed (literals, named consts, plain safe locals) → no ops;
consume (owned +1 returns) → one post-call release;
pin (globals, fields, concat transients, aliasable locals)
→ AddRef before the call, release after. }
interface
uses
Classes, SysUtils, blaise.testing, uStrCompat,
uLexer, uParser, uAST, uSymbolTable, uSemantic,
blaise.codegen.native, blaise.codegen.target;
type
TNativeConstArgTests = class(TTestCase)
private
function GenAsm(const ASrc: string): string;
{ Extract one emitted function's assembly (from 'Name:' to its
'.type Name, @function' trailer) so assertions are not polluted by
other functions' code. }
function FuncRegion(const AAsm, AName: string): string;
function CountOccurrences(const ANeedle, AHaystack: string): Integer;
published
procedure TestCallee_ConstStringParam_NoEntryExitPair;
procedure TestCallee_ValueStringParam_KeepsEntryExitPair;
procedure TestConstArg_ParamForward_NoArcOps;
procedure TestConstArg_Literal_NoPin;
procedure TestConstArg_LocalVar_NoPin;
procedure TestConstArg_GlobalVar_Pins;
procedure TestConstArg_OwnedReturn_ConsumeOnly;
procedure TestConstArg_Concat_Pins;
procedure TestConstArg_VarStringSibling_Pins;
procedure TestConstArg_AddrTakenLocal_Pins;
procedure TestConstArg_CapturedLocal_Pins;
procedure TestConstArg_InterfaceDispatch_ConcatPins;
end;
implementation
function TNativeConstArgTests.GenAsm(const ASrc: string): string;
var
L: TLexer;
P: TParser;
Prog: TProgram;
A: TSemanticAnalyser;
CG: TCodeGenNative;
begin
L := TLexer.Create(ASrc);
P := TParser.Create(L);
try
Prog := P.Parse();
finally
P.Free(); L.Free();
end;
try
A := TSemanticAnalyser.Create();
try
A.Analyse(Prog);
finally
A.Free();
end;
CG := TCodeGenNative.Create();
try
CG.SetTarget(HostTarget());
CG.Generate(Prog);
Result := CG.GetOutput();
finally
CG.Free();
end;
finally
Prog.Free();
end;
end;
function TNativeConstArgTests.FuncRegion(const AAsm, AName: string): string;
var
StartP, EndP: Integer;
begin
StartP := Pos(AName + ':', AAsm);
AssertTrue('function ' + AName + ' present in asm', StartP >= 0);
EndP := StrPos('.type ' + AName, StrCopyTail(AAsm, StartP));
AssertTrue('function ' + AName + ' closed', EndP >= 0);
Result := StrCopyFrom(AAsm, StartP, EndP);
end;
function TNativeConstArgTests.CountOccurrences(const ANeedle,
AHaystack: string): Integer;
var
I: Integer;
begin
Result := 0;
I := Pos(ANeedle, AHaystack);
while I >= 0 do
begin
Result := Result + 1;
I := PosEx(ANeedle, AHaystack, I + 1);
end;
end;
procedure TNativeConstArgTests.TestCallee_ConstStringParam_NoEntryExitPair;
const
Src = '''
program P;
procedure SinkC(const S: string);
begin
end;
begin
SinkC('x')
end.
''';
var
Region: string;
begin
{ The callee must not retain/release a const string param — the caller
protects the argument now (matches the QBE convention since 5a5b5d4). }
Region := FuncRegion(GenAsm(Src), 'SinkC');
AssertEquals('no entry AddRef in const-param callee', -1,
Pos('_StringAddRef', Region));
AssertEquals('no exit Release in const-param callee', -1,
Pos('_StringRelease', Region));
end;
procedure TNativeConstArgTests.TestCallee_ValueStringParam_KeepsEntryExitPair;
const
Src = '''
program P;
procedure SinkV(S: string);
begin
end;
begin
SinkV('x')
end.
''';
var
Region: string;
begin
{ Value string params keep the callee entry/exit pair — only const params
moved to caller-side protection. }
Region := FuncRegion(GenAsm(Src), 'SinkV');
AssertTrue('entry AddRef kept for value param',
Pos('_StringAddRef', Region) >= 0);
AssertTrue('exit Release kept for value param',
Pos('_StringRelease', Region) >= 0);
end;
procedure TNativeConstArgTests.TestConstArg_ParamForward_NoArcOps;
const
Src = '''
program P;
procedure Sink(const S: string);
begin
end;
procedure Caller(const T: string);
begin
Sink(T)
end;
var L: string;
begin
L := 'x';
Caller(L)
end.
''';
var
Region: string;
begin
{ Forwarding a const param to a const param: borrowed all the way. }
Region := FuncRegion(GenAsm(Src), 'Caller');
AssertEquals('no AddRef in Caller', -1, Pos('_StringAddRef', Region));
AssertEquals('no Release in Caller', -1, Pos('_StringRelease', Region));
end;
procedure TNativeConstArgTests.TestConstArg_Literal_NoPin;
const
Src = '''
program P;
procedure Sink(const S: string);
begin
end;
procedure Caller;
begin
Sink('hello')
end;
begin
Caller()
end.
''';
var
Region: string;
begin
Region := FuncRegion(GenAsm(Src), 'Caller');
AssertEquals('no AddRef for literal arg', -1, Pos('_StringAddRef', Region));
AssertEquals('no Release for literal arg', -1, Pos('_StringRelease', Region));
end;
procedure TNativeConstArgTests.TestConstArg_LocalVar_NoPin;
const
Src = '''
program P;
procedure Sink(const S: string);
begin
end;
function Mk: string;
begin
Result := IntToStr(7)
end;
procedure Caller;
var
L: string;
begin
L := Mk();
Sink(L)
end;
begin
Caller()
end.
''';
var
Region: string;
begin
{ L := Mk() consumes the owned return; Sink(L) borrows L (no pin pair).
The only releases allowed are the assignment release-old and L's
scope-exit release — a pinned call would add a third. }
Region := FuncRegion(GenAsm(Src), 'Caller');
AssertEquals('no AddRef in Caller', -1, Pos('_StringAddRef', Region));
AssertTrue('at most two Releases (assign old + scope exit), no call pin',
CountOccurrences('_StringRelease', Region) <= 2);
end;
procedure TNativeConstArgTests.TestConstArg_GlobalVar_Pins;
const
Src = '''
program P;
var G: string;
procedure Sink(const S: string);
begin
end;
procedure Caller;
begin
Sink(G)
end;
begin
G := 'x';
Caller()
end.
''';
var
Region: string;
begin
{ A global can be reassigned by the callee through its own name — pin. }
Region := FuncRegion(GenAsm(Src), 'Caller');
AssertTrue('AddRef pins global arg', Pos('_StringAddRef', Region) >= 0);
AssertTrue('Release unpins global arg', Pos('_StringRelease', Region) >= 0);
end;
procedure TNativeConstArgTests.TestConstArg_OwnedReturn_ConsumeOnly;
const
Src = '''
program P;
procedure Sink(const S: string);
begin
end;
function Mk: string;
begin
Result := IntToStr(7)
end;
procedure Caller;
begin
Sink(Mk())
end;
begin
Caller()
end.
''';
var
Region: string;
begin
{ Mk() hands over a +1 temp; the post-call release consumes it (without
this the temp leaks — the callee no longer frees it for us). }
Region := FuncRegion(GenAsm(Src), 'Caller');
AssertEquals('no AddRef for owned-return arg', -1,
Pos('_StringAddRef', Region));
AssertTrue('Release consumes the owned temp',
Pos('_StringRelease', Region) >= 0);
end;
procedure TNativeConstArgTests.TestConstArg_Concat_Pins;
const
Src = '''
program P;
procedure Sink(const S: string);
begin
end;
procedure Caller(const T: string);
begin
Sink('a' + T)
end;
var L: string;
begin
L := 'x';
Caller(L)
end.
''';
var
Region: string;
begin
{ _StringConcat returns an rc=0 transient: the pin pair both protects it
during the call and frees it afterwards. }
Region := FuncRegion(GenAsm(Src), 'Caller');
AssertTrue('AddRef pins concat temp', Pos('_StringAddRef', Region) >= 0);
AssertTrue('Release frees concat temp', Pos('_StringRelease', Region) >= 0);
end;
procedure TNativeConstArgTests.TestConstArg_VarStringSibling_Pins;
const
Src = '''
program P;
procedure Swapish(const A: string; var B: string);
begin
B := 'new'
end;
procedure Caller;
var
L: string;
begin
L := IntToStr(7);
Swapish(L, L)
end;
begin
Caller()
end.
''';
var
Region: string;
begin
{ B aliases L: the callee's write to B releases L's buffer while A still
borrows it — a var/out string sibling param forces a pin. }
Region := FuncRegion(GenAsm(Src), 'Caller');
AssertTrue('AddRef pins despite local shape',
Pos('_StringAddRef', Region) >= 0);
end;
procedure TNativeConstArgTests.TestConstArg_AddrTakenLocal_Pins;
const
Src = '''
program P;
procedure Sink(const S: string);
begin
end;
procedure Caller;
var
L: string;
PS: ^string;
begin
L := IntToStr(7);
PS := @L;
Sink(L);
PS^ := 'x'
end;
begin
Caller()
end.
''';
var
Region: string;
begin
Region := FuncRegion(GenAsm(Src), 'Caller');
AssertTrue('AddRef pins address-taken local',
Pos('_StringAddRef', Region) >= 0);
end;
procedure TNativeConstArgTests.TestConstArg_CapturedLocal_Pins;
const
Src = '''
program P;
procedure Sink(const S: string);
begin
end;
procedure Caller;
var
L: string;
procedure Nested;
begin
L := 'changed'
end;
begin
L := IntToStr(7);
Sink(L);
Nested()
end;
begin
Caller()
end.
''';
var
Region: string;
begin
Region := FuncRegion(GenAsm(Src), 'Caller');
AssertTrue('AddRef pins captured local',
Pos('_StringAddRef', Region) >= 0);
end;
procedure TNativeConstArgTests.TestConstArg_InterfaceDispatch_ConcatPins;
const
Src = '''
program P;
type
ISink = interface
procedure Put(const S: string);
end;
TSink = class(TObject, ISink)
public
procedure Put(const S: string);
end;
procedure TSink.Put(const S: string);
begin
end;
procedure Caller(V: ISink; const T: string);
begin
V.Put('a' + T)
end;
var
O: TSink;
I: ISink;
L: string;
begin
O := TSink.Create();
I := O;
L := 'x';
Caller(I, L)
end.
''';
var
Region: string;
begin
{ Interface dispatch cannot see the implementing method's const-ness, so
the caller must protect every string argument by shape: the concat
transient pins. Without this, a const-param implementor receives an
unprotected rc=0 transient. }
Region := FuncRegion(GenAsm(Src), 'Caller');
AssertTrue('AddRef pins concat temp at interface call site',
Pos('_StringAddRef', Region) >= 0);
AssertTrue('Release frees concat temp at interface call site',
Pos('_StringRelease', Region) >= 0);
end;
initialization
RegisterTest(TNativeConstArgTests);
end.