← Back to branch summary

~ubuntu-branches/debian/lenny/fpc/lenny

« back to all changes in this revision

Viewing changes to fpcsrc/compiler/rgobj.pas

  • Committer: Bazaar Package Importer
  • Author(s): Mazen Neifer, Torsten Werner, Mazen Neifer
  • Date: 2008-05-17 17:12:11 UTC
  • mfrom: (3.1.9 intrepid)
  • Revision ID: james.westby@ubuntu.com-20080517171211-9qi33xhd9evfa0kg
Tags: 2.2.0-dfsg1-9
http://bugs.debian.org/477743
[ Torsten Werner ]
* Add Mazen Neifer to Uploaders field.

[ Mazen Neifer ]
* Moved FPC sources into a version dependent directory from /usr/share/fpcsrc
  to /usr/share/fpcsrc/${FPCVERSION}. This allow installing more than on FPC
  release.
* Fixed far call issue in compiler preventing building huge binearies.
  (closes: #477743)
* Updated building dependencies, recomennded and suggested packages.
* Moved fppkg to fp-utils as it is just a helper tool and is not required by
  compiler.

Show diffs side-by-side

added added

removed removed

Lines of Context:
fpcsrc/compiler/rgobj.pas
 
1
{
 
2
    Copyright (c) 1998-2002 by Florian Klaempfl
 
3
 
 
4
    This unit implements the base class for the register allocator
 
5
 
 
6
    This program is free software; you can redistribute it and/or modify
 
7
    it under the terms of the GNU General Public License as published by
 
8
    the Free Software Foundation; either version 2 of the License, or
 
9
    (at your option) any later version.
 
10
 
 
11
    This program is distributed in the hope that it will be useful,
 
12
    but WITHOUT ANY WARRANTY; without even the implied warranty of
 
13
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 
14
    GNU General Public License for more details.
 
15
 
 
16
    You should have received a copy of the GNU General Public License
 
17
    along with this program; if not, write to the Free Software
 
18
    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 
19
 ****************************************************************************
 
20
}
 
21
 
 
22
{$i fpcdefs.inc}
 
23
 
 
24
{ Allow duplicate allocations, can be used to get the .s file written }
 
25
{ $define ALLOWDUPREG}
 
26
 
 
27
 
 
28
unit rgobj;
 
29
 
 
30
  interface
 
31
 
 
32
    uses
 
33
      cutils, cpubase,
 
34
      aasmbase,aasmtai,aasmdata,aasmcpu,
 
35
      cclasses,globtype,cgbase,cgutils,
 
36
      cpuinfo
 
37
      ;
 
38
 
 
39
    type
 
40
      {
 
41
        The interference bitmap contains of 2 layers:
 
42
          layer 1 - 256*256 blocks with pointers to layer 2 blocks
 
43
          layer 2 - blocks of 32*256 (32 bytes = 256 bits)
 
44
      }
 
45
      Tinterferencebitmap2 = array[byte] of set of byte;
 
46
      Pinterferencebitmap2 = ^Tinterferencebitmap2;
 
47
      Tinterferencebitmap1 = array[byte] of Pinterferencebitmap2;
 
48
      pinterferencebitmap1 = ^tinterferencebitmap1;
 
49
 
 
50
      Tinterferencebitmap=class
 
51
      private
 
52
        maxx1,
 
53
        maxy1    : byte;
 
54
        fbitmap  : pinterferencebitmap1;
 
55
        function getbitmap(x,y:tsuperregister):boolean;
 
56
        procedure setbitmap(x,y:tsuperregister;b:boolean);
 
57
      public
 
58
        constructor create;
 
59
        destructor destroy;override;
 
60
        property bitmap[x,y:tsuperregister]:boolean read getbitmap write setbitmap;default;
 
61
      end;
 
62
 
 
63
      Tmovelistheader=record
 
64
        count,
 
65
        maxcount,
 
66
        sorted_until : cardinal;
 
67
      end;
 
68
 
 
69
      Tmovelist=record
 
70
        header : Tmovelistheader;
 
71
        data : array[tsuperregister] of Tlinkedlistitem;
 
72
      end;
 
73
      Pmovelist=^Tmovelist;
 
74
 
 
75
      {In the register allocator we keep track of move instructions.
 
76
       These instructions are moved between five linked lists. There
 
77
       is also a linked list per register to keep track about the moves
 
78
       it is associated with. Because we need to determine quickly in
 
79
       which of the five lists it is we add anu enumeradtion to each
 
80
       move instruction.}
 
81
 
 
82
      Tmoveset=(ms_coalesced_moves,ms_constrained_moves,ms_frozen_moves,
 
83
                ms_worklist_moves,ms_active_moves);
 
84
      Tmoveins=class(Tlinkedlistitem)
 
85
        moveset:Tmoveset;
 
86
        x,y:Tsuperregister;
 
87
      end;
 
88
 
 
89
      Treginfoflag=(ri_coalesced,ri_selected);
 
90
      Treginfoflagset=set of Treginfoflag;
 
91
 
 
92
      Treginfo=record
 
93
        live_start,
 
94
        live_end   : Tai;
 
95
        subreg   : tsubregister;
 
96
        alias    : Tsuperregister;
 
97
        { The register allocator assigns each register a colour }
 
98
        colour   : Tsuperregister;
 
99
        movelist : Pmovelist;
 
100
        adjlist  : Psuperregisterworklist;
 
101
        degree   : TSuperregister;
 
102
        flags    : Treginfoflagset;
 
103
      end;
 
104
      Preginfo=^TReginfo;
 
105
 
 
106
      tspillreginfo = record
 
107
        spillreg : tregister;
 
108
        orgreg : tsuperregister;
 
109
        tempreg : tregister;
 
110
        regread,regwritten, mustbespilled: boolean;
 
111
      end;
 
112
      tspillregsinfo = array[0..3] of tspillreginfo;
 
113
 
 
114
      Tspill_temp_list=array[tsuperregister] of Treference;
 
115
 
 
116
      {#------------------------------------------------------------------
 
117
 
 
118
      This class implements the default register allocator. It is used by the
 
119
      code generator to allocate and free registers which might be valid
 
120
      across nodes. It also contains utility routines related to registers.
 
121
 
 
122
      Some of the methods in this class should be overriden
 
123
      by cpu-specific implementations.
 
124
 
 
125
      --------------------------------------------------------------------}
 
126
      trgobj=class
 
127
        preserved_by_proc : tcpuregisterset;
 
128
        used_in_proc : tcpuregisterset;
 
129
 
 
130
        constructor create(Aregtype:Tregistertype;
 
131
                           Adefaultsub:Tsubregister;
 
132
                           const Ausable:array of tsuperregister;
 
133
                           Afirst_imaginary:Tsuperregister;
 
134
                           Apreserved_by_proc:Tcpuregisterset);
 
135
        destructor destroy;override;
 
136
 
 
137
        {# Allocate a register. An internalerror will be generated if there is
 
138
         no more free registers which can be allocated.}
 
139
        function getregister(list:TAsmList;subreg:Tsubregister):Tregister;virtual;
 
140
        {# Get the register specified.}
 
141
        procedure getcpuregister(list:TAsmList;r:Tregister);virtual;
 
142
        procedure ungetcpuregister(list:TAsmList;r:Tregister);virtual;
 
143
        {# Get multiple registers specified.}
 
144
        procedure alloccpuregisters(list:TAsmList;const r:Tcpuregisterset);virtual;
 
145
        {# Free multiple registers specified.}
 
146
        procedure dealloccpuregisters(list:TAsmList;const r:Tcpuregisterset);virtual;
 
147
        function uses_registers:boolean;virtual;
 
148
        procedure add_reg_instruction(instr:Tai;r:tregister);
 
149
        procedure add_move_instruction(instr:Taicpu);
 
150
        {# Do the register allocation.}
 
151
        procedure do_register_allocation(list:TAsmList;headertai:tai);virtual;
 
152
        { Adds an interference edge.
 
153
          don't move this to the protected section, the arm cg requires to access this (FK) }
 
154
        procedure add_edge(u,v:Tsuperregister);
 
155
        { translates a single given imaginary register to it's real register }
 
156
        procedure translate_register(var reg : tregister);
 
157
      protected
 
158
        regtype           : Tregistertype;
 
159
        { default subregister used }
 
160
        defaultsub        : tsubregister;
 
161
        live_registers:Tsuperregisterworklist;
 
162
        { can be overriden to add cpu specific interferences }
 
163
        procedure add_cpu_interferences(p : tai);virtual;
 
164
        procedure add_constraints(reg:Tregister);virtual;
 
165
        function  get_alias(n:Tsuperregister):Tsuperregister;
 
166
        function  getregisterinline(list:TAsmList;subreg:Tsubregister):Tregister;
 
167
        procedure ungetregisterinline(list:TAsmList;r:Tregister);
 
168
        function  get_spill_subreg(r : tregister) : tsubregister;virtual;
 
169
        function  do_spill_replace(list:TAsmList;instr:taicpu;orgreg:tsuperregister;const spilltemp:treference):boolean;virtual;
 
170
        procedure do_spill_read(list:TAsmList;pos:tai;const spilltemp:treference;tempreg:tregister);virtual;
 
171
        procedure do_spill_written(list:TAsmList;pos:tai;const spilltemp:treference;tempreg:tregister);virtual;
 
172
 
 
173
        function instr_spill_register(list:TAsmList;
 
174
                                      instr:taicpu;
 
175
                                      const r:Tsuperregisterset;
 
176
                                      const spilltemplist:Tspill_temp_list): boolean;virtual;
 
177
      private
 
178
        do_extend_live_range_backwards: boolean;
 
179
        {# First imaginary register.}
 
180
        first_imaginary   : Tsuperregister;
 
181
        {# Highest register allocated until now.}
 
182
        reginfo           : PReginfo;
 
183
        maxreginfo,
 
184
        maxreginfoinc,
 
185
        maxreg            : Tsuperregister;
 
186
        usable_registers_cnt : word;
 
187
        usable_registers  : array[0..maxcpuregister-1] of tsuperregister;
 
188
        ibitmap           : Tinterferencebitmap;
 
189
        spillednodes,
 
190
        simplifyworklist,
 
191
        freezeworklist,
 
192
        spillworklist,
 
193
        coalescednodes,
 
194
        selectstack       : tsuperregisterworklist;
 
195
        worklist_moves,
 
196
        active_moves,
 
197
        frozen_moves,
 
198
        coalesced_moves,
 
199
        constrained_moves : Tlinkedlist;
 
200
        extended_backwards,
 
201
        backwards_was_first : tsuperregisterset;
 
202
 
 
203
{$ifdef EXTDEBUG}
 
204
        procedure writegraph(loopidx:longint);
 
205
{$endif EXTDEBUG}
 
206
        {# Disposes of the reginfo array.}
 
207
        procedure dispose_reginfo;
 
208
        {# Prepare the register colouring.}
 
209
        procedure prepare_colouring;
 
210
        {# Clean up after register colouring.}
 
211
        procedure epilogue_colouring;
 
212
        {# Colour the registers; that is do the register allocation.}
 
213
        procedure colour_registers;
 
214
        procedure insert_regalloc_info(list:TAsmList;u:tsuperregister);
 
215
        procedure insert_regalloc_info_all(list:TAsmList);
 
216
        procedure generate_interference_graph(list:TAsmList;headertai:tai);
 
217
        { translates the registers in the given assembler list }
 
218
        procedure translate_registers(list:TAsmList);
 
219
        function  spill_registers(list:TAsmList;headertai:tai):boolean;virtual;
 
220
        function  getnewreg(subreg:tsubregister):tsuperregister;
 
221
        procedure add_edges_used(u:Tsuperregister);
 
222
        procedure add_to_movelist(u:Tsuperregister;data:Tlinkedlistitem);
 
223
        function move_related(n:Tsuperregister):boolean;
 
224
        procedure make_work_list;
 
225
        procedure sort_simplify_worklist;
 
226
        procedure enable_moves(n:Tsuperregister);
 
227
        procedure decrement_degree(m:Tsuperregister);
 
228
        procedure simplify;
 
229
        procedure add_worklist(u:Tsuperregister);
 
230
        function adjacent_ok(u,v:Tsuperregister):boolean;
 
231
        function conservative(u,v:Tsuperregister):boolean;
 
232
        procedure combine(u,v:Tsuperregister);
 
233
        procedure coalesce;
 
234
        procedure freeze_moves(u:Tsuperregister);
 
235
        procedure freeze;
 
236
        procedure select_spill;
 
237
        procedure assign_colours;
 
238
        procedure clear_interferences(u:Tsuperregister);
 
239
        procedure set_live_range_backwards(b: boolean);
 
240
       public
 
241
        property extend_live_range_backwards: boolean read do_extend_live_range_backwards write set_live_range_backwards;
 
242
      end;
 
243
 
 
244
    const
 
245
      first_reg = 0;
 
246
      last_reg = high(tsuperregister)-1;
 
247
      maxspillingcounter = 20;
 
248
 
 
249
 
 
250
  implementation
 
251
 
 
252
    uses
 
253
       systems,
 
254
       globals,verbose,tgobj,procinfo;
 
255
 
 
256
 
 
257
    procedure sort_movelist(ml:Pmovelist);
 
258
 
 
259
    {Ok, sorting pointers is silly, but it does the job to make Trgobj.combine
 
260
     faster.}
 
261
 
 
262
    var h,i,p:word;
 
263
        t:Tlinkedlistitem;
 
264
 
 
265
    begin
 
266
      with ml^ do
 
267
        begin
 
268
          if header.count<2 then
 
269
            exit;
 
270
          p:=1;
 
271
          while 2*p<header.count do
 
272
            p:=2*p;
 
273
          while p<>0 do
 
274
            begin
 
275
              for h:=p to header.count-1 do
 
276
                begin
 
277
                  i:=h;
 
278
                  t:=data[i];
 
279
                  repeat
 
280
                    if ptruint(data[i-p])<=ptruint(t) then
 
281
                      break;
 
282
                    data[i]:=data[i-p];
 
283
                    dec(i,p);
 
284
                  until i<p;
 
285
                  data[i]:=t;
 
286
                end;
 
287
              p:=p shr 1;
 
288
            end;
 
289
          header.sorted_until:=header.count-1;
 
290
        end;
 
291
    end;
 
292
 
 
293
{******************************************************************************
 
294
                              tinterferencebitmap
 
295
******************************************************************************}
 
296
 
 
297
    constructor tinterferencebitmap.create;
 
298
      begin
 
299
        inherited create;
 
300
        maxx1:=1;
 
301
        getmem(fbitmap,sizeof(tinterferencebitmap1)*2);
 
302
        fillchar(fbitmap^,sizeof(tinterferencebitmap1)*2,0);
 
303
      end;
 
304
 
 
305
 
 
306
    destructor tinterferencebitmap.destroy;
 
307
 
 
308
    var i,j:byte;
 
309
 
 
310
    begin
 
311
      for i:=0 to maxx1 do
 
312
        for j:=0 to maxy1 do
 
313
          if assigned(fbitmap[i,j]) then
 
314
            dispose(fbitmap[i,j]);
 
315
      freemem(fbitmap);
 
316
    end;
 
317
 
 
318
 
 
319
    function tinterferencebitmap.getbitmap(x,y:tsuperregister):boolean;
 
320
      var
 
321
        page : pinterferencebitmap2;
 
322
      begin
 
323
        result:=false;
 
324
        if (x shr 8>maxx1) then
 
325
          exit;
 
326
        page:=fbitmap[x shr 8,y shr 8];
 
327
        result:=assigned(page) and
 
328
          ((x and $ff) in page^[y and $ff]);
 
329
      end;
 
330
 
 
331
 
 
332
    procedure tinterferencebitmap.setbitmap(x,y:tsuperregister;b:boolean);
 
333
      var
 
334
        x1,y1 : byte;
 
335
      begin
 
336
        x1:=x shr 8;
 
337
        y1:=y shr 8;
 
338
        if x1>maxx1 then
 
339
          begin
 
340
            reallocmem(fbitmap,sizeof(tinterferencebitmap1)*(x1+1));
 
341
            fillchar(fbitmap[maxx1+1],sizeof(tinterferencebitmap1)*(x1-maxx1),0);
 
342
            maxx1:=x1;
 
343
          end;
 
344
        if not assigned(fbitmap[x1,y1]) then
 
345
          begin
 
346
            if y1>maxy1 then
 
347
              maxy1:=y1;
 
348
            new(fbitmap[x1,y1]);
 
349
            fillchar(fbitmap[x1,y1]^,sizeof(tinterferencebitmap2),0);
 
350
          end;
 
351
        if b then
 
352
          include(fbitmap[x1,y1]^[y and $ff],(x and $ff))
 
353
        else
 
354
          exclude(fbitmap[x1,y1]^[y and $ff],(x and $ff));
 
355
      end;
 
356
 
 
357
 
 
358
{******************************************************************************
 
359
                                trgobj
 
360
******************************************************************************}
 
361
 
 
362
    constructor trgobj.create(Aregtype:Tregistertype;
 
363
                              Adefaultsub:Tsubregister;
 
364
                              const Ausable:array of tsuperregister;
 
365
                              Afirst_imaginary:Tsuperregister;
 
366
                              Apreserved_by_proc:Tcpuregisterset);
 
367
       var
 
368
         i : Tsuperregister;
 
369
       begin
 
370
         { empty super register sets can cause very strange problems }
 
371
         if high(Ausable)=-1 then
 
372
           internalerror(200210181);
 
373
         extend_live_range_backwards := false;
 
374
         supregset_reset(extended_backwards,false,high(tsuperregister));
 
375
         first_imaginary:=Afirst_imaginary;
 
376
         maxreg:=Afirst_imaginary;
 
377
         regtype:=Aregtype;
 
378
         defaultsub:=Adefaultsub;
 
379
         preserved_by_proc:=Apreserved_by_proc;
 
380
         used_in_proc:=[];
 
381
         live_registers.init;
 
382
         { Get reginfo for CPU registers }
 
383
         maxreginfo:=first_imaginary;
 
384
         maxreginfoinc:=16;
 
385
         worklist_moves:=Tlinkedlist.create;
 
386
         reginfo:=allocmem(first_imaginary*sizeof(treginfo));
 
387
         for i:=0 to first_imaginary-1 do
 
388
           begin
 
389
             reginfo[i].degree:=high(tsuperregister);
 
390
             reginfo[i].alias:=RS_INVALID;
 
391
           end;
 
392
         { Usable registers }
 
393
         fillchar(usable_registers,sizeof(usable_registers),0);
 
394
         for i:=low(Ausable) to high(Ausable) do
 
395
           usable_registers[i]:=Ausable[i];
 
396
         usable_registers_cnt:=high(Ausable)+1;
 
397
         { Initialize Worklists }
 
398
         spillednodes.init;
 
399
         simplifyworklist.init;
 
400
         freezeworklist.init;
 
401
         spillworklist.init;
 
402
         coalescednodes.init;
 
403
         selectstack.init;
 
404
      end;
 
405
 
 
406
    destructor trgobj.destroy;
 
407
 
 
408
    begin
 
409
      spillednodes.done;
 
410
      simplifyworklist.done;
 
411
      freezeworklist.done;
 
412
      spillworklist.done;
 
413
      coalescednodes.done;
 
414
      selectstack.done;
 
415
      live_registers.done;
 
416
      worklist_moves.free;
 
417
      dispose_reginfo;
 
418
    end;
 
419
 
 
420
    procedure Trgobj.dispose_reginfo;
 
421
 
 
422
    var i:Tsuperregister;
 
423
 
 
424
    begin
 
425
      if reginfo<>nil then
 
426
        begin
 
427
          for i:=0 to maxreg-1 do
 
428
            with reginfo[i] do
 
429
              begin
 
430
                if adjlist<>nil then
 
431
                  dispose(adjlist,done);
 
432
                if movelist<>nil then
 
433
                  dispose(movelist);
 
434
              end;
 
435
          freemem(reginfo);
 
436
          reginfo:=nil;
 
437
        end;
 
438
    end;
 
439
 
 
440
    function trgobj.getnewreg(subreg:tsubregister):tsuperregister;
 
441
      var
 
442
        oldmaxreginfo : tsuperregister;
 
443
      begin
 
444
        result:=maxreg;
 
445
        inc(maxreg);
 
446
        if maxreg>=last_reg then
 
447
          Message(parser_f_too_complex_proc);
 
448
        if maxreg>=maxreginfo then
 
449
          begin
 
450
            oldmaxreginfo:=maxreginfo;
 
451
            { Prevent overflow }
 
452
            if maxreginfoinc>last_reg-maxreginfo then
 
453
              maxreginfo:=last_reg
 
454
            else
 
455
              begin
 
456
                inc(maxreginfo,maxreginfoinc);
 
457
                if maxreginfoinc<256 then
 
458
                  maxreginfoinc:=maxreginfoinc*2;
 
459
              end;
 
460
            reallocmem(reginfo,maxreginfo*sizeof(treginfo));
 
461
            { Do we really need it to clear it ? At least for 1.0.x (PFV) }
 
462
            fillchar(reginfo[oldmaxreginfo],(maxreginfo-oldmaxreginfo)*sizeof(treginfo),0);
 
463
          end;
 
464
        reginfo[result].subreg:=subreg;
 
465
      end;
 
466
 
 
467
 
 
468
    function trgobj.getregister(list:TAsmList;subreg:Tsubregister):Tregister;
 
469
      begin
 
470
        {$ifdef EXTDEBUG}
 
471
        if reginfo=nil then
 
472
          InternalError(2004020901);
 
473
        {$endif EXTDEBUG}
 
474
        if defaultsub=R_SUBNONE then
 
475
          result:=newreg(regtype,getnewreg(R_SUBNONE),R_SUBNONE)
 
476
        else
 
477
          result:=newreg(regtype,getnewreg(subreg),subreg);
 
478
      end;
 
479
 
 
480
 
 
481
    function trgobj.uses_registers:boolean;
 
482
      begin
 
483
        result:=(maxreg>first_imaginary);
 
484
      end;
 
485
 
 
486
 
 
487
    procedure trgobj.ungetcpuregister(list:TAsmList;r:Tregister);
 
488
      begin
 
489
        if (getsupreg(r)>=first_imaginary) then
 
490
          InternalError(2004020901);
 
491
        list.concat(Tai_regalloc.dealloc(r,nil));
 
492
      end;
 
493
 
 
494
 
 
495
    procedure trgobj.getcpuregister(list:TAsmList;r:Tregister);
 
496
      var
 
497
        supreg:Tsuperregister;
 
498
      begin
 
499
        supreg:=getsupreg(r);
 
500
        if supreg>=first_imaginary then
 
501
          internalerror(2003121503);
 
502
        include(used_in_proc,supreg);
 
503
        list.concat(Tai_regalloc.alloc(r,nil));
 
504
      end;
 
505
 
 
506
 
 
507
    procedure trgobj.alloccpuregisters(list:TAsmList;const r:Tcpuregisterset);
 
508
 
 
509
    var i:Tsuperregister;
 
510
 
 
511
    begin
 
512
      for i:=0 to first_imaginary-1 do
 
513
        if i in r then
 
514
          getcpuregister(list,newreg(regtype,i,defaultsub));
 
515
    end;
 
516
 
 
517
 
 
518
    procedure trgobj.dealloccpuregisters(list:TAsmList;const r:Tcpuregisterset);
 
519
 
 
520
    var i:Tsuperregister;
 
521
 
 
522
    begin
 
523
      for i:=0 to first_imaginary-1 do
 
524
        if i in r then
 
525
          ungetcpuregister(list,newreg(regtype,i,defaultsub));
 
526
    end;
 
527
 
 
528
 
 
529
    procedure trgobj.do_register_allocation(list:TAsmList;headertai:tai);
 
530
      var
 
531
        spillingcounter:byte;
 
532
        endspill:boolean;
 
533
      begin
 
534
        { Insert regalloc info for imaginary registers }
 
535
        insert_regalloc_info_all(list);
 
536
        ibitmap:=tinterferencebitmap.create;
 
537
        generate_interference_graph(list,headertai);
 
538
        { Don't do the real allocation when -sr is passed }
 
539
        if (cs_no_regalloc in current_settings.globalswitches) then
 
540
          exit;
 
541
        {Do register allocation.}
 
542
        spillingcounter:=0;
 
543
        repeat
 
544
          prepare_colouring;
 
545
          colour_registers;
 
546
          epilogue_colouring;
 
547
          endspill:=true;
 
548
          if spillednodes.length<>0 then
 
549
            begin
 
550
              inc(spillingcounter);
 
551
              if spillingcounter>maxspillingcounter then
 
552
                begin
 
553
{$ifdef EXTDEBUG}
 
554
                  { Only exit here so the .s file is still generated. Assembling
 
555
                    the file will still trigger an error }
 
556
                  exit;
 
557
{$else}
 
558
                  internalerror(200309041);
 
559
{$endif}
 
560
                end;
 
561
              endspill:=not spill_registers(list,headertai);
 
562
            end;
 
563
        until endspill;
 
564
        ibitmap.free;
 
565
        translate_registers(list);
 
566
        { we need the translation table for debugging info and verbose assembler output (FK)
 
567
          dispose_reginfo;
 
568
        }
 
569
      end;
 
570
 
 
571
 
 
572
    procedure trgobj.add_constraints(reg:Tregister);
 
573
 
 
574
    begin
 
575
    end;
 
576
 
 
577
 
 
578
    procedure trgobj.add_edge(u,v:Tsuperregister);
 
579
 
 
580
    {This procedure will add an edge to the virtual interference graph.}
 
581
 
 
582
      procedure addadj(u,v:Tsuperregister);
 
583
 
 
584
      begin
 
585
        with reginfo[u] do
 
586
          begin
 
587
            if adjlist=nil then
 
588
              new(adjlist,init);
 
589
            adjlist^.add(v);
 
590
          end;
 
591
      end;
 
592
 
 
593
    begin
 
594
      if (u<>v) and not(ibitmap[v,u]) then
 
595
        begin
 
596
          ibitmap[v,u]:=true;
 
597
          ibitmap[u,v]:=true;
 
598
          {Precoloured nodes are not stored in the interference graph.}
 
599
          if (u>=first_imaginary) then
 
600
            addadj(u,v);
 
601
          if (v>=first_imaginary) then
 
602
            addadj(v,u);
 
603
        end;
 
604
    end;
 
605
 
 
606
 
 
607
    procedure trgobj.add_edges_used(u:Tsuperregister);
 
608
 
 
609
    var i:word;
 
610
 
 
611
    begin
 
612
      with live_registers do
 
613
        if length>0 then
 
614
          for i:=0 to length-1 do
 
615
            add_edge(u,get_alias(buf^[i]));
 
616
    end;
 
617
 
 
618
{$ifdef EXTDEBUG}
 
619
    procedure trgobj.writegraph(loopidx:longint);
 
620
 
 
621
    {This procedure writes out the current interference graph in the
 
622
    register allocator.}
 
623
 
 
624
 
 
625
    var f:text;
 
626
        i,j:Tsuperregister;
 
627
 
 
628
    begin
 
629
      assign(f,'igraph'+tostr(loopidx));
 
630
      rewrite(f);
 
631
      writeln(f,'Interference graph');
 
632
      writeln(f);
 
633
      write(f,'    ');
 
634
      for i:=0 to 15 do
 
635
        for j:=0 to 15 do
 
636
          write(f,hexstr(i,1));
 
637
      writeln(f);
 
638
      write(f,'    ');
 
639
      for i:=0 to 15 do
 
640
        write(f,'0123456789ABCDEF');
 
641
      writeln(f);
 
642
      for i:=0 to maxreg-1 do
 
643
        begin
 
644
          write(f,hexstr(i,2):4);
 
645
          for j:=0 to maxreg-1 do
 
646
            if ibitmap[i,j] then
 
647
              write(f,'*')
 
648
            else
 
649
              write(f,'-');
 
650
          writeln(f);
 
651
        end;
 
652
      close(f);
 
653
    end;
 
654
{$endif EXTDEBUG}
 
655
 
 
656
    procedure trgobj.add_to_movelist(u:Tsuperregister;data:Tlinkedlistitem);
 
657
    begin
 
658
      with reginfo[u] do
 
659
        begin
 
660
          if movelist=nil then
 
661
            begin
 
662
              getmem(movelist,sizeof(tmovelistheader)+60*sizeof(pointer));
 
663
              movelist^.header.maxcount:=60;
 
664
              movelist^.header.count:=0;
 
665
              movelist^.header.sorted_until:=0;
 
666
            end
 
667
          else
 
668
            begin
 
669
              if movelist^.header.count>=movelist^.header.maxcount then
 
670
                begin
 
671
                  movelist^.header.maxcount:=movelist^.header.maxcount*2;
 
672
                  reallocmem(movelist,sizeof(tmovelistheader)+movelist^.header.maxcount*sizeof(pointer));
 
673
                end;
 
674
            end;
 
675
          movelist^.data[movelist^.header.count]:=data;
 
676
          inc(movelist^.header.count);
 
677
        end;
 
678
    end;
 
679
 
 
680
 
 
681
    procedure trgobj.set_live_range_backwards(b: boolean);
 
682
      begin
 
683
        if (b) then
 
684
          begin
 
685
            { new registers may be allocated }
 
686
            supregset_reset(backwards_was_first,false,high(tsuperregister));
 
687
            do_extend_live_range_backwards := true;
 
688
          end
 
689
        else
 
690
          do_extend_live_range_backwards := false;
 
691
      end;
 
692
 
 
693
 
 
694
    procedure trgobj.add_reg_instruction(instr:Tai;r:tregister);
 
695
      var
 
696
        supreg : tsuperregister;
 
697
      begin
 
698
        supreg:=getsupreg(r);
 
699
{$ifdef extdebug}
 
700
        if not (cs_no_regalloc in current_settings.globalswitches) and
 
701
           (supreg>=maxreginfo) then
 
702
          internalerror(200411061);
 
703
{$endif extdebug}
 
704
        if supreg>=first_imaginary then
 
705
          with reginfo[supreg] do
 
706
            begin
 
707
              if not(extend_live_range_backwards) then
 
708
                begin
 
709
                  if not assigned(live_start) then
 
710
                    live_start:=instr;
 
711
                  live_end:=instr;
 
712
                end
 
713
               else
 
714
                 begin
 
715
                   if not supregset_in(extended_backwards,supreg) then
 
716
                     begin
 
717
                       supregset_include(extended_backwards,supreg);
 
718
                       live_start := instr;
 
719
                       if not assigned(live_end) then
 
720
                         begin
 
721
                           supregset_include(backwards_was_first,supreg);
 
722
                           live_end := instr;
 
723
                         end;
 
724
                     end
 
725
                   else
 
726
                     begin
 
727
                       if supregset_in(backwards_was_first,supreg) then
 
728
                         live_end := instr;
 
729
                     end
 
730
                 end
 
731
            end;
 
732
      end;
 
733
 
 
734
 
 
735
    procedure trgobj.add_move_instruction(instr:Taicpu);
 
736
 
 
737
    {This procedure notifies a certain as a move instruction so the
 
738
     register allocator can try to eliminate it.}
 
739
 
 
740
    var i:Tmoveins;
 
741
        ssupreg,dsupreg:Tsuperregister;
 
742
 
 
743
    begin
 
744
    {$ifdef extdebug}
 
745
      if (instr.oper[O_MOV_SOURCE]^.typ<>top_reg) or
 
746
         (instr.oper[O_MOV_DEST]^.typ<>top_reg) then
 
747
        internalerror(200311291);
 
748
    {$endif}
 
749
      i:=Tmoveins.create;
 
750
      i.moveset:=ms_worklist_moves;
 
751
      worklist_moves.insert(i);
 
752
      ssupreg:=getsupreg(instr.oper[O_MOV_SOURCE]^.reg);
 
753
      add_to_movelist(ssupreg,i);
 
754
      dsupreg:=getsupreg(instr.oper[O_MOV_DEST]^.reg);
 
755
      if ssupreg<>dsupreg then
 
756
        {Avoid adding the same move instruction twice to a single register.}
 
757
        add_to_movelist(dsupreg,i);
 
758
      i.x:=ssupreg;
 
759
      i.y:=dsupreg;
 
760
    end;
 
761
 
 
762
    function trgobj.move_related(n:Tsuperregister):boolean;
 
763
 
 
764
    var i:cardinal;
 
765
 
 
766
    begin
 
767
      move_related:=false;
 
768
      with reginfo[n] do
 
769
        if movelist<>nil then
 
770
          with movelist^ do
 
771
            for i:=0 to header.count-1 do
 
772
              if Tmoveins(data[i]).moveset in [ms_worklist_moves,ms_active_moves] then
 
773
                begin
 
774
                  move_related:=true;
 
775
                  break;
 
776
                end;
 
777
    end;
 
778
 
 
779
    procedure Trgobj.sort_simplify_worklist;
 
780
 
 
781
    {Sorts the simplifyworklist by the number of interferences the
 
782
     registers in it cause. This allows simplify to execute in
 
783
     constant time.}
 
784
 
 
785
    var p,h,i,leni,lent:word;
 
786
        t:Tsuperregister;
 
787
        adji,adjt:Psuperregisterworklist;
 
788
 
 
789
    begin
 
790
      with simplifyworklist do
 
791
        begin
 
792
          if length<2 then
 
793
            exit;
 
794
          p:=1;
 
795
          while 2*p<length do
 
796
            p:=2*p;
 
797
          while p<>0 do
 
798
            begin
 
799
              for h:=p to length-1 do
 
800
                begin
 
801
                  i:=h;
 
802
                  t:=buf^[i];
 
803
                  adjt:=reginfo[buf^[i]].adjlist;
 
804
                  lent:=0;
 
805
                  if adjt<>nil then
 
806
                    lent:=adjt^.length;
 
807
                  repeat
 
808
                    adji:=reginfo[buf^[i-p]].adjlist;
 
809
                    leni:=0;
 
810
                    if adji<>nil then
 
811
                      leni:=adji^.length;
 
812
                    if leni<=lent then
 
813
                      break;
 
814
                    buf^[i]:=buf^[i-p];
 
815
                    dec(i,p)
 
816
                  until i<p;
 
817
                  buf^[i]:=t;
 
818
                end;
 
819
              p:=p shr 1;
 
820
            end;
 
821
        end;
 
822
    end;
 
823
 
 
824
    procedure trgobj.make_work_list;
 
825
 
 
826
    var n:Tsuperregister;
 
827
 
 
828
    begin
 
829
      {If we have 7 cpu registers, and the degree of a node is 7, we cannot
 
830
       assign it to any of the registers, thus it is significant.}
 
831
      for n:=first_imaginary to maxreg-1 do
 
832
        with reginfo[n] do
 
833
          begin
 
834
            if adjlist=nil then
 
835
              degree:=0
 
836
            else
 
837
              degree:=adjlist^.length;
 
838
            if degree>=usable_registers_cnt then
 
839
              spillworklist.add(n)
 
840
            else if move_related(n) then
 
841
              freezeworklist.add(n)
 
842
            else
 
843
              simplifyworklist.add(n);
 
844
          end;
 
845
      sort_simplify_worklist;
 
846
    end;
 
847
 
 
848
 
 
849
    procedure trgobj.prepare_colouring;
 
850
    begin
 
851
      make_work_list;
 
852
      active_moves:=Tlinkedlist.create;
 
853
      frozen_moves:=Tlinkedlist.create;
 
854
      coalesced_moves:=Tlinkedlist.create;
 
855
      constrained_moves:=Tlinkedlist.create;
 
856
      selectstack.clear;
 
857
    end;
 
858
 
 
859
    procedure trgobj.enable_moves(n:Tsuperregister);
 
860
 
 
861
    var m:Tlinkedlistitem;
 
862
        i:cardinal;
 
863
 
 
864
    begin
 
865
      with reginfo[n] do
 
866
        if movelist<>nil then
 
867
          for i:=0 to movelist^.header.count-1 do
 
868
            begin
 
869
              m:=movelist^.data[i];
 
870
              if Tmoveins(m).moveset in [ms_worklist_moves,ms_active_moves] then
 
871
                if Tmoveins(m).moveset=ms_active_moves then
 
872
                  begin
 
873
                    {Move m from the set active_moves to the set worklist_moves.}
 
874
                    active_moves.remove(m);
 
875
                    Tmoveins(m).moveset:=ms_worklist_moves;
 
876
                    worklist_moves.concat(m);
 
877
                  end;
 
878
          end;
 
879
    end;
 
880
 
 
881
    procedure Trgobj.decrement_degree(m:Tsuperregister);
 
882
 
 
883
    var adj : Psuperregisterworklist;
 
884
        n : tsuperregister;
 
885
        d,i : word;
 
886
 
 
887
    begin
 
888
      with reginfo[m] do
 
889
        begin
 
890
          d:=degree;
 
891
          if d=0 then
 
892
            internalerror(200312151);
 
893
          dec(degree);
 
894
          if d=usable_registers_cnt then
 
895
            begin
 
896
              {Enable moves for m.}
 
897
              enable_moves(m);
 
898
              {Enable moves for adjacent.}
 
899
              adj:=adjlist;
 
900
              if adj<>nil then
 
901
                for i:=1 to adj^.length do
 
902
                  begin
 
903
                    n:=adj^.buf^[i-1];
 
904
                    if reginfo[n].flags*[ri_selected,ri_coalesced]<>[] then
 
905
                      enable_moves(n);
 
906
                  end;
 
907
              {Remove the node from the spillworklist.}
 
908
              if not spillworklist.delete(m) then
 
909
                internalerror(200310145);
 
910
 
 
911
              if move_related(m) then
 
912
                freezeworklist.add(m)
 
913
              else
 
914
                simplifyworklist.add(m);
 
915
            end;
 
916
        end;
 
917
    end;
 
918
 
 
919
    procedure trgobj.simplify;
 
920
 
 
921
    var adj : Psuperregisterworklist;
 
922
        m,n : Tsuperregister;
 
923
        i : word;
 
924
    begin
 
925
      {We take the element with the least interferences out of the
 
926
       simplifyworklist. Since the simplifyworklist is now sorted, we
 
927
       no longer need to search, but we can simply take the first element.}
 
928
      m:=simplifyworklist.get;
 
929
 
 
930
      {Push it on the selectstack.}
 
931
      selectstack.add(m);
 
932
      with reginfo[m] do
 
933
        begin
 
934
          include(flags,ri_selected);
 
935
          adj:=adjlist;
 
936
        end;
 
937
      if adj<>nil then
 
938
        for i:=1 to adj^.length do
 
939
          begin
 
940
            n:=adj^.buf^[i-1];
 
941
            if (n>=first_imaginary) and
 
942
               (reginfo[n].flags*[ri_selected,ri_coalesced]=[]) then
 
943
              decrement_degree(n);
 
944
          end;
 
945
    end;
 
946
 
 
947
    function trgobj.get_alias(n:Tsuperregister):Tsuperregister;
 
948
 
 
949
    begin
 
950
      while ri_coalesced in reginfo[n].flags do
 
951
        n:=reginfo[n].alias;
 
952
      get_alias:=n;
 
953
    end;
 
954
 
 
955
    procedure trgobj.add_worklist(u:Tsuperregister);
 
956
      begin
 
957
        if (u>=first_imaginary) and
 
958
           (not move_related(u)) and
 
959
           (reginfo[u].degree<usable_registers_cnt) then
 
960
          begin
 
961
            if not freezeworklist.delete(u) then
 
962
              internalerror(200308161); {must be found}
 
963
            simplifyworklist.add(u);
 
964
          end;
 
965
      end;
 
966
 
 
967
 
 
968
    function trgobj.adjacent_ok(u,v:Tsuperregister):boolean;
 
969
 
 
970
    {Check wether u and v should be coalesced. u is precoloured.}
 
971
 
 
972
      function ok(t,r:Tsuperregister):boolean;
 
973
 
 
974
      begin
 
975
        ok:=(t<first_imaginary) or
 
976
            (reginfo[t].degree<usable_registers_cnt) or
 
977
            ibitmap[r,t];
 
978
      end;
 
979
 
 
980
    var adj : Psuperregisterworklist;
 
981
        i : word;
 
982
        n : tsuperregister;
 
983
 
 
984
    begin
 
985
      with reginfo[v] do
 
986
        begin
 
987
          adjacent_ok:=true;
 
988
          adj:=adjlist;
 
989
          if adj<>nil then
 
990
            for i:=1 to adj^.length do
 
991
              begin
 
992
                n:=adj^.buf^[i-1];
 
993
                if (flags*[ri_coalesced,ri_selected]=[]) and not ok(n,u) then
 
994
                  begin
 
995
                    adjacent_ok:=false;
 
996
                    break;
 
997
                  end;
 
998
              end;
 
999
        end;
 
1000
    end;
 
1001
 
 
1002
    function trgobj.conservative(u,v:Tsuperregister):boolean;
 
1003
 
 
1004
    var adj : Psuperregisterworklist;
 
1005
        done : Tsuperregisterset; {To prevent that we count nodes twice.}
 
1006
        i,k:word;
 
1007
        n : tsuperregister;
 
1008
 
 
1009
    begin
 
1010
      k:=0;
 
1011
      supregset_reset(done,false,maxreg);
 
1012
      with reginfo[u] do
 
1013
        begin
 
1014
          adj:=adjlist;
 
1015
          if adj<>nil then
 
1016
            for i:=1 to adj^.length do
 
1017
              begin
 
1018
                n:=adj^.buf^[i-1];
 
1019
                if flags*[ri_coalesced,ri_selected]=[] then
 
1020
                  begin
 
1021
                    supregset_include(done,n);
 
1022
                    if reginfo[n].degree>=usable_registers_cnt then
 
1023
                      inc(k);
 
1024
                  end;
 
1025
              end;
 
1026
        end;
 
1027
      adj:=reginfo[v].adjlist;
 
1028
      if adj<>nil then
 
1029
        for i:=1 to adj^.length do
 
1030
          begin
 
1031
            n:=adj^.buf^[i-1];
 
1032
            if not supregset_in(done,n) and
 
1033
               (reginfo[n].degree>=usable_registers_cnt) and
 
1034
               (reginfo[u].flags*[ri_coalesced,ri_selected]=[]) then
 
1035
              inc(k);
 
1036
          end;
 
1037
      conservative:=(k<usable_registers_cnt);
 
1038
    end;
 
1039
 
 
1040
 
 
1041
    procedure trgobj.combine(u,v:Tsuperregister);
 
1042
 
 
1043
    var adj : Psuperregisterworklist;
 
1044
        i,n,p,q:cardinal;
 
1045
        t : tsuperregister;
 
1046
        searched:Tlinkedlistitem;
 
1047
 
 
1048
    label l1;
 
1049
 
 
1050
    begin
 
1051
      if not freezeworklist.delete(v) then
 
1052
        spillworklist.delete(v);
 
1053
      coalescednodes.add(v);
 
1054
      include(reginfo[v].flags,ri_coalesced);
 
1055
      reginfo[v].alias:=u;
 
1056
 
 
1057
      {Combine both movelists. Since the movelists are sets, only add
 
1058
       elements that are not already present. The movelists cannot be
 
1059
       empty by definition; nodes are only coalesced if there is a move
 
1060
       between them. To prevent quadratic time blowup (movelists of
 
1061
       especially machine registers can get very large because of moves
 
1062
       generated during calls) we need to go into disgusting complexity.
 
1063
 
 
1064
       (See webtbs/tw2242 for an example that stresses this.)
 
1065
 
 
1066
       We want to sort the movelist to be able to search logarithmically.
 
1067
       Unfortunately, sorting the movelist every time before searching
 
1068
       is counter-productive, since the movelist usually grows with a few
 
1069
       items at a time. Therefore, we split the movelist into a sorted
 
1070
       and an unsorted part and search through both. If the unsorted part
 
1071
       becomes too large, we sort.}
 
1072
      if assigned(reginfo[u].movelist) then
 
1073
        begin
 
1074
          {We have to weigh the cost of sorting the list against searching
 
1075
           the cost of the unsorted part. I use factor of 8 here; if the
 
1076
           number of items is less than 8 times the numer of unsorted items,
 
1077
           we'll sort the list.}
 
1078
          with reginfo[u].movelist^ do
 
1079
            if header.count<8*(header.count-header.sorted_until) then
 
1080
              sort_movelist(reginfo[u].movelist);
 
1081
 
 
1082
          if assigned(reginfo[v].movelist) then
 
1083
            begin
 
1084
              for n:=0 to reginfo[v].movelist^.header.count-1 do
 
1085
                begin
 
1086
                  {Binary search the sorted part of the list.}
 
1087
                  searched:=reginfo[v].movelist^.data[n];
 
1088
                  p:=0;
 
1089
                  q:=reginfo[u].movelist^.header.sorted_until;
 
1090
                  i:=0;
 
1091
                  if q<>0 then
 
1092
                    repeat
 
1093
                      i:=(p+q) shr 1;
 
1094
                      if ptruint(searched)>ptruint(reginfo[u].movelist^.data[i]) then
 
1095
                        p:=i+1
 
1096
                      else
 
1097
                        q:=i;
 
1098
                    until p=q;
 
1099
                  with reginfo[u].movelist^ do
 
1100
                    if searched<>data[i] then
 
1101
                      begin
 
1102
                        {Linear search the unsorted part of the list.}
 
1103
                        for i:=header.sorted_until+1 to header.count-1 do
 
1104
                          if searched=data[i] then
 
1105
                            goto l1;
 
1106
                        {Not found -> add}
 
1107
                        add_to_movelist(u,searched);
 
1108
                      l1:
 
1109
                      end;
 
1110
                end;
 
1111
            end;
 
1112
        end;
 
1113
 
 
1114
      enable_moves(v);
 
1115
 
 
1116
      adj:=reginfo[v].adjlist;
 
1117
      if adj<>nil then
 
1118
        for i:=1 to adj^.length do
 
1119
          begin
 
1120
            t:=adj^.buf^[i-1];
 
1121
            with reginfo[t] do
 
1122
              if not(ri_coalesced in flags) then
 
1123
                begin
 
1124
                  {t has a connection to v. Since we are adding v to u, we
 
1125
                   need to connect t to u. However, beware if t was already
 
1126
                   connected to u...}
 
1127
                  if (ibitmap[t,u]) and not (ri_selected in flags) then
 
1128
                    {... because in that case, we are actually removing an edge
 
1129
                     and the degree of t decreases.}
 
1130
                    decrement_degree(t)
 
1131
                  else
 
1132
                    begin
 
1133
                      add_edge(t,u);
 
1134
                      {We have added an edge to t and u. So their degree increases.
 
1135
                       However, v is added to u. That means its neighbours will
 
1136
                       no longer point to v, but to u instead. Therefore, only the
 
1137
                       degree of u increases.}
 
1138
                      if (u>=first_imaginary) and not (ri_selected in flags) then
 
1139
                        inc(reginfo[u].degree);
 
1140
                    end;
 
1141
                end;
 
1142
          end;
 
1143
      if (reginfo[u].degree>=usable_registers_cnt) and freezeworklist.delete(u) then
 
1144
        spillworklist.add(u);
 
1145
    end;
 
1146
 
 
1147
 
 
1148
    procedure trgobj.coalesce;
 
1149
 
 
1150
    var m:Tmoveins;
 
1151
        x,y,u,v:Tsuperregister;
 
1152
 
 
1153
    begin
 
1154
      m:=Tmoveins(worklist_moves.getfirst);
 
1155
      x:=get_alias(m.x);
 
1156
      y:=get_alias(m.y);
 
1157
      if (y<first_imaginary) then
 
1158
        begin
 
1159
          u:=y;
 
1160
          v:=x;
 
1161
        end
 
1162
      else
 
1163
        begin
 
1164
          u:=x;
 
1165
          v:=y;
 
1166
        end;
 
1167
      if (u=v) then
 
1168
        begin
 
1169
          m.moveset:=ms_coalesced_moves;  {Already coalesced.}
 
1170
          coalesced_moves.insert(m);
 
1171
          add_worklist(u);
 
1172
        end
 
1173
      {Do u and v interfere? In that case the move is constrained. Two
 
1174
       precoloured nodes interfere allways. If v is precoloured, by the above
 
1175
       code u is precoloured, thus interference...}
 
1176
      else if (v<first_imaginary) or ibitmap[u,v] then
 
1177
        begin
 
1178
          m.moveset:=ms_constrained_moves;  {Cannot coalesce yet...}
 
1179
          constrained_moves.insert(m);
 
1180
          add_worklist(u);
 
1181
          add_worklist(v);
 
1182
        end
 
1183
      {Next test: is it possible and a good idea to coalesce??}
 
1184
      else if ((u<first_imaginary) and adjacent_ok(u,v)) or
 
1185
              ((u>=first_imaginary) and conservative(u,v)) then
 
1186
        begin
 
1187
          m.moveset:=ms_coalesced_moves;  {Move coalesced!}
 
1188
          coalesced_moves.insert(m);
 
1189
          combine(u,v);
 
1190
          add_worklist(u);
 
1191
        end
 
1192
      else
 
1193
        begin
 
1194
          m.moveset:=ms_active_moves;
 
1195
          active_moves.insert(m);
 
1196
        end;
 
1197
    end;
 
1198
 
 
1199
    procedure trgobj.freeze_moves(u:Tsuperregister);
 
1200
 
 
1201
    var i:cardinal;
 
1202
        m:Tlinkedlistitem;
 
1203
        v,x,y:Tsuperregister;
 
1204
 
 
1205
    begin
 
1206
      if reginfo[u].movelist<>nil then
 
1207
        for i:=0 to reginfo[u].movelist^.header.count-1 do
 
1208
          begin
 
1209
            m:=reginfo[u].movelist^.data[i];
 
1210
            if Tmoveins(m).moveset in [ms_worklist_moves,ms_active_moves] then
 
1211
              begin
 
1212
                x:=Tmoveins(m).x;
 
1213
                y:=Tmoveins(m).y;
 
1214
                if get_alias(y)=get_alias(u) then
 
1215
                  v:=get_alias(x)
 
1216
                else
 
1217
                  v:=get_alias(y);
 
1218
                {Move m from active_moves/worklist_moves to frozen_moves.}
 
1219
                if Tmoveins(m).moveset=ms_active_moves then
 
1220
                  active_moves.remove(m)
 
1221
                else
 
1222
                  worklist_moves.remove(m);
 
1223
                Tmoveins(m).moveset:=ms_frozen_moves;
 
1224
                frozen_moves.insert(m);
 
1225
 
 
1226
                if (v>=first_imaginary) and not(move_related(v)) and
 
1227
                   (reginfo[v].degree<usable_registers_cnt) then
 
1228
                  begin
 
1229
                    freezeworklist.delete(v);
 
1230
                    simplifyworklist.add(v);
 
1231
                  end;
 
1232
              end;
 
1233
          end;
 
1234
    end;
 
1235
 
 
1236
    procedure trgobj.freeze;
 
1237
 
 
1238
    var n:Tsuperregister;
 
1239
 
 
1240
    begin
 
1241
      { We need to take a random element out of the freezeworklist. We take
 
1242
        the last element. Dirty code! }
 
1243
      n:=freezeworklist.get;
 
1244
      {Add it to the simplifyworklist.}
 
1245
      simplifyworklist.add(n);
 
1246
      freeze_moves(n);
 
1247
    end;
 
1248
 
 
1249
    procedure trgobj.select_spill;
 
1250
 
 
1251
    var
 
1252
      n : tsuperregister;
 
1253
      adj : psuperregisterworklist;
 
1254
      max,p,i:word;
 
1255
 
 
1256
    begin
 
1257
      { We must look for the element with the most interferences in the
 
1258
        spillworklist. This is required because those registers are creating
 
1259
        the most conflicts and keeping them in a register will not reduce the
 
1260
        complexity and even can cause the help registers for the spilling code
 
1261
        to get too much conflicts with the result that the spilling code
 
1262
        will never converge (PFV) }
 
1263
      max:=0;
 
1264
      p:=0;
 
1265
      with spillworklist do
 
1266
        begin
 
1267
          {Safe: This procedure is only called if length<>0}
 
1268
          for i:=0 to length-1 do
 
1269
            begin
 
1270
              adj:=reginfo[buf^[i]].adjlist;
 
1271
              if assigned(adj) and (adj^.length>max) then
 
1272
                begin
 
1273
                  p:=i;
 
1274
                  max:=adj^.length;
 
1275
                end;
 
1276
            end;
 
1277
          n:=buf^[p];
 
1278
          deleteidx(p);
 
1279
        end;
 
1280
 
 
1281
      simplifyworklist.add(n);
 
1282
      freeze_moves(n);
 
1283
    end;
 
1284
 
 
1285
    procedure trgobj.assign_colours;
 
1286
 
 
1287
    {Assign_colours assigns the actual colours to the registers.}
 
1288
 
 
1289
    var adj : Psuperregisterworklist;
 
1290
        i,j,k : word;
 
1291
        n,a,c : Tsuperregister;
 
1292
        colourednodes : Tsuperregisterset;
 
1293
        adj_colours:set of 0..255;
 
1294
        found : boolean;
 
1295
 
 
1296
    begin
 
1297
      spillednodes.clear;
 
1298
      {Reset colours}
 
1299
      for n:=0 to maxreg-1 do
 
1300
        reginfo[n].colour:=n;
 
1301
      {Colour the cpu registers...}
 
1302
      supregset_reset(colourednodes,false,maxreg);
 
1303
      for n:=0 to first_imaginary-1 do
 
1304
        supregset_include(colourednodes,n);
 
1305
      {Now colour the imaginary registers on the select-stack.}
 
1306
      for i:=selectstack.length downto 1 do
 
1307
        begin
 
1308
          n:=selectstack.buf^[i-1];
 
1309
          {Create a list of colours that we cannot assign to n.}
 
1310
          adj_colours:=[];
 
1311
          adj:=reginfo[n].adjlist;
 
1312
          if adj<>nil then
 
1313
            for j:=0 to adj^.length-1 do
 
1314
              begin
 
1315
                a:=get_alias(adj^.buf^[j]);
 
1316
                if supregset_in(colourednodes,a) and (reginfo[a].colour<=255) then
 
1317
                  include(adj_colours,reginfo[a].colour);
 
1318
              end;
 
1319
          if regtype=R_INTREGISTER then
 
1320
            include(adj_colours,RS_STACK_POINTER_REG);
 
1321
          {Assume a spill by default...}
 
1322
          found:=false;
 
1323
          {Search for a colour not in this list.}
 
1324
          for k:=0 to usable_registers_cnt-1 do
 
1325
            begin
 
1326
              c:=usable_registers[k];
 
1327
               if not(c in adj_colours) then
 
1328
                 begin
 
1329
                   reginfo[n].colour:=c;
 
1330
                   found:=true;
 
1331
                   supregset_include(colourednodes,n);
 
1332
                   include(used_in_proc,c);
 
1333
                   break;
 
1334
                 end;
 
1335
            end;
 
1336
          if not found then
 
1337
            spillednodes.add(n);
 
1338
        end;
 
1339
      {Finally colour the nodes that were coalesced.}
 
1340
      for i:=1 to coalescednodes.length do
 
1341
        begin
 
1342
          n:=coalescednodes.buf^[i-1];
 
1343
          k:=get_alias(n);
 
1344
          reginfo[n].colour:=reginfo[k].colour;
 
1345
          if reginfo[k].colour<maxcpuregister then
 
1346
            include(used_in_proc,reginfo[k].colour);
 
1347
        end;
 
1348
    end;
 
1349
 
 
1350
    procedure trgobj.colour_registers;
 
1351
 
 
1352
    begin
 
1353
      repeat
 
1354
        if simplifyworklist.length<>0 then
 
1355
          simplify
 
1356
        else if not(worklist_moves.empty) then
 
1357
          coalesce
 
1358
        else if freezeworklist.length<>0 then
 
1359
          freeze
 
1360
        else if spillworklist.length<>0 then
 
1361
          select_spill;
 
1362
      until (simplifyworklist.length=0) and
 
1363
            worklist_moves.empty and
 
1364
            (freezeworklist.length=0) and
 
1365
            (spillworklist.length=0);
 
1366
      assign_colours;
 
1367
    end;
 
1368
 
 
1369
    procedure trgobj.epilogue_colouring;
 
1370
    var
 
1371
      i : Tsuperregister;
 
1372
    begin
 
1373
      worklist_moves.clear;
 
1374
      active_moves.destroy;
 
1375
      active_moves:=nil;
 
1376
      frozen_moves.destroy;
 
1377
      frozen_moves:=nil;
 
1378
      coalesced_moves.destroy;
 
1379
      coalesced_moves:=nil;
 
1380
      constrained_moves.destroy;
 
1381
      constrained_moves:=nil;
 
1382
      for i:=0 to maxreg-1 do
 
1383
        with reginfo[i] do
 
1384
          if movelist<>nil then
 
1385
            begin
 
1386
              dispose(movelist);
 
1387
              movelist:=nil;
 
1388
            end;
 
1389
    end;
 
1390
 
 
1391
 
 
1392
    procedure trgobj.clear_interferences(u:Tsuperregister);
 
1393
 
 
1394
    {Remove node u from the interference graph and remove all collected
 
1395
     move instructions it is associated with.}
 
1396
 
 
1397
    var i : word;
 
1398
        v : Tsuperregister;
 
1399
        adj,adj2 : Psuperregisterworklist;
 
1400
 
 
1401
    begin
 
1402
      adj:=reginfo[u].adjlist;
 
1403
      if adj<>nil then
 
1404
        begin
 
1405
          for i:=1 to adj^.length do
 
1406
            begin
 
1407
              v:=adj^.buf^[i-1];
 
1408
              {Remove (u,v) and (v,u) from bitmap.}
 
1409
              ibitmap[u,v]:=false;
 
1410
              ibitmap[v,u]:=false;
 
1411
              {Remove (v,u) from adjacency list.}
 
1412
              adj2:=reginfo[v].adjlist;
 
1413
              if adj2<>nil then
 
1414
                begin
 
1415
                  adj2^.delete(u);
 
1416
                  if adj2^.length=0 then
 
1417
                    begin
 
1418
                      dispose(adj2,done);
 
1419
                      reginfo[v].adjlist:=nil;
 
1420
                    end;
 
1421
                end;
 
1422
            end;
 
1423
          {Remove ( u,* ) from adjacency list.}
 
1424
          dispose(adj,done);
 
1425
          reginfo[u].adjlist:=nil;
 
1426
        end;
 
1427
    end;
 
1428
 
 
1429
 
 
1430
    function trgobj.getregisterinline(list:TAsmList;subreg:Tsubregister):Tregister;
 
1431
      var
 
1432
        p : Tsuperregister;
 
1433
      begin
 
1434
        p:=getnewreg(subreg);
 
1435
        live_registers.add(p);
 
1436
        result:=newreg(regtype,p,subreg);
 
1437
        add_edges_used(p);
 
1438
        add_constraints(result);
 
1439
      end;
 
1440
 
 
1441
 
 
1442
    procedure trgobj.ungetregisterinline(list:TAsmList;r:Tregister);
 
1443
      var
 
1444
        supreg:Tsuperregister;
 
1445
      begin
 
1446
        supreg:=getsupreg(r);
 
1447
        live_registers.delete(supreg);
 
1448
        insert_regalloc_info(list,supreg);
 
1449
      end;
 
1450
 
 
1451
 
 
1452
    procedure trgobj.insert_regalloc_info(list:TAsmList;u:tsuperregister);
 
1453
      var
 
1454
        p : tai;
 
1455
        r : tregister;
 
1456
        palloc,
 
1457
        pdealloc : tai_regalloc;
 
1458
      begin
 
1459
        { Insert regallocs for all imaginary registers }
 
1460
        with reginfo[u] do
 
1461
          begin
 
1462
            r:=newreg(regtype,u,subreg);
 
1463
            if assigned(live_start) then
 
1464
              begin
 
1465
                { Generate regalloc and bind it to an instruction, this
 
1466
                  is needed to find all live registers belonging to an
 
1467
                  instruction during the spilling }
 
1468
                if live_start.typ=ait_instruction then
 
1469
                  palloc:=tai_regalloc.alloc(r,live_start)
 
1470
                else
 
1471
                  palloc:=tai_regalloc.alloc(r,nil);
 
1472
                if live_end.typ=ait_instruction then
 
1473
                  pdealloc:=tai_regalloc.dealloc(r,live_end)
 
1474
                else
 
1475
                  pdealloc:=tai_regalloc.dealloc(r,nil);
 
1476
                { Insert live start allocation before the instruction/reg_a_sync }
 
1477
                list.insertbefore(palloc,live_start);
 
1478
                { Insert live end deallocation before reg allocations
 
1479
                  to reduce conflicts }
 
1480
                p:=live_end;
 
1481
                while assigned(p) and
 
1482
                      assigned(p.previous) and
 
1483
                      (tai(p.previous).typ=ait_regalloc) and
 
1484
                      (tai_regalloc(p.previous).ratype=ra_alloc) and
 
1485
                      (tai_regalloc(p.previous).reg<>r) do
 
1486
                  p:=tai(p.previous);
 
1487
                { , but add release after a reg_a_sync }
 
1488
                if assigned(p) and
 
1489
                   (p.typ=ait_regalloc) and
 
1490
                   (tai_regalloc(p).ratype=ra_sync) then
 
1491
                  p:=tai(p.next);
 
1492
                if assigned(p) then
 
1493
                  list.insertbefore(pdealloc,p)
 
1494
                else
 
1495
                  list.concat(pdealloc);
 
1496
              end;
 
1497
          end;
 
1498
      end;
 
1499
 
 
1500
 
 
1501
    procedure trgobj.insert_regalloc_info_all(list:TAsmList);
 
1502
      var
 
1503
        supreg : tsuperregister;
 
1504
      begin
 
1505
        { Insert regallocs for all imaginary registers }
 
1506
        for supreg:=first_imaginary to maxreg-1 do
 
1507
          insert_regalloc_info(list,supreg);
 
1508
      end;
 
1509
 
 
1510
 
 
1511
    procedure trgobj.add_cpu_interferences(p : tai);
 
1512
      begin
 
1513
      end;
 
1514
 
 
1515
 
 
1516
    procedure trgobj.generate_interference_graph(list:TAsmList;headertai:tai);
 
1517
      var
 
1518
        p : tai;
 
1519
{$ifdef EXTDEBUG}
 
1520
        i : integer;
 
1521
{$endif EXTDEBUG}
 
1522
        supreg : tsuperregister;
 
1523
      begin
 
1524
        { All allocations are available. Now we can generate the
 
1525
          interference graph. Walk through all instructions, we can
 
1526
          start with the headertai, because before the header tai is
 
1527
          only symbols. }
 
1528
        live_registers.clear;
 
1529
        p:=headertai;
 
1530
        while assigned(p) do
 
1531
          begin
 
1532
            if p.typ=ait_regalloc then
 
1533
              with Tai_regalloc(p) do
 
1534
                begin
 
1535
                  if (getregtype(reg)=regtype) then
 
1536
                    begin
 
1537
                      supreg:=getsupreg(reg);
 
1538
                      case ratype of
 
1539
                        ra_alloc :
 
1540
                          begin
 
1541
                            live_registers.add(supreg);
 
1542
                            add_edges_used(supreg);
 
1543
                          end;
 
1544
                        ra_dealloc :
 
1545
                          begin
 
1546
                            live_registers.delete(supreg);
 
1547
                            add_edges_used(supreg);
 
1548
                          end;
 
1549
                      end;
 
1550
                      { constraints needs always to be updated }
 
1551
                      add_constraints(reg);
 
1552
                    end;
 
1553
                end;
 
1554
            add_cpu_interferences(p);
 
1555
            p:=Tai(p.next);
 
1556
          end;
 
1557
 
 
1558
{$ifdef EXTDEBUG}
 
1559
        if live_registers.length>0 then
 
1560
          begin
 
1561
            for i:=0 to live_registers.length-1 do
 
1562
              begin
 
1563
                { Only report for imaginary registers }
 
1564
                if live_registers.buf^[i]>=first_imaginary then
 
1565
                  Comment(V_Warning,'Register '+std_regname(newreg(R_INTREGISTER,live_registers.buf^[i],defaultsub))+' not released');
 
1566
              end;
 
1567
          end;
 
1568
{$endif}
 
1569
      end;
 
1570
 
 
1571
 
 
1572
    procedure trgobj.translate_register(var reg : tregister);
 
1573
      begin
 
1574
        if (getregtype(reg)=regtype) then
 
1575
          setsupreg(reg,reginfo[getsupreg(reg)].colour)
 
1576
        else
 
1577
          internalerror(200602021);
 
1578
      end;
 
1579
 
 
1580
 
 
1581
    procedure Trgobj.translate_registers(list:TAsmList);
 
1582
      var
 
1583
        hp,p,q:Tai;
 
1584
        i:shortint;
 
1585
{$ifdef arm}
 
1586
        so:pshifterop;
 
1587
{$endif arm}
 
1588
 
 
1589
 
 
1590
      begin
 
1591
        { Leave when no imaginary registers are used }
 
1592
        if maxreg<=first_imaginary then
 
1593
          exit;
 
1594
        p:=Tai(list.first);
 
1595
        while assigned(p) do
 
1596
          begin
 
1597
            case p.typ of
 
1598
              ait_regalloc:
 
1599
                with Tai_regalloc(p) do
 
1600
                  begin
 
1601
                    if (getregtype(reg)=regtype) then
 
1602
                      begin
 
1603
                        { Only alloc/dealloc is needed for the optimizer, remove
 
1604
                          other regalloc }
 
1605
                        if not(ratype in [ra_alloc,ra_dealloc]) then
 
1606
                          begin
 
1607
                            q:=Tai(next);
 
1608
                            list.remove(p);
 
1609
                            p.free;
 
1610
                            p:=q;
 
1611
                            continue;
 
1612
                          end
 
1613
                        else
 
1614
                          begin
 
1615
                            setsupreg(reg,reginfo[getsupreg(reg)].colour);
 
1616
                            {
 
1617
                              Remove sequences of release and
 
1618
                              allocation of the same register like. Other combinations
 
1619
                              of release/allocate need to stay in the list.
 
1620
 
 
1621
                                 # Register X released
 
1622
                                 # Register X allocated
 
1623
                            }
 
1624
                            if assigned(previous) and
 
1625
                               (ratype=ra_alloc) and
 
1626
                               (Tai(previous).typ=ait_regalloc) and
 
1627
                               (Tai_regalloc(previous).reg=reg) and
 
1628
                               (Tai_regalloc(previous).ratype=ra_dealloc) then
 
1629
                              begin
 
1630
                                q:=Tai(next);
 
1631
                                hp:=tai(previous);
 
1632
                                list.remove(hp);
 
1633
                                hp.free;
 
1634
                                list.remove(p);
 
1635
                                p.free;
 
1636
                                p:=q;
 
1637
                                continue;
 
1638
                              end;
 
1639
                          end;
 
1640
                      end;
 
1641
                  end;
 
1642
              ait_instruction:
 
1643
                with Taicpu(p) do
 
1644
                  begin
 
1645
                    current_filepos:=fileinfo;
 
1646
                    for i:=0 to ops-1 do
 
1647
                      with oper[i]^ do
 
1648
                        case typ of
 
1649
                          Top_reg:
 
1650
                             if (getregtype(reg)=regtype) then
 
1651
                               setsupreg(reg,reginfo[getsupreg(reg)].colour);
 
1652
                          Top_ref:
 
1653
                            begin
 
1654
                              if regtype in [R_INTREGISTER,R_ADDRESSREGISTER] then
 
1655
                                with ref^ do
 
1656
                                  begin
 
1657
                                    if base<>NR_NO then
 
1658
                                      setsupreg(base,reginfo[getsupreg(base)].colour);
 
1659
                                    if index<>NR_NO then
 
1660
                                      setsupreg(index,reginfo[getsupreg(index)].colour);
 
1661
                                  end;
 
1662
                            end;
 
1663
{$ifdef arm}
 
1664
                          Top_shifterop:
 
1665
                            begin
 
1666
                              if regtype=R_INTREGISTER then
 
1667
                                begin
 
1668
                                  so:=shifterop;
 
1669
                                  if so^.rs<>NR_NO then
 
1670
                                    setsupreg(so^.rs,reginfo[getsupreg(so^.rs)].colour);
 
1671
                                end;
 
1672
                            end;
 
1673
{$endif arm}
 
1674
                        end;
 
1675
 
 
1676
                    { Maybe the operation can be removed when
 
1677
                      it is a move and both arguments are the same }
 
1678
                    if is_same_reg_move(regtype) then
 
1679
                      begin
 
1680
                        q:=Tai(p.next);
 
1681
                        list.remove(p);
 
1682
                        p.free;
 
1683
                        p:=q;
 
1684
                        continue;
 
1685
                      end;
 
1686
                  end;
 
1687
            end;
 
1688
            p:=Tai(p.next);
 
1689
          end;
 
1690
        current_filepos:=current_procinfo.exitpos;
 
1691
      end;
 
1692
 
 
1693
 
 
1694
    function trgobj.spill_registers(list:TAsmList;headertai:tai):boolean;
 
1695
    { Returns true if any help registers have been used }
 
1696
      var
 
1697
        i : word;
 
1698
        t : tsuperregister;
 
1699
        p,q : Tai;
 
1700
        regs_to_spill_set:Tsuperregisterset;
 
1701
        spill_temps : ^Tspill_temp_list;
 
1702
        supreg : tsuperregister;
 
1703
        templist : TAsmList;
 
1704
      begin
 
1705
        spill_registers:=false;
 
1706
        live_registers.clear;
 
1707
        for i:=first_imaginary to maxreg-1 do
 
1708
          exclude(reginfo[i].flags,ri_selected);
 
1709
        spill_temps:=allocmem(sizeof(treference)*maxreg);
 
1710
        supregset_reset(regs_to_spill_set,false,$ffff);
 
1711
        { Allocate temps and insert in front of the list }
 
1712
        templist:=TAsmList.create;
 
1713
        {Safe: this procedure is only called if there are spilled nodes.}
 
1714
        with spillednodes do
 
1715
          for i:=0 to length-1 do
 
1716
            begin
 
1717
              t:=buf^[i];
 
1718
              {Alternative representation.}
 
1719
              supregset_include(regs_to_spill_set,t);
 
1720
              {Clear all interferences of the spilled register.}
 
1721
              clear_interferences(t);
 
1722
              {Get a temp for the spilled register, the size must at least equal a complete register,
 
1723
               take also care of the fact that subreg can be larger than a single register like doubles
 
1724
               that occupy 2 registers }
 
1725
              tg.gettemp(templist,
 
1726
                         max(tcgsize2size[reg_cgsize(newreg(regtype,t,R_SUBWHOLE))],
 
1727
                             tcgsize2size[reg_cgsize(newreg(regtype,t,reginfo[t].subreg))]),
 
1728
                         tt_noreuse,spill_temps^[t]);
 
1729
            end;
 
1730
        list.insertlistafter(headertai,templist);
 
1731
        templist.free;
 
1732
        { Walk through all instructions, we can start with the headertai,
 
1733
          because before the header tai is only symbols }
 
1734
        p:=headertai;
 
1735
        while assigned(p) do
 
1736
          begin
 
1737
            case p.typ of
 
1738
              ait_regalloc:
 
1739
                with Tai_regalloc(p) do
 
1740
                  begin
 
1741
                    if (getregtype(reg)=regtype) then
 
1742
                      begin
 
1743
                        {A register allocation of a spilled register can be removed.}
 
1744
                        supreg:=getsupreg(reg);
 
1745
                        if supregset_in(regs_to_spill_set,supreg) then
 
1746
                          begin
 
1747
                            q:=Tai(p.next);
 
1748
                            list.remove(p);
 
1749
                            p.free;
 
1750
                            p:=q;
 
1751
                            continue;
 
1752
                          end
 
1753
                        else
 
1754
                          begin
 
1755
                            case ratype of
 
1756
                              ra_alloc :
 
1757
                               live_registers.add(supreg);
 
1758
                              ra_dealloc :
 
1759
                               live_registers.delete(supreg);
 
1760
                            end;
 
1761
                          end;
 
1762
                      end;
 
1763
                  end;
 
1764
              ait_instruction:
 
1765
                with Taicpu(p) do
 
1766
                  begin
 
1767
                    current_filepos:=fileinfo;
 
1768
                    if instr_spill_register(list,taicpu(p),regs_to_spill_set,spill_temps^) then
 
1769
                      spill_registers:=true;
 
1770
                  end;
 
1771
            end;
 
1772
            p:=Tai(p.next);
 
1773
          end;
 
1774
        current_filepos:=current_procinfo.exitpos;
 
1775
        {Safe: this procedure is only called if there are spilled nodes.}
 
1776
        with spillednodes do
 
1777
          for i:=0 to length-1 do
 
1778
            tg.ungettemp(list,spill_temps^[buf^[i]]);
 
1779
        freemem(spill_temps);
 
1780
      end;
 
1781
 
 
1782
 
 
1783
    function trgobj.do_spill_replace(list:TAsmList;instr:taicpu;orgreg:tsuperregister;const spilltemp:treference):boolean;
 
1784
      begin
 
1785
        result:=false;
 
1786
      end;
 
1787
 
 
1788
 
 
1789
    procedure Trgobj.do_spill_read(list:TAsmList;pos:tai;const spilltemp:treference;tempreg:tregister);
 
1790
      begin
 
1791
        list.insertafter(spilling_create_load(spilltemp,tempreg),pos);
 
1792
      end;
 
1793
 
 
1794
 
 
1795
    procedure Trgobj.do_spill_written(list:TAsmList;pos:tai;const spilltemp:treference;tempreg:tregister);
 
1796
      begin
 
1797
        list.insertafter(spilling_create_store(tempreg,spilltemp),pos);
 
1798
      end;
 
1799
 
 
1800
 
 
1801
    function trgobj.get_spill_subreg(r : tregister) : tsubregister;
 
1802
      begin
 
1803
        result:=defaultsub;
 
1804
      end;
 
1805
 
 
1806
 
 
1807
    function trgobj.instr_spill_register(list:TAsmList;
 
1808
                                         instr:taicpu;
 
1809
                                         const r:Tsuperregisterset;
 
1810
                                         const spilltemplist:Tspill_temp_list): boolean;
 
1811
      var
 
1812
        counter, regindex: longint;
 
1813
        regs: tspillregsinfo;
 
1814
        spilled: boolean;
 
1815
 
 
1816
      procedure addreginfo(reg: tregister; operation: topertype);
 
1817
        var
 
1818
          i, tmpindex: longint;
 
1819
          supreg : tsuperregister;
 
1820
        begin
 
1821
          tmpindex := regindex;
 
1822
          supreg:=get_alias(getsupreg(reg));
 
1823
          { did we already encounter this register? }
 
1824
          for i := 0 to pred(regindex) do
 
1825
            if (regs[i].orgreg = supreg) then
 
1826
              begin
 
1827
                tmpindex := i;
 
1828
                break;
 
1829
              end;
 
1830
          if tmpindex > high(regs) then
 
1831
            internalerror(2003120301);
 
1832
          regs[tmpindex].orgreg := supreg;
 
1833
          regs[tmpindex].spillreg:=reg;
 
1834
          if supregset_in(r,supreg) then
 
1835
            begin
 
1836
              { add/update info on this register }
 
1837
              regs[tmpindex].mustbespilled := true;
 
1838
              case operation of
 
1839
                operand_read:
 
1840
                  regs[tmpindex].regread := true;
 
1841
                operand_write:
 
1842
                  regs[tmpindex].regwritten := true;
 
1843
                operand_readwrite:
 
1844
                  begin
 
1845
                    regs[tmpindex].regread := true;
 
1846
                    regs[tmpindex].regwritten := true;
 
1847
                  end;
 
1848
              end;
 
1849
              spilled := true;
 
1850
            end;
 
1851
          inc(regindex,ord(regindex=tmpindex));
 
1852
        end;
 
1853
 
 
1854
 
 
1855
      procedure tryreplacereg(var reg: tregister);
 
1856
        var
 
1857
          i: longint;
 
1858
          supreg: tsuperregister;
 
1859
        begin
 
1860
          supreg:=get_alias(getsupreg(reg));
 
1861
          for i:=0 to pred(regindex) do
 
1862
            if (regs[i].mustbespilled) and
 
1863
               (regs[i].orgreg=supreg) then
 
1864
              begin
 
1865
                { Only replace supreg }
 
1866
                setsupreg(reg,getsupreg(regs[i].tempreg));
 
1867
                break;
 
1868
              end;
 
1869
        end;
 
1870
 
 
1871
      var
 
1872
        loadpos,
 
1873
        storepos : tai;
 
1874
        oldlive_registers : tsuperregisterworklist;
 
1875
      begin
 
1876
        result := false;
 
1877
        fillchar(regs,sizeof(regs),0);
 
1878
        for counter := low(regs) to high(regs) do
 
1879
          regs[counter].orgreg := RS_INVALID;
 
1880
        spilled := false;
 
1881
        regindex := 0;
 
1882
 
 
1883
        { check whether and if so which and how (read/written) this instructions contains
 
1884
          registers that must be spilled }
 
1885
        for counter := 0 to instr.ops-1 do
 
1886
         with instr.oper[counter]^ do
 
1887
          begin
 
1888
            case typ of
 
1889
              top_reg:
 
1890
                begin
 
1891
                  if (getregtype(reg) = regtype) then
 
1892
                    addreginfo(reg,instr.spilling_get_operation_type(counter));
 
1893
                end;
 
1894
              top_ref:
 
1895
                begin
 
1896
                  if regtype in [R_INTREGISTER,R_ADDRESSREGISTER] then
 
1897
                    with ref^ do
 
1898
                      begin
 
1899
                        if (base <> NR_NO) then
 
1900
                          addreginfo(base,instr.spilling_get_operation_type_ref(counter,base));
 
1901
                        if (index <> NR_NO) then
 
1902
                          addreginfo(index,instr.spilling_get_operation_type_ref(counter,index));
 
1903
                      end;
 
1904
                end;
 
1905
{$ifdef ARM}
 
1906
              top_shifterop:
 
1907
                begin
 
1908
                  if regtype in [R_INTREGISTER,R_ADDRESSREGISTER] then
 
1909
                    if shifterop^.rs<>NR_NO then
 
1910
                      addreginfo(shifterop^.rs,operand_read);
 
1911
                end;
 
1912
{$endif ARM}
 
1913
            end;
 
1914
          end;
 
1915
 
 
1916
        { if no spilling for this instruction we can leave }
 
1917
        if not spilled then
 
1918
          exit;
 
1919
 
 
1920
{$ifdef x86}
 
1921
        { Try replacing the register with the spilltemp. This is usefull only
 
1922
          for the i386,x86_64 that support memory locations for several instructions }
 
1923
        for counter := 0 to pred(regindex) do
 
1924
          with regs[counter] do
 
1925
            begin
 
1926
              if mustbespilled then
 
1927
                begin
 
1928
                  if do_spill_replace(list,instr,orgreg,spilltemplist[orgreg]) then
 
1929
                    mustbespilled:=false;
 
1930
                end;
 
1931
            end;
 
1932
{$endif x86}
 
1933
 
 
1934
        {
 
1935
          There are registers that need are spilled. We generate the
 
1936
          following code for it. The used positions where code need
 
1937
          to be inserted are marked using #. Note that code is always inserted
 
1938
          before the positions using pos.previous. This way the position is always
 
1939
          the same since pos doesn't change, but pos.previous is modified everytime
 
1940
          new code is inserted.
 
1941
 
 
1942
          [
 
1943
            - reg_allocs load spills
 
1944
            - load spills
 
1945
          ]
 
1946
          [#loadpos
 
1947
            - reg_deallocs
 
1948
            - reg_allocs
 
1949
          ]
 
1950
          [
 
1951
            - reg_deallocs for load-only spills
 
1952
            - reg_allocs for store-only spills
 
1953
          ]
 
1954
          [#instr
 
1955
            - original instruction
 
1956
          ]
 
1957
          [
 
1958
            - store spills
 
1959
            - reg_deallocs store spills
 
1960
          ]
 
1961
          [#storepos
 
1962
          ]
 
1963
        }
 
1964
 
 
1965
        result := true;
 
1966
        oldlive_registers.copyfrom(live_registers);
 
1967
 
 
1968
        { Process all tai_regallocs belonging to this instruction, ignore explicit
 
1969
          inserted regallocs. These can happend for example in i386:
 
1970
             mov ref,ireg26
 
1971
             <regdealloc ireg26, instr=taicpu of lea>
 
1972
             <regalloc edi, insrt=nil>
 
1973
             lea [ireg26+ireg17],edi
 
1974
          All released registers are also added to the live_registers because
 
1975
          they can't be used during the spilling }
 
1976
        loadpos:=tai(instr.previous);
 
1977
        while assigned(loadpos) and
 
1978
              (loadpos.typ=ait_regalloc) and
 
1979
              ((tai_regalloc(loadpos).instr=nil) or
 
1980
               (tai_regalloc(loadpos).instr=instr)) do
 
1981
          begin
 
1982
            { Only add deallocs belonging to the instruction. Explicit inserted deallocs
 
1983
              belong to the previous instruction and not the current instruction }
 
1984
            if (tai_regalloc(loadpos).instr=instr) and
 
1985
               (tai_regalloc(loadpos).ratype=ra_dealloc) then
 
1986
              live_registers.add(getsupreg(tai_regalloc(loadpos).reg));
 
1987
            loadpos:=tai(loadpos.previous);
 
1988
          end;
 
1989
        loadpos:=tai(loadpos.next);
 
1990
 
 
1991
        { Load the spilled registers }
 
1992
        for counter := 0 to pred(regindex) do
 
1993
          with regs[counter] do
 
1994
            begin
 
1995
              if mustbespilled and regread then
 
1996
                begin
 
1997
                  tempreg:=getregisterinline(list,get_spill_subreg(regs[counter].spillreg));
 
1998
                  do_spill_read(list,tai(loadpos.previous),spilltemplist[orgreg],tempreg);
 
1999
                end;
 
2000
            end;
 
2001
 
 
2002
        { Release temp registers of read-only registers, and add reference of the instruction
 
2003
          to the reginfo }
 
2004
        for counter := 0 to pred(regindex) do
 
2005
          with regs[counter] do
 
2006
            begin
 
2007
              if mustbespilled and regread and (not regwritten) then
 
2008
                begin
 
2009
                  { The original instruction will be the next that uses this register }
 
2010
                  add_reg_instruction(instr,tempreg);
 
2011
                  ungetregisterinline(list,tempreg);
 
2012
                end;
 
2013
            end;
 
2014
 
 
2015
        { Allocate temp registers of write-only registers, and add reference of the instruction
 
2016
          to the reginfo }
 
2017
        for counter := 0 to pred(regindex) do
 
2018
          with regs[counter] do
 
2019
            begin
 
2020
              if mustbespilled and regwritten then
 
2021
                begin
 
2022
                  { When the register is also loaded there is already a register assigned }
 
2023
                  if (not regread) then
 
2024
                    tempreg:=getregisterinline(list,get_spill_subreg(regs[counter].spillreg));
 
2025
                  { The original instruction will be the next that uses this register, this
 
2026
                    also needs to be done for read-write registers }
 
2027
                  add_reg_instruction(instr,tempreg);
 
2028
                end;
 
2029
            end;
 
2030
 
 
2031
        { store the spilled registers }
 
2032
        storepos:=tai(instr.next);
 
2033
        for counter := 0 to pred(regindex) do
 
2034
          with regs[counter] do
 
2035
            begin
 
2036
              if mustbespilled and regwritten then
 
2037
                begin
 
2038
                  do_spill_written(list,tai(storepos.previous),spilltemplist[orgreg],tempreg);
 
2039
                  ungetregisterinline(list,tempreg);
 
2040
                end;
 
2041
            end;
 
2042
 
 
2043
        { now all spilling code is generated we can restore the live registers. This
 
2044
          must be done after the store because the store can need an extra register
 
2045
          that also needs to conflict with the registers of the instruction }
 
2046
        live_registers.done;
 
2047
        live_registers:=oldlive_registers;
 
2048
 
 
2049
        { substitute registers }
 
2050
        for counter:=0 to instr.ops-1 do
 
2051
         with instr.oper[counter]^ do
 
2052
          begin
 
2053
            case typ of
 
2054
              top_reg:
 
2055
                begin
 
2056
                  if (getregtype(reg) = regtype) then
 
2057
                    tryreplacereg(reg);
 
2058
                end;
 
2059
              top_ref:
 
2060
                begin
 
2061
                  if regtype in [R_INTREGISTER,R_ADDRESSREGISTER] then
 
2062
                    begin
 
2063
                      tryreplacereg(ref^.base);
 
2064
                      tryreplacereg(ref^.index);
 
2065
                    end;
 
2066
                end;
 
2067
{$ifdef ARM}
 
2068
              top_shifterop:
 
2069
                begin
 
2070
                  if regtype in [R_INTREGISTER,R_ADDRESSREGISTER] then
 
2071
                    tryreplacereg(shifterop^.rs);
 
2072
                end;
 
2073
{$endif ARM}
 
2074
            end;
 
2075
          end;
 
2076
      end;
 
2077
 
 
2078
end.