+ initial implementation of the RTTI for parameter locations (not *yet* used by anything)

The parameter manager converts from the internal compiler representation of
a parameter's location to an RTTI representation. As the general implementation
more or less directly uses the compiler structures for this a platform specific
parameter manager may override this functionality in case some parameter
information changed in a non-backwards compatible way.
The RTTI parameter location has a layout that allows for an easy enumeration
as the size is fixed for all locations. Additionally there are properties that
allow for easy access to the information stored in them.

git-svn-id: trunk@35250 -

compiler/ncgrtti.pas

@@ -28,7 +28,7 @@ interface
     uses
       cclasses,constexp,
       aasmbase,aasmcnst,
-      symbase,symconst,symtype,symdef;
+      symbase,symconst,symtype,symdef,symsym;
 
     type
 
@@ -60,6 +60,7 @@ interface
         procedure write_header(tcb: ttai_typedconstbuilder; def: tdef; typekind: byte);
         function write_methodkind(tcb:ttai_typedconstbuilder;def:tabstractprocdef):byte;
         procedure write_callconv(tcb:ttai_typedconstbuilder;def:tabstractprocdef);
+        procedure write_paralocs(tcb:ttai_typedconstbuilder;parasym:tparavarsym);
       public
         constructor create;
         procedure write_rtti(def:tdef;rt:trttitype);
@@ -81,9 +82,10 @@ implementation
        cutils,
        globals,globtype,verbose,systems,
        fmodule, procinfo,
-       symtable,symsym,
+       symtable,
        aasmtai,aasmdata,
        defutil,
+       parabase,paramgr,
        wpobase
        ;
 
@@ -237,6 +239,27 @@ implementation
         tcb.emit_ord_const(ProcCallOptionToCallConv[def.proccalloption],u8inttype);
       end;
 
+
+    procedure TRTTIWriter.write_paralocs(tcb:ttai_typedconstbuilder;parasym:tparavarsym);
+      var
+        locs : trttiparalocs;
+        i : longint;
+      begin
+        locs:=paramanager.cgparalocs_to_rttiparalocs(parasym.paraloc[callerside].location);
+        if length(locs)>high(byte) then
+          internalerror(2017010601);
+        tcb.emit_ord_const(length(locs),u8inttype);
+        for i:=low(locs) to high(locs) do
+          begin
+            tcb.emit_ord_const(locs[i].loctype,u8inttype);
+            tcb.emit_ord_const(locs[i].regsub,u8inttype);
+            tcb.emit_ord_const(locs[i].regindex,u16inttype);
+            { the corresponding type for aint is alusinttype }
+            tcb.emit_ord_const(locs[i].offset,alusinttype);
+          end;
+      end;
+
+
     procedure TRTTIWriter.write_rtti_name(tcb: ttai_typedconstbuilder; def: tdef);
       begin
          if is_open_array(def) then

compiler/parabase.pas

@@ -140,6 +140,19 @@ unit parabase;
        end;
 
 
+       trttiparaloc = record
+         { contains the regtype in bits 0-6 and whether it's reference or not
+           in bit 7 }
+         loctype : byte;
+         regsub : byte;
+         regindex : word;
+         { either stack offset or shiftval }
+         offset : aint;
+       end;
+
+
+       trttiparalocs = array of trttiparaloc;
+
 
 implementation
 

compiler/paramgr.pas

@@ -137,6 +137,10 @@ unit paramgr;
           function parseparaloc(parasym : tparavarsym;const s : string) : boolean;virtual;
           function parsefuncretloc(p : tabstractprocdef; const s : string) : boolean;virtual;
 
+          { Convert a list of CGParaLocation entries to a RTTIParaLoc array that
+            can be written by ncgrtti }
+          function cgparalocs_to_rttiparalocs(paralocs:pcgparalocation):trttiparalocs;
+
           { allocate room for parameters on the stack in the entry code? }
           function use_fixed_stack: boolean;
           { whether stack pointer can be changed in the middle of procedure }
@@ -155,6 +159,11 @@ unit paramgr;
             for which the def is paradef and the integer length is restlen.
             fullsize is true if restlen equals the full paradef size }
           function get_paraloc_def(paradef: tdef; restlen: aint; fullsize: boolean): tdef;
+
+          { convert a single CGParaLocation to a RTTIParaLoc; the method *might*
+            be overriden by targets to provide backwards compatibility with
+            older versions in case register indices changed }
+          function cgparaloc_to_rttiparaloc(paraloc:pcgparalocation):trttiparaloc;virtual;
        end;
 
 
@@ -662,6 +671,71 @@ implementation
       end;
 
 
+    function tparamanager.cgparalocs_to_rttiparalocs(paralocs:pcgparalocation):trttiparalocs;
+      var
+        c : longint;
+        tmploc : pcgparalocation;
+      begin
+        c:=0;
+        tmploc:=paralocs;
+        while assigned(tmploc) do
+          begin
+            inc(c);
+            tmploc:=tmploc^.next;
+          end;
+
+        setlength(result,c);
+
+        c:=0;
+        tmploc:=paralocs;
+        while assigned(tmploc) do
+          begin
+            result[c]:=cgparaloc_to_rttiparaloc(tmploc);
+            inc(c);
+            tmploc:=tmploc^.next;
+          end;
+      end;
+
+
+    function tparamanager.cgparaloc_to_rttiparaloc(paraloc:pcgparalocation):trttiparaloc;
+      var
+        reg : tregisterrec;
+      begin
+        if paraloc^.Loc=LOC_REFERENCE then
+          begin
+            reg:=tregisterrec(paraloc^.reference.index);
+            result.offset:=paraloc^.reference.offset;
+            result.loctype:=$80;
+          end
+        else
+          begin
+            reg:=tregisterrec(paraloc^.register);
+            { use sign extension }
+            result.offset:=paraloc^.shiftval;
+            result.loctype:=$00;
+          end;
+        case reg.regtype of
+          R_INTREGISTER,
+          R_FPUREGISTER,
+          R_MMXREGISTER,
+          R_MMREGISTER,
+          R_SPECIALREGISTER,
+          R_ADDRESSREGISTER:
+            begin
+              result.loctype:=result.loctype or ord(reg.regtype);
+              result.regsub:=ord(reg.subreg);
+              result.regindex:=reg.supreg;
+            end;
+          else
+            begin
+              { no need to adjust loctype }
+              result.regsub:=0;
+              result.regindex:=0;
+            end;
+        end;
+      end;
+
+
 initialization
   ;
 finalization

rtl/objpas/typinfo.pp

@@ -80,6 +80,72 @@ unit typinfo;
       TTypeKinds = set of TTypeKind;
       ShortStringBase = string[255];
 
+{$push}
+{$scopedenums on}
+      TSubRegister = (
+        None,
+        Lo,
+        Hi,
+        Word,
+        DWord,
+        QWord,
+        FloatSingle,
+        FloatDouble,
+        FloatQuad,
+        MultiMediaSingle,
+        MultiMediaDouble,
+        MultiMediaWhole,
+        MultiMediaX,
+        MultiMediaY
+      );
+
+      TRegisterType = (
+        Invalid,
+        Int,
+        FP,
+        MMX,
+        MultiMedia,
+        Special,
+        Address
+      );
+{$pop}
+
+      TParameterLocation =
+{$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}
+      packed
+{$endif FPC_REQUIRES_PROPER_ALIGNMENT}
+      record
+      private
+        LocType: Byte;
+        function GetRegType: TRegisterType; inline;
+        function GetReference: Boolean; inline;
+        function GetShiftVal: Int8; inline;
+      public
+        RegSub: TSubRegister;
+        RegNumber: Word;
+        { Stack offset if Reference, ShiftVal if not }
+        Offset: SizeInt;
+        { if Reference then the register is the index register otherwise the
+          register in wihch (part of) the parameter resides }
+        property Reference: Boolean read GetReference;
+        property RegType: TRegisterType read GetRegType;
+        { if Reference, otherwise 0 }
+        property ShiftVal: Int8 read GetShiftVal;
+      end;
+      PParameterLocation = ^TParameterLocation;
+
+      TParameterLocations =
+{$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}
+      packed
+{$endif FPC_REQUIRES_PROPER_ALIGNMENT}
+      record
+      private
+        function GetLocation(aIndex: Byte): PParameterLocation; inline;
+      public
+        Count: Byte;
+        property Location[Index: Byte]: PParameterLocation read GetLocation;
+      end;
+
       PVmtFieldEntry = ^TVmtFieldEntry;
       TVmtFieldEntry =
 {$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}
@@ -2298,6 +2364,41 @@ begin
   Result:=IsStoredProp(instance,FindPropInfo(Instance,PropName));
 end;
 
+{ TParameterLocation }
+
+function TParameterLocation.GetReference: Boolean;
+begin
+  Result := (LocType and $80) <> 0;
+end;
+
+function TParameterLocation.GetRegType: TRegisterType;
+begin
+  Result := TRegisterType(LocType and $7F);
+end;
+
+function TParameterLocation.GetShiftVal: Int8;
+begin
+  if GetReference then begin
+    if Offset < Low(Int8) then
+      Result := Low(Int8)
+    else if Offset > High(Int8) then
+      Result := High(Int8)
+    else
+      Result := Offset;
+  end else
+    Result := 0;
+end;
+
+{ TParameterLocations }
+
+function TParameterLocations.GetLocation(aIndex: Byte): PParameterLocation;
+begin
+  if aIndex >= Count then
+    Result := Nil
+  else
+    Result := PParameterLocation(@Count + SizeOf(Count) + SizeOf(TParameterLocation) * Count);
+end;
+
 { TProcedureParam }
 
 function TProcedureParam.GetParamType: PTypeInfo;