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

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