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

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