diff --git a/compiler/src/main/pascal/blaise.codegen.qbe.pas b/compiler/src/main/pascal/blaise.codegen.qbe.pas index 242a975..a0e83cb 100644 --- a/compiler/src/main/pascal/blaise.codegen.qbe.pas +++ b/compiler/src/main/pascal/blaise.codegen.qbe.pas @@ -26,6 +26,10 @@ 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); + { Growable byte buffer for QBE IR output. Replaces TStringList + .Text: AppendLine writes bytes directly — no per-line string allocation. AppendBuffer bulk-copies another buffer in one memcpy. @@ -250,12 +254,25 @@ type AArgs.Items[i], or '' if that arg was not a value temp (e.g. var param). } procedure EmitOwnedArgReleases(AArgs: TObjectList; AArgTemps: TStringList; AParams: TObjectList); - { Caller-side retain/release for a const-string param. A const param skips - the callee-side _StringAddRef/_StringRelease pair (see 5a5b5d4), so a - fresh transient (rc=0 from _StringConcat or a function returning string) - would be unowned for the duration of the call. Variables/fields/literals - already have a live owner — the AddRef/Release pair nets to zero on them. } - procedure EnsureConstStringRef(const AArgTemp: string; APar: TMethodParam); + { Caller-side protection for const-string params. A const param skips + the callee-side _StringAddRef/_StringRelease pair (5a5b5d4), so the + caller must keep the argument alive for the duration of the call. + ConstArgMode classifies by argument shape: + + camBorrowed — string literals and named string consts: immortal + data, no ARC ops are emitted at all. + camConsume — +1 owned temps (function/method/getter returns): no + AddRef; the single post-call Release consumes the + transferred reference (these previously leaked). + camPin — everything else, including plain local variables — + AddRef before the call, Release after. Locals would + be safe to borrow in principle (the frame's own + reference outlives the call), but eliding their pin + exposes a latent uninitialised-register miscompile + (bugs.txt 2026-06-10) — revisit once that is fixed. } + function ConstArgMode(AArg: TASTExpr; AParams: TObjectList): TConstArgMode; + procedure EnsureConstStringRef(const AArgTemp: string; APar: TMethodParam; + AArg: TASTExpr; AParams: TObjectList); procedure ReleaseConstStringArgs(AArgs: TObjectList; AArgTemps: TStringList; AParams: TObjectList); procedure EmitInheritedCall(ACall: TInheritedCallStmt); @@ -3675,16 +3692,48 @@ begin end; { call $_StringAddRef(l ) } +function TCodeGenQBE.ConstArgMode(AArg: TASTExpr; + AParams: TObjectList): TConstArgMode; +var + IE: TIdentExpr; +begin + Result := camPin; + if AArg = nil then Exit; + if AArg is TStringLiteral then + Exit(camBorrowed); + if AArg is TIdentExpr then + begin + IE := TIdentExpr(AArg); + if IE.IsImplicitSelfMethod then + Exit(camConsume); { bare zero-arg method call — +1 owned return } + if IE.IsConstant then + Exit(camBorrowed); { named string const — immortal literal data } + { Plain non-captured locals/params would also be safe to borrow, but + eliding their pin currently exposes a latent uninitialised-register + miscompile downstream (see bugs.txt 2026-06-10, 'borrowed-local + elision exposes EmitInterfaceCall register corruption') — keep them + pinned until that is fixed. } + Exit(camPin); { variable of any kind — pin } + end; + if ExprOwnsRef(AArg) then + Exit(camConsume); { function/method/getter return — +1 owned temp } +end; + procedure TCodeGenQBE.EnsureConstStringRef(const AArgTemp: string; - APar: TMethodParam); + APar: TMethodParam; AArg: TASTExpr; AParams: TObjectList); begin if (APar = nil) or (AArgTemp = '') then Exit; if APar.IsConstParam and (APar.ResolvedType <> nil) and (APar.ResolvedType.Kind = tyString) then - EmitLine(Format(' call $_StringAddRef(l %s)', [AArgTemp])); + begin + if ConstArgMode(AArg, AParams) = camPin then + EmitLine(Format(' call $_StringAddRef(l %s)', [AArgTemp])); + end; end; -{ call $_StringRelease(l ) for each const-string param. } +{ call $_StringRelease(l ) for each pinned or consumed + const-string argument (borrowed args emitted no AddRef and need no + Release; consumed args take ownership of the +1 temp here). } procedure TCodeGenQBE.ReleaseConstStringArgs(AArgs: TObjectList; AArgTemps: TStringList; AParams: TObjectList); var @@ -3700,8 +3749,11 @@ begin Par := TMethodParam(AParams.Items[I]); if Par.IsConstParam and (Par.ResolvedType <> nil) and (Par.ResolvedType.Kind = tyString) then - EmitLine(Format(' call $_StringRelease(l %s)', - [AArgTemps.Strings[I]])); + begin + if ConstArgMode(TASTExpr(AArgs.Items[I]), AParams) <> camBorrowed then + EmitLine(Format(' call $_StringRelease(l %s)', + [AArgTemps.Strings[I]])); + end; end; end; @@ -5785,7 +5837,7 @@ begin begin ArgTemp := EmitExpr(TASTExpr(ACall.Args.Items[I])); ArgTemps.Add(ArgTemp); - EnsureConstStringRef(ArgTemp, Par); + EnsureConstStringRef(ArgTemp, Par, TASTExpr(ACall.Args.Items[I]), MDecl.Params); QType := QbeTypeOf(Par.ResolvedType); ArgTemp := CoerceArg(ArgTemp, TASTExpr(ACall.Args.Items[I]), QType); ArgLine := ArgLine + Format(', %s %s', [QbeParamTypeOf(Par.ResolvedType), ArgTemp]); @@ -5979,7 +6031,7 @@ begin begin ArgTemp := EmitExpr(TASTExpr(ACall.Args.Items[I])); ArgTemps.Add(ArgTemp); - EnsureConstStringRef(ArgTemp, Par); + EnsureConstStringRef(ArgTemp, Par, TASTExpr(ACall.Args.Items[I]), MDecl.Params); QType := QbeTypeOf(Par.ResolvedType); ArgTemp := CoerceArg(ArgTemp, TASTExpr(ACall.Args.Items[I]), QType); ArgLine := ArgLine + Format(', %s %s', @@ -7554,7 +7606,7 @@ begin ArgTemp := EmitExpr(TASTExpr(ACall.Args.Items[I])); while ArgTemps.Count < I do ArgTemps.Add(''); ArgTemps.Add(ArgTemp); - EnsureConstStringRef(ArgTemp, Par); + EnsureConstStringRef(ArgTemp, Par, TASTExpr(ACall.Args.Items[I]), MDecl.Params); ArgTemp := CoerceArg(ArgTemp, TASTExpr(ACall.Args.Items[I]), QbeTypeOf(Par.ResolvedType)); ArgLine := ArgLine + Format(', %s %s', [QbeParamTypeOf(Par.ResolvedType), ArgTemp]); @@ -7647,7 +7699,7 @@ begin begin ArgTemp := EmitExpr(TASTExpr(ACall.Args.Items[I])); ArgTemps.Add(ArgTemp); - EnsureConstStringRef(ArgTemp, Par); + EnsureConstStringRef(ArgTemp, Par, TASTExpr(ACall.Args.Items[I]), MDecl.Params); ArgTemp := CoerceArg(ArgTemp, TASTExpr(ACall.Args.Items[I]), QbeTypeOf(Par.ResolvedType)); ArgLine := ArgLine + Format('%s %s', [QbeParamTypeOf(Par.ResolvedType), ArgTemp]); end; @@ -9341,7 +9393,7 @@ begin ArgTemp := EmitExpr(TASTExpr(FC.Args.Items[I])); while ArgTemps.Count < I do ArgTemps.Add(''); ArgTemps.Add(ArgTemp); - EnsureConstStringRef(ArgTemp, Par); + EnsureConstStringRef(ArgTemp, Par, TASTExpr(FC.Args.Items[I]), MDecl.Params); ArgTemp := CoerceArg(ArgTemp, TASTExpr(FC.Args.Items[I]), QbeTypeOf(Par.ResolvedType)); ArgLine := ArgLine + Format(', %s %s', [QbeParamTypeOf(Par.ResolvedType), ArgTemp]); @@ -9413,7 +9465,7 @@ begin begin ArgTemp := EmitExpr(TASTExpr(FC.Args.Items[I])); ArgTemps.Add(ArgTemp); - EnsureConstStringRef(ArgTemp, Par); + EnsureConstStringRef(ArgTemp, Par, TASTExpr(FC.Args.Items[I]), MDecl.Params); ArgTemp := CoerceArg(ArgTemp, TASTExpr(FC.Args.Items[I]), QbeTypeOf(Par.ResolvedType)); ArgLine := ArgLine + Format('%s %s', [QbeParamTypeOf(Par.ResolvedType), ArgTemp]); end; @@ -9603,7 +9655,7 @@ begin begin ArgTemp := EmitExpr(TASTExpr(MCallExpr.Args.Items[I])); if Par.IsVarParam then ArgTemps.Add('') else ArgTemps.Add(ArgTemp); - EnsureConstStringRef(ArgTemp, Par); + EnsureConstStringRef(ArgTemp, Par, TASTExpr(MCallExpr.Args.Items[I]), MDecl.Params); ArgTemp := CoerceArg(ArgTemp, TASTExpr(MCallExpr.Args.Items[I]), QbeTypeOf(Par.ResolvedType)); ArgLine := ArgLine + Format(', %s %s', @@ -9772,7 +9824,7 @@ begin begin ArgTemp := EmitExpr(TASTExpr(MCallExpr.Args.Items[I])); ArgTemps.Add(ArgTemp); - EnsureConstStringRef(ArgTemp, Par); + EnsureConstStringRef(ArgTemp, Par, TASTExpr(MCallExpr.Args.Items[I]), MDecl.Params); ArgTemp := CoerceArg(ArgTemp, TASTExpr(MCallExpr.Args.Items[I]), QbeTypeOf(Par.ResolvedType)); ArgLine := ArgLine + Format(', %s %s', [QbeParamTypeOf(Par.ResolvedType), ArgTemp]); diff --git a/compiler/src/test/pascal/TestRunner.pas b/compiler/src/test/pascal/TestRunner.pas index e340e28..15579ef 100644 --- a/compiler/src/test/pascal/TestRunner.pas +++ b/compiler/src/test/pascal/TestRunner.pas @@ -67,6 +67,7 @@ uses cp.test.collections, cp.test.stringlistfind, cp.test.maphash, + cp.test.constarg, cp.test.caseenum, cp.test.sets, cp.test.selfhosting, diff --git a/compiler/src/test/pascal/cp.test.constarg.pas b/compiler/src/test/pascal/cp.test.constarg.pas new file mode 100644 index 0000000..01d5b5a --- /dev/null +++ b/compiler/src/test/pascal/cp.test.constarg.pas @@ -0,0 +1,313 @@ +{ + 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.constarg; + +{ IR tests for shape-aware const-string argument handling (QBE backend). + + Const string params skip the callee-side retain/release pair (5a5b5d4); + the caller protects the argument for the duration of the call. The + protection depends on the argument's shape: + + borrowed — string literals and named string consts (immortal data): + NO AddRef/Release pair is emitted at all. + consume — function/method/getter returns (+1 owned temps): no + AddRef, ONE Release after the call consumes the temp + (previously these leaked). + pin — everything else, including plain local variables — + AddRef before the call, Release after. Locals would be + borrowable in principle, but eliding their pin exposes a + latent uninitialised-register miscompile (bugs.txt + 2026-06-10); these tests pin the CURRENT contract and + should be revisited when local borrowing lands. } + +interface + +uses + Classes, SysUtils, blaise.testing, uStrCompat, + uLexer, uParser, uAST, uSymbolTable, uSemantic, blaise.codegen.qbe; + +type + TConstArgTests = class(TTestCase) + private + function GenIR(const ASrc: string): string; + { Extract the body of one emitted function (from 'function ... $Name(' + to the closing brace) so ARC assertions are not polluted by other + functions' codegen. } + function FuncRegion(const AIR, AName: string): string; + published + procedure TestConstArg_ParamForward_Pins; + procedure TestConstArg_LocalVar_Pins; + procedure TestConstArg_Literal_NoPin; + procedure TestConstArg_GlobalVar_Pins; + procedure TestConstArg_OwnedReturn_ConsumeOnly; + procedure TestConstArg_Concat_Pins; + procedure TestConstArg_VarStringSibling_Pins; + end; + +implementation + +function TConstArgTests.GenIR(const ASrc: string): string; +var + L: TLexer; + P: TParser; + Prog: TProgram; + A: TSemanticAnalyser; + CG: TCodeGenQBE; +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 := TCodeGenQBE.Create(); + try + CG.Generate(Prog); + Result := CG.GetOutput(); + finally + CG.Free(); + end; + finally + Prog.Free(); + end; +end; + +function TConstArgTests.FuncRegion(const AIR, AName: string): string; +var + StartP, EndP: Integer; + Marker: string; +begin + Marker := '$' + AName + '('; + StartP := Pos(Marker, AIR); + AssertTrue('function ' + AName + ' present in IR', StartP >= 0); + EndP := StrPos('}', StrCopyTail(AIR, StartP)); + AssertTrue('function ' + AName + ' closed', EndP >= 0); + Result := StrCopyFrom(AIR, StartP, EndP); +end; + +procedure TConstArgTests.TestConstArg_ParamForward_Pins; +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 would be borrowable, but + variable shapes currently pin (see unit comment). } + Region := FuncRegion(GenIR(Src), 'Caller'); + AssertTrue('AddRef pins forwarded param', Pos('_StringAddRef', Region) >= 0); + AssertTrue('Release unpins forwarded param', + Pos('_StringRelease', Region) >= 0); +end; + +procedure TConstArgTests.TestConstArg_LocalVar_Pins; +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; + RelCount, I: Integer; +begin + { L := Mk() consumes the owned return (no AddRef) but still releases L's + previous value; Sink(L) pins L (variable shape, see unit comment). + Releases in Caller: assignment release-old + call unpin + L's + scope-exit release. } + Region := FuncRegion(GenIR(Src), 'Caller'); + AssertTrue('pin AddRef present', Pos('_StringAddRef', Region) >= 0); + RelCount := 0; + I := Pos('_StringRelease', Region); + while I >= 0 do + begin + RelCount := RelCount + 1; + I := PosEx('_StringRelease', Region, I + 1); + end; + AssertEquals('three Releases (assign old + call unpin + scope exit)', + 3, RelCount); +end; + +procedure TConstArgTests.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(GenIR(Src), 'Caller'); + AssertEquals('no AddRef for literal arg', -1, Pos('_StringAddRef', Region)); + AssertEquals('no Release for literal arg', -1, Pos('_StringRelease', Region)); +end; + +procedure TConstArgTests.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), which + would release the buffer the borrowed argument points at — must pin. } + Region := FuncRegion(GenIR(Src), 'Caller'); + AssertTrue('AddRef pins global arg', Pos('_StringAddRef', Region) >= 0); + AssertTrue('Release unpins global arg', Pos('_StringRelease', Region) >= 0); +end; + +procedure TConstArgTests.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 (this + used to leak — the pin pair netted to zero and nobody released). } + Region := FuncRegion(GenIR(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 TConstArgTests.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 AddRef/Release pair both + protects it during the call and frees it afterwards. } + Region := FuncRegion(GenIR(Src), 'Caller'); + AssertTrue('AddRef pins concat temp', Pos('_StringAddRef', Region) >= 0); + AssertTrue('Release frees concat temp', Pos('_StringRelease', Region) >= 0); +end; + +procedure TConstArgTests.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 itself: the callee's write to B releases L's buffer while + A still borrows it — A must be pinned (variable shapes always pin). } + Region := FuncRegion(GenIR(Src), 'Caller'); + AssertTrue('AddRef pins despite local shape', + Pos('_StringAddRef', Region) >= 0); +end; + +initialization + RegisterTest(TConstArgTests); + +end. diff --git a/stdlib/src/main/pascal/classes.pas b/stdlib/src/main/pascal/classes.pas index 3212f20..a304271 100644 --- a/stdlib/src/main/pascal/classes.pas +++ b/stdlib/src/main/pascal/classes.pas @@ -175,10 +175,10 @@ type FHashCap: Integer; { power of two; 0 = index not built } FHashUsed: Integer; { occupied slots (excludes duplicate keys) } procedure Grow; - function Compare(S1: string; S2: string): Integer; - function FindSorted(S: string; var Idx: Integer): Boolean; - function HashOf(S: string): Integer; - function KeyEquals(S1: string; S2: string): Boolean; + function Compare(const S1: string; const S2: string): Integer; + function FindSorted(const S: string; var Idx: Integer): Boolean; + function HashOf(const S: string): Integer; + function KeyEquals(const S1: string; const S2: string): Boolean; procedure HashInvalidate; procedure HashInsertIdx(AIdx: Integer); procedure HashRebuild; @@ -188,8 +188,8 @@ type procedure Destroy; function Add(S: string): Integer; procedure AddObject(S: string; AObject: Pointer); - function Find(S: string; var Index: Integer): Boolean; - function IndexOf(S: string): Integer; + function Find(const S: string; var Index: Integer): Boolean; + function IndexOf(const S: string): Integer; function Get(AIndex: Integer): string; procedure Put(AIndex: Integer; S: string); function GetObject(AIndex: Integer): Pointer; @@ -387,7 +387,7 @@ begin Self.FCapacity := NewCap end; -function TStringList.Compare(S1: string; S2: string): Integer; +function TStringList.Compare(const S1: string; const S2: string): Integer; begin if Self.FCaseSensitive then Result := CompareStr(S1, S2) @@ -397,7 +397,7 @@ end; { Equality-only comparison for hash probing. Cheaper than Compare: both RTL helpers reject on length before touching the bytes. } -function TStringList.KeyEquals(S1: string; S2: string): Boolean; +function TStringList.KeyEquals(const S1: string; const S2: string): Boolean; begin if Self.FCaseSensitive then Result := S1 = S2 @@ -407,7 +407,7 @@ end; { FNV-1a over the string bytes, folding A..Z to a..z when the list is case-insensitive so equal-modulo-case keys land in the same bucket. } -function TStringList.HashOf(S: string): Integer; +function TStringList.HashOf(const S: string): Integer; var I: Integer; C: Integer; @@ -504,7 +504,7 @@ begin end; end; -function TStringList.FindSorted(S: string; var Idx: Integer): Boolean; +function TStringList.FindSorted(const S: string; var Idx: Integer): Boolean; var Lo: Integer; Hi: Integer; @@ -620,7 +620,7 @@ begin ObjP^ := AObject end; -function TStringList.Find(S: string; var Index: Integer): Boolean; +function TStringList.Find(const S: string; var Index: Integer): Boolean; const cHashThreshold = 16; { below this a linear scan beats building a table } var @@ -676,7 +676,7 @@ begin end end; -function TStringList.IndexOf(S: string): Integer; +function TStringList.IndexOf(const S: string): Integer; var Idx: Integer; begin