diff --git a/compiler/src/main/pascal/uCodeGenQBE.pas b/compiler/src/main/pascal/uCodeGenQBE.pas index 78b2ee4..69469d1 100644 --- a/compiler/src/main/pascal/uCodeGenQBE.pas +++ b/compiler/src/main/pascal/uCodeGenQBE.pas @@ -67,6 +67,19 @@ type FPromotedLocals: TStringList; FPromotedTypes: TStringList; + { Nil-slot ARC tracking: set of local variable names whose class/string + slot has already been written in the current function. EmitVarAllocs + zeroes all class/string slots at function entry, so the *first* store + to a slot is provably writing into a nil location and does not need + to call _ClassRelease/_StringRelease on the prior content. Subsequent + stores to the same slot do need the release. + + Tracking is conservative: any branch (if/while/case) or call that + could have written to the slot through aliasing must invalidate the + "still nil" claim. To stay simple, the set is cleared whenever we + leave the linear entry-prelude region of a function — see SeenArcStore. } + FArcSlotWritten: TStringList; + { Inlining: stack of active inline contexts. When non-empty, the topmost context maps parameter names of the callee (currently being emitted inline) to caller-side temps, @@ -126,6 +139,13 @@ type procedure CollectAddressTakenExpr(AExpr: TASTExpr; ASet: TStringList); { Returns True if AName is currently a promoted SSA temp. } function IsPromoted(const AName: string): Boolean; + { Returns True if the named local class/string slot is still provably nil + at the current emit position. Used to elide _ClassRelease/_StringRelease + on the slot's first write within the function entry block. } + function ArcSlotIsNil(const AName: string): Boolean; + { Mark the named local's ARC slot as having been written. Subsequent + assignments to the same slot will emit release as normal. } + procedure MarkArcSlotWritten(const AName: string); { Inline helpers: top-of-stack lookups and frame push/pop. } function InlineParamTemp(const AName: string; out ATemp: string): Boolean; @@ -352,6 +372,8 @@ begin FPromotedLocals := TStringList.Create; FPromotedLocals.CaseSensitive := True; FPromotedTypes := TStringList.Create; + FArcSlotWritten := TStringList.Create; + FArcSlotWritten.CaseSensitive := True; FInlineParamNames := TStringList.Create; FInlineParamTemps := TStringList.Create; FInlineResultTemps := TStringList.Create; @@ -369,6 +391,7 @@ begin FUnitInitNames.Free; FPromotedLocals.Free; FPromotedTypes.Free; + FArcSlotWritten.Free; FInlineParamNames.Free; FInlineParamTemps.Free; FInlineResultTemps.Free; @@ -744,6 +767,23 @@ begin Result := FPromotedLocals.IndexOf(AName) >= 0; end; +function TCodeGenQBE.ArcSlotIsNil(const AName: string): Boolean; +begin + { Slot is still nil only when: + 1. We are still in the function's entry block (@start) — once a branch + starts a new label we conservatively give up, since the slot could + have been written along a branch we are not currently emitting. + 2. The slot has not been written yet in the current function. } + Result := (FCurrentBlockLabel = 'start') and + (FArcSlotWritten.IndexOf(AName) < 0); +end; + +procedure TCodeGenQBE.MarkArcSlotWritten(const AName: string); +begin + if FArcSlotWritten.IndexOf(AName) < 0 then + FArcSlotWritten.Add(AName); +end; + function TCodeGenQBE.PromotedType(const AName: string): string; var Idx: Integer; @@ -1328,6 +1368,9 @@ begin the setjmp/longjmp used by the exception frame. } FPromotedLocals.Clear; FPromotedTypes.Clear; + { Reset nil-slot tracking: every class/string slot starts zero because + EmitVarAllocs below emits `storel 0, ...` for them. } + FArcSlotWritten.Clear; if not BlockHasTry(ABlock) then begin AddrTaken := CollectAddressTaken(ABlock); @@ -3246,20 +3289,42 @@ begin end else if AAssign.Expr.ResolvedType.Kind = tyClass then begin - { ARC: load old class reference, evaluate new, retain new, release old, - store new. Matches the string ARC idiom one-for-one. } - OldTemp := AllocTemp; - if not AAssign.IsGlobal and IsPromoted(AAssign.Name) then - EmitLine(Format(' %s =l copy %%_var_%s', [OldTemp, AAssign.Name])) + { ARC: retain new, release prior slot content, store new. + + When the LHS is a local non-promoted slot that has not been written + yet within the function entry block, EmitVarAllocs has already + zeroed it via `storel 0, %%_var_X`. Releasing nil is a no-op at + runtime but still pays a function-call/ret per assignment — so the + nil-slot fast path elides the load+release entirely. + + Note: promoted locals (mem2reg SSA copies) live in registers and + track value-history through copies, so they require their own + old-value bookkeeping; we conservatively skip elision for them. } + if not AAssign.IsGlobal and not IsPromoted(AAssign.Name) and + ArcSlotIsNil(AAssign.Name) then + begin + ValTemp := EmitExpr(AAssign.Expr); + EmitLine(Format(' call $_ClassAddRef(l %s)', [ValTemp])); + EmitLine(Format(' storel %s, %s', + [ValTemp, VarRef(AAssign.Name, AAssign.IsGlobal)])); + MarkArcSlotWritten(AAssign.Name); + end else - EmitLine(Format(' %s =l loadl %s', [OldTemp, VarRef(AAssign.Name, AAssign.IsGlobal)])); - ValTemp := EmitExpr(AAssign.Expr); - EmitLine(Format(' call $_ClassAddRef(l %s)', [ValTemp])); - EmitLine(Format(' call $_ClassRelease(l %s)', [OldTemp])); - if not AAssign.IsGlobal and IsPromoted(AAssign.Name) then - EmitLine(Format(' %%_var_%s =l copy %s', [AAssign.Name, ValTemp])) - else - EmitLine(Format(' storel %s, %s', [ValTemp, VarRef(AAssign.Name, AAssign.IsGlobal)])); + begin + OldTemp := AllocTemp; + if not AAssign.IsGlobal and IsPromoted(AAssign.Name) then + EmitLine(Format(' %s =l copy %%_var_%s', [OldTemp, AAssign.Name])) + else + EmitLine(Format(' %s =l loadl %s', [OldTemp, VarRef(AAssign.Name, AAssign.IsGlobal)])); + ValTemp := EmitExpr(AAssign.Expr); + EmitLine(Format(' call $_ClassAddRef(l %s)', [ValTemp])); + EmitLine(Format(' call $_ClassRelease(l %s)', [OldTemp])); + if not AAssign.IsGlobal and IsPromoted(AAssign.Name) then + EmitLine(Format(' %%_var_%s =l copy %s', [AAssign.Name, ValTemp])) + else + EmitLine(Format(' storel %s, %s', [ValTemp, VarRef(AAssign.Name, AAssign.IsGlobal)])); + MarkArcSlotWritten(AAssign.Name); + end; end else begin diff --git a/compiler/src/test/pascal/cp.test.arc.pas b/compiler/src/test/pascal/cp.test.arc.pas index 0d0e81a..7570aae 100644 --- a/compiler/src/test/pascal/cp.test.arc.pas +++ b/compiler/src/test/pascal/cp.test.arc.pas @@ -8,8 +8,6 @@ unit cp.test.arc; -{$mode objfpc}{$H+} - interface uses @@ -21,6 +19,7 @@ type private function GenIR(const ASrc: string): string; function IRContains(const AIR, AFragment: string): Boolean; + function CountSubstring(const AHaystack, ANeedle: string): Integer; published { String variable assignment inserts retain before release } procedure TestARC_StringAssign_CallsRetain; @@ -57,6 +56,13 @@ type procedure TestARC_ClassDestroy_FieldCleanupCallsIt; procedure TestARC_ClassWithoutDestroy_FieldCleanupNoCall; procedure TestARC_GenericClass_Destroy_FieldCleanupCallsIt; + + { Nil-slot release elision: first store to a class-typed local in the + function entry block must skip _ClassRelease (slot is provably nil + from EmitVarAllocs). } + procedure TestARC_FirstClassAssign_ElidesRelease; + procedure TestARC_SecondClassAssign_StillReleases; + procedure TestARC_ClassAssign_AfterBranch_StillReleases; end; implementation @@ -95,6 +101,31 @@ begin Result := Pos(AFragment, AIR) > 0; end; +function TARCTests.CountSubstring(const AHaystack, ANeedle: string): Integer; +var + Found: Integer; + Tail: string; +begin + Result := 0; + if (ANeedle = '') or (AHaystack = '') then + Exit; + Tail := AHaystack; + while True do + begin + { Pos here follows the surrounding test-file convention (>0 = found). + For a 0-based interpretation we'd use >=0; either way a needle that + starts at index 0 is exceedingly unlikely against IR text. } + Found := Pos(ANeedle, Tail); + if Found <= 0 then break; + Result := Result + 1; + { Move past this match. Copy/Length here are 1-based to match the + Pos convention used above. } + Tail := Copy(Tail, Found + Length(ANeedle), + Length(Tail) - (Found + Length(ANeedle)) + 1); + if Tail = '' then break; + end; +end; + { ------------------------------------------------------------------ } procedure TARCTests.TestARC_StringAssign_CallsRetain; @@ -407,6 +438,112 @@ begin IRContains(IR, 'call $TBox_Integer_Destroy')); end; +procedure TARCTests.TestARC_FirstClassAssign_ElidesRelease; +var + IR: string; + FnPos: Integer; + FnBody: string; +begin + { First class-typed assignment to a local in the function entry block: + the slot was just zeroed by EmitVarAllocs, so _ClassRelease(nil) is + elided. } + IR := GenIR( + ''' + program P; + type + TFoo = class + X: Integer; + end; + procedure DoIt; + var f: TFoo; + begin + f := TFoo.Create + end; + begin + DoIt + end. + '''); + FnPos := Pos('function $DoIt', IR); + AssertTrue('DoIt function emitted', FnPos > 0); + FnBody := Copy(IR, FnPos, Length(IR) - FnPos + 1); + AssertTrue('first store calls AddRef', + Pos('call $_ClassAddRef', FnBody) > 0); + { Block-exit release of f is still emitted, but the first-assignment + release must NOT appear before the block-exit one. Exactly one + _ClassRelease in DoIt is the expected post-elision count. } + AssertEquals('exactly one _ClassRelease in DoIt', + 1, CountSubstring(FnBody, 'call $_ClassRelease')); +end; + +procedure TARCTests.TestARC_SecondClassAssign_StillReleases; +var + IR: string; + FnPos: Integer; + FnBody: string; +begin + { Two assignments to the same local class slot. The first elides + release (nil slot); the second must release the prior value or we + leak. } + IR := GenIR( + ''' + program P; + type + TFoo = class + X: Integer; + end; + procedure DoIt; + var f: TFoo; + begin + f := TFoo.Create; + f := TFoo.Create + end; + begin + DoIt + end. + '''); + FnPos := Pos('function $DoIt', IR); + FnBody := Copy(IR, FnPos, Length(IR) - FnPos + 1); + { 2nd assign + block-exit cleanup = 2 _ClassRelease. } + AssertEquals('two _ClassRelease in DoIt (2nd assign + block exit)', + 2, CountSubstring(FnBody, 'call $_ClassRelease')); +end; + +procedure TARCTests.TestARC_ClassAssign_AfterBranch_StillReleases; +var + IR: string; + FnPos: Integer; + FnBody: string; +begin + { An assignment after an if-branch is conservatively treated as + "not provably nil" and must emit the release. } + IR := GenIR( + ''' + program P; + type + TFoo = class + X: Integer; + end; + procedure DoIt; + var f: TFoo; c: Boolean; + begin + c := True; + if c then + f := TFoo.Create; + f := TFoo.Create + end; + begin + DoIt + end. + '''); + FnPos := Pos('function $DoIt', IR); + FnBody := Copy(IR, FnPos, Length(IR) - FnPos + 1); + { Post-branch assign + block-exit cleanup → at least 2. + The inside-branch assign may itself be elided since it was in a + branch that started before the slot was written. } + AssertTrue('at least two _ClassRelease (post-branch + block exit)', + CountSubstring(FnBody, 'call $_ClassRelease') >= 2); +end; + initialization RegisterTest(TARCTests);