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     31684490 : gfc_clear_new_st (void)
      38              : {
      39     31684490 :   memset (&new_st, '\0', sizeof (new_st));
      40     31684490 :   new_st.op = EXEC_NOP;
      41     31684490 : }
      42              : 
      43              : 
      44              : /* Get a gfc_code structure, initialized with the current locus
      45              :    and a statement code 'op'.  */
      46              : 
      47              : gfc_code *
      48       511358 : gfc_get_code (gfc_exec_op op)
      49              : {
      50       511358 :   gfc_code *c;
      51              : 
      52       511358 :   c = XCNEW (gfc_code);
      53       511358 :   c->op = op;
      54       511358 :   c->loc = gfc_current_locus;
      55       511358 :   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        82767 : gfc_append_code (gfc_code *tail, gfc_code *new_code)
      64              : {
      65        82767 :   if (tail != NULL)
      66              :     {
      67        67861 :       while (tail->next != NULL)
      68              :         tail = tail->next;
      69              : 
      70        51109 :       tail->next = new_code;
      71              :     }
      72              : 
      73        83278 :   while (new_code->next != NULL)
      74              :     new_code = new_code->next;
      75              : 
      76        82767 :   return new_code;
      77              : }
      78              : 
      79              : 
      80              : /* Free a single code structure, but not the actual structure itself.  */
      81              : 
      82              : void
      83     30735010 : gfc_free_statement (gfc_code *p)
      84              : {
      85     30735010 :   if (p->expr1)
      86      1249582 :     gfc_free_expr (p->expr1);
      87     30735010 :   if (p->expr2)
      88       347920 :     gfc_free_expr (p->expr2);
      89     30735010 :   if (p->expr3)
      90         4236 :     gfc_free_expr (p->expr3);
      91     30735010 :   if (p->expr4)
      92           40 :     gfc_free_expr (p->expr4);
      93              : 
      94     30735010 :   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        15224 :     case EXEC_BLOCK:
     135        15224 :       gfc_free_namespace (p->ext.block.ns);
     136        15224 :       gfc_free_association_list (p->ext.block.assoc);
     137        15224 :       break;
     138              : 
     139        88199 :     case EXEC_COMPCALL:
     140        88199 :     case EXEC_CALL_PPC:
     141        88199 :     case EXEC_CALL:
     142        88199 :     case EXEC_ASSIGN_CALL:
     143        88199 :       gfc_free_actual_arglist (p->ext.actual);
     144        88199 :       break;
     145              : 
     146        15847 :     case EXEC_SELECT:
     147        15847 :     case EXEC_SELECT_TYPE:
     148        15847 :     case EXEC_SELECT_RANK:
     149        15847 :       if (p->ext.block.case_list)
     150        10357 :         gfc_free_case_list (p->ext.block.case_list);
     151              :       break;
     152              : 
     153        85078 :     case EXEC_DO:
     154        85078 :       gfc_free_iterator (p->ext.iterator, 1);
     155        85078 :       break;
     156              : 
     157        24542 :     case EXEC_ALLOCATE:
     158        24542 :     case EXEC_DEALLOCATE:
     159        24542 :       gfc_free_alloc_list (p->ext.alloc.list);
     160        24542 :       break;
     161              : 
     162         3967 :     case EXEC_OPEN:
     163         3967 :       gfc_free_open (p->ext.open);
     164         3967 :       break;
     165              : 
     166         3160 :     case EXEC_CLOSE:
     167         3160 :       gfc_free_close (p->ext.close);
     168         3160 :       break;
     169              : 
     170         2863 :     case EXEC_BACKSPACE:
     171         2863 :     case EXEC_ENDFILE:
     172         2863 :     case EXEC_REWIND:
     173         2863 :     case EXEC_FLUSH:
     174         2863 :       gfc_free_filepos (p->ext.filepos);
     175         2863 :       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        67366 :     case EXEC_READ:
     186        67366 :     case EXEC_WRITE:
     187        67366 :       gfc_free_dt (p->ext.dt);
     188        67366 :       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         1760 :       for (int i = 0; i < LOCALITY_NUM; i++)
     197         1408 :         gfc_free_expr_list (p->ext.concur.locality[i]);
     198         4338 :       gcc_fallthrough ();
     199         4338 :     case EXEC_FORALL:
     200         4338 :       gfc_free_forall_iterator (p->ext.concur.forall_iterator);
     201         4338 :       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        60280 :     case EXEC_OACC_ATOMIC:
     209        60280 :     case EXEC_OACC_PARALLEL_LOOP:
     210        60280 :     case EXEC_OACC_PARALLEL:
     211        60280 :     case EXEC_OACC_KERNELS_LOOP:
     212        60280 :     case EXEC_OACC_KERNELS:
     213        60280 :     case EXEC_OACC_SERIAL_LOOP:
     214        60280 :     case EXEC_OACC_SERIAL:
     215        60280 :     case EXEC_OACC_DATA:
     216        60280 :     case EXEC_OACC_HOST_DATA:
     217        60280 :     case EXEC_OACC_LOOP:
     218        60280 :     case EXEC_OACC_UPDATE:
     219        60280 :     case EXEC_OACC_WAIT:
     220        60280 :     case EXEC_OACC_CACHE:
     221        60280 :     case EXEC_OACC_ENTER_DATA:
     222        60280 :     case EXEC_OACC_EXIT_DATA:
     223        60280 :     case EXEC_OACC_ROUTINE:
     224        60280 :     case EXEC_OACC_INIT:
     225        60280 :     case EXEC_OACC_SHUTDOWN:
     226        60280 :     case EXEC_OACC_SET:
     227        60280 :     case EXEC_OMP_ALLOCATE:
     228        60280 :     case EXEC_OMP_ALLOCATORS:
     229        60280 :     case EXEC_OMP_ASSUME:
     230        60280 :     case EXEC_OMP_ATOMIC:
     231        60280 :     case EXEC_OMP_CANCEL:
     232        60280 :     case EXEC_OMP_CANCELLATION_POINT:
     233        60280 :     case EXEC_OMP_CRITICAL:
     234        60280 :     case EXEC_OMP_DEPOBJ:
     235        60280 :     case EXEC_OMP_DISPATCH:
     236        60280 :     case EXEC_OMP_DISTRIBUTE:
     237        60280 :     case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
     238        60280 :     case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
     239        60280 :     case EXEC_OMP_DISTRIBUTE_SIMD:
     240        60280 :     case EXEC_OMP_DO:
     241        60280 :     case EXEC_OMP_DO_SIMD:
     242        60280 :     case EXEC_OMP_ERROR:
     243        60280 :     case EXEC_OMP_INTEROP:
     244        60280 :     case EXEC_OMP_LOOP:
     245        60280 :     case EXEC_OMP_END_SINGLE:
     246        60280 :     case EXEC_OMP_MASKED_TASKLOOP:
     247        60280 :     case EXEC_OMP_MASKED_TASKLOOP_SIMD:
     248        60280 :     case EXEC_OMP_MASTER_TASKLOOP:
     249        60280 :     case EXEC_OMP_MASTER_TASKLOOP_SIMD:
     250        60280 :     case EXEC_OMP_ORDERED:
     251        60280 :     case EXEC_OMP_MASKED:
     252        60280 :     case EXEC_OMP_PARALLEL:
     253        60280 :     case EXEC_OMP_PARALLEL_DO:
     254        60280 :     case EXEC_OMP_PARALLEL_DO_SIMD:
     255        60280 :     case EXEC_OMP_PARALLEL_LOOP:
     256        60280 :     case EXEC_OMP_PARALLEL_MASKED:
     257        60280 :     case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
     258        60280 :     case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
     259        60280 :     case EXEC_OMP_PARALLEL_MASTER:
     260        60280 :     case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
     261        60280 :     case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
     262        60280 :     case EXEC_OMP_PARALLEL_SECTIONS:
     263        60280 :     case EXEC_OMP_PARALLEL_WORKSHARE:
     264        60280 :     case EXEC_OMP_SCAN:
     265        60280 :     case EXEC_OMP_SCOPE:
     266        60280 :     case EXEC_OMP_SECTIONS:
     267        60280 :     case EXEC_OMP_SIMD:
     268        60280 :     case EXEC_OMP_SINGLE:
     269        60280 :     case EXEC_OMP_TARGET:
     270        60280 :     case EXEC_OMP_TARGET_DATA:
     271        60280 :     case EXEC_OMP_TARGET_ENTER_DATA:
     272        60280 :     case EXEC_OMP_TARGET_EXIT_DATA:
     273        60280 :     case EXEC_OMP_TARGET_PARALLEL:
     274        60280 :     case EXEC_OMP_TARGET_PARALLEL_DO:
     275        60280 :     case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
     276        60280 :     case EXEC_OMP_TARGET_PARALLEL_LOOP:
     277        60280 :     case EXEC_OMP_TARGET_SIMD:
     278        60280 :     case EXEC_OMP_TARGET_TEAMS:
     279        60280 :     case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
     280        60280 :     case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
     281        60280 :     case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
     282        60280 :     case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
     283        60280 :     case EXEC_OMP_TARGET_TEAMS_LOOP:
     284        60280 :     case EXEC_OMP_TARGET_UPDATE:
     285        60280 :     case EXEC_OMP_TASK:
     286        60280 :     case EXEC_OMP_TASKLOOP:
     287        60280 :     case EXEC_OMP_TASKLOOP_SIMD:
     288        60280 :     case EXEC_OMP_TEAMS:
     289        60280 :     case EXEC_OMP_TEAMS_DISTRIBUTE:
     290        60280 :     case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
     291        60280 :     case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
     292        60280 :     case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
     293        60280 :     case EXEC_OMP_TEAMS_LOOP:
     294        60280 :     case EXEC_OMP_TILE:
     295        60280 :     case EXEC_OMP_UNROLL:
     296        60280 :     case EXEC_OMP_WORKSHARE:
     297        60280 :       gfc_free_omp_clauses (p->ext.omp_clauses);
     298        60280 :       break;
     299              : 
     300            3 :     case EXEC_OMP_END_CRITICAL:
     301            3 :       free (const_cast<char *> (p->ext.omp_name));
     302            3 :       break;
     303              : 
     304           86 :     case EXEC_OMP_FLUSH:
     305           86 :       gfc_free_omp_namelist (p->ext.omp_namelist, OMP_LIST_NONE);
     306           86 :       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           97 :     case EXEC_OMP_METADIRECTIVE:
     317           97 :       gfc_free_omp_variants (p->ext.omp_variants);
     318           97 :       break;
     319              : 
     320            0 :     default:
     321            0 :       gfc_internal_error ("gfc_free_statement(): Bad statement");
     322              :     }
     323     30735010 : }
     324              : 
     325              : 
     326              : /* Free a code statement and all other code structures linked to it.  */
     327              : 
     328              : void
     329     59166178 : gfc_free_statements (gfc_code *p)
     330              : {
     331     59166178 :   gfc_code *q;
     332              : 
     333     60778616 :   for (; p; p = q)
     334              :     {
     335      1612438 :       q = p->next;
     336              : 
     337      1612438 :       if (p->block)
     338       369152 :         gfc_free_statements (p->block);
     339      1612438 :       gfc_free_statement (p);
     340      1612438 :       free (p);
     341              :     }
     342     59166178 : }
     343              : 
     344              : 
     345              : /* Free an association list (of an ASSOCIATE statement).  */
     346              : 
     347              : void
     348        23238 : gfc_free_association_list (gfc_association_list* assoc)
     349              : {
     350        23238 :   if (!assoc)
     351              :     return;
     352              : 
     353         7990 :   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         7990 :   gfc_free_association_list (assoc->next);
     370         7990 :   free (assoc);
     371              : }
     372              : 
     373              : 
     374              : /* Function to generate IF (ALLOCATED(expr)) DEALLOCATE(expr)  */
     375              : 
     376              : static gfc_code *
     377           54 : get_guarded_dealloc (gfc_namespace *ns, gfc_expr *expr)
     378              : {
     379           54 :   gfc_code *dealloc = gfc_get_code (EXEC_IF);
     380           54 :   dealloc->block = gfc_get_code (EXEC_IF);
     381              : #define ALLOCATED dealloc->block->expr1
     382           54 :   ALLOCATED = gfc_get_expr ();
     383           54 :   ALLOCATED->expr_type = EXPR_FUNCTION;
     384           54 :   ALLOCATED->where = gfc_current_locus;
     385           54 :   gfc_find_sym_tree ("allocated", ns, 1, &ALLOCATED->symtree);
     386           54 :   if (!ALLOCATED->symtree)
     387              :     {
     388            8 :       gfc_get_sym_tree ("allocated", ns, &ALLOCATED->symtree, false);
     389            8 :       gfc_commit_symbol (ALLOCATED->symtree->n.sym);
     390              :     }
     391           54 :   ALLOCATED->symtree->n.sym->attr.flavor = FL_PROCEDURE;
     392           54 :   ALLOCATED->symtree->n.sym->attr.intrinsic = 1;
     393           54 :   ALLOCATED->symtree->n.sym->result = ALLOCATED->symtree->n.sym;
     394           54 :   ALLOCATED->ts.type = BT_LOGICAL;
     395           54 :   ALLOCATED->ts.kind = gfc_default_logical_kind;
     396           54 :   ALLOCATED->value.function.isym
     397           54 :                         = gfc_intrinsic_function_by_id (GFC_ISYM_ALLOCATED);
     398           54 :   ALLOCATED->value.function.actual = gfc_get_actual_arglist ();
     399           54 :   ALLOCATED->value.function.actual->expr = gfc_copy_expr (expr);
     400              : #undef ALLOCATED
     401           54 :   dealloc->block->next = gfc_get_code (EXEC_DEALLOCATE);
     402           54 :   dealloc->block->next->ext.alloc.list = gfc_get_alloc ();
     403           54 :   dealloc->block->next->ext.alloc.list->expr = gfc_copy_expr (expr);
     404           54 :   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           28 : deallocate_allocated_coarrays (vec<gfc_expr *> *team_allocs)
     415              : {
     416           28 :   gfc_code *dealloc, **prev;
     417           28 :   gfc_ref *ref, *aref = NULL;
     418           28 :   int i;
     419              : 
     420          138 :   for (gfc_expr *e : *team_allocs)
     421              :     {
     422           54 :       if (!e)
     423            0 :         continue;
     424              : 
     425              :       /* Get the last array_ref right.  */
     426          122 :       for (ref = e->ref; ref; ref = ref->next)
     427           68 :         if (ref->type == REF_ARRAY)
     428           54 :           aref = ref;
     429              : 
     430           54 :       if (aref->u.ar.as->rank)
     431              :         {
     432           16 :           aref->u.ar.type = AR_FULL;
     433           16 :           aref->u.ar.dimen = aref->u.ar.as->rank;
     434           32 :           for (i = 0; i < aref->u.ar.dimen; i++)
     435              :             {
     436           16 :               aref->u.ar.dimen_type[i] = DIMEN_RANGE;
     437              : 
     438           16 :               if (aref->u.ar.start[i]) gfc_free_expr (aref->u.ar.start[i]);
     439           16 :               if (aref->u.ar.end[i]) gfc_free_expr (aref->u.ar.end[i]);
     440           16 :               if (aref->u.ar.stride[i]) gfc_free_expr (aref->u.ar.stride[i]);
     441           16 :               aref->u.ar.start[i] = aref->u.ar.end[i] = aref->u.ar.stride[i] = NULL;
     442              :             }
     443              :         }
     444              : 
     445           54 :       for (i = aref->u.ar.as->rank;
     446          108 :            i < aref->u.ar.as->rank + aref->u.ar.as->corank; i++)
     447           54 :          aref->u.ar.dimen_type[i] = DIMEN_THIS_IMAGE;
     448              : 
     449              :       /* Insert the deallocation code before the END TEAM statement.  */
     450          290 :       for (prev = &gfc_current_ns->code; *prev; prev = &(*prev)->next)
     451          290 :         if ((*prev)->op == EXEC_END_TEAM)
     452              :           break;
     453           54 :       dealloc = get_guarded_dealloc (gfc_current_ns, e);
     454           54 :       dealloc->next = *prev;
     455           54 :       *prev = dealloc;
     456           54 :       gfc_free_expr (e);
     457           54 :       e = NULL;
     458              :     }
     459           28 : }