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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 2329 - (show annotations) (download) (as text)
Wed Dec 22 12:52:47 2010 UTC (7 years, 11 months ago) by jpye
File MIME type: text/x-csrc
File size: 28793 byte(s)
Suppressing some console output.
Added test case that current crashes ASCEND/IPOPT with a memory error.
Issue with library.cpp not containing any way to free libascend memory.
1 /* ASCEND modelling environment
2 Copyright (C) 2006 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 "bintoken.h"
34
35 #include <unistd.h> /* for getpid() */
36
37 #include <ascend/utilities/config.h>
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 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 ASC_NEW_ARRAY(struct bt_table,20);
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 */
194 void BinTokenClearTables(void)
195 {
196 if (g_bt_data.tables != NULL) {
197 ASC_FREE(g_bt_data.tables);
198 g_bt_data.tables = NULL;
199 }
200 g_bt_data.captables = 0;
201 g_bt_data.nextid = 0;
202 BinTokenSetOptions(NULL,NULL,NULL,NULL,NULL,1,0,0);
203 }
204
205 /*
206 * when all the references expire, unload the library.
207 * note there is no AddReference since all the references
208 * are made 1 per share at load time.
209 */
210 void BinTokenDeleteReference(int btable)
211 {
212 if (btable < 0 || btable > g_bt_data.nextid ||
213 g_bt_data.tables[btable].type == BT_error) {
214 return;
215 /* relation references a loadfailure library or already deleted
216 * or corrupted memory has made its way here.
217 */
218 }
219 g_bt_data.tables[btable].refcount--;
220 if (g_bt_data.tables[btable].refcount == 0) {
221 /* unload the library if possible here */
222 #if HAVE_DL_UNLOAD
223 /*ERROR_REPORTER_NOLINE(ASC_PROG_ERR,"UNLOADING %s",g_bt_data.tables[btable].name);*/
224 Asc_DynamicUnLoad(g_bt_data.tables[btable].name);
225 #else
226 ERROR_REPORTER_NOLINE(ASC_PROG_ERR,"Dynamic Unloading not available in this build");
227 #endif /* havedlunload */
228 ASC_FREE(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 }else{
233 CONSOLE_DEBUG("Deleting one reference...");
234 }
235 }
236
237
238 /*
239 * submodule for reducing string form of equations to uniqueness.
240 * This portion is independent of the generated language.
241 * Ben Allan, 2/98.
242 */
243
244 struct bintoken_unique_eqn {
245 int indexU; /* Unique function index of this string */
246 int firstrel; /* index of first relation to have this string.
247 * this can give us a relation list index to refer
248 * to for generating unique gradient code, rather than
249 * differentiating all the eqns in the formal rellist.
250 */
251 int refcount;
252 int len; /* strlen of the string form */
253 /* int-sized hole here on long pointer machines intentional */
254 char *str; /* common string form of the eqn */
255 };
256
257 struct bintoken_eqlist {
258 struct gl_list_t *ue; /* list of unique eqn code strings */
259 int *rel2U;
260 /* array indexed by relindex, giving the corresponding
261 * unique equation indexU.
262 */
263 int nextnew; /* starts at 0. index of the next new unique. */
264 };
265
266
267 /* return 1 if error, 0 if ok */
268 static
269 int InitEQData(struct bintoken_eqlist *eql, int len)
270 {
271 eql->nextnew = 0;
272 eql->ue = gl_create(len);
273 if (eql->ue == NULL) {
274 return 1;
275 }
276 eql->rel2U = ASC_NEW_ARRAY(int,len+1);
277 if (eql->rel2U == NULL) {
278 gl_destroy( eql->ue );
279 return 1;
280 }
281 return 0;
282 }
283
284 static
285 void DestroyEQData(struct bintoken_eqlist *eql)
286 {
287 struct bintoken_unique_eqn *u;
288 unsigned long c;
289 for (c=gl_length(eql->ue); c > 0; c--) {
290 u = (struct bintoken_unique_eqn *)gl_fetch(eql->ue,c);
291 if (u != NULL) {
292 if (u->str != NULL) {
293 ASC_FREE(u->str);
294 }
295 ASC_FREE(u);
296 }
297 }
298 gl_destroy(eql->ue);
299 ASC_FREE(eql->rel2U);
300 }
301
302 /*
303 * This function compares first on string len, secondarily on
304 * str content. knownas is not considered. This function can be
305 * used to search a gl_list of existing unique_eqns to figure
306 * out whether to add a new one or simply extend an existing ones
307 * knownas list.
308 */
309 static
310 int CmpUniqueEqn(struct bintoken_unique_eqn *u1, struct bintoken_unique_eqn *u2)
311 {
312 assert(u1!=NULL);
313 assert(u2!=NULL);
314 assert(u1->len!=0);
315 assert(u2->len!=0);
316 assert(u1->str!=NULL);
317 assert(u2->str!=NULL);
318 if (u1==u2) {
319 /* should never, ever happen */
320 return 0;
321 }
322 if (u1->len != u2->len) {
323 /* I don't know whether this sorts increasing or decreasing len.
324 * not that it really matters. we're sorting on len first to avoid
325 * strcmp calls.
326 */
327 if (u1->len < u2->len) {
328 return -1;
329 } else {
330 return 1;
331 }
332 }
333 return strcmp(u1->str,u2->str);
334 }
335
336 /*
337 * Finds or inserts a unique eqn in the list eql.
338 * Records the unique index U in eql->rel2U[relindex].
339 * Returns 1 if added a record to eql referencing str.
340 * Returns 0 if str already exists in eql somewhere.
341 * len is the length of str.
342 * relindex is the index of the instance the string
343 * came from in some instance list.
344 */
345 static
346 int BinTokenAddUniqueEqn(struct bintoken_eqlist *eql, int relindex,
347 char *str, int len)
348 {
349 struct bintoken_unique_eqn test, *new, *old;
350 unsigned long pos;
351 assert(eql != NULL);
352 assert(relindex >= 0);
353 assert(str != NULL);
354
355 test.len = len;
356 test.str = str;
357 pos = gl_search(eql->ue,&test,(CmpFunc)CmpUniqueEqn);
358 if (!pos) {
359 /* create new unique eqn */
360 new = ASC_NEW(struct bintoken_unique_eqn);
361 assert(new!=NULL);
362 new->len = test.len;
363 new->firstrel = relindex;
364 new->refcount = 1;
365 eql->rel2U[relindex] = eql->nextnew;
366 new->indexU = (eql->nextnew)++;
367 new->str = str; /* keep string */
368 gl_insert_sorted(eql->ue,new,(CmpFunc)CmpUniqueEqn);
369 return 1;
370 } else {
371 /* saw it already */
372 old = (struct bintoken_unique_eqn *)gl_fetch(eql->ue,pos);
373 old->refcount++;
374 eql->rel2U[relindex] = old->indexU;
375 return 0;
376 }
377 }
378
379 /*
380 * C code specific stuff
381 */
382
383 /*
384 * includes the standard headers and any supporting functions
385 * we may require.
386 */
387 static
388 void WritePrologue(FILE *fp, struct Instance *root,
389 unsigned long len, int verbose)
390 {
391 if (verbose) {
392 CLINE("/*\n\tBinTokenSharesToC $Revision: 1.12 $");
393 FPRINTF(fp,"\t%lu relations in instance '",len);
394 WriteInstanceName(fp,root,NULL);
395 CLINE("'\n\t(possibly fewer C functions required)\n*/");
396 }
397 #ifdef HAVE_ERF
398 /* need to define this for btprolog.h to do the right thing */
399 CLINE("#define HAVE_ERF");
400 #endif
401
402 CLINE("#include <ascend/bintokens/btprolog.h>");
403 }
404
405 /* this function should be generalized or duplicated to
406 * handle other languages. It's almost there now.
407 */
408 static
409 enum bintoken_error GetResidualString(struct Instance *i,
410 int nrel,
411 struct RXNameData *rd,
412 enum rel_lang_format lang,
413 int *rellen,
414 char **streqn)
415 {
416 assert(i!=NULL);
417 assert(InstanceKind(i)==REL_INST);
418
419 *streqn = WriteRelationString(i,NULL,(WRSNameFunc)RelationVarXName,
420 rd,lang,rellen);
421 if (*streqn==NULL) {
422 FPRINTF(ASCERR,"Unable to generate code for (%d):\n",nrel);
423 WriteAnyInstanceName(ASCERR,i);
424 return BTE_badrel;
425 }
426 return BTE_ok;
427 }
428
429 /* this function should be generalized or duplicated to
430 * handle other languages. Should be ok for most C-like languages.
431 * Writes K&R C.
432 */
433 static
434 enum bintoken_error WriteResidualCode(FILE *fp, struct Instance *i,
435 int nrel, int verbose,
436 char *streqn, int timesused)
437 {
438 #define C_INDENT 4
439 #define C_WIDTH 70
440 assert(i!=NULL);
441
442 if (streqn==NULL) {
443 return BTE_badrel;
444 }
445
446 if (verbose) {
447 /* put in a little header */
448 CLINE("\n/*");
449 FPRINTF(fp,"\tRelation used %d times, prototyped from:\n",timesused);
450 FPRINTF(fp,"\t");
451 /* Use fastest path to a root */
452 WriteAnyInstanceName(fp,i);
453 CLINE("\n*/");
454 }
455
456 CLINE("static");
457 FPRINTF(fp, "void r_%d(double *x,double *residual){\n", nrel);
458 CLINE("\t*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 ExportBinTokenCTable(struct TableC *t,int size){
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 ASC_FREE(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 ASC_FREE(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 = ASC_NEW_ARRAY(int,newlen);
535 if (r->rd.indices == NULL) {
536 ASC_PANIC("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 = ASC_NEW_ARRAY(int,len);
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 ASC_FREE(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 ASC_EXPORT %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 ASC_FREE(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_NOLINE(ASC_PROG_NOTE,"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 error_reporter(ASC_PROG_WARNING,libname,0,"Failed to load library (init function %s)",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 = ASC_STRDUP(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)buildcommand;
740
741 switch(err) {
742 case BTE_ok:
743 mess="A-ok";
744 break;
745 case BTE_badrel:
746 mess="Bad relation found in code generation";
747 break;
748 case BTE_write:
749 mess="Unable to write file";
750 break;
751 case BTE_build:
752 mess="Unable to build binary";
753 break;
754 case BTE_load:
755 mess="Loaded binary does not match code written";
756 break;
757 case BTE_mem:
758 mess="Insufficient memory to write code.";
759 break;
760 default:
761 mess="Unknown error in BinTokenErrorMessage";
762 break;
763 }
764 error_reporter(ASC_PROG_ERR,filename,0,"%s",mess);
765 }
766
767 void BinTokensCreate(struct Instance *root, enum bintoken_kind method){
768 struct gl_list_t *rellist;
769 char *cbuf;
770 enum bintoken_error status;
771 char *srcname = g_bt_data.srcname;
772 char *objname = g_bt_data.objname;
773 char *libname = g_bt_data.libname;
774 char *buildcommand = g_bt_data.buildcommand;
775 char *unlinkcommand = g_bt_data.unlinkcommand;
776 int verbose = g_bt_data.verbose;
777
778 /*CONSOLE_DEBUG("...");*/
779
780 if (g_bt_data.maxrels == 0) {
781 #ifdef BINTOKEN_VERBOSE
782 ERROR_REPORTER_HERE(ASC_PROG_NOTE,"BinTokensCreate disabled (maxrels=0)\n");
783 #endif
784 return;
785 }
786 if (srcname == NULL || buildcommand == NULL || unlinkcommand == NULL) {
787 ERROR_REPORTER_HERE(ASC_PROG_WARNING,"BinaryTokensCreate called with no options set: ignoring");
788 return;
789 }
790
791 rellist =
792 CollectTokenRelationsWithUniqueBINlessShares(root,g_bt_data.maxrels);
793 if (rellist==NULL) {
794 ERROR_REPORTER_HERE(ASC_PROG_WARNING
795 ,"BinaryTokensCreate found 0 or too many unique relations."
796 );
797 return;
798 }
799
800 ERROR_REPORTER_HERE(ASC_USER_NOTE,"Creating bintokens\n");
801 CONSOLE_DEBUG("buildcommand = %s",buildcommand);
802
803 switch (method) {
804 case BT_C:
805 /* generate code */
806 status = BinTokenSharesToC(root,rellist,srcname,verbose);
807 if (status != BTE_ok) {
808 BinTokenErrorMessage(status,root,srcname,buildcommand);
809 break; /* leave source file there if partial */
810 }
811 status = BinTokenCompileC(buildcommand);
812 if (status != BTE_ok) {
813 BinTokenErrorMessage(status,root,objname,buildcommand);
814 break; /* leave source file there to debug */
815 } else {
816 if (g_bt_data.housekeep) {
817 /* trash src */
818 cbuf = ASC_NEW_ARRAY(char,strlen(unlinkcommand)+1+strlen(srcname)+1);
819 assert(cbuf!=NULL);
820 sprintf(cbuf,"%s %s",unlinkcommand,srcname);
821 system(cbuf); /* we don't care if the delete fails */
822 ASC_FREE(cbuf);
823 /* trash obj */
824 cbuf = ASC_NEW_ARRAY(char,strlen(unlinkcommand)+1+strlen(objname)+1);
825 assert(cbuf!=NULL);
826 sprintf(cbuf,"%s %s",unlinkcommand,objname);
827 system(cbuf); /* we don't care if the delete fails */
828 ASC_FREE(cbuf);
829 }
830
831 status = BinTokenLoadC(rellist,libname,g_bt_data.regname);
832 if (status != BTE_ok) {
833 BinTokenErrorMessage(status,root,libname,buildcommand);
834 /* leave source,binary files there to debug */
835 }/*else{
836 FPRINTF(ASCERR,"BINTOKENLOADC OK\n");
837 }*/
838 }
839 break;
840 default:
841 ERROR_REPORTER_HERE(ASC_PROG_ERR,"BinaryTokensCreate called with unavailable method '%d'",(int)method);
842 break;
843 }
844 gl_destroy(rellist);
845 return;
846 }
847
848 /*
849 * Returns 1 if can't evaluate function.
850 * Vars is assumed already filled with values.
851 * This function must not malloc or free memory.
852 */
853 int BinTokenCalcResidual(int btable, int bindex, double *vars, double *residual)
854 {
855 if (btable < 1 || bindex < 1) {
856 return 1;
857 }
858 switch (g_bt_data.tables[btable].type) {
859 case BT_error:
860 return 1; /* expired table! */
861 case BT_C: {
862 struct TableC *ctable;
863 BinTokenFPtr func;
864 ctable = (struct TableC *)g_bt_data.tables[btable].tu;
865 assert(ctable != NULL);
866 if (bindex > g_bt_data.tables[btable].size) {
867 return 1;
868 }
869 func = ctable[bindex].F;
870 #if 0 /* setting this to 1 is a major performance hit. */
871 if (func != NULL) {
872 if (SETJMP(g_fpe_env)==0) {
873 (*func)(vars,residual);
874 return 0;
875 } else {
876 Asc_SignalRecover();
877 return 1;
878 }
879 }
880 return 1;
881 #else
882 (*func)(vars,residual);
883 return 0;
884 #endif
885 }
886 case BT_F77: {
887 /* this case needs to be cleaned up to match the C case above. */
888 struct TableF *ftable;
889 BinTokenSPtr subroutine;
890 ftable = (struct TableF *)g_bt_data.tables[btable].tu;
891 assert(ftable != NULL);
892 if (bindex < 1 || bindex > g_bt_data.tables[btable].size) {
893 return 1;
894 }
895 subroutine = ftable[0].S; /* its all in func 0 */
896 if (subroutine != NULL) {
897 int ForG,status;
898 ForG = BinTokenRESIDUAL;
899 #ifdef ASC_SIGNAL_TRAPS
900 Asc_SignalHandlerPush(SIGFPE,Asc_SignalTrap);
901 if (SETJMP(g_fpe_env)==0) {
902 #endif /* ASC_SIGNAL_TRAPS */
903 (*subroutine)(vars,NULL,residual,&ForG,&bindex,&status);
904 #ifdef ASC_SIGNAL_TRAPS
905 Asc_SignalHandlerPop(SIGFPE,Asc_SignalTrap);
906 #endif /* ASC_SIGNAL_TRAPS */
907 return status;
908 #ifdef ASC_SIGNAL_TRAPS
909 } else {
910 Asc_SignalHandlerPop(SIGFPE,Asc_SignalTrap);
911 return 1;
912 }
913 #endif /* ASC_SIGNAL_TRAPS */
914 }
915 return 1;
916 }
917 default:
918 return 1;
919 }
920 }
921
922 /*
923 * Returns nonzero if can't evaluate gradient.
924 * Vars is assumed already filled with values.
925 */
926 int BinTokenCalcGradient(int btable, int bindex,double *vars,
927 double *residual, double *gradient)
928 {
929 if (btable == 0) {
930 return 1;
931 }
932 switch (g_bt_data.tables[btable].type) {
933 case BT_error:
934 return 1; /* expired table! */
935 case BT_C: {
936 /* signal handling needs to match func above. this is slow here. */
937 struct TableC *ctable;
938 BinTokenGPtr func;
939 ctable = (struct TableC *)g_bt_data.tables[btable].tu;
940 assert(ctable != NULL);
941 if (bindex < 1 || bindex > g_bt_data.tables[btable].size) {
942 return 1;
943 }
944 func = ctable[bindex].G;
945 if (func != NULL) {
946 #ifdef ASC_SIGNAL_TRAPS
947 Asc_SignalHandlerPush(SIGFPE,Asc_SignalTrap);
948 if (SETJMP(g_fpe_env)==0) {
949 #endif /* ASC_SIGNAL_TRAPS */
950 (*func)(vars,gradient,residual);
951 #ifdef ASC_SIGNAL_TRAPS
952 Asc_SignalHandlerPop(SIGFPE,Asc_SignalTrap);
953 #endif /* ASC_SIGNAL_TRAPS */
954 return 0;
955 #ifdef ASC_SIGNAL_TRAPS
956 } else {
957 Asc_SignalHandlerPop(SIGFPE,Asc_SignalTrap);
958 return 1;
959 }
960 #endif /* ASC_SIGNAL_TRAPS */
961 }
962 return 1;
963 }
964 case BT_F77: {
965 struct TableF *ftable;
966 BinTokenSPtr subroutine;
967 ftable = (struct TableF *)g_bt_data.tables[btable].tu;
968 assert(ftable != NULL);
969 if (bindex < 1 || bindex > g_bt_data.tables[btable].size) {
970 return 1;
971 }
972 subroutine = ftable[0].S; /* its all in func 0 */
973 if (subroutine != NULL) {
974 int ForG,status;
975 ForG = BinTokenGRADIENT;
976 #ifdef ASC_SIGNAL_TRAPS
977 Asc_SignalHandlerPush(SIGFPE,Asc_SignalTrap);
978 if (SETJMP(g_fpe_env)==0) {
979 #endif /* ASC_SIGNAL_TRAPS */
980 (*subroutine)(vars,gradient,residual,&ForG,&bindex,&status);
981 #ifdef ASC_SIGNAL_TRAPS
982 Asc_SignalHandlerPop(SIGFPE,Asc_SignalTrap);
983 #endif /* ASC_SIGNAL_TRAPS */
984 return status;
985 #ifdef ASC_SIGNAL_TRAPS
986 } else {
987 status = 1;
988 }
989 Asc_SignalHandlerPop(SIGFPE,Asc_SignalTrap);
990 return status;
991 #endif /* ASC_SIGNAL_TRAPS */
992 }
993 return 1;
994 }
995 default:
996 return 1;
997 }
998 }
999
1000 #ifdef UNRELOCATE_TEST_BT
1001 /* this code may be out of date, but should be saved. */
1002 #ifdef RELOCATE_STREAMS
1003 FILE *g_ascend_errors = stderr;
1004 #endif
1005
1006 int main() { /* built only if TESTBT defined TRUE in bintoken.c */
1007 double res;
1008 gl_init_pool();
1009 g_test_list = gl_create(5);
1010 gl_append_ptr(g_test_list,(void *)10);
1011 gl_append_ptr(g_test_list,(void *)20);
1012 gl_append_ptr(g_test_list,(void *)30);
1013 gl_append_ptr(g_test_list,(void *)40);
1014 gl_append_ptr(g_test_list,(void *)50);
1015 BinTokenSetOptions(
1016 "/tmp/btsrc.c","/tmp/btsrc.o","/tmp/btsrc.so"
1017 ,"make -f foo/Makefile BTTARGET=/tmp/btsrc /tmp/btsrc"
1018 ,"/bin/rm"
1019 ,1000,1,0
1020 );
1021 BinTokensCreate((struct Instance *)1, BT_C);
1022 BinTokenCalcResidual(1,1,&res,&res);
1023 FPRINTF(ASCERR,"residual 1 = %g\n",res);
1024 BinTokenClearTables();
1025 gl_destroy(g_test_list);
1026 gl_destroy_pool();
1027 return 0;
1028 }
1029 #endif /*unrelocate test bt*/
1030
1031 /* vim: set ts=2 et: */
1032

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