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

Annotation of /trunk/base/generic/compiler/bintoken.c

Parent Directory Parent Directory | Revision Log Revision Log


Revision 708 - (hide annotations) (download) (as text)
Tue Jun 27 07:34:31 2006 UTC (18 years ago) by johnpye
File MIME type: text/x-csrc
File size: 28939 byte(s)
Replaced some references to ascmalloc with ASC_NEW_ARRAY
1 johnpye 62 /* ex: set ts=8 : */
2 johnpye 399 /*
3 aw0a 1 * bintoken.c
4     * By Benjamin A. Allan
5 johnpye 399 * Jan 7, 1998.
6 aw0a 1 * 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 johnpye 399 #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 johnpye 669 #include "expr_types.h"
55 johnpye 399 #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 aw0a 1 /* last */
67 johnpye 399 #include "bintoken.h"
68     #include "btprolog.h"
69 aw0a 1
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 ben.allan 14 } g_bt_data = {NULL,0,0,NULL,0,"ERRARCHIVE",NULL,NULL,NULL,NULL,NULL,1,0,0};
112 aw0a 1
113 johnpye 89 /**
114 jds 101 * 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 johnpye 89 */
117 aw0a 1 static
118 johnpye 89 int bt_string_replace(CONST char *new, char **ptr)
119 aw0a 1 {
120     if (*ptr == new) {
121 johnpye 190 return 0;
122 aw0a 1 }
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 jds 101 *ptr = (char *)new;
133 aw0a 1 }
134     return 0;
135     }
136 jds 101
137 aw0a 1 /*
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 ben.allan 45 * strings given should not be allocated from tcl.
142 aw0a 1 */
143 johnpye 62 int BinTokenSetOptions(CONST char *srcname,
144     CONST char *objname,
145     CONST char *libname,
146     CONST char *buildcommand,
147     CONST char *unlinkcommand,
148 aw0a 1 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 johnpye 708 ASC_NEW_ARRAY(struct bt_table,20);
178 aw0a 1 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 johnpye 190 /*ERROR_REPORTER_NOLINE(ASC_PROG_ERR,"UNLOADING %s",g_bt_data.tables[btable].name);*/
225 aw0a 1 Asc_DynamicUnLoad(g_bt_data.tables[btable].name);
226 johnpye 159 #else
227 johnpye 190 ERROR_REPORTER_NOLINE(ASC_PROG_ERR,"Dynamic Unloading not available in this build");
228 aw0a 1 #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 johnpye 159 }else{
234     CONSOLE_DEBUG("Deleting one reference...");
235 aw0a 1 }
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 johnpye 154 CLINE("/*\n\tBinTokenSharesToC $Revision: 1.12 $");
395     FPRINTF(fp,"\t%lu relations in instance '",len);
396 aw0a 1 WriteInstanceName(fp,root,NULL);
397 johnpye 154 CLINE("'\n\t(possibly fewer C functions required)\n*/");
398 aw0a 1 }
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 johnpye 122
404     CLINE("#include <btprolog.h>");
405 aw0a 1 }
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 johnpye 89 FPRINTF(fp,"\tRelation used %d times, prototyped from:\n",timesused);
452     FPRINTF(fp,"\t");
453 aw0a 1 /* Use fastest path to a root */
454     WriteAnyInstanceName(fp,i);
455 johnpye 89 CLINE("\n*/");
456 aw0a 1 }
457    
458     CLINE("static");
459 johnpye 95 FPRINTF(fp, "void r_%d(double *x,double *residual){\n", nrel);
460 johnpye 89 CLINE("\t*residual =");
461 aw0a 1 #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 johnpye 485 int ExportBinTokenCTable(struct TableC *t,int size){
483 aw0a 1 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 johnpye 669 r->rd.indices = ASC_NEW_ARRAY(int,newlen);
537 aw0a 1 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 johnpye 669 error = ASC_NEW_ARRAY(int,len);
585 aw0a 1 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 johnpye 89 /** @TODO FIXME win32 has getpid but it is bogus as uniquifier. */
630 aw0a 1 /* 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 johnpye 480 FPRINTF(fp,"int ASC_DLLSPEC %s(){\n",g_bt_data.regname);
633 johnpye 89 CLINE("\tint status;");
634     FPRINTF(fp,"\tstatic struct TableC g_ctable[%lu] =\n",len+1);
635     CLINE("\t\t{ {NULL, NULL},");
636 aw0a 1 len--; /* to fudge the final comma */
637     for (c=1; c <= len; c++) {
638     if (error[c-1] == BTE_ok) {
639 johnpye 89 FPRINTF(fp,"\t\t\t{r_%u, NULL},\n",eql.rel2U[c]);
640 aw0a 1 } else {
641 johnpye 89 FPRINTF(fp,"\t\t\t{NULL, NULL},\n");
642 aw0a 1 }
643     }
644     len++;
645     if (error[len-1] == BTE_ok) {
646 johnpye 89 FPRINTF(fp,"\t\t\t{r_%u, NULL}\n",eql.rel2U[c]);
647 aw0a 1 } else {
648 johnpye 89 FPRINTF(fp,"\t\t\t{NULL, NULL}\n");
649 aw0a 1 }
650 johnpye 89 CLINE("\t\t};");
651     FPRINTF(fp,"\tstatus = ExportBinTokenCTable(g_ctable,%lu);\n",len+1);
652     CLINE("\treturn status;");
653 aw0a 1 if (verbose) {
654 johnpye 89 FPRINTF(fp,"\t/* %lu unique equations */\n",gl_length(eql.ue));
655 johnpye 154 FPRINTF(ASCERR,"Prepared %lu external C functions.\n",gl_length(eql.ue));
656 aw0a 1 }
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 johnpye 190 ERROR_REPORTER_NOLINE(ASC_PROG_NOTE,"Starting build, command:\n%s\n",buildcommand);
670 aw0a 1 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 johnpye 159 error_reporter(ASC_PROG_WARNING,libname,0,"Failed to load library (init function %s)",regname);
708 aw0a 1 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 ben.allan 16 g_bt_data.tables[g_bt_data.nextid].name = ascstrdup(libname);
726 aw0a 1 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 johnpye 159 error_reporter(ASC_PROG_ERR,filename,0,"%s",mess);
767 aw0a 1 }
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 jds 216 FPRINTF(ASCERR,"%sBinaryTokensCreate called with no options set.\n",
786 aw0a 1 StatioLabel(3));
787     return;
788 johnpye 399 }
789 aw0a 1
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 johnpye 190
827 johnpye 62 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 johnpye 76 }/*else{
832 johnpye 62 FPRINTF(ASCERR,"BINTOKENLOADC OK\n");
833 johnpye 76 }*/
834 aw0a 1 }
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 ben.allan 14 #ifndef NO_SIGNAL_TRAPS
900 aw0a 1 Asc_SignalHandlerPush(SIGFPE,Asc_SignalTrap);
901     if (setjmp(g_fpe_env)==0) {
902 ben.allan 14 #endif /* NO_SIGNAL_TRAPS */
903 aw0a 1 (*subroutine)(vars,NULL,residual,&ForG,&bindex,&status);
904 ben.allan 14 #ifndef NO_SIGNAL_TRAPS
905 aw0a 1 Asc_SignalHandlerPop(SIGFPE,Asc_SignalTrap);
906 ben.allan 14 #endif /* NO_SIGNAL_TRAPS */
907 aw0a 1 return status;
908 ben.allan 14 #ifndef NO_SIGNAL_TRAPS
909 aw0a 1 } else {
910     Asc_SignalHandlerPop(SIGFPE,Asc_SignalTrap);
911     return 1;
912     }
913 ben.allan 14 #endif /* NO_SIGNAL_TRAPS */
914 aw0a 1 }
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 ben.allan 14 #ifndef NO_SIGNAL_TRAPS
949 aw0a 1 Asc_SignalHandlerPush(SIGFPE,Asc_SignalTrap);
950     if (setjmp(g_fpe_env)==0) {
951 ben.allan 14 #endif /* NO_SIGNAL_TRAPS */
952 aw0a 1 (*func)(vars,gradient,residual);
953 ben.allan 14 #ifndef NO_SIGNAL_TRAPS
954 aw0a 1 Asc_SignalHandlerPop(SIGFPE,Asc_SignalTrap);
955 ben.allan 14 #endif /* NO_SIGNAL_TRAPS */
956 aw0a 1 return 0;
957 ben.allan 14 #ifndef NO_SIGNAL_TRAPS
958 aw0a 1 } else {
959     Asc_SignalHandlerPop(SIGFPE,Asc_SignalTrap);
960     return 1;
961     }
962 ben.allan 14 #endif /* NO_SIGNAL_TRAPS */
963 aw0a 1 }
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 ben.allan 14 #ifndef NO_SIGNAL_TRAPS
979 aw0a 1 Asc_SignalHandlerPush(SIGFPE,Asc_SignalTrap);
980     if (setjmp(g_fpe_env)==0) {
981 ben.allan 14 #endif /* NO_SIGNAL_TRAPS */
982 aw0a 1 (*subroutine)(vars,gradient,residual,&ForG,&bindex,&status);
983 ben.allan 14 #ifndef NO_SIGNAL_TRAPS
984 aw0a 1 Asc_SignalHandlerPop(SIGFPE,Asc_SignalTrap);
985 ben.allan 14 #endif /* NO_SIGNAL_TRAPS */
986 aw0a 1 return status;
987 ben.allan 14 #ifndef NO_SIGNAL_TRAPS
988 aw0a 1 } else {
989     status = 1;
990     }
991     Asc_SignalHandlerPop(SIGFPE,Asc_SignalTrap);
992     return status;
993 ben.allan 14 #endif /* NO_SIGNAL_TRAPS */
994 aw0a 1 }
995     return 1;
996     }
997     case BT_SunJAVA:
998     case BT_MsJAVA:
999     default:
1000     return 1;
1001     }
1002     }
1003    
1004 johnpye 506 /*
1005     /* this code may be out of date, but should be saved. *
1006 aw0a 1 FILE *g_ascend_errors = stderr;
1007 johnpye 506 int main() { /* built only if TESTBT defined TRUE in bintoken.c *
1008 aw0a 1 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 johnpye 708 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 aw0a 1 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 johnpye 506 */

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