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