fpc/compiler/cg64f32.pas

{
    $Id$
    Copyright (c) 1998-2002 by Florian Klaempfl
    Member of the Free Pascal development team

    This unit implements the code generation for 64 bit int
    arithmethics on 32 bit processors

    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.

 ****************************************************************************
}
{# This unit implements the code generation for 64 bit int arithmethics on
   32 bit processors.
}
unit cg64f32;

  {$i fpcdefs.inc}

  interface

    uses
       aasmbase,aasmtai,aasmcpu,
       cpuinfo, cpubase,
       cginfo, cgobj,
       node,symtype;

    type
      {# Defines all the methods required on 32-bit processors
         to handle 64-bit integers.
      }
      tcg64f32 = class(tcg64)
        procedure a_load64_const_ref(list : taasmoutput;value : qword;const ref : treference);override;
        procedure a_load64_reg_ref(list : taasmoutput;reg : tregister64;const ref : treference);override;
        procedure a_load64_ref_reg(list : taasmoutput;const ref : treference;reg : tregister64);override;
        procedure a_load64_reg_reg(list : taasmoutput;regsrc,regdst : tregister64);override;
        procedure a_load64_const_reg(list : taasmoutput;value: qword;reg : tregister64);override;
        procedure a_load64_loc_reg(list : taasmoutput;const l : tlocation;reg : tregister64);override;
        procedure a_load64_loc_ref(list : taasmoutput;const l : tlocation;const ref : treference);override;
        procedure a_load64_const_loc(list : taasmoutput;value : qword;const l : tlocation);override;
        procedure a_load64_reg_loc(list : taasmoutput;reg : tregister64;const l : tlocation);override;

        procedure a_load64high_reg_ref(list : taasmoutput;reg : tregister;const ref : treference);override;
        procedure a_load64low_reg_ref(list : taasmoutput;reg : tregister;const ref : treference);override;
        procedure a_load64high_ref_reg(list : taasmoutput;const ref : treference;reg : tregister);override;
        procedure a_load64low_ref_reg(list : taasmoutput;const ref : treference;reg : tregister);override;
        procedure a_load64high_loc_reg(list : taasmoutput;const l : tlocation;reg : tregister);override;
        procedure a_load64low_loc_reg(list : taasmoutput;const l : tlocation;reg : tregister);override;

        procedure a_op64_const_loc(list : taasmoutput;op:TOpCG;value : qword;const l: tlocation);override;
        procedure a_op64_reg_loc(list : taasmoutput;op:TOpCG;reg : tregister64;const l : tlocation);override;
        procedure a_op64_loc_reg(list : taasmoutput;op:TOpCG;const l : tlocation;reg : tregister64);override;

        procedure a_param64_reg(list : taasmoutput;reg : tregister64;const locpara : tparalocation);override;
        procedure a_param64_const(list : taasmoutput;value : qword;const locpara : tparalocation);override;
        procedure a_param64_ref(list : taasmoutput;const r : treference;const locpara : tparalocation);override;
        procedure a_param64_loc(list : taasmoutput;const l : tlocation;const locpara : tparalocation);override;

        procedure g_rangecheck64(list: taasmoutput; const p: tnode;
          const todef: tdef); override;
      end;

    {# Creates a tregister64 record from 2 32 Bit registers. }
    function joinreg64(reglo,reghi : tregister) : tregister64;

  implementation

    uses
       globtype,globals,systems,
       cgbase,
       verbose,
       symbase,symconst,symdef,types;


    function joinreg64(reglo,reghi : tregister) : tregister64;
      begin
         result.reglo:=reglo;
         result.reghi:=reghi;
      end;

    procedure tcg64f32.a_load64_reg_ref(list : taasmoutput;reg : tregister64;const ref : treference);
      var
        tmpreg: tregister;
        tmpref: treference;
      begin
        if target_info.endian=endian_big then
          begin
            tmpreg:=reg.reglo;
            reg.reglo:=reg.reghi;
            reg.reghi:=tmpreg;
          end;
        cg.a_load_reg_ref(list,OS_32,reg.reglo,ref);
        tmpref := ref;
        inc(tmpref.offset,4);
        cg.a_load_reg_ref(list,OS_32,reg.reghi,tmpref);
      end;

    procedure tcg64f32.a_load64_const_ref(list : taasmoutput;value : qword;const ref : treference);
      var
        tmpvalue : DWord;
        tmpref: treference;
      begin
        if target_info.endian<>source_info.endian then
          swap_qword(value);
        cg.a_load_const_ref(list,OS_32,lo(value),ref);
        tmpref := ref;
        inc(tmpref.offset,4);
        cg.a_load_const_ref(list,OS_32,hi(value),tmpref);
      end;


    procedure tcg64f32.a_load64_ref_reg(list : taasmoutput;const ref : treference;reg : tregister64);
      var
        tmpreg: tregister;
        tmpref: treference;
        got_scratch: boolean;
      begin
        if target_info.endian = endian_big then
          begin
            tmpreg := reg.reglo;
            reg.reglo := reg.reghi;
            reg.reghi := tmpreg;
          end;
        got_scratch:=false;
        tmpref := ref;
        if (tmpref.base=reg.reglo) then
         begin
           tmpreg := cg.get_scratch_reg_int(list);
           got_scratch:=true;
           cg.a_load_reg_reg(list,OS_ADDR,tmpref.base,tmpreg);
           tmpref.base:=tmpreg;
         end
        else
         { this works only for the i386, thus the i386 needs to override  }
         { this method and this method must be replaced by a more generic }
         { implementation FK                                              }
         if (tmpref.index=reg.reglo) then
          begin
            tmpreg:=cg.get_scratch_reg_int(list);
            got_scratch:=true;
            cg.a_load_reg_reg(list,OS_ADDR,tmpref.index,tmpreg);
            tmpref.index:=tmpreg;
          end;
        cg.a_load_ref_reg(list,OS_32,tmpref,reg.reglo);
        inc(tmpref.offset,4);
        cg.a_load_ref_reg(list,OS_32,tmpref,reg.reghi);
        if got_scratch then
          cg.free_scratch_reg(list,tmpreg);
      end;


    procedure tcg64f32.a_load64_reg_reg(list : taasmoutput;regsrc,regdst : tregister64);

      begin
        cg.a_load_reg_reg(list,OS_32,regsrc.reglo,regdst.reglo);
        cg.a_load_reg_reg(list,OS_32,regsrc.reghi,regdst.reghi);
      end;

    procedure tcg64f32.a_load64_const_reg(list : taasmoutput;value : qword;reg : tregister64);

      begin
        if target_info.endian<>source_info.endian then
          swap_qword(value);
        cg.a_load_const_reg(list,OS_32,lo(value),reg.reglo);
        cg.a_load_const_reg(list,OS_32,hi(value),reg.reghi);
      end;

    procedure tcg64f32.a_load64_loc_reg(list : taasmoutput;const l : tlocation;reg : tregister64);

      begin
        case l.loc of
          LOC_REFERENCE, LOC_CREFERENCE:
            a_load64_ref_reg(list,l.reference,reg);
          LOC_REGISTER,LOC_CREGISTER:
            a_load64_reg_reg(list,l.register64,reg);
          LOC_CONSTANT :
            a_load64_const_reg(list,l.valueqword,reg);
          else
            internalerror(200112292);
        end;
      end;


    procedure tcg64f32.a_load64_loc_ref(list : taasmoutput;const l : tlocation;const ref : treference);
      begin
        case l.loc of
          LOC_REGISTER,LOC_CREGISTER:
            a_load64_reg_ref(list,l.reg64,ref);
          LOC_CONSTANT :
            a_load64_const_ref(list,l.valueqword,ref);
          else
            internalerror(200203288);
        end;
      end;


    procedure tcg64f32.a_load64_const_loc(list : taasmoutput;value : qword;const l : tlocation);

      begin
        case l.loc of
          LOC_REFERENCE, LOC_CREFERENCE:
            a_load64_const_ref(list,value,l.reference);
          LOC_REGISTER,LOC_CREGISTER:
            a_load64_const_reg(list,value,l.reg64);
          else
            internalerror(200112293);
        end;
      end;


    procedure tcg64f32.a_load64_reg_loc(list : taasmoutput;reg : tregister64;const l : tlocation);

      begin
        case l.loc of
          LOC_REFERENCE, LOC_CREFERENCE:
            a_load64_reg_ref(list,reg,l.reference);
          LOC_REGISTER,LOC_CREGISTER:
            a_load64_reg_reg(list,reg,l.register64);
          else
            internalerror(200112293);
        end;
      end;



    procedure tcg64f32.a_load64high_reg_ref(list : taasmoutput;reg : tregister;const ref : treference);
      var
        tmpref: treference;
      begin
        if target_info.endian = endian_big then
          cg.a_load_reg_ref(list,OS_32,reg,ref)
        else
          begin
            tmpref := ref;
            inc(tmpref.offset,4);
            cg.a_load_reg_ref(list,OS_32,reg,tmpref)
          end;
      end;

    procedure tcg64f32.a_load64low_reg_ref(list : taasmoutput;reg : tregister;const ref : treference);
      var
        tmpref: treference;
      begin
        if target_info.endian = endian_little then
          cg.a_load_reg_ref(list,OS_32,reg,ref)
        else
          begin
            tmpref := ref;
            inc(tmpref.offset,4);
            cg.a_load_reg_ref(list,OS_32,reg,tmpref)
          end;
      end;

    procedure tcg64f32.a_load64high_ref_reg(list : taasmoutput;const ref : treference;reg : tregister);
      var
        tmpref: treference;
      begin
        if target_info.endian = endian_big then
          cg.a_load_ref_reg(list,OS_32,ref,reg)
        else
          begin
            tmpref := ref;
            inc(tmpref.offset,4);
            cg.a_load_ref_reg(list,OS_32,tmpref,reg)
          end;
      end;

    procedure tcg64f32.a_load64low_ref_reg(list : taasmoutput;const ref : treference;reg : tregister);
      var
        tmpref: treference;
      begin
        if target_info.endian = endian_little then
          cg.a_load_ref_reg(list,OS_32,ref,reg)
        else
          begin
            tmpref := ref;
            inc(tmpref.offset,4);
            cg.a_load_ref_reg(list,OS_32,tmpref,reg)
          end;
      end;

    procedure tcg64f32.a_load64low_loc_reg(list : taasmoutput;const l : tlocation;reg : tregister);
      begin
        case l.loc of
          LOC_REFERENCE,
          LOC_CREFERENCE :
            a_load64low_ref_reg(list,l.reference,reg);
          LOC_REGISTER :
            cg.a_load_reg_reg(list,OS_32,l.registerlow,reg);
          LOC_CONSTANT :
            cg.a_load_const_reg(list,OS_32,l.valuelow,reg);
          else
            internalerror(200203244);
        end;
      end;

    procedure tcg64f32.a_load64high_loc_reg(list : taasmoutput;const l : tlocation;reg : tregister);
      begin
        case l.loc of
          LOC_REFERENCE,
          LOC_CREFERENCE :
            a_load64high_ref_reg(list,l.reference,reg);
          LOC_REGISTER :
            cg.a_load_reg_reg(list,OS_32,l.registerhigh,reg);
          LOC_CONSTANT :
            cg.a_load_const_reg(list,OS_32,l.valuehigh,reg);
          else
            internalerror(200203244);
        end;
      end;


    procedure tcg64f32.a_op64_const_loc(list : taasmoutput;op:TOpCG;value : qword;const l: tlocation);
      begin
        case l.loc of
          LOC_REFERENCE, LOC_CREFERENCE:
            a_op64_const_reg(list,op,value,l.register64);
          LOC_REGISTER,LOC_CREGISTER:
            a_op64_const_ref(list,op,value,l.reference);
          else
            internalerror(200203292);
        end;
      end;


    procedure tcg64f32.a_op64_reg_loc(list : taasmoutput;op:TOpCG;reg : tregister64;const l : tlocation);
      begin
        case l.loc of
          LOC_REFERENCE, LOC_CREFERENCE:
            a_op64_reg_ref(list,op,reg,l.reference);
          LOC_REGISTER,LOC_CREGISTER:
            a_op64_reg_reg(list,op,reg,l.register64);
          else
            internalerror(2002032422);
        end;
      end;



    procedure tcg64f32.a_op64_loc_reg(list : taasmoutput;op:TOpCG;const l : tlocation;reg : tregister64);
      begin
        case l.loc of
          LOC_REFERENCE, LOC_CREFERENCE:
            a_op64_ref_reg(list,op,l.reference,reg);
          LOC_REGISTER,LOC_CREGISTER:
            a_op64_reg_reg(list,op,l.register64,reg);
          LOC_CONSTANT :
            a_op64_const_reg(list,op,l.valueqword,reg);
          else
            internalerror(200203242);
        end;
      end;


    procedure tcg64f32.a_param64_reg(list : taasmoutput;reg : tregister64;const locpara : tparalocation);
      begin
{$warning FIX ME}
         cg.a_param_reg(list,OS_32,reg.reghi,locpara);
         { the nr+1 needs definitivly a fix FK }
         { maybe the parameter numbering needs }
         { to take care of this on 32 Bit      }
         { systems FK                          }
         cg.a_param_reg(list,OS_32,reg.reglo,locpara);
      end;


    procedure tcg64f32.a_param64_const(list : taasmoutput;value : qword;const locpara : tparalocation);
      begin
{$warning FIX ME}
        if target_info.endian<>source_info.endian then
          swap_qword(value);
         cg.a_param_const(list,OS_32,hi(value),locpara);
         { the nr+1 needs definitivly a fix FK }
         { maybe the parameter numbering needs }
         { to take care of this on 32 Bit      }
         { systems FK                          }
         cg.a_param_const(list,OS_32,lo(value),locpara);
      end;


    procedure tcg64f32.a_param64_ref(list : taasmoutput;const r : treference;const locpara : tparalocation);
      var
        tmpref: treference;
      begin
{$warning FIX ME}
        tmpref := r;
        inc(tmpref.offset,4);
        cg.a_param_ref(list,OS_32,tmpref,locpara);
        { the nr+1 needs definitivly a fix FK }
        { maybe the parameter numbering needs }
        { to take care of this on 32 Bit      }
        { systems FK                          }
        cg.a_param_ref(list,OS_32,r,locpara);
      end;


    procedure tcg64f32.a_param64_loc(list : taasmoutput;const l:tlocation;const locpara : tparalocation);
      begin
{$warning FIX ME}
        case l.loc of
          LOC_REGISTER,
          LOC_CREGISTER :
            a_param64_reg(list,l.register64,locpara);
          LOC_CONSTANT :
            a_param64_const(list,l.valueqword,locpara);
          LOC_CREFERENCE,
          LOC_REFERENCE :
            a_param64_ref(list,l.reference,locpara);
        else
          internalerror(200203287);
        end;
      end;


    procedure tcg64f32.g_rangecheck64(list : taasmoutput;const p : tnode;const todef : tdef);

      var
        neglabel,
        poslabel,
        endlabel: tasmlabel;
        hreg   : tregister;
        hdef   :  torddef;
        fromdef : tdef;
        opsize   : tcgsize;
        oldregisterdef: boolean;
        from_signed,to_signed: boolean;
        got_scratch: boolean;

      begin
         fromdef:=p.resulttype.def;
         from_signed := is_signed(fromdef);
         to_signed := is_signed(todef);

         if not is_64bitint(todef) then
           begin
             oldregisterdef := registerdef;
             registerdef := false;

             { get the high dword in a register }
             if p.location.loc in [LOC_REGISTER,LOC_CREGISTER] then
               begin
                 hreg := p.location.registerhigh;
                 got_scratch := false
               end
             else
               begin
                 hreg := cg.get_scratch_reg_int(list);
                 got_scratch := true;
                 a_load64high_ref_reg(list,p.location.reference,hreg);
               end;
             getlabel(poslabel);

             { check high dword, must be 0 (for positive numbers) }
             cg.a_cmp_const_reg_label(list,OS_32,OC_EQ,0,hreg,poslabel);

             { It can also be $ffffffff, but only for negative numbers }
             if from_signed and to_signed then
               begin
                 getlabel(neglabel);
                 cg.a_cmp_const_reg_label(list,OS_32,OC_EQ,aword(-1),hreg,neglabel);
               end;
             { !!! freeing of register should happen directly after compare! (JM) }
             if got_scratch then
               cg.free_scratch_reg(list,hreg);
             { For all other values we have a range check error }
             cg.a_call_name(list,'FPC_RANGEERROR');

             { if the high dword = 0, the low dword can be considered a }
             { simple cardinal                                          }
             cg.a_label(list,poslabel);
             hdef:=torddef.create(u32bit,0,cardinal($ffffffff));
             { the real p.resulttype.def is already saved in fromdef }
             p.resulttype.def := hdef;
             { no use in calling just "g_rangecheck" since that one will }
             { simply call the inherited method too (JM)                 }
             cg.g_rangecheck(list,p,todef);
             hdef.free;
             { restore original resulttype.def }
             p.resulttype.def := todef;

             if from_signed and to_signed then
               begin
                 getlabel(endlabel);
                 cg.a_jmp_always(list,endlabel);
                 { if the high dword = $ffffffff, then the low dword (when }
                 { considered as a longint) must be < 0                    }
                 cg.a_label(list,neglabel);
                 if p.location.loc in [LOC_REGISTER,LOC_CREGISTER] then
                   begin
                     hreg := p.location.registerlow;
                     got_scratch := false
                   end
                 else
                   begin
                     hreg := cg.get_scratch_reg_int(list);
                     got_scratch := true;
                     a_load64low_ref_reg(list,p.location.reference,hreg);
                   end;
                 { get a new neglabel (JM) }
                 getlabel(neglabel);
                 cg.a_cmp_const_reg_label(list,OS_32,OC_LT,0,hreg,neglabel);
                 { !!! freeing of register should happen directly after compare! (JM) }
                 if got_scratch then
                   cg.free_scratch_reg(list,hreg);

                 cg.a_call_name(list,'FPC_RANGEERROR');

                 { if we get here, the 64bit value lies between }
                 { longint($80000000) and -1 (JM)               }
                 cg.a_label(list,neglabel);
                 hdef:=torddef.create(s32bit,longint($80000000),-1);
                 p.resulttype.def := hdef;
                 cg.g_rangecheck(list,p,todef);
                 hdef.free;
                 cg.a_label(list,endlabel);
               end;
             registerdef := oldregisterdef;
             p.resulttype.def := fromdef;
             { restore p's resulttype.def }
           end
         else
           { todef = 64bit int }
           { no 64bit subranges supported, so only a small check is necessary }

           { if both are signed or both are unsigned, no problem! }
           if (from_signed xor to_signed) and
              { also not if the fromdef is unsigned and < 64bit, since that will }
              { always fit in a 64bit int (todef is 64bit)                       }
              (from_signed or
               (torddef(fromdef).typ = u64bit)) then
             begin
               { in all cases, there is only a problem if the higest bit is set }
               if p.location.loc in [LOC_REGISTER,LOC_CREGISTER] then
                 begin
                   if is_64bitint(fromdef) then
                     begin
                       hreg := p.location.registerhigh;
                       opsize := OS_32;
                     end
                   else
                     begin
                       hreg := p.location.register;
                       opsize := def_cgsize(p.resulttype.def);
                     end;
                   got_scratch := false;
                 end
               else
                 begin
                   hreg := cg.get_scratch_reg_int(list);
                   got_scratch := true;

                   opsize := def_cgsize(p.resulttype.def);
                   if opsize in [OS_64,OS_S64] then
                     a_load64high_ref_reg(list,p.location.reference,hreg)
                   else
                     cg.a_load_ref_reg(list,opsize,p.location.reference,hreg);
                 end;
               getlabel(poslabel);
               cg.a_cmp_const_reg_label(list,opsize,OC_GTE,0,hreg,poslabel);

               { !!! freeing of register should happen directly after compare! (JM) }
               if got_scratch then
                 cg.free_scratch_reg(list,hreg);
               cg.a_call_name(list,'FPC_RANGEERROR');
               cg.a_label(list,poslabel);
             end;
      end;

(*
    procedure int64f32_assignment_int64_reg(p : passignmentnode);

      begin
      end;


begin
   p2_assignment:=@int64f32_assignement_int64;
*)
end.
{
  $Log$
  Revision 1.17  2002-07-07 09:52:32  florian
    * powerpc target fixed, very simple units can be compiled
    * some basic stuff for better callparanode handling, far from being finished

  Revision 1.16  2002/07/01 18:46:21  peter
    * internal linker
    * reorganized aasm layer

  Revision 1.15  2002/07/01 16:23:52  peter
    * cg64 patch
    * basics for currency
    * asnode updates for class and interface (not finished)

  Revision 1.14  2002/05/20 13:30:40  carl
  * bugfix of hdisponen (base must be set, not index)
  * more portability fixes

  Revision 1.13  2002/05/18 13:34:05  peter
    * readded missing revisions

  Revision 1.12  2002/05/16 19:46:35  carl
  + defines.inc -> fpcdefs.inc to avoid conflicts if compiling by hand
  + try to fix temp allocation (still in ifdef)
  + generic constructor calls
  + start of tassembler / tmodulebase class cleanup

  Revision 1.10  2002/05/12 16:53:04  peter
    * moved entry and exitcode to ncgutil and cgobj
    * foreach gets extra argument for passing local data to the
      iterator function
    * -CR checks also class typecasts at runtime by changing them
      into as
    * fixed compiler to cycle with the -CR option
    * fixed stabs with elf writer, finally the global variables can
      be watched
    * removed a lot of routines from cga unit and replaced them by
      calls to cgobj
    * u32bit-s32bit updates for and,or,xor nodes. When one element is
      u32bit then the other is typecasted also to u32bit without giving
      a rangecheck warning/error.
    * fixed pascal calling method with reversing also the high tree in
      the parast, detected by tcalcst3 test

  Revision 1.9  2002/04/25 20:16:38  peter
    * moved more routines from cga/n386util

  Revision 1.8  2002/04/21 15:28:51  carl
  * a_jmp_cond -> a_jmp_always

  Revision 1.7  2002/04/07 13:21:18  carl
  + more documentation

  Revision 1.6  2002/04/03 10:41:35  jonas
    + a_load64_const_loc method

  Revision 1.5  2002/04/02 17:11:27  peter
    * tlocation,treference update
    * LOC_CONSTANT added for better constant handling
    * secondadd splitted in multiple routines
    * location_force_reg added for loading a location to a register
      of a specified size
    * secondassignment parses now first the right and then the left node
      (this is compatible with Kylix). This saves a lot of push/pop especially
      with string operations
    * adapted some routines to use the new cg methods

  Revision 1.4  2002/03/04 19:10:11  peter
    * removed compiler warnings

  Revision 1.3  2002/01/24 12:33:52  jonas
    * adapted ranges of native types to int64 (e.g. high cardinal is no
      longer longint($ffffffff), but just $fffffff in psystem)
    * small additional fix in 64bit rangecheck code generation for 32 bit
      processors
    * adaption of ranges required the matching talgorithm used for selecting
      which overloaded procedure to call to be adapted. It should now always
      select the closest match for ordinal parameters.
    + inttostr(qword) in sysstr.inc/sysstrh.inc
    + abs(int64), sqr(int64), sqr(qword) in systemh.inc/generic.inc (previous
      fixes were required to be able to add them)
    * is_in_limit() moved from ncal to types unit, should always be used
      instead of direct comparisons of low/high values of orddefs because
      qword is a special case

}