1 /*
2 * Copyright (c) 1995-2018, NVIDIA CORPORATION. All rights reserved.
3 *
4 * Licensed under the Apache License, Version 2.0 (the "License");
5 * you may not use this file except in compliance with the License.
6 * You may obtain a copy of the License at
7 *
8 * http://www.apache.org/licenses/LICENSE-2.0
9 *
10 * Unless required by applicable law or agreed to in writing, software
11 * distributed under the License is distributed on an "AS IS" BASIS,
12 * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
13 * See the License for the specific language governing permissions and
14 * limitations under the License.
15 *
16 */
17
18 /* clang-format off */
19
20 /** \file
21 * \brief FIXME
22 */
23
24 #include <stdlib.h>
25 #include <string.h>
26 #include <ctype.h>
27 #include <memory.h>
28 #include <sys/time.h>
29
30 #include "global.h"
31 /* FIXME: HACK
32 * include/pgstdio.h:#define __fort_getenv(name) __io_getenv(name)
33 * include/pgstdinit.h:#define __io_getenv(name) getenv(name)
34 * changes the name of __fort_getenv defined in this file.
35 */
36 #undef __fort_getenv
37
38 #include "stdioInterf.h"
39 #include "fioMacros.h"
40
41 #include "open_close.h"
42 #include "format.h"
43
44
45 #if defined(TARGET_OSX)
46 #include <crt_externs.h>
47 #elif defined(__win32)
48 /* OPENTOOLS14 has changed the name. wrap _environ for all of windowws */
49 char **__io_environ();
50 #else
51 WIN_MSVCRT_IMP char **environ;
52 #endif
53 #include "fort_vars.h"
54 char *__fort_getgbuf(long);
55 extern void __fort_init_consts();
56
57 long __fort_strtol(char *str, char **ptr, int base); /* atol.c */
58 void __fort_print_version(); /* version.c */
59
60 extern int __io_get_argc();
61 extern char **__io_get_argv();
62 extern void __io_set_argc(int);
63
64 static char **arg; /* first arg */
65 static char **env; /* internal version of environ */
66
67 #define MAXOPTS 128
68 static char *opts[MAXOPTS];
69 static char *optarea; /* malloc'ed area for opts */
70
71 static struct {
72 char consts;
73 char atexit;
74 } inited;
75
76 /* common blocks containing values for inlined number_of_processors()
77 and my_processor() functions */
78
79 #if defined(WIN64) || defined(WIN32)
80 WIN_IMP __INT_T ENTCOMN(NP, np)[];
81 WIN_IMP __INT_T ENTCOMN(ME, me)[];
82 #elif defined(C90) || defined(WINNT)
83 __INT_T ENTCOMN(NP, np)[1];
84 __INT_T ENTCOMN(ME, me)[1];
85 #else
86 extern __INT_T ENTCOMN(NP, np)[];
87 extern __INT_T ENTCOMN(ME, me)[];
88 #endif
89
90 #if defined(WIN32) || defined(WIN64)
91 #define write _write
92 #endif
93
94 /* Return logical cpu number */
95
96 int
__fort_myprocnum()97 __fort_myprocnum()
98 {
99 return (__fort_lcpu); /* non-shared-memory version */
100 }
101
102 /* Return total number of processors */
103
104 int
__fort_ncpus()105 __fort_ncpus()
106 {
107 return __fort_tcpus;
108 }
109
110 #if defined(WINNT)
111 #if !defined(WIN64) && !defined(WIN32)
112 __INT_T *CORMEM;
113
114 /* special argument pointer access routines */
115
116 char *
__get_fort_01_addr(void)117 __get_fort_01_addr(void)
118 {
119 return (char *)ENTCOMN(0, 0);
120 }
121
122 char *
__get_fort_02_addr(void)123 __get_fort_02_addr(void)
124 {
125 return (char *)ENTCOMN(0, 0) + 4;
126 }
127
128 char *
__get_fort_03_addr(void)129 __get_fort_03_addr(void)
130 {
131 return (char *)ENTCOMN(0, 0) + 8;
132 }
133
134 char *
__get_fort_04_addr(void)135 __get_fort_04_addr(void)
136 {
137 return (char *)ENTCOMN(0, 0) + 12;
138 }
139
140 char *
__get_fort_0c_addr(void)141 __get_fort_0c_addr(void)
142 {
143 return (char *)ENTCOMN(0C, 0c);
144 }
145
146 void
__set_fort_0l_addr(int * addr)147 __set_fort_0l_addr(int *addr)
148 {
149 }
150
151 void
__CORMEM_SCAN(void)152 __CORMEM_SCAN(void)
153 {
154 }
155
156 char *
__get_fort_local_mode_addr(void)157 __get_fort_local_mode_addr(void)
158 {
159 return (char *)ENTCOMN(LOCAL_MODE, local_mode);
160 }
161
162 char *
__get_fort_me_addr(void)163 __get_fort_me_addr(void)
164 {
165 return (char *)ENTCOMN(ME, me);
166 }
167
168 char *
__get_fort_np_addr(void)169 __get_fort_np_addr(void)
170 {
171 return (char *)ENTCOMN(NP, np);
172 }
173 #endif /* !WIN64 || !WIN32 */
174
175 /* access routines for data shared between windows dlls */
176
177 /* logical CPU id of the i/o processor */
178
179 int
__get_fort_debug(void)180 __get_fort_debug(void)
181 {
182 return __fort_debug;
183 }
184
185 void
__set_fort_debug(int debug)186 __set_fort_debug(int debug)
187 {
188 __fort_debug = debug;
189 }
190
191 int
__get_fort_debugn(void)192 __get_fort_debugn(void)
193 {
194 return __fort_debugn;
195 }
196
197 void
__set_fort_debugn(int debugn)198 __set_fort_debugn(int debugn)
199 {
200 __fort_debugn = debugn;
201 }
202
203 long
__get_fort_heapz(void)204 __get_fort_heapz(void)
205 {
206 return __fort_heapz;
207 }
208
209 void
__set_fort_heapz(long heapz)210 __set_fort_heapz(long heapz)
211 {
212 __fort_heapz = heapz;
213 }
214
215 int
__get_fort_ioproc(void)216 __get_fort_ioproc(void)
217 {
218 return __fort_ioproc;
219 }
220
221 void
__set_fort_ioproc(int ioproc)222 __set_fort_ioproc(int ioproc)
223 {
224 __fort_ioproc = ioproc;
225 }
226
227 /* logical cpu number */
228
229 int
__get_fort_lcpu(void)230 __get_fort_lcpu(void)
231 {
232 return __fort_lcpu;
233 }
234
235 void
__set_fort_lcpu(int lcpu)236 __set_fort_lcpu(int lcpu)
237 {
238 __fort_lcpu = lcpu;
239 }
240
241 int *
__get_fort_lcpu_addr(void)242 __get_fort_lcpu_addr(void)
243 {
244 return &__fort_lcpu;
245 }
246
247 /* pario */
248
249 int
__get_fort_pario(void)250 __get_fort_pario(void)
251 {
252 return __fort_pario;
253 }
254
255 void
__set_fort_pario(int pario)256 __set_fort_pario(int pario)
257 {
258 __fort_pario = pario;
259 }
260
261 /* runtime statistics */
262
263 int
__get_fort_quiet(void)264 __get_fort_quiet(void)
265 {
266 return __fort_quiet;
267 }
268
269 void
__set_fort_quiet(int quiet)270 __set_fort_quiet(int quiet)
271 {
272 __fort_quiet = quiet;
273 }
274
275 /* total number of processors */
276
277 int
__get_fort_tcpus(void)278 __get_fort_tcpus(void)
279 {
280 return __fort_tcpus;
281 }
282
283 int *
__get_fort_tcpus_addr(void)284 __get_fort_tcpus_addr(void)
285 {
286 return &__fort_tcpus;
287 }
288
289 void
__set_fort_tcpus(int tcpus)290 __set_fort_tcpus(int tcpus)
291 {
292 __fort_tcpus = tcpus;
293 }
294
295 /* tid for each processor */
296
297 int *
__get_fort_tids(void)298 __get_fort_tids(void)
299 {
300 return __fort_tids;
301 }
302
303 void
__set_fort_tids(int * tids)304 __set_fort_tids(int *tids)
305 {
306 __fort_tids = tids;
307 }
308
309 int
__get_fort_tids_elem(int idx)310 __get_fort_tids_elem(int idx)
311 {
312 return __fort_tids[idx];
313 }
314
315 void
__set_fort_tids_elem(int idx,int val)316 __set_fort_tids_elem(int idx, int val)
317 {
318 __fort_tids[idx] = val;
319 }
320
321 #endif /* WINNT */
322
323 int
__fort_getioproc()324 __fort_getioproc()
325 {
326 return (__fort_ioproc);
327 }
328
329 /* Return true if this is the i/o processor. */
330
331 int
__fort_is_ioproc()332 __fort_is_ioproc()
333 {
334 return (__fort_lcpu == __fort_ioproc);
335 }
336
337 /* abort with message */
338
339 void
__fort_abort(char * s)340 __fort_abort(char *s)
341 {
342 char buf[256];
343
344 if (s != NULL) {
345 sprintf(buf, "%d: %s\n", __fort_lcpu, s);
346 write(2, buf, strlen(buf));
347 }
348 __fort_abortx();
349 }
350
351 /* abort with perror message */
352
353 void
__fort_abortp(char * s)354 __fort_abortp(char *s)
355 {
356 fprintf(__io_stderr(), "%d: ", __fort_lcpu);
357 perror(s);
358 __fort_abort(NULL);
359 }
360
361 /* exit */
362
363 void
__fort_exit(int s)364 __fort_exit(int s)
365 {
366 exit(s);
367 }
368
369 /* init command line processing */
370
371 static char *dumarg = NULL;
372
373 static void
__fort_initarg()374 __fort_initarg()
375 {
376 char *p, *q;
377 int i;
378 char **v;
379 int c;
380
381 if (arg != (char **)0) {
382 return;
383 }
384 v = __io_get_argv();
385 if (v == (char **)0) {
386 arg = &(dumarg); /* no argv -> no args */
387 } else {
388 arg = v;
389 }
390 #if defined(TARGET_OSX)
391 env = *_NSGetEnviron();
392 #elif defined(__WIN32)
393 env = __io_environ();
394 #else
395 env = environ;
396 #endif
397 }
398
399 /** \brief getenv (uses env, not environ) */
400 char *
__fort_getenv(const char * nm)401 __fort_getenv(const char *nm)
402 {
403 char **e;
404 int n;
405
406 n = strlen(nm);
407 #if defined(TARGET_OSX)
408 e = env;
409 #else
410 e = environ;
411 #endif
412 while (*e != NULL) {
413 if ((strncmp(*e, nm, n) == 0) && ((*((*e) + n)) == '=')) {
414 return ((*e) + n + 1);
415 }
416 e++;
417 }
418 return (NULL);
419 }
420
421 /* init option processing */
422
423 static void
__fort_initopt()424 __fort_initopt()
425 {
426 char *p, *q;
427 int i;
428
429 p = __fort_getenv("PGDIST_OPTS");
430 if (p == NULL) {
431 return;
432 }
433 if (optarea != NULL) {
434 __fort_free(optarea);
435 }
436 optarea = __fort_malloc(strlen(p) + 1);
437 q = optarea;
438 strcpy(q, p);
439 i = 0;
440 while (1) {
441 while (*q == ' ') {
442 q++;
443 }
444 if (*q == '\0') {
445 break;
446 }
447 if (i >= (MAXOPTS - 1)) {
448 __fort_abort("PGDIST_OPTS: too many options");
449 }
450 opts[i++] = q;
451 while ((*q != ' ') && (*q != '\0')) {
452 q++;
453 }
454 if (*q == ' ') {
455 *q++ = '\0';
456 }
457 }
458 opts[i] = NULL;
459 }
460
461 /* get option (command line -xx and environment */
462
__fort_getopt(opt)463 char *__fort_getopt(opt) char *opt;
464 {
465 char env[64];
466 char *p, *q;
467 int n;
468
469 if (arg == NULL)
470 return NULL;
471 p = NULL;
472 for (n = 0; arg[n] != NULL; n++) {
473 if (strcmp(arg[n], opt) == 0) {
474 p = arg[n + 1];
475 if (p == NULL) {
476 p = "";
477 }
478 break;
479 }
480 }
481 if (p == NULL) {
482 strcpy(env, "PGHPF_");
483 p = env + 6;
484 q = opt + 1;
485 while (*q != '\0') {
486 *p++ = toupper(*q++);
487 }
488 *p++ = '\0';
489 p = __fort_getenv(env);
490 }
491 if (p == NULL) {
492 for (n = 0; opts[n] != NULL; n++) {
493 if (strcmp(opts[n], opt) == 0) {
494 p = opts[n + 1];
495 if (p == NULL) {
496 p = "";
497 }
498 break;
499 }
500 }
501 }
502 if ((strcmp(opt, "-g") == 0) && (p != NULL) && (*p == '-')) {
503 p = "";
504 }
505 return (p);
506 }
507
508 /* abort because of problem with command/environment option */
509
510 static void
getopt_abort(char * problem,char * opt)511 getopt_abort(char *problem, char *opt)
512 {
513 char buf[128], *p, *q;
514
515 p = buf;
516 q = opt;
517 while (*++q != '\0')
518 *p++ = toupper(*q);
519 *p++ = '\0';
520 sprintf(p, "%s for %s/%s command/environment option\n", problem, opt,
521 buf);
522 __fort_abort(p);
523 }
524
525 /* get numeric option */
526
527 long
__fort_getoptn(char * opt,long def)528 __fort_getoptn(char *opt, long def)
529 {
530 char *p, *q;
531 long n;
532
533 p = __fort_getopt(opt);
534 if (p == NULL)
535 return def; /* default if option is absent */
536 n = __fort_strtol(p, &q, 0);
537 if (q == p || *q != '\0')
538 getopt_abort("missing or invalid numeric value", opt);
539 return n;
540 }
541
542 /* get yes/no option */
543
544 int
__fort_getoptb(char * opt,int def)545 __fort_getoptb(char *opt, int def)
546 {
547 char *p;
548 int n;
549
550 p = __fort_getopt(opt);
551 if (p == NULL)
552 return def; /* default if option is absent */
553 if (*p == 'y' || *p == 'Y')
554 n = 1;
555 else if (*p == 'n' || *p == 'N')
556 n = 0;
557 else
558 getopt_abort("missing or invalid yes/no value", opt);
559 return n;
560 }
561
562 /* init stats (set options) */
563
564 static void
__fort_istat()565 __fort_istat()
566 {
567 char *p;
568
569 p = __fort_getopt("-stat");
570 if (p == NULL) {
571 return;
572 }
573 if ((*p == '\0') || (*p == '-')) {
574 p = "all";
575 }
576 while (1) {
577 if (strncmp(p, "cpus", 4) == 0) {
578 __fort_quiet |= Q_CPUS;
579 } else if (strncmp(p, "mems", 4) == 0) {
580 __fort_quiet |= Q_MEMS;
581 } else if (strncmp(p, "msgs", 4) == 0) {
582 __fort_quiet |= Q_MSGS;
583 } else if (strncmp(p, "alls", 4) == 0) {
584 __fort_quiet |= (Q_CPUS | Q_MEMS | Q_MSGS);
585 } else if (strncmp(p, "cpu", 3) == 0) {
586 __fort_quiet |= Q_CPU;
587 } else if (strncmp(p, "mem", 3) == 0) {
588 __fort_quiet |= Q_MEM;
589 } else if (strncmp(p, "msg", 3) == 0) {
590 __fort_quiet |= Q_MSG;
591 } else if (strncmp(p, "all", 3) == 0) {
592 __fort_quiet |= (Q_CPU | Q_MEM | Q_MSG);
593 } else if (strncmp(p, "prof", 4) == 0) {
594 __fort_quiet |= Q_PROF;
595 } else if (strncmp(p, "trace", 5) == 0) {
596 __fort_quiet |= Q_TRAC;
597 } else if ((*p >= '0') && (*p <= '9')) {
598 __fort_quiet |= (int)strtol(p, (char **)0, 0);
599 } else {
600 getopt_abort("invalid format", "-stat");
601 }
602 p = strchr(p, ',');
603 if (p == NULL) {
604 break;
605 }
606 p++;
607 }
608 }
609
610 /* process (what used to be) generic command/environment options */
611
612 static void
__fort_initcom()613 __fort_initcom()
614 {
615 char *p, *q;
616 int n;
617
618 /* -test [<n>] */
619
620 p = __fort_getopt("-test");
621 if (p) {
622 __fort_test = (int)__fort_strtol(p, &q, 0);
623 if (q == p)
624 __fort_test = -1;
625 else if (*q != '\0')
626 getopt_abort("invalid numeric value", "-test");
627 }
628
629 /* -np <n> = number of processors */
630
631 p = __fort_getopt("-np");
632 if (p) {
633 n = (int)__fort_strtol(p, &q, 0);
634 if (q == p || *q != '\0' || n < 1)
635 getopt_abort("missing or invalid numeric value", "-np");
636 __fort_tcpus = n;
637 }
638
639 /* -g [<n>|all] = debug */
640
641 p = __fort_getopt("-g");
642 if (p) {
643 __fort_debug = 1;
644 __fort_debugn = (int)__fort_strtol(p, &q, 0);
645 if (q == p)
646 __fort_debugn = -1;
647 else if (*q != '\0' || __fort_debugn < 0 || __fort_debugn >= __fort_tcpus)
648 getopt_abort("invalid numeric value", "-g");
649 }
650
651 /* -stat ... */
652
653 __fort_istat();
654
655 /* -prof av[erage]|no[ne]|al[l] */
656
657 p = __fort_getopt("-prof");
658 if (p) {
659 int k = strlen(p);
660 if (k < 2)
661 k = 2;
662 if (strncmp(p, "average", k) == 0)
663 __fort_quiet |= Q_PROF_AVG;
664 else if (strncmp(p, "none", k) == 0)
665 __fort_quiet |= Q_PROF_NONE;
666 else if (strncmp(p, "all", k) != 0)
667 getopt_abort("invalid value", "-prof");
668 }
669 }
670
671 /* init and process command/environment options */
672
673 void
__fort_procargs()674 __fort_procargs()
675 {
676
677 if (arg != (char **)0) {
678 return;
679 }
680 __fort_initarg(); /* init command line args */
681 __fort_initopt(); /* init opt */
682 __fort_initcom(); /* init common arg/env */
683 }
684
685 /* pass an arg to other processors, passing of a null is permitted */
686
687 static char *
__fort_passarg(int fr,int tol,int toh,char * val)688 __fort_passarg(int fr, int tol, int toh, char *val)
689 {
690 int cpu;
691 int len;
692 char *p;
693
694 if (__fort_lcpu == fr) {
695 len = (val != NULL ? strlen(val) + 1 : 0);
696 for (cpu = tol; cpu < toh; cpu++) {
697 __fort_rsendl(cpu, &len, sizeof(len), 1, __UCHAR, 1);
698 if (len != 0) {
699 __fort_rsendl(cpu, val, len, 1, __UCHAR, 1);
700 }
701 }
702 p = val;
703 } else {
704 __fort_rrecvl(fr, &len, sizeof(len), 1, __UCHAR, 1);
705 if (len == 0) {
706 p = NULL;
707 } else {
708 p = __fort_malloc(len);
709 __fort_rrecvl(fr, p, len, 1, __UCHAR, 1);
710 }
711 }
712 return (p);
713 }
714
715 /* pass arglist */
716
717 void
__fort_passargs(int fr,int tol,int toh)718 __fort_passargs(int fr, int tol, int toh)
719 {
720 char **toe;
721 char **fre;
722 int n;
723 int cpu;
724
725 if (__fort_lcpu == fr) {
726 n = 0;
727 while (env[n] != NULL) {
728 n++;
729 }
730 n++;
731 for (cpu = tol; cpu < toh; cpu++) {
732 __fort_rsendl(cpu, &n, sizeof(n), 1, __UCHAR, 1);
733 }
734 fre = env;
735 while (*fre != NULL) {
736 if ((strlen(*fre) > 6) && (strncmp("PGHPF_", *fre, 6) == 0)) {
737 __fort_passarg(fr, tol, toh, *fre);
738 }
739 fre++;
740 }
741 __fort_passarg(fr, tol, toh, NULL);
742 } else {
743 __fort_rrecvl(fr, &n, sizeof(n), 1, __UCHAR, 1);
744 env = (char **)__fort_malloc(n * sizeof(char *));
745 toe = env;
746 while (1) {
747 *toe = __fort_passarg(fr, tol, toh, NULL);
748 if (*toe == NULL) {
749 break;
750 }
751 toe++;
752 }
753 }
754
755 if (__fort_lcpu == fr) {
756 n = 0;
757 while (arg[n] != NULL) {
758 n++;
759 }
760 n++;
761 for (cpu = tol; cpu < toh; cpu++) {
762 __fort_rsendl(cpu, &n, sizeof(n), 1, __UCHAR, 1);
763 }
764 fre = arg;
765 while (*fre != NULL) {
766 __fort_passarg(fr, tol, toh, *fre);
767 fre++;
768 }
769 __fort_passarg(fr, tol, toh, NULL);
770 } else {
771 __fort_rrecvl(fr, &n, sizeof(n), 1, __UCHAR, 1);
772 arg = (char **)__fort_malloc(n * sizeof(char *));
773 toe = arg;
774 while (1) {
775 *toe = __fort_passarg(fr, tol, toh, NULL);
776 if (*toe == NULL) {
777 break;
778 }
779 toe++;
780 }
781 __fort_initopt(); /* init opt */
782 __fort_initcom(); /* init common arg/env */
783 }
784 }
785
786 /* terminate everything */
787
788 static void
term()789 term()
790 {
791 extern void __f90_allo_term(void);
792 __f90_allo_term();
793 __fortio_cleanup(); /* cleanup i/o */
794 __fort_entry_term(); /* end of profiling/tracing/stats */
795 __fort_endpar(); /* TI-specific termination */
796 }
797
798 /* initialize everything */
799
ENTFTN(INIT,init)800 void ENTFTN(INIT, init)(__INT_T *n)
801 {
802 __fort_setarg(); /* set __argv_save and __argc_save (maybe) */
803 if (!inited.consts) {
804 __fort_init_consts(); /* constants need initialization */
805 inited.consts = 1;
806 }
807 __fort_begpar(*n); /* TI-specific initialization */
808
809 /* smallest power of 2 >= number of processors */
810
811 for (__fort_np2 = 1; __fort_np2 < __fort_tcpus; __fort_np2 <<= 1)
812 ;
813
814 /* -V or -version */
815
816 if (__fort_lcpu == 0 && (__fort_getopt("-V") || __fort_getopt("-version")))
817 __fort_print_version();
818
819 __fort_zmem = __fort_getoptb("-zmem", 0);
820
821 __fort_entry_init(); /* start profiling/tracing/stats */
822
823 if (!inited.atexit) {
824 atexit(term); /* register term */
825 inited.atexit = 1;
826 }
827
828 ENTCOMN(NP, np)[0] = __fort_tcpus; /* for number_of_processors() */
829 ENTCOMN(ME, me)[0] = __fort_lcpu; /* for my_processor() */
830 }
831
832 /* pull in the following code (not really called) */
833
834 void
__fort_pull_them_in()835 __fort_pull_them_in()
836 {
837 __fort_getgbuf(0);
838 __fort_rrecv(0, (char *)0, 0, 0, 0);
839 __fort_rsend(0, (char *)0, 0, 0, 0);
840 __fort_zopen((char *)0);
841 }
842
843 /* -------------------------------------------------------------------- */
844
845 #pragma global opt = 1
846 static void
f90_compiled_arg()847 f90_compiled_arg()
848 {
849 }
850
851 /*
852 * this routine is called from .init. it does limited initialization
853 * for f90 routines called from a non-f90 main routine. argc and
854 * argv may not be set.
855 */
856
857
858 void
859 __attribute__((constructor))
f90_compiled()860 f90_compiled()
861 {
862 #ifndef TARGET_LINUX_ARM
863 static void (*p)(void) = f90_compiled_arg;
864 #endif
865 if (!inited.consts) {
866 __fort_tcpus = 1;
867 __fort_np2 = 1;
868 __fort_init_consts(); /* constants need initialization */
869 inited.consts = 1;
870 }
871 if (!inited.atexit) {
872 atexit(term); /* register term */
873 inited.atexit = 1;
874 }
875 }
876
877