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

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