freepascal.compiler/compiler/jvm/njvmcal.pas

{
    Copyright (c) 2011 by Jonas Maebe

    JVM-specific code for call 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 njvmcal;

{$i fpcdefs.inc}

interface

    uses
      cgbase,
      symtype,symdef,
      node,ncgcal;

    type
       tjvmcallparanode = class(tcgcallparanode)
        protected
         outcopybasereg: tregister;
         procedure push_formal_para; override;
         procedure push_copyout_para; override;

         procedure handleformalcopyoutpara(orgparadef: tdef); override;

         procedure load_arrayref_para(useparadef: tdef);
       end;

       { tjvmcallnode }

       tjvmcallnode = class(tcgcallnode)
        protected
         procedure extra_pre_call_code; override;
         procedure set_result_location(realresdef: tstoreddef); override;
         procedure do_release_unused_return_value;override;
         procedure extra_post_call_code; override;
         function dispatch_procvar: tnode;
         procedure remove_hidden_paras;
        public
         function pass_1: tnode; override;
       end;


implementation

    uses
      verbose,globtype,constexp,cutils,
      symconst,symtable,symsym,defutil,
      ncal,
      cgutils,tgobj,procinfo,
      cpubase,aasmdata,aasmcpu,
      hlcgobj,hlcgcpu,
      pass_1,nutils,nbas,ncnv,ncon,ninl,nld,nmem,
      jvmdef;

{*****************************************************************************
                           TJVMCALLPARANODE
*****************************************************************************}

    procedure tjvmcallparanode.load_arrayref_para(useparadef: tdef);
      var
        arrayloc: tlocation;
        arrayref: treference;
      begin
        { cannot be a regular array or record, because those are passed by
          plain reference (since they are reference types at the Java level,
          but not at the Pascal level) -> no special initialisation necessary }
        outcopybasereg:=hlcg.getaddressregister(current_asmdata.CurrAsmList,java_jlobject);
        thlcgjvm(hlcg).a_load_stack_reg(current_asmdata.CurrAsmList,java_jlobject,outcopybasereg);
        reference_reset_base(arrayref,outcopybasereg,0,4);
        arrayref.arrayreftype:=art_indexconst;
        arrayref.indexoffset:=0;
        { load the current parameter value into the array in case it's not an
          out-parameter; if it's an out-parameter the contents must be nil
          but that's already ok, since the anewarray opcode takes care of that }
        if (parasym.varspez<>vs_out) then
          hlcg.a_load_loc_ref(current_asmdata.CurrAsmList,useparadef,useparadef,left.location,arrayref);

        { store the array reference into the parameter location (don't change
          left.location, we may need it for copy-back after the call) }
        location_reset(arrayloc,LOC_REGISTER,OS_ADDR);
        arrayloc.register:=outcopybasereg;
        hlcg.gen_load_loc_cgpara(current_asmdata.CurrAsmList,java_jlobject,arrayloc,tempcgpara)
      end;


    procedure tjvmcallparanode.push_formal_para;
      begin
        { primitive values are boxed, so in all cases this is a pointer to
          something and since it cannot be changed (or is not supposed to be
          changed anyway), we don't have to create a temporary array to hold a
          pointer to this value and can just pass the pointer to this value
          directly.

          In case the value can be changed (formal var/out), then we have
          already created a temporary array of one element that holds the boxed
          (or in case of a non-primitive type: original) value. The reason is
          that copying it back out may be a complex operation which we don't
          want to handle at the code generator level.

          -> always push a value parameter (which is either an array of one
          element, or an object) }
        push_value_para
      end;


    procedure tjvmcallparanode.push_copyout_para;
      var
        mangledname: string;
        primitivetype: boolean;
        opc: tasmop;
      begin
        { create an array with one element of the parameter type }
        thlcgjvm(hlcg).a_load_const_stack(current_asmdata.CurrAsmList,s32inttype,1,R_INTREGISTER);
        mangledname:=jvmarrtype(left.resultdef,primitivetype);
        if primitivetype then
          opc:=a_newarray
        else
          opc:=a_anewarray;
        { doesn't change stack height: one int replaced by one reference }
        current_asmdata.CurrAsmList.concat(taicpu.op_sym(opc,current_asmdata.RefAsmSymbol(mangledname)));
        load_arrayref_para(left.resultdef);
      end;


    procedure getparabasenodes(p: tnode; out basenode: tnode; out parent: tunarynode);
      begin
        parent:=nil;
        while assigned(p) do
          begin
            case p.nodetype of
              inlinen:
                begin
                  if tinlinenode(p).inlinenumber=in_box_x then
                    begin
                      parent:=tunarynode(p);
                      p:=parent.left;
                    end
                  else
                    break;
                end;
              subscriptn,
              vecn:
                begin
                  break;
                end;
              typeconvn:
                begin
                  parent:=tunarynode(p);
                  { skip typeconversions that don't change the node type }
                  p:=p.actualtargetnode;
                end;
              derefn:
                begin
                  parent:=tunarynode(p);
                  p:=tunarynode(p).left;
                end
              else
                break;
            end;
          end;
        basenode:=p;
      end;


    function replacewithtemps(var orgnode, copiednode: tnode): ttempcreatenode;
      begin
        result:=ctempcreatenode.create_value(
          orgnode.resultdef,orgnode.resultdef.size,
          tt_persistent,true,orgnode);
        { this right is reused while constructing the temp }
        orgnode:=ctemprefnode.create(result);
        typecheckpass(orgnode);
        { this right is not reused }
        copiednode.free;
        copiednode:=ctemprefnode.create(result);
        typecheckpass(copiednode);
      end;


    procedure tjvmcallparanode.handleformalcopyoutpara(orgparadef: tdef);
      var
        paravaltemp,
        arraytemp,
        indextemp: ttempcreatenode;
        arrdef: tarraydef;
        initstat,
        finistat: tstatementnode;
        leftcopy: tnode;
        realpara, copyrealpara, tempn, assignmenttempn: tnode;
        realparaparent,copyrealparaparent: tunarynode;
        derefbasedef: tdef;
        deref: boolean;
      begin
        fparainit:=internalstatements(initstat);
        { In general, we now create a temp array of one element, assign left
          (or its address in case of a jvmimplicitpointertype) to it, replace
          the parameter with this array, and add code to paracopyback that
          extracts the value from the array again and assigns it to the original
          variable.

          Complications
            a) in case the parameter involves calling a function, it must not
               be called twice, so take the address of the location (since this
               is a var/out parameter, taking the address is conceptually
               always possible)
            b) in case this is an element of a string, we can't take the address
               in JVM code, so we then have to take the address of the string
               (which conceptually may not be possible since it can be a
                property or so) and store the index value into a temp, and
                reconstruct the vecn in te paracopyback code from this data
                (it's similar for normal var/out parameters)
        }

        { we'll replace a bunch of stuff in the parameter with temprefnodes,
          but we can't take a getcopy for the assignment afterwards of this
          result since a getcopy will always assume that we are copying the
          init/deletenodes too and that the temprefnodes have to point to the
          new temps -> get a copy of the parameter in advance, and then replace
          the nodes in the copy with temps just like in the original para }
        leftcopy:=left.getcopy;
        { get the real parameter source in case of type conversions. This is
          the same logic as for set_unique(). The parent is where we have to
          replace realpara with the temp that replaces it. }
        getparabasenodes(left,realpara,realparaparent);
        getparabasenodes(leftcopy,copyrealpara,copyrealparaparent);
        { assign either the parameter's address (in case it's an implicit
          pointer type) or the parameter itself (in case it's a primitive or
          actual pointer/object type) to the temp }
        deref:=false;
        if jvmimplicitpointertype(realpara.resultdef) then
          begin
            derefbasedef:=realpara.resultdef;
            realpara:=caddrnode.create_internal(realpara);
            include(realpara.flags,nf_typedaddr);
            typecheckpass(realpara);
            { we'll have to reference the parameter again in the expression }
            deref:=true;
          end;
        paravaltemp:=nil;
        { make sure we don't replace simple loadnodes with a temp, because
          in case of passing e.g. stringvar[3] to a formal var/out parameter,
          we add "stringvar[3]:=<result>" afterwards. Because Java strings are
          immutable, this is translated into "stringvar:=stringvar.setChar(3,
          <result>)". So if we replace stringvar with a temp, this will change
          the temp rather than stringvar. }
        indextemp:=nil;
        if (realpara.nodetype=vecn) then
          begin
            if node_complexity(tvecnode(realpara).left)>1 then
              begin
                paravaltemp:=replacewithtemps(tvecnode(realpara).left,
                  tvecnode(copyrealpara).left);
                addstatement(initstat,paravaltemp);
              end;
            { in case of an array index, also replace the index with a temp if
              necessary/useful }
            if (node_complexity(tvecnode(realpara).right)>1) then
              begin
                indextemp:=replacewithtemps(tvecnode(realpara).right,
                  tvecnode(copyrealpara).right);
                addstatement(initstat,indextemp);
              end;
          end
        else
          begin
            paravaltemp:=ctempcreatenode.create_value(
              realpara.resultdef,java_jlobject.size,tt_persistent,true,realpara);
            addstatement(initstat,paravaltemp);
            { replace the parameter in the parameter expression with this temp }
            tempn:=ctemprefnode.create(paravaltemp);
            assignmenttempn:=ctemprefnode.create(paravaltemp);
            { will be spliced in the middle of a tree that has already been
              typecheckpassed }
            typecheckpass(tempn);
            typecheckpass(assignmenttempn);
            if assigned(realparaparent) then
              begin
                { left has been reused in paravaltemp (it's realpara itself) ->
                  don't free }
                realparaparent.left:=tempn;
                { the left's copy is not reused }
                copyrealparaparent.left.free;
                copyrealparaparent.left:=assignmenttempn;
              end
            else
              begin
                { left has been reused in paravaltemp (it's realpara itself) ->
                  don't free }
                left:=tempn;
                { leftcopy can remain the same }
                assignmenttempn.free;
              end;
          end;
        { create the array temp that that will serve as the paramter }
        arrdef:=tarraydef.create(0,1,s32inttype);
        if parasym.vardef.typ=formaldef then
          arrdef.elementdef:=java_jlobject
        else
          arrdef.elementdef:=parasym.vardef;
        arraytemp:=ctempcreatenode.create(arrdef,java_jlobject.size,
          tt_persistent,true);
        addstatement(initstat,arraytemp);
        { in case of a non-out parameter, pass in the original value }
        if parasym.varspez<>vs_out then
          begin
            { wrap the primitive type in an object container
              if required }
            if parasym.vardef.typ=formaldef then
              begin
                if (left.resultdef.typ in [orddef,floatdef]) then
                  begin
                    left:=cinlinenode.create(in_box_x,false,ccallparanode.create(left,nil));
                    typecheckpass(left);
                  end;
                left:=ctypeconvnode.create_explicit(left,java_jlobject);
              end;
            addstatement(initstat,cassignmentnode.create(
              cvecnode.create(ctemprefnode.create(arraytemp),genintconstnode(0)),
              left));
          end
        else
          left.free;
        { replace the parameter with the array }
        left:=ctemprefnode.create(arraytemp);
        { add the extraction of the parameter and assign it back to the
          original location }
        fparacopyback:=internalstatements(finistat);
        tempn:=cvecnode.create(ctemprefnode.create(arraytemp),genintconstnode(0));
        { unbox if necessary }
        if parasym.vardef.typ=formaldef then
          begin
            if orgparadef.typ in [orddef,floatdef] then
              tempn:=cinlinenode.create(in_unbox_x_y,false,ccallparanode.create(
                ctypenode.create(orgparadef),ccallparanode.create(tempn,nil)));
          end;
        if (deref) then
          begin
            inserttypeconv_explicit(tempn,getpointerdef(derefbasedef));
            tempn:=cderefnode.create(tempn);
          end;
        addstatement(finistat,cassignmentnode.create(leftcopy,
          ctypeconvnode.create_explicit(tempn,orgparadef)));
        if assigned(indextemp) then
          addstatement(finistat,ctempdeletenode.create(indextemp));
        addstatement(finistat,ctempdeletenode.create(arraytemp));
        if assigned(paravaltemp) then
          addstatement(finistat,ctempdeletenode.create(paravaltemp));
        typecheckpass(fparainit);
        typecheckpass(left);
        typecheckpass(fparacopyback);
      end;


{*****************************************************************************
                             TJVMCALLNODE
*****************************************************************************}

    procedure tjvmcallnode.extra_pre_call_code;
      begin
        { when calling a constructor, first create a new instance, except
          when calling it from another constructor (because then this has
          already been done before calling the current constructor) }
        if procdefinition.typ<>procdef then
          exit;
        if tabstractprocdef(procdefinition).proctypeoption<>potype_constructor then
          exit;
        if not(methodpointer.resultdef.typ in [classrefdef,recorddef]) then
          exit;
        current_asmdata.CurrAsmList.concat(taicpu.op_sym(a_new,current_asmdata.RefAsmSymbol(tabstractrecorddef(tabstractprocdef(procdefinition).owner.defowner).jvm_full_typename(true))));
        { the constructor doesn't return anything, so put a duplicate of the
          self pointer on the evaluation stack for use as function result
          after the constructor has run }
        current_asmdata.CurrAsmList.concat(taicpu.op_none(a_dup));
        thlcgjvm(hlcg).incstack(current_asmdata.CurrAsmList,2);
      end;


    procedure tjvmcallnode.set_result_location(realresdef: tstoreddef);
      begin
        location_reset_ref(location,LOC_REFERENCE,def_cgsize(realresdef),1);
        { in case of jvmimplicitpointertype(), the function will have allocated
          it already and we don't have to allocate it again here }
        if not jvmimplicitpointertype(realresdef) then
          tg.gethltemp(current_asmdata.CurrAsmList,realresdef,realresdef.size,tt_normal,location.reference)
        else
          tg.gethltemp(current_asmdata.CurrAsmList,java_jlobject,java_jlobject.size,tt_normal,location.reference);
      end;


    procedure tjvmcallnode.do_release_unused_return_value;
      begin
        if (tabstractprocdef(procdefinition).proctypeoption=potype_constructor) and
           (current_procinfo.procdef.proctypeoption=potype_constructor) then
          exit;
        if (location.loc=LOC_REFERENCE) then
          tg.ungetiftemp(current_asmdata.CurrAsmList,location.reference);
        if assigned(funcretnode) then
          exit;
        case resultdef.size of
          0:
            ;
          1..4:
            begin
              current_asmdata.CurrAsmList.concat(taicpu.op_none(a_pop));
              thlcgjvm(hlcg).decstack(current_asmdata.CurrAsmList,1);
            end;
          8:
            begin
              current_asmdata.CurrAsmList.concat(taicpu.op_none(a_pop2));
              thlcgjvm(hlcg).decstack(current_asmdata.CurrAsmList,2);
            end
          else
            internalerror(2011010305);
        end;
      end;


    procedure tjvmcallnode.extra_post_call_code;
      var
        totalremovesize: longint;
        realresdef: tdef;
        ppn: tjvmcallparanode;
        pararef: treference;
      begin
        if not assigned(typedef) then
          realresdef:=tstoreddef(resultdef)
        else
          realresdef:=tstoreddef(typedef);
        { a constructor doesn't actually return a value in the jvm }
        if (tabstractprocdef(procdefinition).proctypeoption=potype_constructor) then
          totalremovesize:=pushedparasize
        else
          { even a byte takes up a full stackslot -> align size to multiple of 4 }
          totalremovesize:=pushedparasize-(align(realresdef.size,4) shr 2);
        { remove parameters from internal evaluation stack counter (in case of
          e.g. no parameters and a result, it can also increase) }
        if totalremovesize>0 then
          thlcgjvm(hlcg).decstack(current_asmdata.CurrAsmList,totalremovesize)
        else if totalremovesize<0 then
          thlcgjvm(hlcg).incstack(current_asmdata.CurrAsmList,-totalremovesize);

        { if this was an inherited constructor call, initialise all fields that
          are wrapped types following it }
        if (tabstractprocdef(procdefinition).proctypeoption=potype_constructor) and
           (cnf_inherited in callnodeflags) then
          thlcgjvm(hlcg).gen_initialize_fields_code(current_asmdata.CurrAsmList);

        { copy back the copyout parameter values, if any }
        { Release temps from parameters }
        ppn:=tjvmcallparanode(left);
        while assigned(ppn) do
          begin
            if assigned(ppn.left) then
              begin
                { don't try to copy back vs_constref }
                if (ppn.parasym.varspez in [vs_var,vs_out]) and
                   (ppn.outcopybasereg<>NR_NO) then
                  begin
                    reference_reset_base(pararef,NR_NO,0,4);
                    pararef.arrayreftype:=art_indexconst;
                    pararef.base:=ppn.outcopybasereg;
                    pararef.indexoffset:=0;
                    { the value has to be copied back into persistent storage }
                    if (ppn.parasym.vardef.typ<>formaldef) then
                      begin
                        case ppn.left.location.loc of
                          LOC_REFERENCE:
                            hlcg.a_load_ref_ref(current_asmdata.CurrAsmList,ppn.left.resultdef,ppn.left.resultdef,pararef,ppn.left.location.reference);
                          LOC_CREGISTER:
                            hlcg.a_load_ref_reg(current_asmdata.CurrAsmList,ppn.left.resultdef,ppn.left.resultdef,pararef,ppn.left.location.register);
                        else
                          internalerror(2011051201);
                        end;
                      end
                    else
                      begin
                        { extracting values from foramldef parameters is done
                          by the generic code }
                      end;
                  end;
              end;
            ppn:=tjvmcallparanode(ppn.right);
          end;
      end;


  procedure tjvmcallnode.remove_hidden_paras;
    var
      prevpara, para, nextpara: tcallparanode;
    begin
      prevpara:=nil;
      para:=tcallparanode(left);
      while assigned(para) do
        begin
          nextpara:=tcallparanode(para.right);
          if vo_is_hidden_para in para.parasym.varoptions then
            begin
              if assigned(prevpara) then
                prevpara.right:=nextpara
              else
                left:=nextpara;
              para.right:=nil;
              para.free;
            end
          else
            prevpara:=para;
          para:=nextpara;
        end;
    end;


  function tjvmcallnode.dispatch_procvar: tnode;
    var
      pdclass: tobjectdef;
    begin
      pdclass:=tprocvardef(right.resultdef).classdef;
      { convert procvar type into corresponding class }
      if not tprocvardef(right.resultdef).is_addressonly then
        begin
          right:=caddrnode.create_internal(right);
          include(right.flags,nf_typedaddr);
        end;
      right:=ctypeconvnode.create_explicit(right,pdclass);
      include(right.flags,nf_load_procvar);
      typecheckpass(right);

      { call the invoke method with these parameters. It will take care of the
        wrapping and typeconversions; first filter out the automatically added
        hidden parameters though }
      remove_hidden_paras;
      result:=ccallnode.createinternmethod(right,'INVOKE',left);
      { reused }
      left:=nil;
      right:=nil;
    end;


  function tjvmcallnode.pass_1: tnode;
    var
      sym: tsym;
      wrappername: shortstring;
    begin
      { transform procvar calls }
      if assigned(right) then
        result:=dispatch_procvar
      else
        begin
          { replace virtual class method and constructor calls in case they may
            be indirect; make sure we don't replace the callthrough to the
            original constructor with another call to the wrapper }
          if (procdefinition.typ=procdef) and
             (current_procinfo.procdef.synthetickind<>tsk_callthrough) and
             not(cnf_inherited in callnodeflags) and
             ((procdefinition.proctypeoption=potype_constructor) or
              (po_classmethod in procdefinition.procoptions)) and
             (po_virtualmethod in procdefinition.procoptions) and
             (methodpointer.nodetype<>loadvmtaddrn) then
            begin
              wrappername:=symtableprocentry.name+'__FPCVIRTUALCLASSMETHOD__';
              sym:=
                search_struct_member(tobjectdef(procdefinition.owner.defowner),
                  wrappername);
              if not assigned(sym) or
                 (sym.typ<>procsym) then
                internalerror(2011072801);
                { do not simply replace the procsym/procdef in case we could
                  in theory do that, because the parameter nodes have already
                  been bound to the current procdef's parasyms }
                remove_hidden_paras;
                result:=ccallnode.create(left,tprocsym(sym),symtableproc,methodpointer,callnodeflags);
                result.flags:=flags;
                left:=nil;
                methodpointer:=nil;
                exit;
            end;
          result:=inherited pass_1;
          if assigned(result) then
            exit;
        end;
    end;


begin
  ccallnode:=tjvmcallnode;
  ccallparanode:=tjvmcallparanode;
end.