compiler:

- add TTagHashSet class descendant of THashSet with an ability to has also a LongWord value together with key
  - change TAsmData.ConstPools[] to be an indexed property to properly initialize ConstPool class, remove pool initialization from all other units
  - add ansistring constants to pool together with their encoding to distinct the same text constants with different codepage
  + test

git-svn-id: trunk@19261 -

.gitattributes

@@ -9949,6 +9949,7 @@ tests/test/tconstref4.pp svneol=native#text/pascal
 tests/test/tcpstr1.pp svneol=native#text/plain
 tests/test/tcpstr10.pp svneol=native#text/pascal
 tests/test/tcpstr11.pp svneol=native#text/pascal
+tests/test/tcpstr12.pp svneol=native#text/pascal
 tests/test/tcpstr2.pp svneol=native#text/plain
 tests/test/tcpstr2a.pp svneol=native#text/plain
 tests/test/tcpstr3.pp svneol=native#text/plain

compiler/aasmdata.pas

@@ -138,6 +138,8 @@ interface
       end;
       TAsmCFIClass=class of TAsmCFI;
 
+      { TAsmData }
+
       TAsmData = class
       private
         { Symbols }
@@ -147,6 +149,8 @@ interface
         FNextLabelNr   : array[TAsmLabeltype] of longint;
         { Call Frame Information for stack unwinding}
         FAsmCFI        : TAsmCFI;
+        FConstPools    : array[TConstPoolType] of THashSet;
+        function GetConstPools(APoolType: TConstPoolType): THashSet;
       public
         name,
         realname      : string[80];
@@ -156,8 +160,6 @@ interface
         CurrAsmList   : TAsmList;
         WideInits     : TLinkedList;
         ResStrInits   : TLinkedList;
-        { hash tables for reusing constant storage }
-        ConstPools    : array[TConstPoolType] of THashSet;
         constructor create(const n:string);
         destructor  destroy;override;
         { asmsymbol }
@@ -176,6 +178,8 @@ interface
         procedure ResetAltSymbols;
         property AsmSymbolDict:TFPHashObjectList read FAsmSymbolDict;
         property AsmCFI:TAsmCFI read FAsmCFI;
+        { hash tables for reusing constant storage }
+        property ConstPools[APoolType:TConstPoolType]: THashSet read GetConstPools;
       end;
 
       TTCInitItem = class(TLinkedListItem)
@@ -315,6 +319,17 @@ implementation
                                 TAsmData
 ****************************************************************************}
 
+    function TAsmData.GetConstPools(APoolType: TConstPoolType): THashSet;
+      begin
+        if FConstPools[APoolType] = nil then
+          case APoolType of
+            sp_ansistr: FConstPools[APoolType] := TTagHashSet.Create(64, True, False);
+          else
+            FConstPools[APoolType] := THashSet.Create(64, True, False);
+          end;
+        Result := FConstPools[APoolType];
+      end;
+
     constructor TAsmData.create(const n:string);
       var
         alt : TAsmLabelType;
@@ -376,7 +391,7 @@ implementation
          memasmlists.stop;
 {$endif}
          for hp := low(TConstPoolType) to high(TConstPoolType) do
-           ConstPools[hp].Free;
+           FConstPools[hp].Free;
       end;
 
 

compiler/cclasses.pas

@@ -479,13 +479,16 @@ type
        THashSet = class(TObject)
        private
          FCount: LongWord;
-         FBucketCount: LongWord;
-         FBucket: PPHashSetItem;
          FOwnsObjects: Boolean;
          FOwnsKeys: Boolean;
          function Lookup(Key: Pointer; KeyLen: Integer; var Found: Boolean;
            CanCreate: Boolean): PHashSetItem;
          procedure Resize(NewCapacity: LongWord);
+       protected
+         FBucket: PPHashSetItem;
+         FBucketCount: LongWord;
+         class procedure FreeItem(item:PHashSetItem); virtual;
+         class function SizeOfItem: Integer; virtual;
        public
          constructor Create(InitSize: Integer; OwnKeys, OwnObjects: Boolean);
          destructor Destroy; override;
@@ -502,7 +505,40 @@ type
          { removes an entry, returns False if entry wasn't there }
          function Remove(Entry: PHashSetItem): Boolean;
          property Count: LongWord read FCount;
-      end;
+       end;
+
+{******************************************************************
+                             TTagHasSet
+*******************************************************************}
+       PPTagHashSetItem = ^PTagHashSetItem;
+       PTagHashSetItem = ^TTagHashSetItem;
+       TTagHashSetItem = record
+         Next: PTagHashSetItem;
+         Key: Pointer;
+         KeyLength: Integer;
+         HashValue: LongWord;
+         Data: TObject;
+         Tag: LongWord;
+       end;
+
+       TTagHashSet = class(THashSet)
+       private
+         function Lookup(Key: Pointer; KeyLen: Integer; Tag: LongWord; var Found: Boolean;
+           CanCreate: Boolean): PTagHashSetItem;
+       protected
+         class procedure FreeItem(item:PHashSetItem); override;
+         class function SizeOfItem: Integer; override;
+       public
+         { finds an entry by key }
+         function Find(Key: Pointer; KeyLen: Integer; Tag: LongWord): PTagHashSetItem; reintroduce;
+         { finds an entry, creates one if not exists }
+         function FindOrAdd(Key: Pointer; KeyLen: Integer; Tag: LongWord;
+           var Found: Boolean): PTagHashSetItem; reintroduce;
+         { finds an entry, creates one if not exists }
+         function FindOrAdd(Key: Pointer; KeyLen: Integer; Tag: LongWord): PTagHashSetItem; reintroduce;
+         { returns Data by given Key }
+         function Get(Key: Pointer; KeyLen: Integer; Tag: LongWord): TObject; reintroduce;
+       end;
 
 
 {******************************************************************
@@ -536,6 +572,7 @@ type
 
     function FPHash(const s:shortstring):LongWord;
     function FPHash(P: PChar; Len: Integer): LongWord;
+    function FPHash(P: PChar; Len: Integer; Tag: LongWord): LongWord;
 
 
 implementation
@@ -1118,6 +1155,21 @@ end;
 {$pop}
       end;
 
+    function FPHash(P: PChar; Len: Integer; Tag: LongWord): LongWord;
+      Var
+        pmax : pchar;
+      begin
+{$push}
+{$q-,r-}
+        result:=Tag;
+        pmax:=p+len;
+        while (p<pmax) do
+          begin
+            result:=LongWord(LongInt(result shl 5) - LongInt(result)) xor LongWord(P^);
+            inc(p);
+          end;
+{$pop}
+      end;
 
 procedure TFPHashList.RaiseIndexError(Index : Integer);
 begin
@@ -2641,7 +2693,7 @@ end;
               item^.Data.Free;
             if FOwnsKeys then
               FreeMem(item^.Key);
-            Dispose(item);
+            FreeItem(item);
             item := next;
           end;
         end;
@@ -2735,7 +2787,7 @@ end;
         i: Integer;
         e, n: PHashSetItem;
       begin
-        p := AllocMem(NewCapacity * sizeof(PHashSetItem));
+        p := AllocMem(NewCapacity * SizeOfItem);
         for i := 0 to FBucketCount-1 do
           begin
             e := FBucket[i];
@@ -2753,6 +2805,15 @@ end;
         FBucket := p;
       end;
 
+    class procedure THashSet.FreeItem(item: PHashSetItem);
+      begin
+        Dispose(item);
+      end;
+
+    class function THashSet.SizeOfItem: Integer;
+      begin
+        Result := SizeOf(THashSetItem);
+      end;
 
     function THashSet.Remove(Entry: PHashSetItem): Boolean;
       var
@@ -2768,7 +2829,7 @@ end;
                   Entry^.Data.Free;
                 if FOwnsKeys then
                   FreeMem(Entry^.Key);
-                Dispose(Entry);
+                FreeItem(Entry);
                 Dec(FCount);
                 Result := True;
                 Exit;
@@ -2779,6 +2840,96 @@ end;
       end;
 
 
+{****************************************************************************
+                                ttaghashset
+****************************************************************************}
+
+    function TTagHashSet.Lookup(Key: Pointer; KeyLen: Integer;
+      Tag: LongWord; var Found: Boolean; CanCreate: Boolean): PTagHashSetItem;
+      var
+        Entry: PPTagHashSetItem;
+        h: LongWord;
+      begin
+        h := FPHash(Key, KeyLen, Tag);
+        Entry := @PPTagHashSetItem(FBucket)[h mod FBucketCount];
+        while Assigned(Entry^) and
+          not ((Entry^^.HashValue = h) and (Entry^^.KeyLength = KeyLen) and
+            (Entry^^.Tag = Tag) and (CompareByte(Entry^^.Key^, Key^, KeyLen) = 0)) do
+              Entry := @Entry^^.Next;
+        Found := Assigned(Entry^);
+        if Found or (not CanCreate) then
+          begin
+            Result := Entry^;
+            Exit;
+          end;
+        if FCount > FBucketCount then  { arbitrary limit, probably too high }
+          begin
+            { rehash and repeat search }
+            Resize(FBucketCount * 2);
+            Result := Lookup(Key, KeyLen, Tag, Found, CanCreate);
+          end
+        else
+          begin
+            New(Result);
+            if FOwnsKeys then
+            begin
+              GetMem(Result^.Key, KeyLen);
+              Move(Key^, Result^.Key^, KeyLen);
+            end
+            else
+              Result^.Key := Key;
+            Result^.KeyLength := KeyLen;
+            Result^.HashValue := h;
+            Result^.Tag := Tag;
+            Result^.Data := nil;
+            Result^.Next := nil;
+            Inc(FCount);
+            Entry^ := Result;
+          end;
+      end;
+
+    class procedure TTagHashSet.FreeItem(item: PHashSetItem);
+      begin
+        Dispose(PTagHashSetItem(item));
+      end;
+
+    class function TTagHashSet.SizeOfItem: Integer;
+      begin
+        Result := SizeOf(TTagHashSetItem);
+      end;
+
+    function TTagHashSet.Find(Key: Pointer; KeyLen: Integer; Tag: LongWord): PTagHashSetItem;
+      var
+        Dummy: Boolean;
+      begin
+        Result := Lookup(Key, KeyLen, Tag, Dummy, False);
+      end;
+
+    function TTagHashSet.FindOrAdd(Key: Pointer; KeyLen: Integer; Tag: LongWord;
+      var Found: Boolean): PTagHashSetItem;
+      begin
+        Result := Lookup(Key, KeyLen, Tag, Found, True);
+      end;
+
+    function TTagHashSet.FindOrAdd(Key: Pointer; KeyLen: Integer; Tag: LongWord): PTagHashSetItem;
+      var
+        Dummy: Boolean;
+      begin
+        Result := Lookup(Key, KeyLen, Tag, Dummy, True);
+      end;
+
+    function TTagHashSet.Get(Key: Pointer; KeyLen: Integer; Tag: LongWord): TObject;
+      var
+        e: PTagHashSetItem;
+        Dummy: Boolean;
+      begin
+        e := Lookup(Key, KeyLen, Tag, Dummy, False);
+        if Assigned(e) then
+          Result := e^.Data
+        else
+          Result := nil;
+      end;
+
 {****************************************************************************
                                 tbitset
 ****************************************************************************}

compiler/ncgcon.pas

@@ -139,9 +139,6 @@ implementation
         { const already used ? }
         if not assigned(lab_real) then
           begin
-            if current_asmdata.ConstPools[sp_floats] = nil then
-              current_asmdata.ConstPools[sp_floats] := THashSet.Create(64, True, False);
-
             { there may be gap between record fields, zero it out }
             fillchar(key,sizeof(key),0);
             key.value:=value_real;
@@ -255,11 +252,10 @@ implementation
 
     procedure tcgstringconstnode.pass_generate_code;
       var
-         lastlabel   : tasmlabel;
-         pc       : pchar;
+         lastlabel: tasmlabel;
+         pc: pchar;
          l: longint;
          href: treference;
-         pooltype: TConstPoolType;
          pool: THashSet;
          entry: PHashSetItem;
 
@@ -283,13 +279,13 @@ implementation
          { const already used ? }
          if not assigned(lab_str) then
            begin
-              pooltype := PoolMap[cst_type];
-              if current_asmdata.ConstPools[pooltype] = nil then
-                current_asmdata.ConstPools[pooltype] := THashSet.Create(64, True, False);
-              pool := current_asmdata.ConstPools[pooltype];
+              pool := current_asmdata.ConstPools[PoolMap[cst_type]];
 
               if cst_type in [cst_widestring, cst_unicodestring] then
                 entry := pool.FindOrAdd(pcompilerwidestring(value_str)^.data, len*cwidechartype.size)
+              else
+              if cst_type = cst_ansistring then
+                entry := PHashSetItem(TTagHashSet(pool).FindOrAdd(value_str, len, tstringdef(resultdef).encoding))
               else
                 entry := pool.FindOrAdd(value_str, len);
 
@@ -415,8 +411,6 @@ implementation
           { const already used ? }
           if not assigned(lab_set) then
             begin
-              if current_asmdata.ConstPools[sp_varsets] = nil then
-                current_asmdata.ConstPools[sp_varsets] := THashSet.Create(64, True, False);
               entry := current_asmdata.ConstPools[sp_varsets].FindOrAdd(value_set, 32);
 
               lab_set := TAsmLabel(entry^.Data);  // is it needed anymore?

compiler/ncgmem.pas

@@ -114,8 +114,6 @@ implementation
                end
              else
                begin
-                 if current_asmdata.ConstPools[sp_objcclassnamerefs]=nil then
-                   current_asmdata.ConstPools[sp_objcclassnamerefs]:=THashSet.Create(64, True, False);
                  pool:=current_asmdata.ConstPools[sp_objcclassnamerefs];
                  entry:=pool.FindOrAdd(@tobjectdef(left.resultdef).objextname^[1],length(tobjectdef(left.resultdef).objextname^));
                  if (target_info.system in systems_objc_nfabi) then

compiler/ncgobjc.pas

@@ -58,8 +58,6 @@ procedure tcgobjcselectornode.pass_generate_code;
     entry  : PHashSetItem;
     name   : pshortstring;
   begin
-    if current_asmdata.ConstPools[sp_varnamerefs]=nil then
-      current_asmdata.ConstPools[sp_varnamerefs]:=THashSet.Create(64, True, False);
     pool:=current_asmdata.ConstPools[sp_varnamerefs];
 
     case left.nodetype of

compiler/objcgutl.pas

@@ -133,9 +133,6 @@ function objcaddprotocolentry(const p: shortstring; ref: TAsmSymbol): Boolean;
   var
     item  : PHashSetItem;
   begin
-    if current_asmdata.ConstPools[sp_objcprotocolrefs]=nil then
-      current_asmdata.ConstPools[sp_objcprotocolrefs]:=THashSet.Create(64, True, False);
-
     item:=current_asmdata.constpools[sp_objcprotocolrefs].FindOrAdd(@p[1], length(p));
     Result:=(item^.Data=nil);
     if Result then
@@ -153,8 +150,6 @@ function objcreatestringpoolentryintern(p: pchar; len: longint; pooltype: tconst
     pc     : pchar;
     pool   : THashSet;
   begin
-    if current_asmdata.ConstPools[pooltype]=nil then
-       current_asmdata.ConstPools[pooltype]:=THashSet.Create(64, True, False);
     pool := current_asmdata.constpools[pooltype];
 
     entry:=pool.FindOrAdd(p,len);

tests/test/tcpstr12.pp

@@ -0,0 +1,18 @@
+program tcpstr12;
+
+// check that 'test' constants assigned to ansistring variables have different codepage
+
+{$mode delphi}
+type
+  cp866 = type AnsiString(866);
+var
+  A: cp866;
+  B: AnsiString;
+begin
+  B := 'test';
+//  if StringCodePage(B) <> DefaultSystemCodePage then
+//    halt(1);
+  A := 'test';
+  if StringCodePage(A) <> 866 then
+    halt(2);
+end.