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

Contents of /trunk/ascend/compiler/bintoken.c

Parent Directory Parent Directory | Revision Log Revision Log


Revision 2395 - (show annotations) (download) (as text)
Mon Feb 28 01:30:17 2011 UTC (11 years, 4 months ago) by jpye
File MIME type: text/x-csrc
File size: 29223 byte(s)
Add support for reporting block status in Diagnose window.
1 /* ASCEND modelling environment
2 Copyright (C) 2006-2011 Carnegie Mellon University
3 Copyright (C) 1998 Carnegie Mellon University
4
5 This program is free software; you can redistribute it and/or modify
6 it under the terms of the GNU General Public License as published by
7 the Free Software Foundation; either version 2, or (at your option)
8 any later version.
9
10 This program is distributed in the hope that it will be useful,
11 but WITHOUT ANY WARRANTY; without even the implied warranty of
12 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 GNU General Public License for more details.
14
15 You should have received a copy of the GNU General Public License
16 along with this program; if not, write to the Free Software
17 Foundation, Inc., 59 Temple Place - Suite 330,
18 Boston, MA 02111-1307, USA.
19 *//*
20 By Benjamin A. Allan
21 Jan 7, 1998.
22 Last in CVS:$Revision: 1.12 $ $Date: 1998/06/16 16:38:36 $ $Author: mthomas $
23 */
24
25 #if 0
26 TIMESTAMP = -DTIMESTAMP="\"by `whoami`@`hostname`\""
27 #endif
28 /*
29 * binary tokens implementation for real relation instances.
30 * much of this goes in bintoken.h.
31 */
32
33 #include <ascend/utilities/config.h>
34 #include "bintoken.h"
35
36 #include <unistd.h> /* for getpid() */
37
38 #include <ascend/general/platform.h>
39 #include <ascend/general/ascMalloc.h>
40 #include <ascend/utilities/ascPrint.h>
41 #include <ascend/utilities/ascSignal.h>
42 #include <ascend/general/panic.h>
43 #include <ascend/utilities/ascDynaLoad.h>
44 #include <ascend/general/list.h>
45 #include <ascend/general/dstring.h>
46 #include <ascend/general/pretty.h>
47
48 #include "functype.h"
49 #include "expr_types.h"
50 #include "stattypes.h"
51 #include "statio.h"
52 #include "instquery.h"
53 #include "instance_io.h"
54 #include "relation_io.h"
55 #include "find.h"
56 #include "rel_blackbox.h"
57 #include "relation.h"
58 #include "relation_util.h"
59 #include "mathinst.h"
60 /* last */
61
62 #include <ascend/bintokens/btprolog.h>
63
64 //#define BINTOKEN_VERBOSE
65
66 #define CLINE(a) FPRINTF(fp,"%s\n",(a))
67
68 enum bintoken_error {
69 BTE_ok,
70 BTE_badrel,
71 BTE_write,
72 BTE_build,
73 BTE_load,
74 BTE_mem
75 };
76
77 struct bt_table {
78 enum bintoken_kind type;
79 char *name;
80 union TableUnion *tu;
81 int btable; /* check id */
82 int refcount; /* total number of relation shares with btable = our number */
83 int size; /* may be larger than refcount. */
84 };
85
86 /*
87 * slot to manage all the tables from, especially if we'll do
88 * dynamic unloading.
89 */
90 struct bt_data {
91 struct bt_table *tables;
92 int captables;
93 int nextid;
94 /* loading hooks */
95 union TableUnion *newtable;
96 int newtablesize;
97 char regname[256];
98 /* ui set build options */
99 char *srcname;
100 char *objname;
101 char *libname;
102 char *buildcommand;
103 char *unlinkcommand;
104 unsigned long maxrels; /* no more than this many C relations per file */
105 int verbose; /* comments in generated code */
106 int housekeep; /* if !=0, generated src files are deleted sometimes. */
107 } g_bt_data = {NULL,0,0,NULL,0,"ERRARCHIVE",NULL,NULL,NULL,NULL,NULL,1,0,0};
108
109 /**
110 * In the C++ interface, the arguments of BinTokenSetOptions need to be
111 * const char*. But here, new can lose its constness in *ptr = new. - JP
112 */
113 static
114 int bt_string_replace(CONST char *new, char **ptr){
115 if(*ptr == new){
116 /* no destination specified */
117 return 0;
118 }
119 if(new == NULL){
120 /* free the current value */
121 if(*ptr != NULL) {
122 ASC_FREE(*ptr);
123 *ptr = NULL;
124 }
125 }else{
126 /* free then reallocate */
127 if(*ptr != NULL){
128 ASC_FREE(*ptr);
129 }
130 *ptr = ASC_NEW_ARRAY(char,strlen(new)+1);
131 strcpy(*ptr,new);
132 }
133 return 0;
134 }
135
136 /*
137 * Set the configurations for building code.
138 * The string arguments given are kept.
139 * They are freed on the next call which specifies a new string or NULL.
140 * strings given should not be allocated from tcl.
141 */
142 int BinTokenSetOptions(CONST char *srcname,
143 CONST char *objname,
144 CONST char *libname,
145 CONST char *buildcommand,
146 CONST char *unlinkcommand,
147 unsigned long maxrels,
148 int verbose,
149 int housekeep)
150 {
151 /*CONSOLE_DEBUG("...");*/
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 #ifdef BINTOKEN_VERBOSE
162 CONSOLE_DEBUG("make command = %s",buildcommand);
163 #endif
164 return err;
165 }
166
167
168 /*
169 * grows the table when need be.
170 * note that nextid is the current number of possibly real
171 * entries in the table and we need to insure that nextid+1
172 * exists because we are running this table from 1 instead of 0.
173 */
174 static
175 int BinTokenCheckCapacity()
176 {
177 if (g_bt_data.tables == NULL) {
178 assert(g_bt_data.captables == 0);
179 g_bt_data.tables =
180 ASC_NEW_ARRAY(struct bt_table,20);
181 assert(g_bt_data.tables != NULL);
182 g_bt_data.captables = 20;
183 return 0;
184 }
185 if (g_bt_data.nextid >= g_bt_data.captables) {
186 g_bt_data.tables = (struct bt_table *)ascrealloc(g_bt_data.tables,
187 2*sizeof(struct bt_table)*g_bt_data.captables);
188 assert(g_bt_data.tables != NULL);
189 g_bt_data.captables *= 2;
190 }
191 return 0;
192 }
193
194 /*
195 frees global memory.
196 */
197 void BinTokenClearTables(void)
198 {
199 if (g_bt_data.tables != NULL) {
200 ASC_FREE(g_bt_data.tables);
201 g_bt_data.tables = NULL;
202 }
203 g_bt_data.captables = 0;
204 g_bt_data.nextid = 0;
205 BinTokenSetOptions(NULL,NULL,NULL,NULL,NULL,1,0,0);
206 }
207
208 /*
209 * when all the references expire, unload the library.
210 * note there is no AddReference since all the references
211 * are made 1 per share at load time.
212 */
213 void BinTokenDeleteReference(int btable)
214 {
215 if (btable < 0 || btable > g_bt_data.nextid ||
216 g_bt_data.tables[btable].type == BT_error) {
217 return;
218 /* relation references a loadfailure library or already deleted
219 * or corrupted memory has made its way here.
220 */
221 }
222 g_bt_data.tables[btable].refcount--;
223 if (g_bt_data.tables[btable].refcount == 0) {
224 /* unload the library if possible here */
225 #if HAVE_DL_UNLOAD
226 /*ERROR_REPORTER_NOLINE(ASC_PROG_ERR,"UNLOADING %s",g_bt_data.tables[btable].name);*/
227 Asc_DynamicUnLoad(g_bt_data.tables[btable].name);
228 #else
229 ERROR_REPORTER_NOLINE(ASC_PROG_ERR,"Dynamic Unloading not available in this build");
230 #endif /* havedlunload */
231 ASC_FREE(g_bt_data.tables[btable].name);
232 g_bt_data.tables[btable].name = NULL;
233 g_bt_data.tables[btable].tu = NULL;
234 g_bt_data.tables[btable].type = BT_error;
235 }else{
236 CONSOLE_DEBUG("Deleting one reference...");
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 = ASC_NEW_ARRAY(int,len+1);
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 ASC_FREE(u->str);
297 }
298 ASC_FREE(u);
299 }
300 }
301 gl_destroy(eql->ue);
302 ASC_FREE(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 = ASC_NEW(struct bintoken_unique_eqn);
364 assert(new!=NULL);
365 new->len = test.len;
366 new->firstrel = relindex;
367 new->refcount = 1;
368 eql->rel2U[relindex] = eql->nextnew;
369 new->indexU = (eql->nextnew)++;
370 new->str = str; /* keep string */
371 gl_insert_sorted(eql->ue,new,(CmpFunc)CmpUniqueEqn);
372 return 1;
373 } else {
374 /* saw it already */
375 old = (struct bintoken_unique_eqn *)gl_fetch(eql->ue,pos);
376 old->refcount++;
377 eql->rel2U[relindex] = old->indexU;
378 return 0;
379 }
380 }
381
382 /*
383 * C code specific stuff
384 */
385
386 /*
387 * includes the standard headers and any supporting functions
388 * we may require.
389 */
390 static
391 void WritePrologue(FILE *fp, struct Instance *root,
392 unsigned long len, int verbose)
393 {
394 if (verbose) {
395 CLINE("/*\n\tAuto-generated code from" __FILE__);
396 FPRINTF(fp,"\t%lu relations in instance '",len);
397 WriteInstanceName(fp,root,NULL);
398 CLINE("'\n\t(possibly fewer C functions required)\n*/");
399 }
400 #ifdef HAVE_ERF
401 /* need to define this for btprolog.h to do the right thing */
402 CLINE("#define HAVE_ERF");
403 #endif
404
405 CLINE("#include <ascend/bintokens/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 #ifdef BINTOKEN_VERBOSE
475 FPRINTF(fp," fprintf(stderr,\"%%s:%%d: residual for '%%s' is %%f.\\n\", __FILE__, __LINE__, \"");
476 WriteAnyInstanceName(fp,i);
477 FPRINTF(fp,"\", *residual);\n");
478 #endif
479 CLINE("}");
480 return BTE_ok;
481 }
482
483 /*
484 * t is the array of function pointers. size is number or
485 * relations represented +1 since element 0 is {NULL,NULL}
486 * by convention.
487 */
488 int ExportBinTokenCTable(struct TableC *t,int size){
489 if (g_bt_data.newtable != NULL || t == NULL || size < 1) {
490 return 1;
491 }
492 g_bt_data.newtable = (union TableUnion *)t;
493 g_bt_data.newtablesize = size;
494 return 0;
495 }
496
497 struct reusable_rxnd {
498 struct RXNameData rd;
499 unsigned long cap;
500 };
501
502 /*
503 * puts an index list in r->rd which is just the shift by 1
504 * so r->rd.indices[j+1] == j.
505 */
506 static
507 void ResizeIndices(struct Instance *rel, struct reusable_rxnd *r)
508 {
509 unsigned long newlen,j;
510 assert(r!=NULL);
511
512 /* free and return if NULL rel */
513 if (rel == NULL) {
514 if (r->rd.indices != NULL) {
515 ASC_FREE(r->rd.indices);
516 r->rd.indices = NULL;
517 r->cap = 0;
518 }
519 return;
520 }
521
522 /* get desired size */
523 newlen = NumberVariables(GetInstanceRelationOnly(rel));
524 newlen++; /* gotta remember to allow for indexing from 1 */
525
526 /* skip out if we have it already */
527 if (newlen <= r->cap) {
528 return;
529 }
530
531 if (r->rd.indices != NULL) {
532 /* assume we'll grow again and try not to do it often */
533 ASC_FREE(r->rd.indices);
534 r->rd.indices = NULL;
535 newlen *= 2;
536 }
537 /* require min */
538 if (newlen < 100) {
539 newlen = 100;
540 }
541 /* create mem_*/
542 r->rd.indices = ASC_NEW_ARRAY(int,newlen);
543 if (r->rd.indices == NULL) {
544 ASC_PANIC("out of memory error");
545 exit(2);
546 }
547 /* set up one-less indices */
548 for (j = 0; j < newlen; j++) {
549 r->rd.indices[j] = (int)j - 1;
550 }
551 r->cap = newlen;
552 }
553
554 /*
555 * generate code for a table of function pointers and the function
556 * pointers also in an archive load function.
557 * The table is always 1 pair larger than rellist since by convention
558 * index 0 has the NULL functions.
559 */
560 static
561 enum bintoken_error BinTokenSharesToC(struct Instance *root,
562 struct gl_list_t *rellist,
563 char *srcname,
564 int verbose)
565 {
566 int *error;
567 FILE *fp;
568 struct Instance *i;
569 char *str;
570 int slen;
571 struct bintoken_unique_eqn *eqn;
572 struct bintoken_eqlist eql;
573 unsigned long c, len;
574 int pid;
575 int eqns_done;
576 struct reusable_rxnd rrd = {{"x[",NULL,"]"},0};
577
578 if (root == NULL || rellist == NULL) {
579 return BTE_ok;
580 }
581 len = gl_length(rellist);
582 if (!len) {
583 return BTE_ok;
584 }
585 fp = fopen(srcname,"w+");
586 if (fp == NULL) {
587 return BTE_write;
588 }
589 eqns_done = 0;
590 error = ASC_NEW_ARRAY(int,len);
591 WritePrologue(fp,root,len,verbose);
592
593 /* algorithm to collect eqns:
594 * (at the cost of more string memory, since we keep unique strings while
595 * determining minimum set of C functions to write).
596 * Really, the instantiator could be taking steps to make this less necesssary,
597 * but even then the compiler will miss some similarities arising from
598 * different Statements.
599 */
600
601 if (InitEQData(&eql,(int)len)!= 0) {
602 fclose(fp);
603 return BTE_mem;
604 }
605
606 /* get unique set of code strings. */
607 for (c=1; c <= len; c++) {
608 i = gl_fetch(rellist,c);
609 /* make space and configure for subscript translation from 1 to 0 */
610 ResizeIndices(i,&rrd);
611 error[c-1] = GetResidualString(i,(int)c,&(rrd.rd),relio_C,&slen,&str);
612 if (error[c-1] == BTE_ok) {
613 eqns_done++;
614 if (BinTokenAddUniqueEqn(&eql,(int)c,str,slen) == 0) {
615 ASC_FREE(str);
616 } /* else string is kept in eql and killed later */
617 }
618 /* else { eql.rel2U[c] = -1; } needed? */
619 }
620 ResizeIndices(NULL,&rrd);
621 if (!eqns_done) {
622 /* no generable code. clean up and leave. */
623 fclose(fp);
624 DestroyEQData(&eql);
625 return BTE_badrel;
626 }
627 for (c = gl_length(eql.ue); c > 0; c--) {
628 eqn = (struct bintoken_unique_eqn *)gl_fetch(eql.ue,c);
629 i = gl_fetch(rellist,eqn->firstrel);
630 WriteResidualCode(fp,i,eqn->indexU,verbose,eqn->str,eqn->refcount);
631 /* here we could also write gradient code based on i, indexU. */
632 }
633 /* write the registered function name */
634 pid = getpid();
635 /** @TODO FIXME win32 has getpid but it is bogus as uniquifier. */
636 /* so long as makefile deletes previous dll, windows is ok though */
637 sprintf(g_bt_data.regname,"BinTokenArch_%d_%d",++(g_bt_data.nextid),(int)pid);
638 FPRINTF(fp,"\n\nint ASC_EXPORT %s(){\n",g_bt_data.regname);
639 CLINE("\tint status;");
640 FPRINTF(fp,"\tstatic struct TableC g_ctable[%lu] =\n",len+1);
641 CLINE("\t\t{ {NULL, NULL},");
642 len--; /* to fudge the final comma */
643 for (c=1; c <= len; c++) {
644 if (error[c-1] == BTE_ok) {
645 FPRINTF(fp,"\t\t\t{r_%u, NULL},\n",eql.rel2U[c]);
646 } else {
647 FPRINTF(fp,"\t\t\t{NULL, NULL},\n");
648 }
649 }
650 len++;
651 if (error[len-1] == BTE_ok) {
652 FPRINTF(fp,"\t\t\t{r_%u, NULL}\n",eql.rel2U[c]);
653 } else {
654 FPRINTF(fp,"\t\t\t{NULL, NULL}\n");
655 }
656 CLINE("\t\t};");
657 FPRINTF(fp,"\tstatus = ExportBinTokenCTable(g_ctable,%lu);\n",len+1);
658 CLINE("\treturn status;");
659 if (verbose) {
660 FPRINTF(fp,"\t/* %lu unique equations */\n",gl_length(eql.ue));
661 FPRINTF(ASCERR,"Prepared %lu external C functions.\n",gl_length(eql.ue));
662 }
663 CLINE("}");
664
665 ASC_FREE(error);
666 DestroyEQData(&eql);
667 fclose(fp);
668 return BTE_ok;
669 }
670
671 static
672 enum bintoken_error BinTokenCompileC(char *buildcommand)
673 {
674 int status;
675 ERROR_REPORTER_NOLINE(ASC_PROG_NOTE,"Starting build, command:\n%s\n",buildcommand);
676 status = system(buildcommand);
677 if (status) {
678 CONSOLE_DEBUG("BUILD returned %d",status);
679 return BTE_build;
680 }
681 #ifdef BINTOKEN_VERBOSE
682 CONSOLE_DEBUG("Build command returned OK, status=%d",status);
683 #endif
684 return BTE_ok;
685 }
686
687 static
688 void BinTokenResetHooks()
689 {
690 g_bt_data.tables[g_bt_data.nextid].type = BT_error;
691 g_bt_data.newtable = NULL;
692 g_bt_data.newtablesize = 0;
693 }
694
695 static
696 void BinTokenHookToTable(int entry, enum bintoken_kind type)
697 {
698 g_bt_data.tables[entry].tu = g_bt_data.newtable;
699 g_bt_data.tables[entry].size = g_bt_data.newtablesize;
700 g_bt_data.tables[entry].btable = entry;
701 g_bt_data.tables[entry].type = type;
702 g_bt_data.newtable = NULL;
703 g_bt_data.newtablesize = 0;
704 }
705
706 static
707 enum bintoken_error BinTokenLoadC(struct gl_list_t *rellist,
708 char *libname,
709 char *regname)
710 {
711 int status;
712 unsigned long c,len;
713 BinTokenCheckCapacity();
714 status = Asc_DynamicLoad(libname,regname);
715 if (status != 0) {
716 error_reporter(ASC_PROG_WARNING,libname,0,"Failed to load library (init function %s)",regname);
717 BinTokenResetHooks();
718 /* could do this maybe, but not needed if we want each
719 * relation to get one shot only..
720 * for (c=1;c <= len; c++) {
721 * RelationSetBinTokens((struct Instance *)gl_fetch(rellist,c),
722 * g_bt_data.nextid,(int)c);
723 * }
724 */
725 return BTE_load;
726 }
727 BinTokenHookToTable(g_bt_data.nextid,BT_C);
728 len = gl_length(rellist);
729 for (c=1;c <= len; c++) {
730 RelationSetBinTokens((struct Instance *)gl_fetch(rellist,c),
731 g_bt_data.nextid,(int)c);
732 }
733 g_bt_data.tables[g_bt_data.nextid].refcount = (int)len;
734 g_bt_data.tables[g_bt_data.nextid].name = ASC_STRDUP(libname);
735 return BTE_ok;
736 }
737
738 /*
739 * this function should be more helpful.
740 */
741 static
742 void BinTokenErrorMessage(enum bintoken_error err,
743 struct Instance *root,
744 char *filename,
745 char *buildcommand)
746 {
747 char *mess;
748
749 (void)root;
750 (void)buildcommand;
751
752 switch(err) {
753 case BTE_ok:
754 mess="A-ok";
755 break;
756 case BTE_badrel:
757 mess="Bad relation found in code generation";
758 break;
759 case BTE_write:
760 mess="Unable to write file";
761 break;
762 case BTE_build:
763 mess="Unable to build binary";
764 break;
765 case BTE_load:
766 mess="Loaded binary does not match code written";
767 break;
768 case BTE_mem:
769 mess="Insufficient memory to write code.";
770 break;
771 default:
772 mess="Unknown error in BinTokenErrorMessage";
773 break;
774 }
775 error_reporter(ASC_PROG_ERR,filename,0,"%s",mess);
776 }
777
778 void BinTokensCreate(struct Instance *root, enum bintoken_kind method){
779 struct gl_list_t *rellist;
780 char *cbuf;
781 enum bintoken_error status;
782 char *srcname = g_bt_data.srcname;
783 char *objname = g_bt_data.objname;
784 char *libname = g_bt_data.libname;
785 char *buildcommand = g_bt_data.buildcommand;
786 char *unlinkcommand = g_bt_data.unlinkcommand;
787 int verbose = g_bt_data.verbose;
788
789 #ifdef BINTOKEN_VERBOSE
790 CONSOLE_DEBUG("...");
791 #endif
792
793 if (g_bt_data.maxrels == 0) {
794 #ifdef BINTOKEN_VERBOSE
795 ERROR_REPORTER_HERE(ASC_PROG_NOTE,"BinTokensCreate disabled (maxrels=0)\n");
796 #endif
797 return;
798 }
799 if (srcname == NULL || buildcommand == NULL || unlinkcommand == NULL) {
800 #ifdef BINTOKEN_VERBOSE
801 ERROR_REPORTER_HERE(ASC_PROG_WARNING,"BinaryTokensCreate called with no options set: ignoring");
802 #endif
803 return;
804 }
805
806 rellist =
807 CollectTokenRelationsWithUniqueBINlessShares(root,g_bt_data.maxrels);
808 if (rellist==NULL) {
809 ERROR_REPORTER_HERE(ASC_PROG_WARNING
810 ,"BinaryTokensCreate found 0 or too many unique relations."
811 );
812 return;
813 }
814
815 ERROR_REPORTER_HERE(ASC_USER_NOTE,"Creating bintokens\n");
816 CONSOLE_DEBUG("buildcommand = %s",buildcommand);
817
818 switch (method) {
819 case BT_C:
820 /* generate code */
821 status = BinTokenSharesToC(root,rellist,srcname,verbose);
822 if (status != BTE_ok) {
823 BinTokenErrorMessage(status,root,srcname,buildcommand);
824 break; /* leave source file there if partial */
825 }
826 status = BinTokenCompileC(buildcommand);
827 if (status != BTE_ok) {
828 BinTokenErrorMessage(status,root,objname,buildcommand);
829 break; /* leave source file there to debug */
830 } else {
831 if (g_bt_data.housekeep) {
832 /* trash src */
833 cbuf = ASC_NEW_ARRAY(char,strlen(unlinkcommand)+1+strlen(srcname)+1);
834 assert(cbuf!=NULL);
835 sprintf(cbuf,"%s %s",unlinkcommand,srcname);
836 system(cbuf); /* we don't care if the delete fails */
837 ASC_FREE(cbuf);
838 /* trash obj */
839 cbuf = ASC_NEW_ARRAY(char,strlen(unlinkcommand)+1+strlen(objname)+1);
840 assert(cbuf!=NULL);
841 sprintf(cbuf,"%s %s",unlinkcommand,objname);
842 system(cbuf); /* we don't care if the delete fails */
843 ASC_FREE(cbuf);
844 }
845
846 status = BinTokenLoadC(rellist,libname,g_bt_data.regname);
847 if (status != BTE_ok) {
848 BinTokenErrorMessage(status,root,libname,buildcommand);
849 /* leave source,binary files there to debug */
850 }/*else{
851 FPRINTF(ASCERR,"BINTOKENLOADC OK\n");
852 }*/
853 }
854 break;
855 default:
856 ERROR_REPORTER_HERE(ASC_PROG_ERR,"BinaryTokensCreate called with unavailable method '%d'",(int)method);
857 break;
858 }
859 gl_destroy(rellist);
860 return;
861 }
862
863 /*
864 * Returns 1 if can't evaluate function.
865 * Vars is assumed already filled with values.
866 * This function must not malloc or free memory.
867 */
868 int BinTokenCalcResidual(int btable, int bindex, double *vars, double *residual)
869 {
870 if (btable < 1 || bindex < 1) {
871 return 1;
872 }
873 switch (g_bt_data.tables[btable].type) {
874 case BT_error:
875 return 1; /* expired table! */
876 case BT_C: {
877 struct TableC *ctable;
878 BinTokenFPtr func;
879 ctable = (struct TableC *)g_bt_data.tables[btable].tu;
880 assert(ctable != NULL);
881 if (bindex > g_bt_data.tables[btable].size) {
882 return 1;
883 }
884 func = ctable[bindex].F;
885 #if 0 /* setting this to 1 is a major performance hit. */
886 if (func != NULL) {
887 if (SETJMP(g_fpe_env)==0) {
888 (*func)(vars,residual);
889 return 0;
890 } else {
891 Asc_SignalRecover();
892 return 1;
893 }
894 }
895 return 1;
896 #else
897 (*func)(vars,residual);
898 return 0;
899 #endif
900 }
901 case BT_F77: {
902 /* this case needs to be cleaned up to match the C case above. */
903 struct TableF *ftable;
904 BinTokenSPtr subroutine;
905 ftable = (struct TableF *)g_bt_data.tables[btable].tu;
906 assert(ftable != NULL);
907 if (bindex < 1 || bindex > g_bt_data.tables[btable].size) {
908 return 1;
909 }
910 subroutine = ftable[0].S; /* its all in func 0 */
911 if (subroutine != NULL) {
912 int ForG,status;
913 ForG = BinTokenRESIDUAL;
914 #ifdef ASC_SIGNAL_TRAPS
915 Asc_SignalHandlerPush(SIGFPE,Asc_SignalTrap);
916 if (SETJMP(g_fpe_env)==0) {
917 #endif /* ASC_SIGNAL_TRAPS */
918 (*subroutine)(vars,NULL,residual,&ForG,&bindex,&status);
919 #ifdef ASC_SIGNAL_TRAPS
920 Asc_SignalHandlerPop(SIGFPE,Asc_SignalTrap);
921 #endif /* ASC_SIGNAL_TRAPS */
922 return status;
923 #ifdef ASC_SIGNAL_TRAPS
924 } else {
925 Asc_SignalHandlerPop(SIGFPE,Asc_SignalTrap);
926 return 1;
927 }
928 #endif /* ASC_SIGNAL_TRAPS */
929 }
930 return 1;
931 }
932 default:
933 return 1;
934 }
935 }
936
937 /*
938 * Returns nonzero if can't evaluate gradient.
939 * Vars is assumed already filled with values.
940 */
941 int BinTokenCalcGradient(int btable, int bindex,double *vars,
942 double *residual, double *gradient)
943 {
944 if (btable == 0) {
945 return 1;
946 }
947 switch (g_bt_data.tables[btable].type) {
948 case BT_error:
949 return 1; /* expired table! */
950 case BT_C: {
951 /* signal handling needs to match func above. this is slow here. */
952 struct TableC *ctable;
953 BinTokenGPtr func;
954 ctable = (struct TableC *)g_bt_data.tables[btable].tu;
955 assert(ctable != NULL);
956 if (bindex < 1 || bindex > g_bt_data.tables[btable].size) {
957 return 1;
958 }
959 func = ctable[bindex].G;
960 if (func != NULL) {
961 #ifdef ASC_SIGNAL_TRAPS
962 Asc_SignalHandlerPush(SIGFPE,Asc_SignalTrap);
963 if (SETJMP(g_fpe_env)==0) {
964 #endif /* ASC_SIGNAL_TRAPS */
965 (*func)(vars,gradient,residual);
966 #ifdef ASC_SIGNAL_TRAPS
967 Asc_SignalHandlerPop(SIGFPE,Asc_SignalTrap);
968 #endif /* ASC_SIGNAL_TRAPS */
969 return 0;
970 #ifdef ASC_SIGNAL_TRAPS
971 } else {
972 Asc_SignalHandlerPop(SIGFPE,Asc_SignalTrap);
973 return 1;
974 }
975 #endif /* ASC_SIGNAL_TRAPS */
976 }
977 return 1;
978 }
979 case BT_F77: {
980 struct TableF *ftable;
981 BinTokenSPtr subroutine;
982 ftable = (struct TableF *)g_bt_data.tables[btable].tu;
983 assert(ftable != NULL);
984 if (bindex < 1 || bindex > g_bt_data.tables[btable].size) {
985 return 1;
986 }
987 subroutine = ftable[0].S; /* its all in func 0 */
988 if (subroutine != NULL) {
989 int ForG,status;
990 ForG = BinTokenGRADIENT;
991 #ifdef ASC_SIGNAL_TRAPS
992 Asc_SignalHandlerPush(SIGFPE,Asc_SignalTrap);
993 if (SETJMP(g_fpe_env)==0) {
994 #endif /* ASC_SIGNAL_TRAPS */
995 (*subroutine)(vars,gradient,residual,&ForG,&bindex,&status);
996 #ifdef ASC_SIGNAL_TRAPS
997 Asc_SignalHandlerPop(SIGFPE,Asc_SignalTrap);
998 #endif /* ASC_SIGNAL_TRAPS */
999 return status;
1000 #ifdef ASC_SIGNAL_TRAPS
1001 } else {
1002 status = 1;
1003 }
1004 Asc_SignalHandlerPop(SIGFPE,Asc_SignalTrap);
1005 return status;
1006 #endif /* ASC_SIGNAL_TRAPS */
1007 }
1008 return 1;
1009 }
1010 default:
1011 return 1;
1012 }
1013 }
1014
1015 #ifdef UNRELOCATE_TEST_BT
1016 /* this code may be out of date, but should be saved. */
1017 #ifdef RELOCATE_STREAMS
1018 FILE *g_ascend_errors = stderr;
1019 #endif
1020
1021 int main() { /* built only if TESTBT defined TRUE in bintoken.c */
1022 double res;
1023 gl_init_pool();
1024 g_test_list = gl_create(5);
1025 gl_append_ptr(g_test_list,(void *)10);
1026 gl_append_ptr(g_test_list,(void *)20);
1027 gl_append_ptr(g_test_list,(void *)30);
1028 gl_append_ptr(g_test_list,(void *)40);
1029 gl_append_ptr(g_test_list,(void *)50);
1030 BinTokenSetOptions(
1031 "/tmp/btsrc.c","/tmp/btsrc.o","/tmp/btsrc.so"
1032 ,"make -f foo/Makefile BTTARGET=/tmp/btsrc /tmp/btsrc"
1033 ,"/bin/rm"
1034 ,1000,1,0
1035 );
1036 BinTokensCreate((struct Instance *)1, BT_C);
1037 BinTokenCalcResidual(1,1,&res,&res);
1038 FPRINTF(ASCERR,"residual 1 = %g\n",res);
1039 BinTokenClearTables();
1040 gl_destroy(g_test_list);
1041 gl_destroy_pool();
1042 return 0;
1043 }
1044 #endif /*unrelocate test bt*/
1045
1046 /* vim: set ts=2 et: */
1047

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