freepascal.compiler/compiler/i386/n386con.pas

{
    $Id$
    Copyright (c) 1998-2000 by Florian Klaempfl

    Generate i386 assembler for constants

    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 n386con;

{$i defines.inc}

interface

    uses
       ncon;

    type
       ti386realconstnode = class(trealconstnode)
          procedure pass_2;override;
       end;

       ti386ordconstnode = class(tordconstnode)
          procedure pass_2;override;
       end;

       ti386pointerconstnode = class(tpointerconstnode)
          procedure pass_2;override;
       end;

       ti386stringconstnode = class(tstringconstnode)
          procedure pass_2;override;
       end;

       ti386setconstnode = class(tsetconstnode)
          procedure pass_2;override;
       end;

       ti386nilnode = class(tnilnode)
          procedure pass_2;override;
       end;


implementation

    uses
      globtype,widestr,systems,
      verbose,globals,
      symconst,symdef,aasm,types,
      temp_gen,
      cpubase,
      cgai386,tgcpu;

{*****************************************************************************
                           TI386REALCONSTNODE
*****************************************************************************}

    procedure ti386realconstnode.pass_2;
      const
        floattype2ait:array[tfloattype] of tait=
          (ait_real_32bit,ait_real_64bit,ait_real_80bit,ait_comp_64bit);

      var
         hp1 : tai;
         lastlabel : tasmlabel;
         realait : tait;

      begin
         if (value_real=1.0) then
           begin
              emit_none(A_FLD1,S_NO);
              location.loc:=LOC_FPU;
              inc(fpuvaroffset);
           end
         else if (value_real=0.0) then
           begin
              emit_none(A_FLDZ,S_NO);
              location.loc:=LOC_FPU;
              inc(fpuvaroffset);
           end
         else
           begin
              lastlabel:=nil;
              realait:=floattype2ait[tfloatdef(resulttype.def).typ];
              { const already used ? }
              if not assigned(lab_real) then
                begin
                   { tries to find an old entry }
                   hp1:=tai(Consts.first);
                   while assigned(hp1) do
                     begin
                        if hp1.typ=ait_label then
                          lastlabel:=tai_label(hp1).l
                        else
                          begin
                             if (hp1.typ=realait) and (lastlabel<>nil) then
                               begin
                                  if(
                                     ((realait=ait_real_32bit) and (tai_real_32bit(hp1).value=value_real)) or
                                     ((realait=ait_real_64bit) and (tai_real_64bit(hp1).value=value_real)) or
                                     ((realait=ait_real_80bit) and (tai_real_80bit(hp1).value=value_real)) or
                                     ((realait=ait_comp_64bit) and (tai_comp_64bit(hp1).value=value_real))
                                    ) then
                                    begin
                                       { found! }
                                       lab_real:=lastlabel;
                                       break;
                                    end;
                               end;
                             lastlabel:=nil;
                          end;
                        hp1:=tai(hp1.next);
                     end;
                   { :-(, we must generate a new entry }
                   if not assigned(lab_real) then
                     begin
                        getdatalabel(lastlabel);
                        lab_real:=lastlabel;
                        if (cs_create_smart in aktmoduleswitches) then
                         Consts.concat(Tai_cut.Create);
                        Consts.concat(Tai_label.Create(lastlabel));
                        case realait of
                          ait_real_32bit :
                            Consts.concat(Tai_real_32bit.Create(value_real));
                          ait_real_64bit :
                            Consts.concat(Tai_real_64bit.Create(value_real));
                          ait_real_80bit :
                            Consts.concat(Tai_real_80bit.Create(value_real));
                          ait_comp_64bit :
                            Consts.concat(Tai_comp_64bit.Create(value_real));
                        else
                          internalerror(10120);
                        end;
                     end;
                end;
              reset_reference(location.reference);
              location.reference.symbol:=lab_real;
              location.loc:=LOC_MEM;
           end;
      end;


{*****************************************************************************
                            TI386ORDCONSTNODE
*****************************************************************************}

    procedure ti386ordconstnode.pass_2;
      var
         l : tasmlabel;

      begin
         location.loc:=LOC_MEM;
         if is_64bitint(resulttype.def) then
           begin
              getdatalabel(l);
              if (cs_create_smart in aktmoduleswitches) then
                Consts.concat(Tai_cut.Create);
              Consts.concat(Tai_label.Create(l));
              Consts.concat(Tai_const.Create_32bit(longint(lo(value))));
              Consts.concat(Tai_const.Create_32bit(longint(hi(value))));
              reset_reference(location.reference);
              location.reference.symbol:=l;
           end
         else
           begin
              { non int64 const. behaves as a memory reference }
              location.reference.is_immediate:=true;
              location.reference.offset:=longint(value);
           end;
      end;


{*****************************************************************************
                          TI386POINTERCONSTNODE
*****************************************************************************}

    procedure ti386pointerconstnode.pass_2;
      begin
         { an integer const. behaves as a memory reference }
         location.loc:=LOC_MEM;
         location.reference.is_immediate:=true;
         location.reference.offset:=longint(value);
      end;


{*****************************************************************************
                          Ti386STRINGCONSTNODE
*****************************************************************************}

    procedure ti386stringconstnode.pass_2;
      var
         hp1 : tai;
         l1,l2,
         lastlabel   : tasmlabel;
         pc       : pchar;
         same_string : boolean;
         l,j,
         i,mylength  : longint;
      begin
         { for empty ansistrings we could return a constant 0 }
         if is_ansistring(resulttype.def) and
            (len=0) then
          begin
            location.loc:=LOC_MEM;
            location.reference.is_immediate:=true;
            location.reference.offset:=0;
            exit;
          end;
         { const already used ? }
         lastlabel:=nil;
         if not assigned(lab_str) then
           begin
              if is_shortstring(resulttype.def) then
                mylength:=len+2
              else
                mylength:=len+1;
              { widestrings can't be reused yet }
              if not(is_widestring(resulttype.def)) then
                begin
                  { tries to found an old entry }
                  hp1:=tai(Consts.first);
                  while assigned(hp1) do
                    begin
                       if hp1.typ=ait_label then
                         lastlabel:=tai_label(hp1).l
                       else
                         begin
                            { when changing that code, be careful that }
                            { you don't use typed consts, which are    }
                            { are also written to consts           }
                            { currently, this is no problem, because   }
                            { typed consts have no leading length or   }
                            { they have no trailing zero           }
                            if (hp1.typ=ait_string) and (lastlabel<>nil) and
                               (tai_string(hp1).len=mylength) then
                              begin
                                 same_string:=true;
                                 { if shortstring then check the length byte first and
                                   set the start index to 1 }
                                 if is_shortstring(resulttype.def) then
                                  begin
                                    if len<>ord(tai_string(hp1).str[0]) then
                                     same_string:=false;
                                    j:=1;
                                  end
                                 else
                                  j:=0;
                                 { don't check if the length byte was already wrong }
                                 if same_string then
                                  begin
                                    for i:=0 to len do
                                     begin
                                       if tai_string(hp1).str[j]<>value_str[i] then
                                        begin
                                          same_string:=false;
                                          break;
                                        end;
                                       inc(j);
                                     end;
                                  end;
                                 { found ? }
                                 if same_string then
                                  begin
                                    lab_str:=lastlabel;
                                    { create a new entry for ansistrings, but reuse the data }
                                    if (st_type in [st_ansistring,st_widestring]) then
                                     begin
                                       getdatalabel(l2);
                                       Consts.concat(Tai_label.Create(l2));
                                       Consts.concat(Tai_const_symbol.Create(lab_str));
                                       { return the offset of the real string }
                                       lab_str:=l2;
                                     end;
                                    break;
                                  end;
                              end;
                            lastlabel:=nil;
                         end;
                       hp1:=tai(hp1.next);
                    end;
                end;
              { :-(, we must generate a new entry }
              if not assigned(lab_str) then
                begin
                   getdatalabel(lastlabel);
                   lab_str:=lastlabel;
                   if (cs_create_smart in aktmoduleswitches) then
                    Consts.concat(Tai_cut.Create);
                   Consts.concat(Tai_label.Create(lastlabel));
                   { generate an ansi string ? }
                   case st_type of
                      st_ansistring:
                        begin
                           { an empty ansi string is nil! }
                           if len=0 then
                             Consts.concat(Tai_const.Create_32bit(0))
                           else
                             begin
                                getdatalabel(l1);
                                getdatalabel(l2);
                                Consts.concat(Tai_label.Create(l2));
                                Consts.concat(Tai_const_symbol.Create(l1));
                                Consts.concat(Tai_const.Create_32bit(len));
                                Consts.concat(Tai_const.Create_32bit(len));
                                Consts.concat(Tai_const.Create_32bit(-1));
                                Consts.concat(Tai_label.Create(l1));
                                getmem(pc,len+2);
                                move(value_str^,pc^,len);
                                pc[len]:=#0;
                                { to overcome this problem we set the length explicitly }
                                { with the ending null char }
                                Consts.concat(Tai_string.Create_length_pchar(pc,len+1));
                                { return the offset of the real string }
                                lab_str:=l2;
                             end;
                        end;
                      st_widestring:
                        begin
                           { an empty wide string is nil! }
                           if len=0 then
                             Consts.concat(Tai_const.Create_32bit(0))
                           else
                             begin
                                getdatalabel(l1);
                                getdatalabel(l2);
                                Consts.concat(Tai_label.Create(l2));
                                Consts.concat(Tai_const_symbol.Create(l1));

                                { we use always UTF-16 coding for constants }
                                { at least for now                          }
                                Consts.concat(Tai_const.Create_8bit(2));
                                Consts.concat(Tai_const.Create_32bit(len));
                                Consts.concat(Tai_const.Create_32bit(len));
                                Consts.concat(Tai_const.Create_32bit(-1));
                                Consts.concat(Tai_label.Create(l1));
                                for i:=0 to len-1 do
                                  Consts.concat(Tai_const.Create_16bit(
                                    pcompilerwidestring(value_str)^.data[i]));
                                { return the offset of the real string }
                                lab_str:=l2;
                             end;
                        end;
                      st_shortstring:
                        begin
                          { truncate strings larger than 255 chars }
                          if len>255 then
                           l:=255
                          else
                           l:=len;
                          { also length and terminating zero }
                          getmem(pc,l+3);
                          move(value_str^,pc[1],l+1);
                          pc[0]:=chr(l);
                          { to overcome this problem we set the length explicitly }
                          { with the ending null char }
                          pc[l+1]:=#0;
                          Consts.concat(Tai_string.Create_length_pchar(pc,l+2));
                        end;
                   end;
                end;
           end;
         reset_reference(location.reference);
         location.reference.symbol:=lab_str;
         location.loc:=LOC_MEM;
      end;


{*****************************************************************************
                           TI386SETCONSTNODE
*****************************************************************************}

    procedure ti386setconstnode.pass_2;
      var
         hp1     : tai;
         lastlabel   : tasmlabel;
         i         : longint;
         neededtyp   : tait;
      begin
        { small sets are loaded as constants }
        if tsetdef(resulttype.def).settype=smallset then
         begin
           location.loc:=LOC_MEM;
           location.reference.is_immediate:=true;
           location.reference.offset:=plongint(value_set)^;
           exit;
         end;
        if tsetdef(resulttype.def).settype=smallset then
         neededtyp:=ait_const_32bit
        else
         neededtyp:=ait_const_8bit;
        lastlabel:=nil;
        { const already used ? }
        if not assigned(lab_set) then
          begin
             { tries to found an old entry }
             hp1:=tai(Consts.first);
             while assigned(hp1) do
               begin
                  if hp1.typ=ait_label then
                    lastlabel:=tai_label(hp1).l
                  else
                    begin
                      if (lastlabel<>nil) and (hp1.typ=neededtyp) then
                        begin
                          if (hp1.typ=ait_const_8bit) then
                           begin
                             { compare normal set }
                             i:=0;
                             while assigned(hp1) and (i<32) do
                              begin
                                if tai_const(hp1).value<>value_set^[i] then
                                 break;
                                inc(i);
                                hp1:=tai(hp1.next);
                              end;
                             if i=32 then
                              begin
                                { found! }
                                lab_set:=lastlabel;
                                break;
                              end;
                             { leave when the end of consts is reached, so no
                               hp1.next is done }
                             if not assigned(hp1) then
                              break;
                           end
                          else
                           begin
                             { compare small set }
                             if plongint(value_set)^=tai_const(hp1).value then
                              begin
                                { found! }
                                lab_set:=lastlabel;
                                break;
                              end;
                           end;
                        end;
                      lastlabel:=nil;
                    end;
                  hp1:=tai(hp1.next);
               end;
             { :-(, we must generate a new entry }
             if not assigned(lab_set) then
               begin
                 getdatalabel(lastlabel);
                 lab_set:=lastlabel;
                 if (cs_create_smart in aktmoduleswitches) then
                  Consts.concat(Tai_cut.Create);
                 Consts.concat(Tai_label.Create(lastlabel));
                 if tsetdef(resulttype.def).settype=smallset then
                  begin
                    move(value_set^,i,sizeof(longint));
                    Consts.concat(Tai_const.Create_32bit(i));
                  end
                 else
                  begin
                    for i:=0 to 31 do
                      Consts.concat(Tai_const.Create_8bit(value_set^[i]));
                  end;
               end;
          end;
        reset_reference(location.reference);
        location.reference.symbol:=lab_set;
        location.loc:=LOC_MEM;
      end;


{*****************************************************************************
                             TI386NILNODE
*****************************************************************************}

    procedure ti386nilnode.pass_2;
      begin
         location.loc:=LOC_MEM;
         location.reference.is_immediate:=true;
         location.reference.offset:=0;
      end;

begin
   crealconstnode:=ti386realconstnode;
   cordconstnode:=ti386ordconstnode;
   cpointerconstnode:=ti386pointerconstnode;
   cstringconstnode:=ti386stringconstnode;
   csetconstnode:=ti386setconstnode;
   cnilnode:=ti386nilnode;
end.
{
  $Log$
  Revision 1.8  2001-04-13 01:22:18  peter
    * symtable change to classes
    * range check generation and errors fixed, make cycle DEBUG=1 works
    * memory leaks fixed

  Revision 1.7  2001/04/02 21:20:37  peter
    * resulttype rewrite

  Revision 1.6  2000/12/25 00:07:32  peter
    + new tlinkedlist class (merge of old tstringqueue,tcontainer and
      tlinkedlist objects)

  Revision 1.5  2000/11/29 00:30:47  florian
    * unused units removed from uses clause
    * some changes for widestrings

  Revision 1.4  2000/11/20 15:31:38  jonas
  *  longint typecast to assignment of constant to offset field

  Revision 1.3  2000/11/13 14:44:36  jonas
    * fixes so no more range errors with improved range checking code

  Revision 1.2  2000/10/31 22:02:56  peter
    * symtable splitted, no real code changes

  Revision 1.1  2000/10/15 09:33:31  peter
    * moved n386*.pas to i386/ cpu_target dir

  Revision 1.2  2000/10/14 10:14:48  peter
    * moehrendorf oct 2000 rewrite

  Revision 1.1  2000/09/28 20:48:52  florian
  *** empty log message ***
}