freepascal.compiler/compiler/cg68kmem.pas

{
    $Id$
    Copyright (c) 1993-98 by Florian Klaempfl

    Generate m68k assembler for in memory related nodes

    This program is free software; you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation; either version 2 of the License, or
    (at your option) any later version.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with this program; if not, write to the Free Software
    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.

 ****************************************************************************
}
unit cg68kmem;
interface

    uses
      tree;

    procedure secondloadvmt(var p : ptree);
    procedure secondhnewn(var p : ptree);
    procedure secondnewn(var p : ptree);
    procedure secondhdisposen(var p : ptree);
    procedure secondsimplenewdispose(var p : ptree);
    procedure secondaddr(var p : ptree);
    procedure seconddoubleaddr(var p : ptree);
    procedure secondderef(var p : ptree);
    procedure secondsubscriptn(var p : ptree);
    procedure secondvecn(var p : ptree);
    procedure secondselfn(var p : ptree);
    procedure secondwith(var p : ptree);


implementation

    uses
      cobjects,verbose,globals,systems,
      symtable,aasm,types,
      hcodegen,temp_gen,pass_2,
      m68k,cga68k,tgen68k;


{*****************************************************************************
                             SecondLoadVMT
*****************************************************************************}

    procedure secondloadvmt(var p : ptree);
      begin
         p^.location.loc:=LOC_REGISTER;
         p^.location.register:=getregister32;
         exprasmlist^.concat(new(pai68k,op_csymbol_reg(A_MOVE,
            S_L,newcsymbol(pobjectdef(pclassrefdef(p^.resulttype)^.definition)^.vmt_mangledname,0),
            p^.location.register)));
      end;


{*****************************************************************************
                             SecondHNewN
*****************************************************************************}

    procedure secondhnewn(var p : ptree);
      begin
      end;


{*****************************************************************************
                             SecondNewN
*****************************************************************************}

    procedure secondnewn(var p : ptree);
      begin
         secondpass(p^.left);
         if codegenerror then
           exit;
         p^.location.register:=p^.left^.location.register;
      end;


{*****************************************************************************
                             SecondDisposeN
*****************************************************************************}

    procedure secondhdisposen(var p : ptree);
      begin
         secondpass(p^.left);
         if codegenerror then
           exit;
         clear_reference(p^.location.reference);
         case p^.left^.location.loc of
            LOC_REGISTER,
            LOC_CREGISTER : begin
                               p^.location.reference.base:=getaddressreg;
                               exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,
                                 p^.left^.location.register,
                                 p^.location.reference.base)));
                            end;
            LOC_MEM,LOC_REFERENCE :
                            begin
                               del_reference(p^.left^.location.reference);
                               p^.location.reference.base:=getaddressreg;
                               exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,newreference(p^.left^.location.reference),
                                 p^.location.reference.base)));
                            end;
         end;
      end;


{*****************************************************************************
                             SecondNewDispose
*****************************************************************************}

    procedure secondsimplenewdispose(var p : ptree);


      var
         pushed : tpushed;
         r : preference;

      begin
         secondpass(p^.left);
         if codegenerror then
           exit;

         pushusedregisters(pushed,$ffff);
         { determines the size of the mem block }
         push_int(ppointerdef(p^.left^.resulttype)^.definition^.size);

         { push pointer adress }
         case p^.left^.location.loc of
            LOC_CREGISTER : exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,
              p^.left^.location.register,R_SPPUSH)));
            LOC_REFERENCE : emitpushreferenceaddr(p^.left^.location.reference);

         end;

         { call the mem handling procedures }
         case p^.treetype of
           simpledisposen:
             begin
                if ppointerdef(p^.left^.resulttype)^.definition^.needs_inittable then
                  begin
{!!!!!!!}

(*                     new(r);
                     reset_reference(r^);
                     r^.symbol:=stringdup(lab2str(ppointerdef(p^.left^.resulttype)^.definition^.get_rtti_label));
                     emitpushreferenceaddr(exprasmlist,r^);
                     { push pointer adress }
                     case p^.left^.location.loc of
                        LOC_CREGISTER : exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,
                          p^.left^.location.register)));
                        LOC_REFERENCE:
                          emitpushreferenceaddr(exprasmlist,p^.left^.location.reference);
                     end;
                     emitcall('FPC_FINALIZE',true); *)
                  end;
                emitcall('FPC_FREEMEM',true);
             end;
           simplenewn:
             begin
                emitcall('FPC_GETMEM',true);
                if ppointerdef(p^.left^.resulttype)^.definition^.needs_inittable then
                  begin
{!!!!!!!}

(*                     new(r);
                     reset_reference(r^);
                     r^.symbol:=stringdup(lab2str(ppointerdef(p^.left^.resulttype)^.definition^.get_rtti_label));
                     emitpushreferenceaddr(exprasmlist,r^);
                     { push pointer adress }
                     case p^.left^.location.loc of
                        LOC_CREGISTER : exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,
                          p^.left^.location.register)));
                        LOC_REFERENCE:
                          emitpushreferenceaddr(exprasmlist,p^.left^.location.reference);
                     end;
                     emitcall('FPC_INITIALIZE',true); *)
                  end;
             end;
         end;
         popusedregisters(pushed);
         { may be load ESI }
         maybe_loada5;
      end;


{*****************************************************************************
                             SecondAddr
*****************************************************************************}

    procedure secondaddr(var p : ptree);
      begin
         secondpass(p^.left);
         p^.location.loc:=LOC_REGISTER;
         p^.location.register:=getregister32;
         {@ on a procvar means returning an address to the procedure that
          is stored in it.}
       { yes but p^.left^.symtableentry can be nil
       for example on @self !! }
         { symtableentry can be also invalid, if left is no tree node }
         if (p^.left^.treetype=loadn) and
          assigned(p^.left^.symtableentry) and
            (p^.left^.symtableentry^.typ=varsym) and
          (Pvarsym(p^.left^.symtableentry)^.definition^.deftype=
           procvardef) then
            exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,
             newreference(p^.left^.location.reference),
             p^.location.register)))
         else
           begin
            exprasmlist^.concat(new(pai68k,op_ref_reg(A_LEA,S_L,
             newreference(p^.left^.location.reference),R_A0)));
            exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,
             R_A0,p^.location.register)));
           end;
         { for use of other segments }
         { if p^.left^.location.reference.segment<>R_DEFAULT_SEG then
             p^.location.segment:=p^.left^.location.reference.segment;
         }
         del_reference(p^.left^.location.reference);
      end;


{*****************************************************************************
                             SecondDoubleAddr
*****************************************************************************}

    procedure seconddoubleaddr(var p : ptree);
      begin
         secondpass(p^.left);
         p^.location.loc:=LOC_REGISTER;
         del_reference(p^.left^.location.reference);
         p^.location.register:=getregister32;
         exprasmlist^.concat(new(pai68k,op_ref_reg(A_LEA,S_L,
          newreference(p^.left^.location.reference),R_A0)));
         exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,
          R_A0,p^.location.register)));
      end;


{*****************************************************************************
                             SecondDeRef
*****************************************************************************}

    procedure secondderef(var p : ptree);
      var
         hr : tregister;

      begin
         secondpass(p^.left);
         clear_reference(p^.location.reference);
         case p^.left^.location.loc of
            LOC_REGISTER : Begin
                             hr := getaddressreg;
                             emit_reg_reg(A_MOVE,S_L,p^.left^.location.register,hr);
                             p^.location.reference.base:=hr;
                             ungetregister(p^.left^.location.register);
                           end;
            LOC_CREGISTER : begin
                               { ... and reserve one for the pointer }
                               hr:=getaddressreg;
                               emit_reg_reg(A_MOVE,S_L,p^.left^.location.register,hr);
                                      p^.location.reference.base:=hr;
                               { LOC_REGISTER indicates that this is a
                               variable register which should not be freed. }
{                               ungetregister(p^.left^.location.register); }
                            end;
            else
              begin
                 { free register }
                 del_reference(p^.left^.location.reference);

                 { ...and reserve one for the pointer }
                 hr:=getaddressreg;
                 exprasmlist^.concat(new(pai68k,op_ref_reg(
                   A_MOVE,S_L,newreference(p^.left^.location.reference),
                   hr)));
                 p^.location.reference.base:=hr;
              end;
         end;
      end;


{*****************************************************************************
                             SecondSubScriptN
*****************************************************************************}

    procedure secondsubscriptn(var p : ptree);
      var
       hr: tregister;

      begin

         secondpass(p^.left);

         if codegenerror then
           exit;
         { classes must be dereferenced implicit }
         if (p^.left^.resulttype^.deftype=objectdef) and
           pobjectdef(p^.left^.resulttype)^.isclass then
           begin
             clear_reference(p^.location.reference);
             case p^.left^.location.loc of
                LOC_REGISTER:
                  begin
                     { move it to an address register...}
                     hr:=getaddressreg;
                     emit_reg_reg(A_MOVE,S_L,p^.left^.location.register,hr);
                     p^.location.reference.base:=hr;
                     { free register }
                     ungetregister(p^.left^.location.register);
                  end;
                LOC_CREGISTER:
                  begin
                     { ... and reserve one for the pointer }
                     hr:=getaddressreg;
                     emit_reg_reg(A_MOVE,S_L,p^.left^.location.register,hr);
                       p^.location.reference.base:=hr;
                  end;
                else
                  begin
                     { free register }
                     del_reference(p^.left^.location.reference);

                     { ... and reserve one for the pointer }
                     hr:=getaddressreg;
                     exprasmlist^.concat(new(pai68k,op_ref_reg(
                       A_MOVE,S_L,newreference(p^.left^.location.reference),
                       hr)));
                     p^.location.reference.base:=hr;
                  end;
             end;
           end
         else
           set_location(p^.location,p^.left^.location);

         inc(p^.location.reference.offset,p^.vs^.address);
      end;


{*****************************************************************************
                               SecondVecN
*****************************************************************************}

    { used D0, D1 as scratch (ok) }
    { arrays ...                  }
    { Sets up the array and string }
    { references .                 }
    procedure secondvecn(var p : ptree);

      var
         pushed : boolean;
         ind : tregister;
         _p : ptree;

      procedure calc_emit_mul;

        var
           l1,l2 : longint;

        begin
           l1:=p^.resulttype^.size;
           case l1 of
              1     : p^.location.reference.scalefactor:=l1;
              2 : exprasmlist^.concat(new(pai68k,op_const_reg(A_LSL,S_L,1,ind)));
              4 : exprasmlist^.concat(new(pai68k,op_const_reg(A_LSL,S_L,2,ind)));
              8 : exprasmlist^.concat(new(pai68k,op_const_reg(A_LSL,S_L,3,ind)));
           else
             begin
               if ispowerof2(l1,l2) then
                 exprasmlist^.concat(new(pai68k,op_const_reg(A_LSL,S_L,l2,ind)))
                   else
                 begin
                   { use normal MC68000 signed multiply }
                   if (l1 >= -32768) and (l1 <= 32767) then
                     exprasmlist^.concat(new(pai68k,op_const_reg(A_MULS,S_W,l1,ind)))
                   else
                   { use long MC68020 long multiply }
                   if (aktoptprocessor = MC68020) then
                     exprasmlist^.concat(new(pai68k,op_const_reg(A_MULS,S_L,l1,ind)))
                   else
                   { MC68000 long multiply }
                     begin
                       exprasmlist^.concat(new(pai68k,op_const_reg(A_MOVE,S_L,l1,R_D0)));
                       exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,ind,R_D1)));
                       emitcall('FPC_LONGMUL',true);
                       exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,R_D0,ind)));
                     end;
                 end;
             end; { else case }
            end; { end case }
        end; { calc_emit_mul }

      var
       extraoffset : longint;
         t : ptree;
         hp : preference;
         tai:pai68k;
       reg: tregister;

      begin
         secondpass(p^.left);
         { RESULT IS IN p^.location.reference }
         set_location(p^.location,p^.left^.location);

         { offset can only differ from 0 if arraydef }
         if p^.left^.resulttype^.deftype=arraydef then
           dec(p^.location.reference.offset,
             p^.resulttype^.size*
             parraydef(p^.left^.resulttype)^.lowrange);

         if p^.right^.treetype=ordconstn then
           begin
              { offset can only differ from 0 if arraydef }
              if (p^.left^.resulttype^.deftype=arraydef) then
              begin
                   if not(is_open_array(p^.left^.resulttype)) then
                       begin
                     if (p^.right^.value>parraydef(p^.left^.resulttype)^.highrange) or
                        (p^.right^.value<parraydef(p^.left^.resulttype)^.lowrange) then
                        CGMessage(parser_e_range_check_error);

                     dec(p^.left^.location.reference.offset,
                        p^.resulttype^.size*parraydef(p^.left^.resulttype)^.lowrange);
                    end
                   else
                     begin
                        { range checking for open arrays }
                     end;
                  end;
              inc(p^.left^.location.reference.offset,
                 p^.right^.value*p^.resulttype^.size);
              p^.left^.resulttype:=p^.resulttype;
              disposetree(p^.right);
              _p:=p^.left;
              putnode(p);
              p:=_p;
           end
         else
           begin
              { quick hack, to overcome Delphi 2 }
              if (�cs_regalloc in aktglobalswitches) and
                (p^.left^.resulttype^.deftype=arraydef) then
                begin
                   extraoffset:=0;
                   if (p^.right^.treetype=addn) then
                     begin
                        if p^.right^.right^.treetype=ordconstn then
                          begin
                             extraoffset:=p^.right^.right^.value;
                             t:=p^.right^.left;
                             putnode(p^.right);
                             putnode(p^.right^.right);
                             p^.right:=t
                          end
                        else if p^.right^.left^.treetype=ordconstn then
                          begin
                             extraoffset:=p^.right^.left^.value;
                             t:=p^.right^.right;
                                    putnode(p^.right);
                             putnode(p^.right^.left);
                             p^.right:=t
                          end;
                     end
                   else if (p^.right^.treetype=subn) then
                     begin
                              if p^.right^.right^.treetype=ordconstn then
                          begin
                             extraoffset:=p^.right^.right^.value;
                             t:=p^.right^.left;
                             putnode(p^.right);
                             putnode(p^.right^.right);
                             p^.right:=t
                          end
                        else if p^.right^.left^.treetype=ordconstn then
                          begin
                             extraoffset:=p^.right^.left^.value;
                                    t:=p^.right^.right;
                             putnode(p^.right);
                             putnode(p^.right^.left);
                             p^.right:=t
                          end;
                     end;
                   inc(p^.location.reference.offset,
                     p^.resulttype^.size*extraoffset);
                end;
              { calculate from left to right }
              if (p^.location.loc<>LOC_REFERENCE) and
                 (p^.location.loc<>LOC_MEM) then
                CGMessage(cg_e_illegal_expression);

              pushed:=maybe_push(p^.right^.registers32,p);
              secondpass(p^.right);
              if pushed then restore(p);
                 case p^.right^.location.loc of
                LOC_REGISTER : begin
                                 ind:=p^.right^.location.register;
                                 case p^.right^.resulttype^.size of
                                 1: exprasmlist^.concat(new(pai68k,op_const_reg(A_AND,S_L,
                                      $ff,ind)));
                                 2: exprasmlist^.concat(new(pai68k,op_const_reg(A_AND,S_L,
                                      $ffff,ind)));
                                 end;
                               end;

                LOC_CREGISTER : begin
                                       ind:=getregister32;
                                   emit_reg_reg(A_MOVE,S_L,p^.right^.location.register,ind);
                                   case p^.right^.resulttype^.size of
                                   1: exprasmlist^.concat(new(pai68k,op_const_reg(A_AND,S_L,
                                      $ff,ind)));
                                   2: exprasmlist^.concat(new(pai68k,op_const_reg(A_AND,S_L,
                                      $ffff,ind)));
                                end;
                                end;
                   LOC_FLAGS:
                     begin
                        ind:=getregister32;
                        exprasmlist^.concat(new(pai68k,op_reg(flag_2_set[p^.right^.location.resflags],S_B,ind)));
                        exprasmlist^.concat(new(pai68k,op_const_reg(A_AND,S_L,$ff,ind)));
                     end
                else { else outer case }
                   begin
                      del_reference(p^.right^.location.reference);
                           ind:=getregister32;

                      exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,
                        newreference(p^.right^.location.reference),ind)));

                           {Booleans are stored in an 8 bit memory location, so
                           the use of MOVL is not correct.}
                      case p^.right^.resulttype^.size of
                        1: exprasmlist^.concat(new(pai68k,op_const_reg(A_AND,S_L,
                          $ff,ind)));
                        2: exprasmlist^.concat(new(pai68k,op_const_reg(A_AND,S_L,
                          $ffff,ind)));
                      end; { end case }
                      end; { end else begin }
              end;

              { produce possible range check code: }
              if cs_check_range in aktlocalswitches  then
                begin
                   if p^.left^.resulttype^.deftype=arraydef then
                     begin
                        new(hp);
                        reset_reference(hp^);
                        parraydef(p^.left^.resulttype)^.genrangecheck;
                        hp^.symbol:=stringdup(parraydef(p^.left^.resulttype)^.getrangecheckstring);
                        emit_bounds_check(hp^,ind);
                     end;
                end;

           { ------------------------ HANDLE INDEXING ----------------------- }
           { In Motorola 680x0 mode, displacement can only be of 64K max.     }
           { Therefore instead of doing a direct displacement, we must first  }
           { load the new address into an address register. Therefore the     }
           { symbol is not used.                                              }
           if assigned(p^.location.reference.symbol) then
           begin
              if p^.location.reference.base <> R_NO then
               CGMessage(cg_f_secondvecn_base_defined_twice);
              p^.location.reference.base:=getaddressreg;
              exprasmlist^.concat(new(pai68k,op_csymbol_reg(A_LEA,S_L,newcsymbol(p^.location.reference.symbol^,0),
                p^.location.reference.base)));
              stringdispose(p^.location.reference.symbol);
           end;

              if (p^.location.reference.index=R_NO) then
                begin
                   p^.location.reference.index:=ind;
                   calc_emit_mul;
               { here we must check for the offset      }
               { and if out of bounds for the motorola  }
               { eg: out of signed d8 then reload index }
               { with correct value.                    }
               if p^.location.reference.offset > 127 then
               begin
                  exprasmlist^.concat(new(pai68k,op_const_reg(A_ADD,S_L,p^.location.reference.offset,ind)));
                  p^.location.reference.offset := 0;
               end
               else
               if p^.location.reference.offset < -128 then
               begin
                  exprasmlist^.concat(new(pai68k,op_const_reg(A_SUB,S_L,-p^.location.reference.offset,ind)));
                  p^.location.reference.offset := 0;
               end;
                end
              else
                begin
                   if p^.location.reference.base=R_NO then
                      begin
                          case p^.location.reference.scalefactor of
                       2 : exprasmlist^.concat(new(pai68k,op_const_reg(A_LSL,S_L,1,p^.location.reference.index)));
                       4 : exprasmlist^.concat(new(pai68k,op_const_reg(A_LSL,S_L,2,p^.location.reference.index)));
                       8 : exprasmlist^.concat(new(pai68k,op_const_reg(A_LSL,S_L,3,p^.location.reference.index)));
                       end;
                          calc_emit_mul;

                    { we must use address register to put index in base }
                    { compare with cgi386.pas                           }

                    reg := getaddressreg;
                    p^.location.reference.base := reg;

                    emit_reg_reg(A_MOVE,S_L,p^.location.reference.index,reg);
                    ungetregister(p^.location.reference.index);

                    p^.location.reference.index:=ind;
                 end
               else
                 begin
                    reg := getaddressreg;
                    exprasmlist^.concat(new(pai68k,op_ref_reg(
                      A_LEA,S_L,newreference(p^.location.reference),
                      reg)));

                    ungetregister(p^.location.reference.base);
                    { the symbol offset is loaded,               }
                    { so release the symbol name and set symbol  }
                    { to nil                                     }
                    stringdispose(p^.location.reference.symbol);
                    p^.location.reference.offset:=0;
                    calc_emit_mul;
                    p^.location.reference.base:=reg;
                    ungetregister32(p^.location.reference.index);
                    p^.location.reference.index:=ind;
                 end;
               end;
           end;
      end;


{*****************************************************************************
                               SecondSelfN
*****************************************************************************}

    procedure secondselfn(var p : ptree);
      begin
         clear_reference(p^.location.reference);
         p^.location.reference.base:=R_A5;
      end;


{*****************************************************************************
                               SecondWithN
*****************************************************************************}

    procedure secondwith(var p : ptree);
       var
          ref : treference;
          symtable : psymtable;
          i : longint;

       begin
          if assigned(p^.left) then
            begin
               secondpass(p^.left);
               ref.symbol:=nil;
               gettempofsizereference(4,ref);
               exprasmlist^.concat(new(pai68k,op_ref_reg(A_LEA,S_L,
                 newreference(p^.left^.location.reference),R_A0)));
               exprasmlist^.concat(new(pai68k,op_reg_ref(A_MOVE,S_L,
                 R_A0,newreference(ref))));
               del_reference(p^.left^.location.reference);
               { the offset relative to (%ebp) is only needed here! }
               symtable:=p^.withsymtable;
               for i:=1 to p^.tablecount do
                 begin
                    symtable^.datasize:=ref.offset;
                    symtable:=symtable^.next;
                 end;

               { p^.right can be optimize out !!! }
               if p^.right<>nil then
                 secondpass(p^.right);
               { clear some stuff }
               ungetiftemp(ref);
            end;
       end;

end.
{
  $Log$
  Revision 1.6  1998-10-06 20:49:00  peter
    * m68k compiler compiles again

  Revision 1.5  1998/09/17 09:42:28  peter
    + pass_2 for cg386
    * Message() -> CGMessage() for pass_1/pass_2

  Revision 1.4  1998/09/14 10:44:02  peter
    * all internal RTL functions start with FPC_

  Revision 1.3  1998/09/11 12:29:44  pierre
    * removed explicit range_checking as it is buggy

  Revision 1.2.2.1  1998/09/11 12:08:59  pierre
    * removed explicit range_check was buggy

  Revision 1.2  1998/09/07 18:45:57  peter
    * update smartlinking, uses getdatalabel
    * renamed ptree.value vars to value_str,value_real,value_set

  Revision 1.1  1998/09/01 09:07:09  peter
    * m68k fixes, splitted cg68k like cgi386

}