/[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 1317 - (hide annotations) (download) (as text)
Mon Mar 5 14:11:37 2007 UTC (15 years, 5 months ago) by johnpye
File MIME type: text/x-csrc
File size: 28571 byte(s)
Added new 'system_jacobian' function for use by IDA (maybe elsewhere?)
Refactored the matrix output stuff in IDA.
Fixed the index checking in idaanalyse
Still a problem with checking rank of small matrices.
1 johnpye 62 /* ex: set ts=8 : */
2 johnpye 1046 /* ASCEND modelling environment
3     Copyright (C) 2006 Carnegie Mellon University
4     Copyright (C) 1998 Carnegie Mellon University
5 aw0a 1
6 johnpye 1046 This program is free software; you can redistribute it and/or modify
7     it under the terms of the GNU General Public License as published by
8     the Free Software Foundation; either version 2, or (at your option)
9     any later version.
10    
11     This program is distributed in the hope that it will be useful,
12     but WITHOUT ANY WARRANTY; without even the implied warranty of
13     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14     GNU General Public License for more details.
15    
16     You should have received a copy of the GNU General Public License
17     along with this program; if not, write to the Free Software
18     Foundation, Inc., 59 Temple Place - Suite 330,
19     Boston, MA 02111-1307, USA.
20     *//*
21     By Benjamin A. Allan
22     Jan 7, 1998.
23     Last in CVS:$Revision: 1.12 $ $Date: 1998/06/16 16:38:36 $ $Author: mthomas $
24     */
25    
26 aw0a 1 #if 0
27     TIMESTAMP = -DTIMESTAMP="\"by `whoami`@`hostname`\""
28     #endif
29     /*
30     * binary tokens implementation for real relation instances.
31     * much of this goes in bintoken.h.
32     */
33    
34 johnpye 1142 #include <unistd.h> /* for getpid() */
35    
36     #include <utilities/config.h>
37 johnpye 399 #include <utilities/ascConfig.h>
38     #include <utilities/ascMalloc.h>
39     #include <utilities/ascPrint.h>
40     #include <utilities/ascSignal.h>
41     #include <utilities/ascPanic.h>
42     #include <utilities/ascDynaLoad.h>
43     #include <general/list.h>
44     #include <general/dstring.h>
45     #include <general/pretty.h>
46 johnpye 1210
47 johnpye 1211
48    
49 johnpye 399 #include "functype.h"
50 johnpye 669 #include "expr_types.h"
51 johnpye 399 #include "stattypes.h"
52     #include "statio.h"
53     #include "instance_enum.h"
54     #include "instquery.h"
55     #include "instance_io.h"
56     #include "relation_io.h"
57     #include "find.h"
58 johnpye 908 #include "extfunc.h"
59     #include "rel_blackbox.h"
60 johnpye 399 #include "relation.h"
61     #include "relation_util.h"
62     #include "mathinst.h"
63 aw0a 1 /* last */
64 johnpye 399 #include "bintoken.h"
65     #include "btprolog.h"
66 aw0a 1
67     #define CLINE(a) FPRINTF(fp,"%s\n",(a))
68    
69     enum bintoken_error {
70     BTE_ok,
71     BTE_badrel,
72     BTE_write,
73     BTE_build,
74     BTE_load,
75     BTE_mem
76     };
77    
78     struct bt_table {
79     enum bintoken_kind type;
80     char *name;
81     union TableUnion *tu;
82     int btable; /* check id */
83     int refcount; /* total number of relation shares with btable = our number */
84     int size; /* may be larger than refcount. */
85     };
86    
87     /*
88     * slot to manage all the tables from, especially if we'll do
89     * dynamic unloading.
90     */
91     struct bt_data {
92     struct bt_table *tables;
93     int captables;
94     int nextid;
95     /* loading hooks */
96     union TableUnion *newtable;
97     int newtablesize;
98     char regname[256];
99     /* ui set build options */
100     char *srcname;
101     char *objname;
102     char *libname;
103     char *buildcommand;
104     char *unlinkcommand;
105     unsigned long maxrels; /* no more than this many C relations per file */
106     int verbose; /* comments in generated code */
107     int housekeep; /* if !=0, generated src files are deleted sometimes. */
108 ben.allan 14 } g_bt_data = {NULL,0,0,NULL,0,"ERRARCHIVE",NULL,NULL,NULL,NULL,NULL,1,0,0};
109 aw0a 1
110 johnpye 89 /**
111 jds 101 * In the C++ interface, the arguments of BinTokenSetOptions need to be
112     * const char*. But here, new can lose its constness in *ptr = new. - JP
113 johnpye 89 */
114 aw0a 1 static
115 johnpye 1046 int bt_string_replace(CONST char *new, char **ptr){
116     if(*ptr == new){
117     /* no destination specified */
118 johnpye 190 return 0;
119 aw0a 1 }
120 johnpye 1046 if(new == NULL){
121     /* free the current value */
122     if(*ptr != NULL) {
123     ASC_FREE(*ptr);
124 aw0a 1 *ptr = NULL;
125     }
126 johnpye 1046 }else{
127     /* free then reallocate */
128     if(*ptr != NULL){
129     ASC_FREE(*ptr);
130 aw0a 1 }
131 johnpye 1046 *ptr = ASC_NEW_ARRAY(char,strlen(new)+1);
132     strcpy(*ptr,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 johnpye 1046 frees global memory.
193     */
194 aw0a 1 void BinTokenClearTables(void)
195     {
196     if (g_bt_data.tables != NULL) {
197 johnpye 1046 ASC_FREE(g_bt_data.tables);
198 aw0a 1 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 johnpye 190 /*ERROR_REPORTER_NOLINE(ASC_PROG_ERR,"UNLOADING %s",g_bt_data.tables[btable].name);*/
224 aw0a 1 Asc_DynamicUnLoad(g_bt_data.tables[btable].name);
225 johnpye 159 #else
226 johnpye 190 ERROR_REPORTER_NOLINE(ASC_PROG_ERR,"Dynamic Unloading not available in this build");
227 aw0a 1 #endif /* havedlunload */
228 johnpye 1046 ASC_FREE(g_bt_data.tables[btable].name);
229 aw0a 1 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 johnpye 159 }else{
233     CONSOLE_DEBUG("Deleting one reference...");
234 aw0a 1 }
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 johnpye 709 eql->rel2U = ASC_NEW_ARRAY(int,len+1);
277 aw0a 1 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 johnpye 1046 ASC_FREE(u->str);
294 aw0a 1 }
295 johnpye 1046 ASC_FREE(u);
296 aw0a 1 }
297     }
298     gl_destroy(eql->ue);
299 johnpye 1046 ASC_FREE(eql->rel2U);
300 aw0a 1 }
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 johnpye 709 new = ASC_NEW(struct bintoken_unique_eqn);
361 aw0a 1 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 johnpye 154 CLINE("/*\n\tBinTokenSharesToC $Revision: 1.12 $");
393     FPRINTF(fp,"\t%lu relations in instance '",len);
394 aw0a 1 WriteInstanceName(fp,root,NULL);
395 johnpye 154 CLINE("'\n\t(possibly fewer C functions required)\n*/");
396 aw0a 1 }
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 johnpye 122
402     CLINE("#include <btprolog.h>");
403 aw0a 1 }
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 johnpye 89 FPRINTF(fp,"\tRelation used %d times, prototyped from:\n",timesused);
450     FPRINTF(fp,"\t");
451 aw0a 1 /* Use fastest path to a root */
452     WriteAnyInstanceName(fp,i);
453 johnpye 89 CLINE("\n*/");
454 aw0a 1 }
455    
456     CLINE("static");
457 johnpye 95 FPRINTF(fp, "void r_%d(double *x,double *residual){\n", nrel);
458 johnpye 89 CLINE("\t*residual =");
459 aw0a 1 #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 johnpye 485 int ExportBinTokenCTable(struct TableC *t,int size){
481 aw0a 1 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 johnpye 1046 ASC_FREE(r->rd.indices);
508 aw0a 1 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 johnpye 1046 ASC_FREE(r->rd.indices);
526 aw0a 1 r->rd.indices = NULL;
527     newlen *= 2;
528     }
529     /* require min */
530     if (newlen < 100) {
531     newlen = 100;
532     }
533     /* create mem_*/
534 johnpye 669 r->rd.indices = ASC_NEW_ARRAY(int,newlen);
535 aw0a 1 if (r->rd.indices == NULL) {
536 johnpye 1064 ASC_PANIC("out of memory error");
537 aw0a 1 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 johnpye 669 error = ASC_NEW_ARRAY(int,len);
583 aw0a 1 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 johnpye 1046 ASC_FREE(str);
608 aw0a 1 } /* 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 johnpye 89 /** @TODO FIXME win32 has getpid but it is bogus as uniquifier. */
628 aw0a 1 /* 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 johnpye 480 FPRINTF(fp,"int ASC_DLLSPEC %s(){\n",g_bt_data.regname);
631 johnpye 89 CLINE("\tint status;");
632     FPRINTF(fp,"\tstatic struct TableC g_ctable[%lu] =\n",len+1);
633     CLINE("\t\t{ {NULL, NULL},");
634 aw0a 1 len--; /* to fudge the final comma */
635     for (c=1; c <= len; c++) {
636     if (error[c-1] == BTE_ok) {
637 johnpye 89 FPRINTF(fp,"\t\t\t{r_%u, NULL},\n",eql.rel2U[c]);
638 aw0a 1 } else {
639 johnpye 89 FPRINTF(fp,"\t\t\t{NULL, NULL},\n");
640 aw0a 1 }
641     }
642     len++;
643     if (error[len-1] == BTE_ok) {
644 johnpye 89 FPRINTF(fp,"\t\t\t{r_%u, NULL}\n",eql.rel2U[c]);
645 aw0a 1 } else {
646 johnpye 89 FPRINTF(fp,"\t\t\t{NULL, NULL}\n");
647 aw0a 1 }
648 johnpye 89 CLINE("\t\t};");
649     FPRINTF(fp,"\tstatus = ExportBinTokenCTable(g_ctable,%lu);\n",len+1);
650     CLINE("\treturn status;");
651 aw0a 1 if (verbose) {
652 johnpye 89 FPRINTF(fp,"\t/* %lu unique equations */\n",gl_length(eql.ue));
653 johnpye 154 FPRINTF(ASCERR,"Prepared %lu external C functions.\n",gl_length(eql.ue));
654 aw0a 1 }
655     CLINE("}");
656    
657 johnpye 1046 ASC_FREE(error);
658 aw0a 1 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 johnpye 190 ERROR_REPORTER_NOLINE(ASC_PROG_NOTE,"Starting build, command:\n%s\n",buildcommand);
668 aw0a 1 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 johnpye 159 error_reporter(ASC_PROG_WARNING,libname,0,"Failed to load library (init function %s)",regname);
706 aw0a 1 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 johnpye 1219 g_bt_data.tables[g_bt_data.nextid].name = ASC_STRDUP(libname);
724 aw0a 1 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 johnpye 159 error_reporter(ASC_PROG_ERR,filename,0,"%s",mess);
765 aw0a 1 }
766    
767 johnpye 1046 void BinTokensCreate(struct Instance *root, enum bintoken_kind method){
768 aw0a 1 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     if (g_bt_data.maxrels == 0) {
779 johnpye 1317 ERROR_REPORTER_HERE(ASC_PROG_NOTE,"BinTokensCreate disabled (maxrels=0)\n");
780 aw0a 1 return;
781     }
782     if (srcname == NULL || buildcommand == NULL || unlinkcommand == NULL) {
783 johnpye 1035 ERROR_REPORTER_HERE(ASC_PROG_WARNING,"BinaryTokensCreate called with no options set: ignoring");
784 aw0a 1 return;
785 johnpye 399 }
786 aw0a 1
787     rellist =
788     CollectTokenRelationsWithUniqueBINlessShares(root,g_bt_data.maxrels);
789     if (rellist==NULL) {
790 johnpye 737 ERROR_REPORTER_HERE(ASC_PROG_WARNING
791     ,"BinaryTokensCreate found 0 or too many unique relations."
792     );
793 aw0a 1 return;
794     }
795    
796 johnpye 1317 ERROR_REPORTER_HERE(ASC_PROG_NOTE,"Creating bintokens\n");
797 johnpye 1046
798 aw0a 1 switch (method) {
799     case BT_C:
800     /* generate code */
801     status = BinTokenSharesToC(root,rellist,srcname,verbose);
802     if (status != BTE_ok) {
803     BinTokenErrorMessage(status,root,srcname,buildcommand);
804     break; /* leave source file there if partial */
805     }
806     status = BinTokenCompileC(buildcommand);
807     if (status != BTE_ok) {
808     BinTokenErrorMessage(status,root,objname,buildcommand);
809     break; /* leave source file there to debug */
810     } else {
811     if (g_bt_data.housekeep) {
812     /* trash src */
813 johnpye 709 cbuf = ASC_NEW_ARRAY(char,strlen(unlinkcommand)+1+strlen(srcname)+1);
814 aw0a 1 assert(cbuf!=NULL);
815     sprintf(cbuf,"%s %s",unlinkcommand,srcname);
816     system(cbuf); /* we don't care if the delete fails */
817 johnpye 1046 ASC_FREE(cbuf);
818 aw0a 1 /* trash obj */
819 johnpye 709 cbuf = ASC_NEW_ARRAY(char,strlen(unlinkcommand)+1+strlen(objname)+1);
820 aw0a 1 assert(cbuf!=NULL);
821     sprintf(cbuf,"%s %s",unlinkcommand,objname);
822     system(cbuf); /* we don't care if the delete fails */
823 johnpye 1046 ASC_FREE(cbuf);
824 aw0a 1 }
825 johnpye 190
826 johnpye 62 status = BinTokenLoadC(rellist,libname,g_bt_data.regname);
827     if (status != BTE_ok) {
828     BinTokenErrorMessage(status,root,libname,buildcommand);
829     /* leave source,binary files there to debug */
830 johnpye 76 }/*else{
831 johnpye 62 FPRINTF(ASCERR,"BINTOKENLOADC OK\n");
832 johnpye 76 }*/
833 aw0a 1 }
834     break;
835     default:
836 johnpye 1046 ERROR_REPORTER_HERE(ASC_PROG_ERR,"BinaryTokensCreate called with unavailable method '%d'",(int)method);
837 aw0a 1 break;
838     }
839     gl_destroy(rellist);
840     return;
841     }
842    
843     /*
844     * Returns 1 if can't evaluate function.
845     * Vars is assumed already filled with values.
846     * This function must not malloc or free memory.
847     */
848     int BinTokenCalcResidual(int btable, int bindex, double *vars, double *residual)
849     {
850     if (btable < 1 || bindex < 1) {
851     return 1;
852     }
853     switch (g_bt_data.tables[btable].type) {
854     case BT_error:
855     return 1; /* expired table! */
856     case BT_C: {
857     struct TableC *ctable;
858     BinTokenFPtr func;
859     ctable = (struct TableC *)g_bt_data.tables[btable].tu;
860     assert(ctable != NULL);
861     if (bindex > g_bt_data.tables[btable].size) {
862     return 1;
863     }
864     func = ctable[bindex].F;
865     #if 0 /* setting this to 1 is a major performance hit. */
866     if (func != NULL) {
867 johnpye 997 if (SETJMP(g_fpe_env)==0) {
868 aw0a 1 (*func)(vars,residual);
869     return 0;
870     } else {
871     Asc_SignalRecover();
872     return 1;
873     }
874     }
875     return 1;
876     #else
877     (*func)(vars,residual);
878     return 0;
879     #endif
880     }
881     case BT_F77: {
882     /* this case needs to be cleaned up to match the C case above. */
883     struct TableF *ftable;
884     BinTokenSPtr subroutine;
885     ftable = (struct TableF *)g_bt_data.tables[btable].tu;
886     assert(ftable != NULL);
887     if (bindex < 1 || bindex > g_bt_data.tables[btable].size) {
888     return 1;
889     }
890     subroutine = ftable[0].S; /* its all in func 0 */
891     if (subroutine != NULL) {
892     int ForG,status;
893     ForG = BinTokenRESIDUAL;
894 johnpye 1142 #ifdef ASC_SIGNAL_TRAPS
895 aw0a 1 Asc_SignalHandlerPush(SIGFPE,Asc_SignalTrap);
896 johnpye 997 if (SETJMP(g_fpe_env)==0) {
897 johnpye 1142 #endif /* ASC_SIGNAL_TRAPS */
898 aw0a 1 (*subroutine)(vars,NULL,residual,&ForG,&bindex,&status);
899 johnpye 1142 #ifdef ASC_SIGNAL_TRAPS
900 aw0a 1 Asc_SignalHandlerPop(SIGFPE,Asc_SignalTrap);
901 johnpye 1142 #endif /* ASC_SIGNAL_TRAPS */
902 aw0a 1 return status;
903 johnpye 1142 #ifdef ASC_SIGNAL_TRAPS
904 aw0a 1 } else {
905     Asc_SignalHandlerPop(SIGFPE,Asc_SignalTrap);
906     return 1;
907     }
908 johnpye 1142 #endif /* ASC_SIGNAL_TRAPS */
909 aw0a 1 }
910     return 1;
911     }
912     default:
913     return 1;
914     }
915     }
916    
917     /*
918     * Returns nonzero if can't evaluate gradient.
919     * Vars is assumed already filled with values.
920     */
921     int BinTokenCalcGradient(int btable, int bindex,double *vars,
922     double *residual, double *gradient)
923     {
924     if (btable == 0) {
925     return 1;
926     }
927     switch (g_bt_data.tables[btable].type) {
928     case BT_error:
929     return 1; /* expired table! */
930     case BT_C: {
931     /* signal handling needs to match func above. this is slow here. */
932     struct TableC *ctable;
933     BinTokenGPtr func;
934     ctable = (struct TableC *)g_bt_data.tables[btable].tu;
935     assert(ctable != NULL);
936     if (bindex < 1 || bindex > g_bt_data.tables[btable].size) {
937     return 1;
938     }
939     func = ctable[bindex].G;
940     if (func != NULL) {
941 johnpye 1142 #ifdef ASC_SIGNAL_TRAPS
942 aw0a 1 Asc_SignalHandlerPush(SIGFPE,Asc_SignalTrap);
943 johnpye 997 if (SETJMP(g_fpe_env)==0) {
944 johnpye 1142 #endif /* ASC_SIGNAL_TRAPS */
945 aw0a 1 (*func)(vars,gradient,residual);
946 johnpye 1142 #ifdef ASC_SIGNAL_TRAPS
947 aw0a 1 Asc_SignalHandlerPop(SIGFPE,Asc_SignalTrap);
948 johnpye 1142 #endif /* ASC_SIGNAL_TRAPS */
949 aw0a 1 return 0;
950 johnpye 1142 #ifdef ASC_SIGNAL_TRAPS
951 aw0a 1 } else {
952     Asc_SignalHandlerPop(SIGFPE,Asc_SignalTrap);
953     return 1;
954     }
955 johnpye 1142 #endif /* ASC_SIGNAL_TRAPS */
956 aw0a 1 }
957     return 1;
958     }
959     case BT_F77: {
960     struct TableF *ftable;
961     BinTokenSPtr subroutine;
962     ftable = (struct TableF *)g_bt_data.tables[btable].tu;
963     assert(ftable != NULL);
964     if (bindex < 1 || bindex > g_bt_data.tables[btable].size) {
965     return 1;
966     }
967     subroutine = ftable[0].S; /* its all in func 0 */
968     if (subroutine != NULL) {
969     int ForG,status;
970     ForG = BinTokenGRADIENT;
971 johnpye 1142 #ifdef ASC_SIGNAL_TRAPS
972 aw0a 1 Asc_SignalHandlerPush(SIGFPE,Asc_SignalTrap);
973 johnpye 997 if (SETJMP(g_fpe_env)==0) {
974 johnpye 1142 #endif /* ASC_SIGNAL_TRAPS */
975 aw0a 1 (*subroutine)(vars,gradient,residual,&ForG,&bindex,&status);
976 johnpye 1142 #ifdef ASC_SIGNAL_TRAPS
977 aw0a 1 Asc_SignalHandlerPop(SIGFPE,Asc_SignalTrap);
978 johnpye 1142 #endif /* ASC_SIGNAL_TRAPS */
979 aw0a 1 return status;
980 johnpye 1142 #ifdef ASC_SIGNAL_TRAPS
981 aw0a 1 } else {
982     status = 1;
983     }
984     Asc_SignalHandlerPop(SIGFPE,Asc_SignalTrap);
985     return status;
986 johnpye 1142 #endif /* ASC_SIGNAL_TRAPS */
987 aw0a 1 }
988     return 1;
989     }
990     default:
991     return 1;
992     }
993     }
994    
995 johnpye 908 #ifdef UNRELOCATE_TEST_BT
996 johnpye 716 /* this code may be out of date, but should be saved. */
997 johnpye 1071 #ifdef RELOCATE_STREAMS
998 aw0a 1 FILE *g_ascend_errors = stderr;
999 johnpye 1071 #endif
1000    
1001 johnpye 716 int main() { /* built only if TESTBT defined TRUE in bintoken.c */
1002 aw0a 1 double res;
1003     gl_init_pool();
1004     g_test_list = gl_create(5);
1005     gl_append_ptr(g_test_list,(void *)10);
1006     gl_append_ptr(g_test_list,(void *)20);
1007     gl_append_ptr(g_test_list,(void *)30);
1008     gl_append_ptr(g_test_list,(void *)40);
1009     gl_append_ptr(g_test_list,(void *)50);
1010 johnpye 1046 BinTokenSetOptions(
1011     "/tmp/btsrc.c","/tmp/btsrc.o","/tmp/btsrc.so"
1012     ,"make -f foo/Makefile BTTARGET=/tmp/btsrc /tmp/btsrc"
1013     ,"/bin/rm"
1014     ,1000,1,0
1015     );
1016 aw0a 1 BinTokensCreate((struct Instance *)1, BT_C);
1017     BinTokenCalcResidual(1,1,&res,&res);
1018     FPRINTF(ASCERR,"residual 1 = %g\n",res);
1019     BinTokenClearTables();
1020     gl_destroy(g_test_list);
1021     gl_destroy_pool();
1022     return 0;
1023     }
1024 johnpye 908 #endif /*unrelocate test bt*/

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