/[ascend]/trunk/base/generic/compiler/bintoken.c
ViewVC logotype

Contents of /trunk/base/generic/compiler/bintoken.c

Parent Directory Parent Directory | Revision Log Revision Log


Revision 101 - (show annotations) (download) (as text)
Sat Dec 10 04:22:07 2005 UTC (15 years, 4 months ago) by jds
File MIME type: text/x-csrc
File size: 29167 byte(s)
A little more progress killing compiler warnings.
1 /* ex: set ts=8 : */
2 /*
3 * bintoken.c
4 * By Benjamin A. Allan
5 * Jan 7, 1998.
6 * Part of ASCEND
7 * Version: $Revision: 1.12 $
8 * Version control file: $RCSfile: bintoken.c,v $
9 * Date last modified: $Date: 1998/06/16 16:38:36 $
10 * Last modified by: $Author: mthomas $
11 *
12 * This file is part of the Ascend Language Interpreter.
13 *
14 * Copyright (C) 1998 Carnegie Mellon University
15 *
16 * The Ascend Language Interpreter is free software; you can
17 * redistribute it and/or modify it under the terms of the GNU
18 * General Public License as published by the Free Software
19 * Foundation; either version 2 of the License, or (at your option)
20 * any later version.
21 *
22 * The Ascend Language Interpreter is distributed in hope that it
23 * will be useful, but WITHOUT ANY WARRANTY; without even the implied
24 * warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
25 * See the GNU General Public License for more details.
26 *
27 * You should have received a copy of the GNU General Public License
28 * along with the program; if not, write to the Free Software
29 * Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139 USA. Check
30 * the file named COPYING.
31 */
32
33 #if 0
34 TIMESTAMP = -DTIMESTAMP="\"by `whoami`@`hostname`\""
35 #endif
36 /*
37 * binary tokens implementation for real relation instances.
38 * much of this goes in bintoken.h.
39 */
40
41 #include "utilities/ascConfig.h"
42 #include "utilities/ascMalloc.h"
43 #include "utilities/ascPrint.h"
44 #include "utilities/ascSignal.h"
45 #include "utilities/ascPanic.h"
46 #include "utilities/ascDynaLoad.h"
47 #include "general/list.h"
48 #include "general/dstring.h"
49 #include "general/pretty.h"
50 #include "compiler/compiler.h" /* for symchar */
51 #include "compiler/fractions.h"
52 #include "compiler/dimen.h"
53 #include "compiler/functype.h"
54 #include "compiler/types.h"
55 #include "compiler/stattypes.h"
56 #include "compiler/statio.h"
57 #include "compiler/instance_enum.h"
58 #include "compiler/instquery.h"
59 #include "compiler/instance_io.h"
60 #include "compiler/relation_type.h"
61 #include "compiler/relation_io.h"
62 #include "compiler/find.h"
63 #include "compiler/relation.h"
64 #include "compiler/relation_util.h"
65 #include "compiler/mathinst.h"
66 /* last */
67 #include "compiler/bintoken.h"
68 #include "compiler/btprolog.h"
69
70 #define CLINE(a) FPRINTF(fp,"%s\n",(a))
71
72 #if (defined(__HPUX__) || defined(__ALPHA_OSF__) || \
73 defined(__WIN32__) || defined(__SUN_SOLARIS__) || \
74 defined(__SUN_SUNOS__) || defined(__SGI_IRIX__))
75 #define HAVE_DL_UNLOAD 1
76 #endif
77 /* we don't know about ultrix, aix, and others */
78
79 enum bintoken_error {
80 BTE_ok,
81 BTE_badrel,
82 BTE_write,
83 BTE_build,
84 BTE_load,
85 BTE_mem
86 };
87
88 struct bt_table {
89 enum bintoken_kind type;
90 char *name;
91 union TableUnion *tu;
92 int btable; /* check id */
93 int refcount; /* total number of relation shares with btable = our number */
94 int size; /* may be larger than refcount. */
95 };
96
97 /*
98 * slot to manage all the tables from, especially if we'll do
99 * dynamic unloading.
100 */
101 struct bt_data {
102 struct bt_table *tables;
103 int captables;
104 int nextid;
105 /* loading hooks */
106 union TableUnion *newtable;
107 int newtablesize;
108 char regname[256];
109 /* ui set build options */
110 char *srcname;
111 char *objname;
112 char *libname;
113 char *buildcommand;
114 char *unlinkcommand;
115 unsigned long maxrels; /* no more than this many C relations per file */
116 int verbose; /* comments in generated code */
117 int housekeep; /* if !=0, generated src files are deleted sometimes. */
118 } g_bt_data = {NULL,0,0,NULL,0,"ERRARCHIVE",NULL,NULL,NULL,NULL,NULL,1,0,0};
119
120 /**
121 * In the C++ interface, the arguments of BinTokenSetOptions need to be
122 * const char*. But here, new can lose its constness in *ptr = new. - JP
123 */
124 static
125 int bt_string_replace(CONST char *new, char **ptr)
126 {
127 if (*ptr == new) {
128 return 0;
129 }
130 if (new == NULL) {
131 if (*ptr != NULL) {
132 ascfree(*ptr);
133 *ptr = NULL;
134 }
135 } else {
136 if (*ptr != NULL) {
137 ascfree(*ptr);
138 }
139 *ptr = (char *)new;
140 }
141 return 0;
142 }
143
144 /*
145 * Set the configurations for building code.
146 * The string arguments given are kept.
147 * They are freed on the next call which specifies a new string or NULL.
148 * strings given should not be allocated from tcl.
149 */
150 int BinTokenSetOptions(CONST char *srcname,
151 CONST char *objname,
152 CONST char *libname,
153 CONST char *buildcommand,
154 CONST char *unlinkcommand,
155 unsigned long maxrels,
156 int verbose,
157 int housekeep)
158 {
159 int err = 0;
160 err += bt_string_replace(srcname,&(g_bt_data.srcname));
161 err += bt_string_replace(objname,&(g_bt_data.objname));
162 err += bt_string_replace(libname,&(g_bt_data.libname));
163 err += bt_string_replace(buildcommand,&(g_bt_data.buildcommand));
164 err += bt_string_replace(unlinkcommand,&(g_bt_data.unlinkcommand));
165 g_bt_data.maxrels = maxrels;
166 g_bt_data.verbose = verbose;
167 g_bt_data.housekeep = housekeep;
168 return err;
169 }
170
171
172 /*
173 * grows the table when need be.
174 * note that nextid is the current number of possibly real
175 * entries in the table and we need to insure that nextid+1
176 * exists because we are running this table from 1 instead of 0.
177 */
178 static
179 int BinTokenCheckCapacity()
180 {
181 if (g_bt_data.tables == NULL) {
182 assert(g_bt_data.captables == 0);
183 g_bt_data.tables =
184 (struct bt_table *)ascmalloc(20*sizeof(struct bt_table));
185 assert(g_bt_data.tables != NULL);
186 g_bt_data.captables = 20;
187 return 0;
188 }
189 if (g_bt_data.nextid >= g_bt_data.captables) {
190 g_bt_data.tables = (struct bt_table *)ascrealloc(g_bt_data.tables,
191 2*sizeof(struct bt_table)*g_bt_data.captables);
192 assert(g_bt_data.tables != NULL);
193 g_bt_data.captables *= 2;
194 }
195 return 0;
196 }
197
198 /*
199 * frees global memory.
200 * should be more careful.
201 */
202 void BinTokenClearTables(void)
203 {
204 if (g_bt_data.tables != NULL) {
205 ascfree(g_bt_data.tables);
206 g_bt_data.tables = NULL;
207 }
208 g_bt_data.captables = 0;
209 g_bt_data.nextid = 0;
210 BinTokenSetOptions(NULL,NULL,NULL,NULL,NULL,1,0,0);
211 }
212
213 /*
214 * when all the references expire, unload the library.
215 * note there is no AddReference since all the references
216 * are made 1 per share at load time.
217 */
218 void BinTokenDeleteReference(int btable)
219 {
220 if (btable < 0 || btable > g_bt_data.nextid ||
221 g_bt_data.tables[btable].type == BT_error) {
222 return;
223 /* relation references a loadfailure library or already deleted
224 * or corrupted memory has made its way here.
225 */
226 }
227 g_bt_data.tables[btable].refcount--;
228 if (g_bt_data.tables[btable].refcount == 0) {
229 /* unload the library if possible here */
230 #if HAVE_DL_UNLOAD
231 Asc_DynamicUnLoad(g_bt_data.tables[btable].name);
232 #endif /* havedlunload */
233 ascfree(g_bt_data.tables[btable].name);
234 g_bt_data.tables[btable].name = NULL;
235 g_bt_data.tables[btable].tu = NULL;
236 g_bt_data.tables[btable].type = BT_error;
237 }
238 }
239
240
241 /*
242 * submodule for reducing string form of equations to uniqueness.
243 * This portion is independent of the generated language.
244 * Ben Allan, 2/98.
245 */
246
247 struct bintoken_unique_eqn {
248 int indexU; /* Unique function index of this string */
249 int firstrel; /* index of first relation to have this string.
250 * this can give us a relation list index to refer
251 * to for generating unique gradient code, rather than
252 * differentiating all the eqns in the formal rellist.
253 */
254 int refcount;
255 int len; /* strlen of the string form */
256 /* int-sized hole here on long pointer machines intentional */
257 char *str; /* common string form of the eqn */
258 };
259
260 struct bintoken_eqlist {
261 struct gl_list_t *ue; /* list of unique eqn code strings */
262 int *rel2U;
263 /* array indexed by relindex, giving the corresponding
264 * unique equation indexU.
265 */
266 int nextnew; /* starts at 0. index of the next new unique. */
267 };
268
269
270 /* return 1 if error, 0 if ok */
271 static
272 int InitEQData(struct bintoken_eqlist *eql, int len)
273 {
274 eql->nextnew = 0;
275 eql->ue = gl_create(len);
276 if (eql->ue == NULL) {
277 return 1;
278 }
279 eql->rel2U = (int *)ascmalloc((len+1)*sizeof(int));
280 if (eql->rel2U == NULL) {
281 gl_destroy( eql->ue );
282 return 1;
283 }
284 return 0;
285 }
286
287 static
288 void DestroyEQData(struct bintoken_eqlist *eql)
289 {
290 struct bintoken_unique_eqn *u;
291 unsigned long c;
292 for (c=gl_length(eql->ue); c > 0; c--) {
293 u = (struct bintoken_unique_eqn *)gl_fetch(eql->ue,c);
294 if (u != NULL) {
295 if (u->str != NULL) {
296 ascfree(u->str);
297 }
298 ascfree(u);
299 }
300 }
301 gl_destroy(eql->ue);
302 ascfree(eql->rel2U);
303 }
304
305 /*
306 * This function compares first on string len, secondarily on
307 * str content. knownas is not considered. This function can be
308 * used to search a gl_list of existing unique_eqns to figure
309 * out whether to add a new one or simply extend an existing ones
310 * knownas list.
311 */
312 static
313 int CmpUniqueEqn(struct bintoken_unique_eqn *u1, struct bintoken_unique_eqn *u2)
314 {
315 assert(u1!=NULL);
316 assert(u2!=NULL);
317 assert(u1->len!=0);
318 assert(u2->len!=0);
319 assert(u1->str!=NULL);
320 assert(u2->str!=NULL);
321 if (u1==u2) {
322 /* should never, ever happen */
323 return 0;
324 }
325 if (u1->len != u2->len) {
326 /* I don't know whether this sorts increasing or decreasing len.
327 * not that it really matters. we're sorting on len first to avoid
328 * strcmp calls.
329 */
330 if (u1->len < u2->len) {
331 return -1;
332 } else {
333 return 1;
334 }
335 }
336 return strcmp(u1->str,u2->str);
337 }
338
339 /*
340 * Finds or inserts a unique eqn in the list eql.
341 * Records the unique index U in eql->rel2U[relindex].
342 * Returns 1 if added a record to eql referencing str.
343 * Returns 0 if str already exists in eql somewhere.
344 * len is the length of str.
345 * relindex is the index of the instance the string
346 * came from in some instance list.
347 */
348 static
349 int BinTokenAddUniqueEqn(struct bintoken_eqlist *eql, int relindex,
350 char *str, int len)
351 {
352 struct bintoken_unique_eqn test, *new, *old;
353 unsigned long pos;
354 assert(eql != NULL);
355 assert(relindex >= 0);
356 assert(str != NULL);
357
358 test.len = len;
359 test.str = str;
360 pos = gl_search(eql->ue,&test,(CmpFunc)CmpUniqueEqn);
361 if (!pos) {
362 /* create new unique eqn */
363 new = (struct bintoken_unique_eqn *)
364 ascmalloc(sizeof(struct bintoken_unique_eqn));
365 assert(new!=NULL);
366 new->len = test.len;
367 new->firstrel = relindex;
368 new->refcount = 1;
369 eql->rel2U[relindex] = eql->nextnew;
370 new->indexU = (eql->nextnew)++;
371 new->str = str; /* keep string */
372 gl_insert_sorted(eql->ue,new,(CmpFunc)CmpUniqueEqn);
373 return 1;
374 } else {
375 /* saw it already */
376 old = (struct bintoken_unique_eqn *)gl_fetch(eql->ue,pos);
377 old->refcount++;
378 eql->rel2U[relindex] = old->indexU;
379 return 0;
380 }
381 }
382
383 /*
384 * C code specific stuff
385 */
386
387 /*
388 * includes the standard headers and any supporting functions
389 * we may require.
390 */
391 static
392 void WritePrologue(FILE *fp, struct Instance *root,
393 unsigned long len, int verbose)
394 {
395 if (verbose) {
396 CLINE("/* BinTokenSharesToC $Revision: 1.12 $");
397 FPRINTF(fp," * %lu relations in\n * ",len);
398 WriteInstanceName(fp,root,NULL);
399 CLINE("\n * (possibly fewer C functions required)\n */");
400 }
401 #ifdef HAVE_ERF
402 /* need to define this for btprolog.h to do the right thing */
403 CLINE("#define HAVE_ERF");
404 #endif
405 CLINE("#include \"btprolog.h\"");
406 }
407
408 /* this function should be generalized or duplicated to
409 * handle other languages. It's almost there now.
410 */
411 static
412 enum bintoken_error GetResidualString(struct Instance *i,
413 int nrel,
414 struct RXNameData *rd,
415 enum rel_lang_format lang,
416 int *rellen,
417 char **streqn)
418 {
419 assert(i!=NULL);
420 assert(InstanceKind(i)==REL_INST);
421
422 *streqn = WriteRelationString(i,NULL,(WRSNameFunc)RelationVarXName,
423 rd,lang,rellen);
424 if (*streqn==NULL) {
425 FPRINTF(ASCERR,"Unable to generate code for (%d):\n",nrel);
426 WriteAnyInstanceName(ASCERR,i);
427 return BTE_badrel;
428 }
429 return BTE_ok;
430 }
431
432 /* this function should be generalized or duplicated to
433 * handle other languages. Should be ok for most C-like languages.
434 * Writes K&R C.
435 */
436 static
437 enum bintoken_error WriteResidualCode(FILE *fp, struct Instance *i,
438 int nrel, int verbose,
439 char *streqn, int timesused)
440 {
441 #define C_INDENT 4
442 #define C_WIDTH 70
443 assert(i!=NULL);
444
445 if (streqn==NULL) {
446 return BTE_badrel;
447 }
448
449 if (verbose) {
450 /* put in a little header */
451 CLINE("\n/*");
452 FPRINTF(fp,"\tRelation used %d times, prototyped from:\n",timesused);
453 FPRINTF(fp,"\t");
454 /* Use fastest path to a root */
455 WriteAnyInstanceName(fp,i);
456 CLINE("\n*/");
457 }
458
459 CLINE("static");
460 FPRINTF(fp, "void r_%d(double *x,double *residual){\n", nrel);
461 CLINE("\t*residual =");
462 #define FMTNORMAL 1
463 #if FMTNORMAL
464 print_long_string(fp,streqn,C_WIDTH,C_INDENT); /* human readable, sort of */
465 #else
466 FPRINTF(fp,"%s",streqn); /* all on one ugly long line */
467 #endif
468
469 if (verbose) {
470 FPRINTF(fp, " ; /* eqn %d */\n", nrel);
471 } else {
472 CLINE(" ;");
473 }
474 CLINE("}");
475 return BTE_ok;
476 }
477
478 /*
479 * t is the array of function pointers. size is number or
480 * relations represented +1 since element 0 is {NULL,NULL}
481 * by convention.
482 */
483 int DLEXPORT ExportBinTokenCTable(struct TableC *t,int size)
484 {
485 if (g_bt_data.newtable != NULL || t == NULL || size < 1) {
486 return 1;
487 }
488 g_bt_data.newtable = (union TableUnion *)t;
489 g_bt_data.newtablesize = size;
490 return 0;
491 }
492
493 struct reusable_rxnd {
494 struct RXNameData rd;
495 unsigned long cap;
496 };
497
498 /*
499 * puts an index list in r->rd which is just the shift by 1
500 * so r->rd.indices[j+1] == j.
501 */
502 static
503 void ResizeIndices(struct Instance *rel, struct reusable_rxnd *r)
504 {
505 unsigned long newlen,j;
506 assert(r!=NULL);
507
508 /* free and return if NULL rel */
509 if (rel == NULL) {
510 if (r->rd.indices != NULL) {
511 ascfree(r->rd.indices);
512 r->rd.indices = NULL;
513 r->cap = 0;
514 }
515 return;
516 }
517
518 /* get desired size */
519 newlen = NumberVariables(GetInstanceRelationOnly(rel));
520 newlen++; /* gotta remember to allow for indexing from 1 */
521
522 /* skip out if we have it already */
523 if (newlen <= r->cap) {
524 return;
525 }
526
527 if (r->rd.indices != NULL) {
528 /* assume we'll grow again and try not to do it often */
529 ascfree(r->rd.indices);
530 r->rd.indices = NULL;
531 newlen *= 2;
532 }
533 /* require min */
534 if (newlen < 100) {
535 newlen = 100;
536 }
537 /* create mem_*/
538 r->rd.indices = (int *)ascmalloc(sizeof(int)*newlen);
539 if (r->rd.indices == NULL) {
540 Asc_Panic(2, "BinTokenSharesToC","out of memory error");
541 exit(2);
542 }
543 /* set up one-less indices */
544 for (j = 0; j < newlen; j++) {
545 r->rd.indices[j] = (int)j - 1;
546 }
547 r->cap = newlen;
548 }
549
550 /*
551 * generate code for a table of function pointers and the function
552 * pointers also in an archive load function.
553 * The table is always 1 pair larger than rellist since by convention
554 * index 0 has the NULL functions.
555 */
556 static
557 enum bintoken_error BinTokenSharesToC(struct Instance *root,
558 struct gl_list_t *rellist,
559 char *srcname,
560 int verbose)
561 {
562 int *error;
563 FILE *fp;
564 struct Instance *i;
565 char *str;
566 int slen;
567 struct bintoken_unique_eqn *eqn;
568 struct bintoken_eqlist eql;
569 unsigned long c, len;
570 int pid;
571 int eqns_done;
572 struct reusable_rxnd rrd = {{"x[",NULL,"]"},0};
573
574 if (root == NULL || rellist == NULL) {
575 return BTE_ok;
576 }
577 len = gl_length(rellist);
578 if (!len) {
579 return BTE_ok;
580 }
581 fp = fopen(srcname,"w+");
582 if (fp == NULL) {
583 return BTE_write;
584 }
585 eqns_done = 0;
586 error = (int *)ascmalloc(len*sizeof(int));
587 WritePrologue(fp,root,len,verbose);
588
589 /* algorithm to collect eqns:
590 * (at the cost of more string memory, since we keep unique strings while
591 * determining minimum set of C functions to write).
592 * Really, the instantiator could be taking steps to make this less necesssary,
593 * but even then the compiler will miss some similarities arising from
594 * different Statements.
595 */
596
597 if (InitEQData(&eql,(int)len)!= 0) {
598 fclose(fp);
599 return BTE_mem;
600 }
601
602 /* get unique set of code strings. */
603 for (c=1; c <= len; c++) {
604 i = gl_fetch(rellist,c);
605 /* make space and configure for subscript translation from 1 to 0 */
606 ResizeIndices(i,&rrd);
607 error[c-1] = GetResidualString(i,(int)c,&(rrd.rd),relio_C,&slen,&str);
608 if (error[c-1] == BTE_ok) {
609 eqns_done++;
610 if (BinTokenAddUniqueEqn(&eql,(int)c,str,slen) == 0) {
611 ascfree(str);
612 } /* else string is kept in eql and killed later */
613 }
614 /* else { eql.rel2U[c] = -1; } needed? */
615 }
616 ResizeIndices(NULL,&rrd);
617 if (!eqns_done) {
618 /* no generable code. clean up and leave. */
619 fclose(fp);
620 DestroyEQData(&eql);
621 return BTE_badrel;
622 }
623 for (c = gl_length(eql.ue); c > 0; c--) {
624 eqn = (struct bintoken_unique_eqn *)gl_fetch(eql.ue,c);
625 i = gl_fetch(rellist,eqn->firstrel);
626 WriteResidualCode(fp,i,eqn->indexU,verbose,eqn->str,eqn->refcount);
627 /* here we could also write gradient code based on i, indexU. */
628 }
629 /* write the registered function name */
630 pid = getpid();
631 /** @TODO FIXME win32 has getpid but it is bogus as uniquifier. */
632 /* so long as makefile deletes previous dll, windows is ok though */
633 sprintf(g_bt_data.regname,"BinTokenArch_%d_%d",++(g_bt_data.nextid),(int)pid);
634 FPRINTF(fp,"int DLEXPORT %s(){\n",g_bt_data.regname);
635 CLINE("\tint status;");
636 FPRINTF(fp,"\tstatic struct TableC g_ctable[%lu] =\n",len+1);
637 CLINE("\t\t{ {NULL, NULL},");
638 len--; /* to fudge the final comma */
639 for (c=1; c <= len; c++) {
640 if (error[c-1] == BTE_ok) {
641 FPRINTF(fp,"\t\t\t{r_%u, NULL},\n",eql.rel2U[c]);
642 } else {
643 FPRINTF(fp,"\t\t\t{NULL, NULL},\n");
644 }
645 }
646 len++;
647 if (error[len-1] == BTE_ok) {
648 FPRINTF(fp,"\t\t\t{r_%u, NULL}\n",eql.rel2U[c]);
649 } else {
650 FPRINTF(fp,"\t\t\t{NULL, NULL}\n");
651 }
652 CLINE("\t\t};");
653 FPRINTF(fp,"\tstatus = ExportBinTokenCTable(g_ctable,%lu);\n",len+1);
654 CLINE("\treturn status;");
655 if (verbose) {
656 FPRINTF(fp,"\t/* %lu unique equations */\n",gl_length(eql.ue));
657 FPRINTF(ASCERR,"C Functions: %lu\n",gl_length(eql.ue));
658 }
659 CLINE("}");
660
661 ascfree(error);
662 DestroyEQData(&eql);
663 fclose(fp);
664 return BTE_ok;
665 }
666
667 static
668 enum bintoken_error BinTokenCompileC(char *buildcommand)
669 {
670 int status;
671 error_reporter(ASC_PROG_NOTE,NULL,0,"Starting build, command:\n%s",buildcommand);
672 status = system(buildcommand);
673 if (status) {
674 FPRINTF(ASCERR,"\nBUILD returned %d\n",status);
675 return BTE_build;
676 }
677 return BTE_ok;
678 }
679
680 static
681 void BinTokenResetHooks()
682 {
683 g_bt_data.tables[g_bt_data.nextid].type = BT_error;
684 g_bt_data.newtable = NULL;
685 g_bt_data.newtablesize = 0;
686 }
687
688 static
689 void BinTokenHookToTable(int entry, enum bintoken_kind type)
690 {
691 g_bt_data.tables[entry].tu = g_bt_data.newtable;
692 g_bt_data.tables[entry].size = g_bt_data.newtablesize;
693 g_bt_data.tables[entry].btable = entry;
694 g_bt_data.tables[entry].type = type;
695 g_bt_data.newtable = NULL;
696 g_bt_data.newtablesize = 0;
697 }
698
699 static
700 enum bintoken_error BinTokenLoadC(struct gl_list_t *rellist,
701 char *libname,
702 char *regname)
703 {
704 int status;
705 unsigned long c,len;
706 BinTokenCheckCapacity();
707 status = Asc_DynamicLoad(libname,regname);
708 if (status != 0) {
709 FPRINTF(ASCERR,"Load failure of %s:%s\n",libname,regname);
710 BinTokenResetHooks();
711 /* could do this maybe, but not needed if we want each
712 * relation to get one shot only..
713 * for (c=1;c <= len; c++) {
714 * RelationSetBinTokens((struct Instance *)gl_fetch(rellist,c),
715 * g_bt_data.nextid,(int)c);
716 * }
717 */
718 return BTE_load;
719 }
720 BinTokenHookToTable(g_bt_data.nextid,BT_C);
721 len = gl_length(rellist);
722 for (c=1;c <= len; c++) {
723 RelationSetBinTokens((struct Instance *)gl_fetch(rellist,c),
724 g_bt_data.nextid,(int)c);
725 }
726 g_bt_data.tables[g_bt_data.nextid].refcount = (int)len;
727 g_bt_data.tables[g_bt_data.nextid].name = ascstrdup(libname);
728 return BTE_ok;
729 }
730
731 /*
732 * this function should be more helpful.
733 */
734 static
735 void BinTokenErrorMessage(enum bintoken_error err,
736 struct Instance *root,
737 char *filename,
738 char *buildcommand)
739 {
740 char *mess;
741
742 (void)root;
743 (void)filename;
744 (void)buildcommand;
745
746 switch(err) {
747 case BTE_ok:
748 mess="A-ok";
749 break;
750 case BTE_badrel:
751 mess="Bad relation found in code generation";
752 break;
753 case BTE_write:
754 mess="Unable to write file";
755 break;
756 case BTE_build:
757 mess="Unable to build binary";
758 break;
759 case BTE_load:
760 mess="Loaded binary does not match code written";
761 break;
762 case BTE_mem:
763 mess="Insufficient memory to write code.";
764 break;
765 default:
766 mess="Unknown error in BinTokenErrorMessage";
767 break;
768 }
769 FPRINTF(ASCERR,"%s: %s\n",__FILE__,mess);
770 }
771
772 void BinTokensCreate(struct Instance *root, enum bintoken_kind method)
773 {
774 struct gl_list_t *rellist;
775 char *cbuf;
776 enum bintoken_error status;
777 char *srcname = g_bt_data.srcname;
778 char *objname = g_bt_data.objname;
779 char *libname = g_bt_data.libname;
780 char *buildcommand = g_bt_data.buildcommand;
781 char *unlinkcommand = g_bt_data.unlinkcommand;
782 int verbose = g_bt_data.verbose;
783
784 if (g_bt_data.maxrels == 0) {
785 return;
786 }
787 if (srcname == NULL || buildcommand == NULL || unlinkcommand == NULL) {
788 FPRINTF(ASCERR,"%sBinaryTokensCreate called with no options set.",
789 StatioLabel(3));
790 return;
791 }
792
793 rellist =
794 CollectTokenRelationsWithUniqueBINlessShares(root,g_bt_data.maxrels);
795 if (rellist==NULL) {
796 FPRINTF(ASCERR,
797 "%sBinaryTokensCreate found 0 or too many unique relations\n",
798 StatioLabel(2));
799 return;
800 }
801
802 switch (method) {
803 case BT_C:
804 /* generate code */
805 status = BinTokenSharesToC(root,rellist,srcname,verbose);
806 if (status != BTE_ok) {
807 BinTokenErrorMessage(status,root,srcname,buildcommand);
808 break; /* leave source file there if partial */
809 }
810 status = BinTokenCompileC(buildcommand);
811 if (status != BTE_ok) {
812 BinTokenErrorMessage(status,root,objname,buildcommand);
813 break; /* leave source file there to debug */
814 } else {
815 if (g_bt_data.housekeep) {
816 /* trash src */
817 cbuf = (char *)ascmalloc(strlen(unlinkcommand)+1+strlen(srcname)+1);
818 assert(cbuf!=NULL);
819 sprintf(cbuf,"%s %s",unlinkcommand,srcname);
820 system(cbuf); /* we don't care if the delete fails */
821 ascfree(cbuf);
822 /* trash obj */
823 cbuf = (char *)ascmalloc(strlen(unlinkcommand)+1+strlen(objname)+1);
824 assert(cbuf!=NULL);
825 sprintf(cbuf,"%s %s",unlinkcommand,objname);
826 system(cbuf); /* we don't care if the delete fails */
827 ascfree(cbuf);
828 }
829
830 status = BinTokenLoadC(rellist,libname,g_bt_data.regname);
831 if (status != BTE_ok) {
832 BinTokenErrorMessage(status,root,libname,buildcommand);
833 /* leave source,binary files there to debug */
834 }/*else{
835 FPRINTF(ASCERR,"BINTOKENLOADC OK\n");
836 }*/
837 }
838 break;
839 case BT_F77:
840 case BT_SunJAVA:
841 case BT_MsJAVA:
842 default:
843 FPRINTF(ASCERR,"%sBinaryTokensCreate called with\n" /* no comma */
844 " unavailable method %d",StatioLabel(3),(int)method);
845 break;
846 }
847 gl_destroy(rellist);
848 return;
849 }
850
851 /*
852 * Returns 1 if can't evaluate function.
853 * Vars is assumed already filled with values.
854 * This function must not malloc or free memory.
855 */
856 int BinTokenCalcResidual(int btable, int bindex, double *vars, double *residual)
857 {
858 if (btable < 1 || bindex < 1) {
859 return 1;
860 }
861 switch (g_bt_data.tables[btable].type) {
862 case BT_error:
863 return 1; /* expired table! */
864 case BT_C: {
865 struct TableC *ctable;
866 BinTokenFPtr func;
867 ctable = (struct TableC *)g_bt_data.tables[btable].tu;
868 assert(ctable != NULL);
869 if (bindex > g_bt_data.tables[btable].size) {
870 return 1;
871 }
872 func = ctable[bindex].F;
873 #if 0 /* setting this to 1 is a major performance hit. */
874 if (func != NULL) {
875 if (setjmp(g_fpe_env)==0) {
876 (*func)(vars,residual);
877 return 0;
878 } else {
879 Asc_SignalRecover();
880 return 1;
881 }
882 }
883 return 1;
884 #else
885 (*func)(vars,residual);
886 return 0;
887 #endif
888 }
889 case BT_F77: {
890 /* this case needs to be cleaned up to match the C case above. */
891 struct TableF *ftable;
892 BinTokenSPtr subroutine;
893 ftable = (struct TableF *)g_bt_data.tables[btable].tu;
894 assert(ftable != NULL);
895 if (bindex < 1 || bindex > g_bt_data.tables[btable].size) {
896 return 1;
897 }
898 subroutine = ftable[0].S; /* its all in func 0 */
899 if (subroutine != NULL) {
900 int ForG,status;
901 ForG = BinTokenRESIDUAL;
902 #ifndef NO_SIGNAL_TRAPS
903 Asc_SignalHandlerPush(SIGFPE,Asc_SignalTrap);
904 if (setjmp(g_fpe_env)==0) {
905 #endif /* NO_SIGNAL_TRAPS */
906 (*subroutine)(vars,NULL,residual,&ForG,&bindex,&status);
907 #ifndef NO_SIGNAL_TRAPS
908 Asc_SignalHandlerPop(SIGFPE,Asc_SignalTrap);
909 #endif /* NO_SIGNAL_TRAPS */
910 return status;
911 #ifndef NO_SIGNAL_TRAPS
912 } else {
913 Asc_SignalHandlerPop(SIGFPE,Asc_SignalTrap);
914 return 1;
915 }
916 #endif /* NO_SIGNAL_TRAPS */
917 }
918 return 1;
919 }
920 case BT_SunJAVA:
921 case BT_MsJAVA:
922 default:
923 return 1;
924 }
925 }
926
927 /*
928 * Returns nonzero if can't evaluate gradient.
929 * Vars is assumed already filled with values.
930 */
931 int BinTokenCalcGradient(int btable, int bindex,double *vars,
932 double *residual, double *gradient)
933 {
934 if (btable == 0) {
935 return 1;
936 }
937 switch (g_bt_data.tables[btable].type) {
938 case BT_error:
939 return 1; /* expired table! */
940 case BT_C: {
941 /* signal handling needs to match func above. this is slow here. */
942 struct TableC *ctable;
943 BinTokenGPtr func;
944 ctable = (struct TableC *)g_bt_data.tables[btable].tu;
945 assert(ctable != NULL);
946 if (bindex < 1 || bindex > g_bt_data.tables[btable].size) {
947 return 1;
948 }
949 func = ctable[bindex].G;
950 if (func != NULL) {
951 #ifndef NO_SIGNAL_TRAPS
952 Asc_SignalHandlerPush(SIGFPE,Asc_SignalTrap);
953 if (setjmp(g_fpe_env)==0) {
954 #endif /* NO_SIGNAL_TRAPS */
955 (*func)(vars,gradient,residual);
956 #ifndef NO_SIGNAL_TRAPS
957 Asc_SignalHandlerPop(SIGFPE,Asc_SignalTrap);
958 #endif /* NO_SIGNAL_TRAPS */
959 return 0;
960 #ifndef NO_SIGNAL_TRAPS
961 } else {
962 Asc_SignalHandlerPop(SIGFPE,Asc_SignalTrap);
963 return 1;
964 }
965 #endif /* NO_SIGNAL_TRAPS */
966 }
967 return 1;
968 }
969 case BT_F77: {
970 struct TableF *ftable;
971 BinTokenSPtr subroutine;
972 ftable = (struct TableF *)g_bt_data.tables[btable].tu;
973 assert(ftable != NULL);
974 if (bindex < 1 || bindex > g_bt_data.tables[btable].size) {
975 return 1;
976 }
977 subroutine = ftable[0].S; /* its all in func 0 */
978 if (subroutine != NULL) {
979 int ForG,status;
980 ForG = BinTokenGRADIENT;
981 #ifndef NO_SIGNAL_TRAPS
982 Asc_SignalHandlerPush(SIGFPE,Asc_SignalTrap);
983 if (setjmp(g_fpe_env)==0) {
984 #endif /* NO_SIGNAL_TRAPS */
985 (*subroutine)(vars,gradient,residual,&ForG,&bindex,&status);
986 #ifndef NO_SIGNAL_TRAPS
987 Asc_SignalHandlerPop(SIGFPE,Asc_SignalTrap);
988 #endif /* NO_SIGNAL_TRAPS */
989 return status;
990 #ifndef NO_SIGNAL_TRAPS
991 } else {
992 status = 1;
993 }
994 Asc_SignalHandlerPop(SIGFPE,Asc_SignalTrap);
995 return status;
996 #endif /* NO_SIGNAL_TRAPS */
997 }
998 return 1;
999 }
1000 case BT_SunJAVA:
1001 case BT_MsJAVA:
1002 default:
1003 return 1;
1004 }
1005 }
1006
1007 #if TESTBT /* this code may be out of date, but should be saved. */
1008
1009 FILE *g_ascend_errors = stderr;
1010 int main() { /* built only if TESTBT defined TRUE in bintoken.c */
1011 double res;
1012 char *b[5];
1013 gl_init_pool();
1014 g_test_list = gl_create(5);
1015 gl_append_ptr(g_test_list,(void *)10);
1016 gl_append_ptr(g_test_list,(void *)20);
1017 gl_append_ptr(g_test_list,(void *)30);
1018 gl_append_ptr(g_test_list,(void *)40);
1019 gl_append_ptr(g_test_list,(void *)50);
1020 b[0]=(char *)ascmalloc(50);
1021 b[1]=(char *)ascmalloc(50);
1022 b[2]=(char *)ascmalloc(50);
1023 b[4]=(char *)ascmalloc(50);
1024 b[5]=(char *)ascmalloc(50);
1025 sprintf(b[0],"/tmp/btsrc.c");
1026 sprintf(b[1],"/tmp/btsrc.o");
1027 sprintf(b[2],"/tmp/btsrc.so");
1028 sprintf(b[3],"make -f foo/Makefile BTTARGET=/tmp/btsrc /tmp/btsrc");
1029 sprintf(b[4],"/bin/rm");
1030 BinTokenSetOptions(b[0],b[1],b[2],b[3],b[4],1000,1,0);
1031 BinTokensCreate((struct Instance *)1, BT_C);
1032 BinTokenCalcResidual(1,1,&res,&res);
1033 FPRINTF(ASCERR,"residual 1 = %g\n",res);
1034 BinTokenClearTables();
1035 gl_destroy(g_test_list);
1036 gl_destroy_pool();
1037 return 0;
1038 }
1039 #endif /* testbt */

john.pye@anu.edu.au
ViewVC Help
Powered by ViewVC 1.1.22