Line data    Source code

       1              : /* Build executable statement trees.
       2              :    Copyright (C) 2000-2026 Free Software Foundation, Inc.
       3              :    Contributed by Andy Vaught
       4              : 
       5              : This file is part of GCC.
       6              : 
       7              : GCC is free software; you can redistribute it and/or modify it under
       8              : the terms of the GNU General Public License as published by the Free
       9              : Software Foundation; either version 3, or (at your option) any later
      10              : version.
      11              : 
      12              : GCC is distributed in the hope that it will be useful, but WITHOUT ANY
      13              : WARRANTY; without even the implied warranty of MERCHANTABILITY or
      14              : FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
      15              : for more details.
      16              : 
      17              : You should have received a copy of the GNU General Public License
      18              : along with GCC; see the file COPYING3.  If not see
      19              : <http://www.gnu.org/licenses/>.  */
      20              : 
      21              : /* Executable statements are strung together into a singly linked list
      22              :    of code structures.  These structures are later translated into GCC
      23              :    GENERIC tree structures and from there to executable code for a
      24              :    target.  */
      25              : 
      26              : #include "config.h"
      27              : #include "system.h"
      28              : #include "coretypes.h"
      29              : #include "gfortran.h"
      30              : 
      31              : gfc_code new_st;
      32              : 
      33              : 
      34              : /* Zeroes out the new_st structure.  */
      35              : 
      36              : void
      37     31104102 : gfc_clear_new_st (void)
      38              : {
      39     31104102 :   memset (&new_st, '\0', sizeof (new_st));
      40     31104102 :   new_st.op = EXEC_NOP;
      41     31104102 : }
      42              : 
      43              : 
      44              : /* Get a gfc_code structure, initialized with the current locus
      45              :    and a statement code 'op'.  */
      46              : 
      47              : gfc_code *
      48       502674 : gfc_get_code (gfc_exec_op op)
      49              : {
      50       502674 :   gfc_code *c;
      51              : 
      52       502674 :   c = XCNEW (gfc_code);
      53       502674 :   c->op = op;
      54       502674 :   c->loc = gfc_current_locus;
      55       502674 :   return c;
      56              : }
      57              : 
      58              : 
      59              : /* Given some part of a gfc_code structure, append a set of code to
      60              :    its tail, returning a pointer to the new tail.  */
      61              : 
      62              : gfc_code *
      63        82357 : gfc_append_code (gfc_code *tail, gfc_code *new_code)
      64              : {
      65        82357 :   if (tail != NULL)
      66              :     {
      67        67470 :       while (tail->next != NULL)
      68              :         tail = tail->next;
      69              : 
      70        50838 :       tail->next = new_code;
      71              :     }
      72              : 
      73        82892 :   while (new_code->next != NULL)
      74              :     new_code = new_code->next;
      75              : 
      76        82357 :   return new_code;
      77              : }
      78              : 
      79              : 
      80              : /* Free a single code structure, but not the actual structure itself.  */
      81              : 
      82              : void
      83     30168693 : gfc_free_statement (gfc_code *p)
      84              : {
      85     30168693 :   if (p->expr1)
      86      1231695 :     gfc_free_expr (p->expr1);
      87     30168693 :   if (p->expr2)
      88       343137 :     gfc_free_expr (p->expr2);
      89     30168693 :   if (p->expr3)
      90         4096 :     gfc_free_expr (p->expr3);
      91     30168693 :   if (p->expr4)
      92           40 :     gfc_free_expr (p->expr4);
      93              : 
      94     30168693 :   switch (p->op)
      95              :     {
      96              :     case EXEC_NOP:
      97              :     case EXEC_END_BLOCK:
      98              :     case EXEC_END_NESTED_BLOCK:
      99              :     case EXEC_ASSIGN:
     100              :     case EXEC_INIT_ASSIGN:
     101              :     case EXEC_GOTO:
     102              :     case EXEC_CYCLE:
     103              :     case EXEC_RETURN:
     104              :     case EXEC_END_PROCEDURE:
     105              :     case EXEC_IF:
     106              :     case EXEC_PAUSE:
     107              :     case EXEC_STOP:
     108              :     case EXEC_ERROR_STOP:
     109              :     case EXEC_EXIT:
     110              :     case EXEC_WHERE:
     111              :     case EXEC_IOLENGTH:
     112              :     case EXEC_POINTER_ASSIGN:
     113              :     case EXEC_DO_WHILE:
     114              :     case EXEC_CONTINUE:
     115              :     case EXEC_TRANSFER:
     116              :     case EXEC_LABEL_ASSIGN:
     117              :     case EXEC_ENTRY:
     118              :     case EXEC_ARITHMETIC_IF:
     119              :     case EXEC_CRITICAL:
     120              :     case EXEC_SYNC_ALL:
     121              :     case EXEC_SYNC_IMAGES:
     122              :     case EXEC_SYNC_MEMORY:
     123              :     case EXEC_LOCK:
     124              :     case EXEC_UNLOCK:
     125              :     case EXEC_EVENT_POST:
     126              :     case EXEC_EVENT_WAIT:
     127              :     case EXEC_FAIL_IMAGE:
     128              :     case EXEC_CHANGE_TEAM:
     129              :     case EXEC_END_TEAM:
     130              :     case EXEC_FORM_TEAM:
     131              :     case EXEC_SYNC_TEAM:
     132              :       break;
     133              : 
     134        14682 :     case EXEC_BLOCK:
     135        14682 :       gfc_free_namespace (p->ext.block.ns);
     136        14682 :       gfc_free_association_list (p->ext.block.assoc);
     137        14682 :       break;
     138              : 
     139        86914 :     case EXEC_COMPCALL:
     140        86914 :     case EXEC_CALL_PPC:
     141        86914 :     case EXEC_CALL:
     142        86914 :     case EXEC_ASSIGN_CALL:
     143        86914 :       gfc_free_actual_arglist (p->ext.actual);
     144        86914 :       break;
     145              : 
     146        15341 :     case EXEC_SELECT:
     147        15341 :     case EXEC_SELECT_TYPE:
     148        15341 :     case EXEC_SELECT_RANK:
     149        15341 :       if (p->ext.block.case_list)
     150        10036 :         gfc_free_case_list (p->ext.block.case_list);
     151              :       break;
     152              : 
     153        83483 :     case EXEC_DO:
     154        83483 :       gfc_free_iterator (p->ext.iterator, 1);
     155        83483 :       break;
     156              : 
     157        23902 :     case EXEC_ALLOCATE:
     158        23902 :     case EXEC_DEALLOCATE:
     159        23902 :       gfc_free_alloc_list (p->ext.alloc.list);
     160        23902 :       break;
     161              : 
     162         3955 :     case EXEC_OPEN:
     163         3955 :       gfc_free_open (p->ext.open);
     164         3955 :       break;
     165              : 
     166         3148 :     case EXEC_CLOSE:
     167         3148 :       gfc_free_close (p->ext.close);
     168         3148 :       break;
     169              : 
     170         2851 :     case EXEC_BACKSPACE:
     171         2851 :     case EXEC_ENDFILE:
     172         2851 :     case EXEC_REWIND:
     173         2851 :     case EXEC_FLUSH:
     174         2851 :       gfc_free_filepos (p->ext.filepos);
     175         2851 :       break;
     176              : 
     177          838 :     case EXEC_INQUIRE:
     178          838 :       gfc_free_inquire (p->ext.inquire);
     179          838 :       break;
     180              : 
     181           89 :     case EXEC_WAIT:
     182           89 :       gfc_free_wait (p->ext.wait);
     183           89 :       break;
     184              : 
     185        67052 :     case EXEC_READ:
     186        67052 :     case EXEC_WRITE:
     187        67052 :       gfc_free_dt (p->ext.dt);
     188        67052 :       break;
     189              : 
     190              :     case EXEC_DT_END:
     191              :       /* The ext.dt member is a duplicate pointer and doesn't need to
     192              :          be freed.  */
     193              :       break;
     194              : 
     195              :     case EXEC_DO_CONCURRENT:
     196         1120 :       for (int i = 0; i < LOCALITY_NUM; i++)
     197          896 :         gfc_free_expr_list (p->ext.concur.locality[i]);
     198         4210 :       gcc_fallthrough ();
     199         4210 :     case EXEC_FORALL:
     200         4210 :       gfc_free_forall_iterator (p->ext.concur.forall_iterator);
     201         4210 :       break;
     202              : 
     203          152 :     case EXEC_OACC_DECLARE:
     204          152 :       if (p->ext.oacc_declare)
     205           76 :         gfc_free_oacc_declare_clauses (p->ext.oacc_declare);
     206              :       break;
     207              : 
     208        60109 :     case EXEC_OACC_ATOMIC:
     209        60109 :     case EXEC_OACC_PARALLEL_LOOP:
     210        60109 :     case EXEC_OACC_PARALLEL:
     211        60109 :     case EXEC_OACC_KERNELS_LOOP:
     212        60109 :     case EXEC_OACC_KERNELS:
     213        60109 :     case EXEC_OACC_SERIAL_LOOP:
     214        60109 :     case EXEC_OACC_SERIAL:
     215        60109 :     case EXEC_OACC_DATA:
     216        60109 :     case EXEC_OACC_HOST_DATA:
     217        60109 :     case EXEC_OACC_LOOP:
     218        60109 :     case EXEC_OACC_UPDATE:
     219        60109 :     case EXEC_OACC_WAIT:
     220        60109 :     case EXEC_OACC_CACHE:
     221        60109 :     case EXEC_OACC_ENTER_DATA:
     222        60109 :     case EXEC_OACC_EXIT_DATA:
     223        60109 :     case EXEC_OACC_ROUTINE:
     224        60109 :     case EXEC_OACC_INIT:
     225        60109 :     case EXEC_OACC_SHUTDOWN:
     226        60109 :     case EXEC_OACC_SET:
     227        60109 :     case EXEC_OMP_ALLOCATE:
     228        60109 :     case EXEC_OMP_ALLOCATORS:
     229        60109 :     case EXEC_OMP_ASSUME:
     230        60109 :     case EXEC_OMP_ATOMIC:
     231        60109 :     case EXEC_OMP_CANCEL:
     232        60109 :     case EXEC_OMP_CANCELLATION_POINT:
     233        60109 :     case EXEC_OMP_CRITICAL:
     234        60109 :     case EXEC_OMP_DEPOBJ:
     235        60109 :     case EXEC_OMP_DISPATCH:
     236        60109 :     case EXEC_OMP_DISTRIBUTE:
     237        60109 :     case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
     238        60109 :     case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
     239        60109 :     case EXEC_OMP_DISTRIBUTE_SIMD:
     240        60109 :     case EXEC_OMP_DO:
     241        60109 :     case EXEC_OMP_DO_SIMD:
     242        60109 :     case EXEC_OMP_ERROR:
     243        60109 :     case EXEC_OMP_INTEROP:
     244        60109 :     case EXEC_OMP_LOOP:
     245        60109 :     case EXEC_OMP_END_SINGLE:
     246        60109 :     case EXEC_OMP_MASKED_TASKLOOP:
     247        60109 :     case EXEC_OMP_MASKED_TASKLOOP_SIMD:
     248        60109 :     case EXEC_OMP_MASTER_TASKLOOP:
     249        60109 :     case EXEC_OMP_MASTER_TASKLOOP_SIMD:
     250        60109 :     case EXEC_OMP_ORDERED:
     251        60109 :     case EXEC_OMP_MASKED:
     252        60109 :     case EXEC_OMP_PARALLEL:
     253        60109 :     case EXEC_OMP_PARALLEL_DO:
     254        60109 :     case EXEC_OMP_PARALLEL_DO_SIMD:
     255        60109 :     case EXEC_OMP_PARALLEL_LOOP:
     256        60109 :     case EXEC_OMP_PARALLEL_MASKED:
     257        60109 :     case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
     258        60109 :     case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
     259        60109 :     case EXEC_OMP_PARALLEL_MASTER:
     260        60109 :     case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
     261        60109 :     case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
     262        60109 :     case EXEC_OMP_PARALLEL_SECTIONS:
     263        60109 :     case EXEC_OMP_PARALLEL_WORKSHARE:
     264        60109 :     case EXEC_OMP_SCAN:
     265        60109 :     case EXEC_OMP_SCOPE:
     266        60109 :     case EXEC_OMP_SECTIONS:
     267        60109 :     case EXEC_OMP_SIMD:
     268        60109 :     case EXEC_OMP_SINGLE:
     269        60109 :     case EXEC_OMP_TARGET:
     270        60109 :     case EXEC_OMP_TARGET_DATA:
     271        60109 :     case EXEC_OMP_TARGET_ENTER_DATA:
     272        60109 :     case EXEC_OMP_TARGET_EXIT_DATA:
     273        60109 :     case EXEC_OMP_TARGET_PARALLEL:
     274        60109 :     case EXEC_OMP_TARGET_PARALLEL_DO:
     275        60109 :     case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
     276        60109 :     case EXEC_OMP_TARGET_PARALLEL_LOOP:
     277        60109 :     case EXEC_OMP_TARGET_SIMD:
     278        60109 :     case EXEC_OMP_TARGET_TEAMS:
     279        60109 :     case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
     280        60109 :     case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
     281        60109 :     case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
     282        60109 :     case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
     283        60109 :     case EXEC_OMP_TARGET_TEAMS_LOOP:
     284        60109 :     case EXEC_OMP_TARGET_UPDATE:
     285        60109 :     case EXEC_OMP_TASK:
     286        60109 :     case EXEC_OMP_TASKLOOP:
     287        60109 :     case EXEC_OMP_TASKLOOP_SIMD:
     288        60109 :     case EXEC_OMP_TEAMS:
     289        60109 :     case EXEC_OMP_TEAMS_DISTRIBUTE:
     290        60109 :     case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
     291        60109 :     case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
     292        60109 :     case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
     293        60109 :     case EXEC_OMP_TEAMS_LOOP:
     294        60109 :     case EXEC_OMP_TILE:
     295        60109 :     case EXEC_OMP_UNROLL:
     296        60109 :     case EXEC_OMP_WORKSHARE:
     297        60109 :       gfc_free_omp_clauses (p->ext.omp_clauses);
     298        60109 :       break;
     299              : 
     300            3 :     case EXEC_OMP_END_CRITICAL:
     301            3 :       free (const_cast<char *> (p->ext.omp_name));
     302            3 :       break;
     303              : 
     304           77 :     case EXEC_OMP_FLUSH:
     305           77 :       gfc_free_omp_namelist (p->ext.omp_namelist, OMP_LIST_NONE);
     306           77 :       break;
     307              : 
     308              :     case EXEC_OMP_BARRIER:
     309              :     case EXEC_OMP_MASTER:
     310              :     case EXEC_OMP_END_NOWAIT:
     311              :     case EXEC_OMP_TASKGROUP:
     312              :     case EXEC_OMP_TASKWAIT:
     313              :     case EXEC_OMP_TASKYIELD:
     314              :       break;
     315              : 
     316           93 :     case EXEC_OMP_METADIRECTIVE:
     317           93 :       gfc_free_omp_variants (p->ext.omp_variants);
     318           93 :       break;
     319              : 
     320            0 :     default:
     321            0 :       gfc_internal_error ("gfc_free_statement(): Bad statement");
     322              :     }
     323     30168693 : }
     324              : 
     325              : 
     326              : /* Free a code statement and all other code structures linked to it.  */
     327              : 
     328              : void
     329     58066548 : gfc_free_statements (gfc_code *p)
     330              : {
     331     58066548 :   gfc_code *q;
     332              : 
     333     59656233 :   for (; p; p = q)
     334              :     {
     335      1589685 :       q = p->next;
     336              : 
     337      1589685 :       if (p->block)
     338       364044 :         gfc_free_statements (p->block);
     339      1589685 :       gfc_free_statement (p);
     340      1589685 :       free (p);
     341              :     }
     342     58066548 : }
     343              : 
     344              : 
     345              : /* Free an association list (of an ASSOCIATE statement).  */
     346              : 
     347              : void
     348        22297 : gfc_free_association_list (gfc_association_list* assoc)
     349              : {
     350        22297 :   if (!assoc)
     351              :     return;
     352              : 
     353         7591 :   if (assoc->ar)
     354              :     {
     355           68 :       for (int i = 0; i < assoc->ar->dimen; i++)
     356              :         {
     357           39 :           if (assoc->ar->start[i]
     358           39 :               && assoc->ar->start[i]->ts.type == BT_INTEGER)
     359           39 :             gfc_free_expr (assoc->ar->start[i]);
     360           39 :           if (assoc->ar->end[i]
     361           39 :               && assoc->ar->end[i]->ts.type == BT_INTEGER)
     362           39 :             gfc_free_expr (assoc->ar->end[i]);
     363           39 :           if (assoc->ar->stride[i]
     364            0 :               && assoc->ar->stride[i]->ts.type == BT_INTEGER)
     365            0 :             gfc_free_expr (assoc->ar->stride[i]);
     366              :         }
     367              :     }
     368              : 
     369         7591 :   gfc_free_association_list (assoc->next);
     370         7591 :   free (assoc);
     371              : }
     372              : 
     373              : 
     374              : /* Function to generate IF (ALLOCATED(expr)) DEALLOCATE(expr)  */
     375              : 
     376              : static gfc_code *
     377           40 : get_guarded_dealloc (gfc_namespace *ns, gfc_expr *expr)
     378              : {
     379           40 :   gfc_code *dealloc = gfc_get_code (EXEC_IF);
     380           40 :   dealloc->block = gfc_get_code (EXEC_IF);
     381              : #define ALLOCATED dealloc->block->expr1
     382           40 :   ALLOCATED = gfc_get_expr ();
     383           40 :   ALLOCATED->expr_type = EXPR_FUNCTION;
     384           40 :   ALLOCATED->where = gfc_current_locus;
     385           40 :   gfc_find_sym_tree ("allocated", ns, 1, &ALLOCATED->symtree);
     386           40 :   if (!ALLOCATED->symtree)
     387              :     {
     388            2 :       gfc_get_sym_tree ("allocated", ns, &ALLOCATED->symtree, false);
     389            2 :       gfc_commit_symbol (ALLOCATED->symtree->n.sym);
     390              :     }
     391           40 :   ALLOCATED->symtree->n.sym->attr.flavor = FL_PROCEDURE;
     392           40 :   ALLOCATED->symtree->n.sym->attr.intrinsic = 1;
     393           40 :   ALLOCATED->symtree->n.sym->result = ALLOCATED->symtree->n.sym;
     394           40 :   ALLOCATED->ts.type = BT_LOGICAL;
     395           40 :   ALLOCATED->ts.kind = gfc_default_logical_kind;
     396           40 :   ALLOCATED->value.function.isym
     397           40 :                         = gfc_intrinsic_function_by_id (GFC_ISYM_ALLOCATED);
     398           40 :   ALLOCATED->value.function.actual = gfc_get_actual_arglist ();
     399           40 :   ALLOCATED->value.function.actual->expr = gfc_copy_expr (expr);
     400              : #undef ALLOCATED
     401           40 :   dealloc->block->next = gfc_get_code (EXEC_DEALLOCATE);
     402           40 :   dealloc->block->next->ext.alloc.list = gfc_get_alloc ();
     403           40 :   dealloc->block->next->ext.alloc.list->expr = gfc_copy_expr (expr);
     404           40 :   return dealloc;
     405              : }
     406              : 
     407              : 
     408              : /* F2018(11.1.5.2): Insert code to deallocate coarrays, allocated within a team
     409              :    block. This uses the previous function to effect a guarded deallocation of
     410              :    allocated coarray expressions. These are gathered in gfc_match_allocate and
     411              :    stashed in team_allocs.  */
     412              : 
     413              : void
     414           18 : deallocate_allocated_coarrays (vec<gfc_expr *> *team_allocs)
     415              : {
     416           18 :   gfc_code *dealloc, *last_stmt;
     417           18 :   gfc_ref *ref, *aref = NULL;
     418           18 :   int i;
     419              : 
     420           94 :   for (gfc_expr *e : *team_allocs)
     421              :     {
     422           40 :       if (!e)
     423            0 :         continue;
     424              : 
     425              :       /* Get the last array_ref right.  */
     426           94 :       for (ref = e->ref; ref; ref = ref->next)
     427           54 :         if (ref->type == REF_ARRAY)
     428           40 :           aref = ref;
     429              : 
     430           40 :       if (aref->u.ar.as->rank)
     431              :         {
     432           10 :           aref->u.ar.type = AR_FULL;
     433           10 :           aref->u.ar.dimen = aref->u.ar.as->rank;
     434           20 :           for (i = 0; i < aref->u.ar.dimen; i++)
     435              :             {
     436           10 :               aref->u.ar.dimen_type[i] = DIMEN_RANGE;
     437              : 
     438           10 :               if (aref->u.ar.start[i]) gfc_free_expr (aref->u.ar.start[i]);
     439           10 :               if (aref->u.ar.end[i]) gfc_free_expr (aref->u.ar.end[i]);
     440           10 :               if (aref->u.ar.stride[i]) gfc_free_expr (aref->u.ar.stride[i]);
     441           10 :               aref->u.ar.start[i] = aref->u.ar.end[i] = aref->u.ar.stride[i] = NULL;
     442              :             }
     443              :         }
     444              : 
     445           40 :       for (i = aref->u.ar.as->rank;
     446           80 :            i < aref->u.ar.as->rank + aref->u.ar.as->corank; i++)
     447           40 :          aref->u.ar.dimen_type[i] = DIMEN_THIS_IMAGE;
     448              : 
     449              :       /* Insert the deallocation code before the END TEAM statement.  */
     450           40 :       last_stmt = gfc_current_ns->code;
     451          148 :       while (last_stmt)
     452              :         {
     453          148 :           last_stmt = last_stmt->next;
     454          148 :           if (last_stmt->next->op == EXEC_END_TEAM || !last_stmt->next)
     455              :             {
     456           40 :               dealloc = get_guarded_dealloc (gfc_current_ns, e);
     457           40 :               if (dealloc)
     458              :                 {
     459           40 :                   dealloc->next = last_stmt->next;
     460           40 :                   last_stmt->next = dealloc;
     461           40 :                   break;
     462              :                 }
     463              :             }
     464              :         }
     465           40 :       gfc_free_expr (e);
     466           40 :       e = NULL;
     467              :     }
     468           18 : }