/[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 708 - (show annotations) (download) (as text)
Tue Jun 27 07:34:31 2006 UTC (17 years, 11 months ago) by johnpye
File MIME type: text/x-csrc
File size: 28939 byte(s)
Replaced some references to ascmalloc with ASC_NEW_ARRAY
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.h" /* for symchar */
51 #include "fractions.h"
52 #include "dimen.h"
53 #include "functype.h"
54 #include "expr_types.h"
55 #include "stattypes.h"
56 #include "statio.h"
57 #include "instance_enum.h"
58 #include "instquery.h"
59 #include "instance_io.h"
60 #include "relation_type.h"
61 #include "relation_io.h"
62 #include "find.h"
63 #include "relation.h"
64 #include "relation_util.h"
65 #include "mathinst.h"
66 /* last */
67 #include "bintoken.h"
68 #include "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 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 * 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_NOLINE(ASC_PROG_ERR,"UNLOADING %s",g_bt_data.tables[btable].name);*/
225 Asc_DynamicUnLoad(g_bt_data.tables[btable].name);
226 #else
227 ERROR_REPORTER_NOLINE(ASC_PROG_ERR,"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 ExportBinTokenCTable(struct TableC *t,int size){
483 if (g_bt_data.newtable != NULL || t == NULL || size < 1) {
484 return 1;
485 }
486 g_bt_data.newtable = (union TableUnion *)t;
487 g_bt_data.newtablesize = size;
488 return 0;
489 }
490
491 struct reusable_rxnd {
492 struct RXNameData rd;
493 unsigned long cap;
494 };
495
496 /*
497 * puts an index list in r->rd which is just the shift by 1
498 * so r->rd.indices[j+1] == j.
499 */
500 static
501 void ResizeIndices(struct Instance *rel, struct reusable_rxnd *r)
502 {
503 unsigned long newlen,j;
504 assert(r!=NULL);
505
506 /* free and return if NULL rel */
507 if (rel == NULL) {
508 if (r->rd.indices != NULL) {
509 ascfree(r->rd.indices);
510 r->rd.indices = NULL;
511 r->cap = 0;
512 }
513 return;
514 }
515
516 /* get desired size */
517 newlen = NumberVariables(GetInstanceRelationOnly(rel));
518 newlen++; /* gotta remember to allow for indexing from 1 */
519
520 /* skip out if we have it already */
521 if (newlen <= r->cap) {
522 return;
523 }
524
525 if (r->rd.indices != NULL) {
526 /* assume we'll grow again and try not to do it often */
527 ascfree(r->rd.indices);
528 r->rd.indices = NULL;
529 newlen *= 2;
530 }
531 /* require min */
532 if (newlen < 100) {
533 newlen = 100;
534 }
535 /* create mem_*/
536 r->rd.indices = ASC_NEW_ARRAY(int,newlen);
537 if (r->rd.indices == NULL) {
538 Asc_Panic(2, "BinTokenSharesToC","out of memory error");
539 exit(2);
540 }
541 /* set up one-less indices */
542 for (j = 0; j < newlen; j++) {
543 r->rd.indices[j] = (int)j - 1;
544 }
545 r->cap = newlen;
546 }
547
548 /*
549 * generate code for a table of function pointers and the function
550 * pointers also in an archive load function.
551 * The table is always 1 pair larger than rellist since by convention
552 * index 0 has the NULL functions.
553 */
554 static
555 enum bintoken_error BinTokenSharesToC(struct Instance *root,
556 struct gl_list_t *rellist,
557 char *srcname,
558 int verbose)
559 {
560 int *error;
561 FILE *fp;
562 struct Instance *i;
563 char *str;
564 int slen;
565 struct bintoken_unique_eqn *eqn;
566 struct bintoken_eqlist eql;
567 unsigned long c, len;
568 int pid;
569 int eqns_done;
570 struct reusable_rxnd rrd = {{"x[",NULL,"]"},0};
571
572 if (root == NULL || rellist == NULL) {
573 return BTE_ok;
574 }
575 len = gl_length(rellist);
576 if (!len) {
577 return BTE_ok;
578 }
579 fp = fopen(srcname,"w+");
580 if (fp == NULL) {
581 return BTE_write;
582 }
583 eqns_done = 0;
584 error = ASC_NEW_ARRAY(int,len);
585 WritePrologue(fp,root,len,verbose);
586
587 /* algorithm to collect eqns:
588 * (at the cost of more string memory, since we keep unique strings while
589 * determining minimum set of C functions to write).
590 * Really, the instantiator could be taking steps to make this less necesssary,
591 * but even then the compiler will miss some similarities arising from
592 * different Statements.
593 */
594
595 if (InitEQData(&eql,(int)len)!= 0) {
596 fclose(fp);
597 return BTE_mem;
598 }
599
600 /* get unique set of code strings. */
601 for (c=1; c <= len; c++) {
602 i = gl_fetch(rellist,c);
603 /* make space and configure for subscript translation from 1 to 0 */
604 ResizeIndices(i,&rrd);
605 error[c-1] = GetResidualString(i,(int)c,&(rrd.rd),relio_C,&slen,&str);
606 if (error[c-1] == BTE_ok) {
607 eqns_done++;
608 if (BinTokenAddUniqueEqn(&eql,(int)c,str,slen) == 0) {
609 ascfree(str);
610 } /* else string is kept in eql and killed later */
611 }
612 /* else { eql.rel2U[c] = -1; } needed? */
613 }
614 ResizeIndices(NULL,&rrd);
615 if (!eqns_done) {
616 /* no generable code. clean up and leave. */
617 fclose(fp);
618 DestroyEQData(&eql);
619 return BTE_badrel;
620 }
621 for (c = gl_length(eql.ue); c > 0; c--) {
622 eqn = (struct bintoken_unique_eqn *)gl_fetch(eql.ue,c);
623 i = gl_fetch(rellist,eqn->firstrel);
624 WriteResidualCode(fp,i,eqn->indexU,verbose,eqn->str,eqn->refcount);
625 /* here we could also write gradient code based on i, indexU. */
626 }
627 /* write the registered function name */
628 pid = getpid();
629 /** @TODO FIXME win32 has getpid but it is bogus as uniquifier. */
630 /* so long as makefile deletes previous dll, windows is ok though */
631 sprintf(g_bt_data.regname,"BinTokenArch_%d_%d",++(g_bt_data.nextid),(int)pid);
632 FPRINTF(fp,"int ASC_DLLSPEC %s(){\n",g_bt_data.regname);
633 CLINE("\tint status;");
634 FPRINTF(fp,"\tstatic struct TableC g_ctable[%lu] =\n",len+1);
635 CLINE("\t\t{ {NULL, NULL},");
636 len--; /* to fudge the final comma */
637 for (c=1; c <= len; c++) {
638 if (error[c-1] == BTE_ok) {
639 FPRINTF(fp,"\t\t\t{r_%u, NULL},\n",eql.rel2U[c]);
640 } else {
641 FPRINTF(fp,"\t\t\t{NULL, NULL},\n");
642 }
643 }
644 len++;
645 if (error[len-1] == BTE_ok) {
646 FPRINTF(fp,"\t\t\t{r_%u, NULL}\n",eql.rel2U[c]);
647 } else {
648 FPRINTF(fp,"\t\t\t{NULL, NULL}\n");
649 }
650 CLINE("\t\t};");
651 FPRINTF(fp,"\tstatus = ExportBinTokenCTable(g_ctable,%lu);\n",len+1);
652 CLINE("\treturn status;");
653 if (verbose) {
654 FPRINTF(fp,"\t/* %lu unique equations */\n",gl_length(eql.ue));
655 FPRINTF(ASCERR,"Prepared %lu external C functions.\n",gl_length(eql.ue));
656 }
657 CLINE("}");
658
659 ascfree(error);
660 DestroyEQData(&eql);
661 fclose(fp);
662 return BTE_ok;
663 }
664
665 static
666 enum bintoken_error BinTokenCompileC(char *buildcommand)
667 {
668 int status;
669 ERROR_REPORTER_NOLINE(ASC_PROG_NOTE,"Starting build, command:\n%s\n",buildcommand);
670 status = system(buildcommand);
671 if (status) {
672 FPRINTF(ASCERR,"\nBUILD returned %d\n",status);
673 return BTE_build;
674 }
675 return BTE_ok;
676 }
677
678 static
679 void BinTokenResetHooks()
680 {
681 g_bt_data.tables[g_bt_data.nextid].type = BT_error;
682 g_bt_data.newtable = NULL;
683 g_bt_data.newtablesize = 0;
684 }
685
686 static
687 void BinTokenHookToTable(int entry, enum bintoken_kind type)
688 {
689 g_bt_data.tables[entry].tu = g_bt_data.newtable;
690 g_bt_data.tables[entry].size = g_bt_data.newtablesize;
691 g_bt_data.tables[entry].btable = entry;
692 g_bt_data.tables[entry].type = type;
693 g_bt_data.newtable = NULL;
694 g_bt_data.newtablesize = 0;
695 }
696
697 static
698 enum bintoken_error BinTokenLoadC(struct gl_list_t *rellist,
699 char *libname,
700 char *regname)
701 {
702 int status;
703 unsigned long c,len;
704 BinTokenCheckCapacity();
705 status = Asc_DynamicLoad(libname,regname);
706 if (status != 0) {
707 error_reporter(ASC_PROG_WARNING,libname,0,"Failed to load library (init function %s)",regname);
708 BinTokenResetHooks();
709 /* could do this maybe, but not needed if we want each
710 * relation to get one shot only..
711 * for (c=1;c <= len; c++) {
712 * RelationSetBinTokens((struct Instance *)gl_fetch(rellist,c),
713 * g_bt_data.nextid,(int)c);
714 * }
715 */
716 return BTE_load;
717 }
718 BinTokenHookToTable(g_bt_data.nextid,BT_C);
719 len = gl_length(rellist);
720 for (c=1;c <= len; c++) {
721 RelationSetBinTokens((struct Instance *)gl_fetch(rellist,c),
722 g_bt_data.nextid,(int)c);
723 }
724 g_bt_data.tables[g_bt_data.nextid].refcount = (int)len;
725 g_bt_data.tables[g_bt_data.nextid].name = ascstrdup(libname);
726 return BTE_ok;
727 }
728
729 /*
730 * this function should be more helpful.
731 */
732 static
733 void BinTokenErrorMessage(enum bintoken_error err,
734 struct Instance *root,
735 char *filename,
736 char *buildcommand)
737 {
738 char *mess;
739
740 (void)root;
741 (void)buildcommand;
742
743 switch(err) {
744 case BTE_ok:
745 mess="A-ok";
746 break;
747 case BTE_badrel:
748 mess="Bad relation found in code generation";
749 break;
750 case BTE_write:
751 mess="Unable to write file";
752 break;
753 case BTE_build:
754 mess="Unable to build binary";
755 break;
756 case BTE_load:
757 mess="Loaded binary does not match code written";
758 break;
759 case BTE_mem:
760 mess="Insufficient memory to write code.";
761 break;
762 default:
763 mess="Unknown error in BinTokenErrorMessage";
764 break;
765 }
766 error_reporter(ASC_PROG_ERR,filename,0,"%s",mess);
767 }
768
769 void BinTokensCreate(struct Instance *root, enum bintoken_kind method)
770 {
771 struct gl_list_t *rellist;
772 char *cbuf;
773 enum bintoken_error status;
774 char *srcname = g_bt_data.srcname;
775 char *objname = g_bt_data.objname;
776 char *libname = g_bt_data.libname;
777 char *buildcommand = g_bt_data.buildcommand;
778 char *unlinkcommand = g_bt_data.unlinkcommand;
779 int verbose = g_bt_data.verbose;
780
781 if (g_bt_data.maxrels == 0) {
782 return;
783 }
784 if (srcname == NULL || buildcommand == NULL || unlinkcommand == NULL) {
785 FPRINTF(ASCERR,"%sBinaryTokensCreate called with no options set.\n",
786 StatioLabel(3));
787 return;
788 }
789
790 rellist =
791 CollectTokenRelationsWithUniqueBINlessShares(root,g_bt_data.maxrels);
792 if (rellist==NULL) {
793 FPRINTF(ASCERR,
794 "%sBinaryTokensCreate found 0 or too many unique relations\n",
795 StatioLabel(2));
796 return;
797 }
798
799 switch (method) {
800 case BT_C:
801 /* generate code */
802 status = BinTokenSharesToC(root,rellist,srcname,verbose);
803 if (status != BTE_ok) {
804 BinTokenErrorMessage(status,root,srcname,buildcommand);
805 break; /* leave source file there if partial */
806 }
807 status = BinTokenCompileC(buildcommand);
808 if (status != BTE_ok) {
809 BinTokenErrorMessage(status,root,objname,buildcommand);
810 break; /* leave source file there to debug */
811 } else {
812 if (g_bt_data.housekeep) {
813 /* trash src */
814 cbuf = (char *)ascmalloc(strlen(unlinkcommand)+1+strlen(srcname)+1);
815 assert(cbuf!=NULL);
816 sprintf(cbuf,"%s %s",unlinkcommand,srcname);
817 system(cbuf); /* we don't care if the delete fails */
818 ascfree(cbuf);
819 /* trash obj */
820 cbuf = (char *)ascmalloc(strlen(unlinkcommand)+1+strlen(objname)+1);
821 assert(cbuf!=NULL);
822 sprintf(cbuf,"%s %s",unlinkcommand,objname);
823 system(cbuf); /* we don't care if the delete fails */
824 ascfree(cbuf);
825 }
826
827 status = BinTokenLoadC(rellist,libname,g_bt_data.regname);
828 if (status != BTE_ok) {
829 BinTokenErrorMessage(status,root,libname,buildcommand);
830 /* leave source,binary files there to debug */
831 }/*else{
832 FPRINTF(ASCERR,"BINTOKENLOADC OK\n");
833 }*/
834 }
835 break;
836 case BT_F77:
837 case BT_SunJAVA:
838 case BT_MsJAVA:
839 default:
840 FPRINTF(ASCERR,"%sBinaryTokensCreate called with\n" /* no comma */
841 " unavailable method %d",StatioLabel(3),(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 #ifndef NO_SIGNAL_TRAPS
900 Asc_SignalHandlerPush(SIGFPE,Asc_SignalTrap);
901 if (setjmp(g_fpe_env)==0) {
902 #endif /* NO_SIGNAL_TRAPS */
903 (*subroutine)(vars,NULL,residual,&ForG,&bindex,&status);
904 #ifndef NO_SIGNAL_TRAPS
905 Asc_SignalHandlerPop(SIGFPE,Asc_SignalTrap);
906 #endif /* NO_SIGNAL_TRAPS */
907 return status;
908 #ifndef NO_SIGNAL_TRAPS
909 } else {
910 Asc_SignalHandlerPop(SIGFPE,Asc_SignalTrap);
911 return 1;
912 }
913 #endif /* NO_SIGNAL_TRAPS */
914 }
915 return 1;
916 }
917 case BT_SunJAVA:
918 case BT_MsJAVA:
919 default:
920 return 1;
921 }
922 }
923
924 /*
925 * Returns nonzero if can't evaluate gradient.
926 * Vars is assumed already filled with values.
927 */
928 int BinTokenCalcGradient(int btable, int bindex,double *vars,
929 double *residual, double *gradient)
930 {
931 if (btable == 0) {
932 return 1;
933 }
934 switch (g_bt_data.tables[btable].type) {
935 case BT_error:
936 return 1; /* expired table! */
937 case BT_C: {
938 /* signal handling needs to match func above. this is slow here. */
939 struct TableC *ctable;
940 BinTokenGPtr func;
941 ctable = (struct TableC *)g_bt_data.tables[btable].tu;
942 assert(ctable != NULL);
943 if (bindex < 1 || bindex > g_bt_data.tables[btable].size) {
944 return 1;
945 }
946 func = ctable[bindex].G;
947 if (func != NULL) {
948 #ifndef NO_SIGNAL_TRAPS
949 Asc_SignalHandlerPush(SIGFPE,Asc_SignalTrap);
950 if (setjmp(g_fpe_env)==0) {
951 #endif /* NO_SIGNAL_TRAPS */
952 (*func)(vars,gradient,residual);
953 #ifndef NO_SIGNAL_TRAPS
954 Asc_SignalHandlerPop(SIGFPE,Asc_SignalTrap);
955 #endif /* NO_SIGNAL_TRAPS */
956 return 0;
957 #ifndef NO_SIGNAL_TRAPS
958 } else {
959 Asc_SignalHandlerPop(SIGFPE,Asc_SignalTrap);
960 return 1;
961 }
962 #endif /* NO_SIGNAL_TRAPS */
963 }
964 return 1;
965 }
966 case BT_F77: {
967 struct TableF *ftable;
968 BinTokenSPtr subroutine;
969 ftable = (struct TableF *)g_bt_data.tables[btable].tu;
970 assert(ftable != NULL);
971 if (bindex < 1 || bindex > g_bt_data.tables[btable].size) {
972 return 1;
973 }
974 subroutine = ftable[0].S; /* its all in func 0 */
975 if (subroutine != NULL) {
976 int ForG,status;
977 ForG = BinTokenGRADIENT;
978 #ifndef NO_SIGNAL_TRAPS
979 Asc_SignalHandlerPush(SIGFPE,Asc_SignalTrap);
980 if (setjmp(g_fpe_env)==0) {
981 #endif /* NO_SIGNAL_TRAPS */
982 (*subroutine)(vars,gradient,residual,&ForG,&bindex,&status);
983 #ifndef NO_SIGNAL_TRAPS
984 Asc_SignalHandlerPop(SIGFPE,Asc_SignalTrap);
985 #endif /* NO_SIGNAL_TRAPS */
986 return status;
987 #ifndef NO_SIGNAL_TRAPS
988 } else {
989 status = 1;
990 }
991 Asc_SignalHandlerPop(SIGFPE,Asc_SignalTrap);
992 return status;
993 #endif /* NO_SIGNAL_TRAPS */
994 }
995 return 1;
996 }
997 case BT_SunJAVA:
998 case BT_MsJAVA:
999 default:
1000 return 1;
1001 }
1002 }
1003
1004 /*
1005 /* this code may be out of date, but should be saved. *
1006 FILE *g_ascend_errors = stderr;
1007 int main() { /* built only if TESTBT defined TRUE in bintoken.c *
1008 double res;
1009 char *b[5];
1010 gl_init_pool();
1011 g_test_list = gl_create(5);
1012 gl_append_ptr(g_test_list,(void *)10);
1013 gl_append_ptr(g_test_list,(void *)20);
1014 gl_append_ptr(g_test_list,(void *)30);
1015 gl_append_ptr(g_test_list,(void *)40);
1016 gl_append_ptr(g_test_list,(void *)50);
1017 b[0]=ASC_NEW_ARRAY(char,50);
1018 b[1]=ASC_NEW_ARRAY(char,50);
1019 b[2]=ASC_NEW_ARRAY(char,50);
1020 b[4]=ASC_NEW_ARRAY(char,50);
1021 b[5]=ASC_NEW_ARRAY(char,50);
1022 sprintf(b[0],"/tmp/btsrc.c");
1023 sprintf(b[1],"/tmp/btsrc.o");
1024 sprintf(b[2],"/tmp/btsrc.so");
1025 sprintf(b[3],"make -f foo/Makefile BTTARGET=/tmp/btsrc /tmp/btsrc");
1026 sprintf(b[4],"/bin/rm");
1027 BinTokenSetOptions(b[0],b[1],b[2],b[3],b[4],1000,1,0);
1028 BinTokensCreate((struct Instance *)1, BT_C);
1029 BinTokenCalcResidual(1,1,&res,&res);
1030 FPRINTF(ASCERR,"residual 1 = %g\n",res);
1031 BinTokenClearTables();
1032 gl_destroy(g_test_list);
1033 gl_destroy_pool();
1034 return 0;
1035 }
1036 */

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