1
2 /* pdlapi.c - functions for manipulating pdl structs */
3 /* - for a while (up to + including 2.2.1) this file */
4 /* created by pdlapi.c.PL [due to bad value code] */
5 /* we now have dummy functions so do not need to */
6 /* create the file */
7
8 #define PDL_CORE /* For certain ifdefs */
9 #include "pdl.h" /* Data structure declarations */
10 #include "pdlcore.h" /* Core declarations */
11
12 /* Uncomment the following if you have core dumps or strange
13 * behaviour - it may reveal the cause by croaking because of
14 * bad magic number.
15 */
16
17 /* #define DONT_REALLY_FREE
18 */
19
20 /* This define causes the affine transformations not to be
21 * optimized away so $a->slice(...) will always made physical.
22 * Uncommenting this define is not recommended at the moment
23 */
24
25 /* #define DONT_OPTIMIZE
26 * #define DONT_VAFFINE
27 */
28
29 extern Core PDL;
30
31 void pdl__ensure_trans(pdl_trans *trans,int what) ;
32
has_children(pdl * it)33 static int has_children(pdl *it) {
34 PDL_DECL_CHILDLOOP(it)
35 PDL_START_CHILDLOOP(it)
36 return 1;
37 PDL_END_CHILDLOOP(it)
38 return 0;
39 }
40
is_child_of(pdl * it,pdl_trans * trans)41 static int is_child_of(pdl *it,pdl_trans *trans) {
42 int i;
43 for(i=trans->vtable->nparents; i<trans->vtable->npdls; i++) {
44 if(trans->pdls[i] == it) return 1;
45 }
46 return 0;
47 }
48
is_parent_of(pdl * it,pdl_trans * trans)49 static int is_parent_of(pdl *it,pdl_trans *trans) {
50 int i;
51 for(i=0; i<trans->vtable->nparents; i++) {
52 if(trans->pdls[i] == it) return 1;
53 }
54 return 0;
55 }
56
pdl_null()57 pdl *pdl_null() {
58 PDL_Indx d[1] = {0};
59 pdl *it = pdl_new();
60 PDL_Anyval zero = { PDL_B, 0 };
61 pdl_makescratchhash(it, zero);
62 pdl_setdims(it,d,1);
63 it->state |= PDL_NOMYDIMS;
64 return it;
65 }
66
pdl_get_convertedpdl(pdl * old,int type)67 pdl *pdl_get_convertedpdl(pdl *old,int type) {
68 if(old->datatype != type) {
69 pdl *it;
70 it = pdl_null();
71 PDL.converttypei_new(old,it,type);
72 if(it->datatype != type) { croak("FOOBAR! HELP!\n"); }
73 return it;
74 } else {
75 return old;
76 }
77 }
78
pdl_allocdata(pdl * it)79 void pdl_allocdata(pdl *it) {
80 int i;
81 PDL_Indx nvals=1;
82 SV *bar;
83 for(i=0; i<it->ndims; i++) {
84 nvals *= it->dims[i];
85 }
86 it->nvals = nvals;
87 PDLDEBUG_f(printf("pdl_allocdata %p, %"IND_FLAG", %d\n",(void*)it, it->nvals,
88 it->datatype));
89
90 pdl_grow(it,nvals);
91 PDLDEBUG_f(pdl_dump(it));
92
93 it->state |= PDL_ALLOCATED;
94 }
95
96 /* Wrapper to pdl_create so that the pdl_new and pdl_tmp functions
97 can be stored in the Core struct and exported to external
98 PDL XS modules */
pdl_external_new()99 pdl* pdl_external_new() {
100 return pdl_new();
101 }
pdl_external_tmp()102 pdl* pdl_external_tmp() {
103 return pdl_tmp();
104 }
105 /* Return a new pdl - type is PDL_PERM or PDL_TMP - the latter is auto-freed
106 * when current perl context is left
107 *
108 * pdl_new() and pdl_tmp() are macroes defined in pdlcore.h
109 * which just call this routine.
110 */
111
112
pdl_create(int type)113 pdl* pdl_create(int type) {
114 int i;
115 pdl* it;
116
117 if(type == PDL_TMP) {croak("PDL internal error. FIX!\n");}
118
119 it = (pdl*) malloc(sizeof(pdl));
120 if (it==NULL)
121 croak("Out of Memory\n");
122
123 it->magicno = PDL_MAGICNO;
124 it->state = 0;
125 it->datatype = 0;
126 it->trans = NULL;
127 it->vafftrans = NULL;
128 it->sv = NULL;
129 it->datasv = 0;
130 it->data = 0;
131 it->has_badvalue = 0;
132
133 it->dims = it->def_dims;
134 it->dimincs = it->def_dimincs;
135 it->ndims = 0;
136
137 it->nthreadids = 0;
138 it->threadids = it->def_threadids;
139 it->threadids[0] = 0;
140
141 for(i=0; i<PDL_NCHILDREN; i++) {it->children.trans[i]=NULL;}
142 it->children.next = NULL;
143
144 it->magic = 0;
145 it->hdrsv = 0;
146
147 PDLDEBUG_f(printf("CREATE %p (size=%zu)\n",(void*)it,sizeof(pdl)));
148 return it;
149 }
150
151 /* Explicit free. Do not use, use destroy instead, which causes this
152 to be called when the time is right */
pdl__free(pdl * it)153 void pdl__free(pdl *it) {
154 pdl_children *p1,*p2;
155 PDL_CHKMAGIC(it);
156
157 /* now check if magic is still there */
158 if (pdl__ismagic(it)) {
159 PDLDEBUG_f(printf("%p is still magic\n",(void*)it));
160 PDLDEBUG_f(pdl__print_magic(it));
161 }
162
163 it->magicno = 0x42424245;
164 PDLDEBUG_f(printf("FREE %p\n",(void*)it));
165 #ifndef DONT_REALLY_FREE
166 if(it->dims != it->def_dims) free((void*)it->dims);
167 if(it->dimincs != it->def_dimincs) free((void*)it->dimincs);
168 if(it->threadids != it->def_threadids) free((void*)it->threadids);
169
170 if(it->vafftrans) {
171 pdl_vafftrans_free(it);
172 }
173
174 p1 = it->children.next;
175 while(p1) {
176 p2 = p1->next;
177 free(p1);
178 p1 = p2;
179 }
180 /* Free the phys representation */
181 /* XXX MEMLEAK */
182 /* it->vtable->freetrans(it,it->trans); */
183
184 /* Call special freeing magic, if exists */
185 if(PDL_ISMAGIC(it)) {
186 pdl__call_magic(it, PDL_MAGIC_DELETEDATA);
187 pdl__magic_free(it);
188 }
189
190 if(it->datasv) {
191 SvREFCNT_dec(it->datasv);
192 it->data=0;
193 } else if(it->data) {
194 pdl_warn("Warning: special data without datasv is not freed currently!!");
195 }
196 if(it->hdrsv) {
197 SvREFCNT_dec(it->hdrsv);
198 it->hdrsv = 0;
199 }
200 free(it);
201 #endif
202 PDLDEBUG_f(printf("ENDFREE %p\n",(void*)it));
203 }
204
pdl__destroy_childtranses(pdl * it,int ensure)205 void pdl__destroy_childtranses(pdl *it,int ensure) {
206 PDL_DECL_CHILDLOOP(it);
207 PDL_START_CHILDLOOP(it)
208 pdl_destroytransform(PDL_CHILDLOOP_THISCHILD(it),ensure);
209 PDL_END_CHILDLOOP(it)
210 }
211
212 /*
213
214 A piddle may be
215 - a parent of something - just ensure & destroy
216 - a child of something - just ensure & destroy
217 - parent of two pdls which both propagate backwards - mustn't destroy.
218 - both parent and child at same time, to something that propagates.
219 Therefore, simple rules:
220 - allowed to destroy if
221 1. a parent with max. 1 backwards propagating transformation
222 2. a child with no children
223
224 When a piddle is destroyed, it must tell its children and/or
225 parent.
226
227 */
pdl_destroy(pdl * it)228 void pdl_destroy(pdl *it) {
229 int nback=0,nback2=0,nforw=0,nundest=0,nundestp=0;
230 int nafn=0;
231 pdl_trans *curt;
232 PDL_DECL_CHILDLOOP(it);
233 PDL_CHKMAGIC(it);
234 PDLDEBUG_f(printf("Destr. %p\n",(void*)it);)
235 if(it->state & PDL_DESTROYING) {
236 PDLDEBUG_f(printf("Already Destr. %p\n",(void*)it);)
237 return;
238 }
239 it->state |= PDL_DESTROYING;
240 /* Clear the sv field so that there will be no dangling ptrs */
241 if(it->sv) {
242 sv_setiv(it->sv,0x4242);
243 it->sv = NULL;
244 }
245
246 /* 1. count the children that do flow */
247 PDL_START_CHILDLOOP(it)
248 curt = PDL_CHILDLOOP_THISCHILD(it);
249 if(PDL_CHILDLOOP_THISCHILD(it)->flags & (PDL_ITRANS_DO_DATAFLOW_F|
250 PDL_ITRANS_DO_DATAFLOW_B))
251 nforw ++;
252 if(PDL_CHILDLOOP_THISCHILD(it)->flags & PDL_ITRANS_DO_DATAFLOW_B)
253 {
254 nback ++;
255 /* Cases where more than two in relationship
256 * must always be soft-destroyed */
257 if(curt->vtable->npdls > 2) nback2++;
258 }
259
260 if(PDL_CHILDLOOP_THISCHILD(it)->flags & PDL_ITRANS_ISAFFINE) {
261 if(!(curt->pdls[1]->state & PDL_ALLOCATED)) {
262 nafn ++;
263 }
264 }
265 PDL_END_CHILDLOOP(it)
266
267 /* First case where we may not destroy */
268 if(nback2 > 0) goto soft_destroy;
269 if(nback > 1) goto soft_destroy;
270
271 /* Also not here */
272 if(it->trans && nforw) goto soft_destroy;
273
274 /* Also, we do not wish to destroy if the children would be larger
275 * than the parent and are currently not allocated (e.g. lags).
276 * Because this is too much work to check, we refrain from destroying
277 * for now if there is an affine child that is not allocated
278 */
279 if(nafn) goto soft_destroy;
280 if(pdl__magic_isundestroyable(it)) {
281 PDLDEBUG_f(printf("Magic, not Destr. %p\n",(void*)it);)
282 goto soft_destroy;
283 }
284
285 pdl__destroy_childtranses(it,1);
286
287 if(it->trans) {
288 PDLDEBUG_f(printf("Destr_trans. %p %d\n",(void*)(it->trans), it->trans->flags);)
289 /* Ensure only if there are other children! */
290 /* XXX Bad: tmp! */
291 if (it->trans->flags & PDL_ITRANS_NONMUTUAL)
292 pdl_destroytransform_nonmutual(it->trans,(it->trans->vtable->npdls
293 - it->trans->vtable->nparents > 1));
294 else
295 pdl_destroytransform(it->trans,(it->trans->vtable->npdls
296 - it->trans->vtable->nparents > 1));
297 }
298
299 /* Here, this is a child but has no children */
300 goto hard_destroy;
301
302
303 hard_destroy:
304
305 pdl__free(it);
306 PDLDEBUG_f(printf("End destroy %p\n",(void*)it);)
307
308 return;
309
310 soft_destroy:
311 PDLDEBUG_f(printf("May have dependencies, not destr. %p, nu(%d, %d), nba(%d, %d), nforw(%d), tra(%p), nafn(%d)\n",
312 (void*)it, nundest, nundestp, nback, nback2, nforw, (void*)(it->trans), nafn);)
313 it->state &= ~PDL_DESTROYING;
314 }
315
316
317 /* Straight copy, no dataflow */
pdl_hard_copy(pdl * src)318 pdl *pdl_hard_copy(pdl *src) {
319 int i;
320 pdl *it = pdl_null();
321 it->state = 0;
322
323 pdl_make_physical(src); /* Wasteful XXX... should be lazier */
324
325 it->datatype = src->datatype;
326
327 pdl_setdims(it,src->dims,src->ndims);
328 pdl_allocdata(it);
329
330 /* null != [0] */
331 #ifdef ELIFSLEFJSEFSE
332 if(src->ndims == 1 && src->dims[0] == 0)
333 #else
334 if(src->state & PDL_NOMYDIMS)
335 #endif
336 it->state |= PDL_NOMYDIMS;
337
338 pdl_reallocthreadids(it,src->nthreadids);
339 for(i=0; i<src->nthreadids; i++) {
340 it->threadids[i] = src->threadids[i];
341 }
342
343 memcpy(it->data,src->data, pdl_howbig(it->datatype) * it->nvals);
344
345 return it;
346
347 }
348
349 /* some constants for the dump_XXX routines */
350 #define PDL_FLAGS_TRANS 0
351 #define PDL_FLAGS_PDL 1
352 #define PDL_MAXSPACE 256 /* maximal number of prefix spaces in dump routines */
353 #define PDL_MAXLIN 60
pdl_dump_flags_fixspace(int flags,int nspac,int type)354 void pdl_dump_flags_fixspace(int flags, int nspac, int type)
355 {
356 int i;
357 int len, found, sz;
358
359 int pdlflagval[] = {
360 PDL_ALLOCATED,PDL_PARENTDATACHANGED,
361 PDL_PARENTDIMSCHANGED,PDL_PARENTREPRCHANGED,
362 PDL_DATAFLOW_F,PDL_DATAFLOW_B,PDL_NOMYDIMS,
363 PDL_OPT_VAFFTRANSOK,PDL_INPLACE,PDL_DESTROYING,
364 PDL_DONTTOUCHDATA, PDL_MYDIMS_TRANS, PDL_HDRCPY,
365 PDL_BADVAL, PDL_TRACEDEBUG, 0
366 };
367
368 char *pdlflagchar[] = {
369 "ALLOCATED","PARENTDATACHANGED",
370 "PARENTDIMSCHANGED","PARENTREPRCHANGED",
371 "DATAFLOW_F","DATAFLOW_B","NOMYDIMS",
372 "OPT_VAFFTRANSOK","INPLACE","DESTROYING",
373 "DONTTOUCHDATA","MYDIMS_TRANS", "HDRCPY",
374 "BADVAL", "TRACEDEBUG"
375 };
376
377 int transflagval[] = {
378 PDL_ITRANS_REVERSIBLE, PDL_ITRANS_DO_DATAFLOW_F,
379 PDL_ITRANS_DO_DATAFLOW_B,
380 PDL_ITRANS_ISAFFINE, PDL_ITRANS_VAFFINEVALID,
381 PDL_ITRANS_NONMUTUAL, 0
382 };
383
384 char *transflagchar[] = {
385 "REVERSIBLE", "DO_DATAFLOW_F",
386 "DO_DATAFLOW_B",
387 "ISAFFINE", "VAFFINEVALID",
388 "NONMUTUAL"
389 };
390
391 int *flagval;
392 char **flagchar;
393 char spaces[PDL_MAXSPACE];
394 if (nspac >= PDL_MAXSPACE) {
395 printf("too many spaces requested: %d"
396 " (increase PDL_MAXSPACE in pdlapi.c), returning\n",nspac);
397 return;
398 }
399 if (type == PDL_FLAGS_PDL) {
400 flagval = pdlflagval;
401 flagchar = pdlflagchar;
402 } else {
403 flagval = transflagval;
404 flagchar = transflagchar;
405 }
406 for(i=0; i<nspac; i++) spaces[i]=' ';
407 spaces[i] = '\0';
408 sz = 0;
409
410 printf("%sState: (%d) ",spaces,flags);
411 len = 0;
412 found = 0;
413 for (i=0;flagval[i]!=0; i++)
414 if (flags & flagval[i]) {
415 printf("%s%s",found ? "|":"",flagchar[i]);
416 found = 1;
417 sz += strlen(flagchar[i]);
418 if (sz>PDL_MAXLIN) {sz=0; printf("\n %s",spaces);}
419 }
420 printf("\n");
421 }
422
423 /* Dump a transformation (don't dump the pdls, just pointers to them */
pdl_dump_trans_fixspace(pdl_trans * it,int nspac)424 void pdl_dump_trans_fixspace (pdl_trans *it, int nspac) {
425 int i;
426 char spaces[PDL_MAXSPACE];
427 if (nspac >= PDL_MAXSPACE) {
428 printf("too many spaces requested: %d"
429 " (increase PDL_MAXSPACE in pdlapi.c), returning\n",nspac);
430 return;
431 }
432 for(i=0; i<nspac; i++) spaces[i]=' ';
433 spaces[i] = '\0';
434 printf("%sDUMPTRANS %p (%s)\n",spaces,(void*)it,it->vtable->name);
435 pdl_dump_flags_fixspace(it->flags,nspac+3,PDL_FLAGS_TRANS);
436 if(it->flags & PDL_ITRANS_ISAFFINE) {
437 pdl_trans_affine *foo = (pdl_trans_affine *)it;
438 if(it->pdls[1]->state & PDL_PARENTDIMSCHANGED) {
439 printf("%s AFFINE, BUT DIMSCHANGED\n",spaces);
440 } else {
441 printf("%s AFFINE: o:%"IND_FLAG", i:(",spaces,foo->offs);
442 for(i=0; i<foo->pdls[1]->ndims; i++) {
443 printf("%s%"IND_FLAG,(i?" ":""),foo->incs[i]);
444 }
445 printf(") d:(");
446 for(i=0; i<foo->pdls[1]->ndims; i++) {
447 printf("%s%"IND_FLAG,(i?" ":""),foo->pdls[1]->dims[i]);
448 }
449 printf(")\n");
450 }
451 }
452 /* if(it->vtable->dump) {it->vtable->dump(it);} */
453 printf("%s INPUTS: (",spaces);
454 for(i=0; i<it->vtable->nparents; i++)
455 printf("%s%p",(i?" ":""),(void*)(it->pdls[i]));
456 printf(") OUTPUTS: (");
457 for(;i<it->vtable->npdls; i++)
458 printf("%s%p",(i?" ":""),(void*)(it->pdls[i]));
459 printf(")\n");
460 }
461
pdl_dump_fixspace(pdl * it,int nspac)462 void pdl_dump_fixspace(pdl *it,int nspac)
463 {
464 PDL_DECL_CHILDLOOP(it)
465 PDL_Indx i;
466 char spaces[PDL_MAXSPACE];
467 if (nspac >= PDL_MAXSPACE) {
468 printf("too many spaces requested: %d"
469 " (increase PDL_MAXSPACE in pdlapi.c), returning\n",nspac);
470 return;
471 }
472 for(i=0; i<nspac; i++) spaces[i]=' ';
473 spaces[i] = '\0';
474 printf("%sDUMPING %p datatype: %d\n",spaces,(void*)it,it->datatype);
475 pdl_dump_flags_fixspace(it->state,nspac+3,PDL_FLAGS_PDL);
476 printf("%s transvtable: %p, trans: %p, sv: %p\n",spaces,
477 (void*)(it->trans?it->trans->vtable:0), (void*)(it->trans), (void*)(it->sv));
478 if(it->datasv) {
479 printf("%s Data SV: %p, Svlen: %d, data: %p, nvals: %"IND_FLAG"\n", spaces,
480 (void*)(it->datasv), (int)SvCUR((SV*)it->datasv), (void*)(it->data), it->nvals);
481 }
482 printf("%s Dims: %p (",spaces,(void*)(it->dims));
483 for(i=0; i<it->ndims; i++) {
484 printf("%s%"IND_FLAG,(i?" ":""),it->dims[i]);
485 };
486 printf(")\n%s ThreadIds: %p (",spaces,(void*)(it->threadids));
487 for(i=0; i<it->nthreadids+1; i++) {
488 printf("%s%d",(i?" ":""),it->threadids[i]);
489 }
490 if(PDL_VAFFOK(it)) {
491 printf(")\n%s Vaffine ok: %p (parent), o:%"IND_FLAG", i:(",
492 spaces,(void*)(it->vafftrans->from),it->vafftrans->offs);
493 for(i=0; i<it->ndims; i++) {
494 printf("%s%"IND_FLAG,(i?" ":""),it->vafftrans->incs[i]);
495 }
496 }
497 if(it->state & PDL_ALLOCATED) {
498 printf(")\n%s First values: (",spaces);
499 for(i=0; i<it->nvals && i<10; i++) {
500 printf("%s%f",(i?" ":""),pdl_get_offs(it,i).value.D);
501 }
502 } else {
503 printf(")\n%s (not allocated",spaces);
504 }
505 printf(")\n");
506 if(it->trans) {
507 pdl_dump_trans_fixspace(it->trans,nspac+3);
508 }
509 printf("%s CHILDREN:\n",spaces);
510 PDL_START_CHILDLOOP(it)
511 pdl_dump_trans_fixspace(PDL_CHILDLOOP_THISCHILD(it),nspac+4);
512 PDL_END_CHILDLOOP(it)
513 /* XXX phys etc. also */
514 }
515
pdl_dump(pdl * it)516 void pdl_dump (pdl *it) {
517 pdl_dump_fixspace(it,0);
518 }
519
520
521 /* Reallocate this PDL to have ndims dimensions. The previous dims
522 are copied. */
523
pdl_reallocdims(pdl * it,int ndims)524 void pdl_reallocdims(pdl *it,int ndims) {
525 int i;
526 if (it->ndims < ndims) { /* Need to realloc for more */
527 if(it->dims != it->def_dims) free(it->dims);
528 if(it->dimincs != it->def_dimincs) free(it->dimincs);
529 if (ndims>PDL_NDIMS) { /* Need to malloc */
530 it->dims = malloc(ndims*sizeof(*(it->dims)));
531 it->dimincs = malloc(ndims*sizeof(*(it->dimincs)));
532 if (it->dims==NULL || it->dimincs==NULL)
533 croak("Out of Memory\n");
534 }
535 else {
536 it->dims = it->def_dims;
537 it->dimincs = it->def_dimincs;
538 }
539 }
540 it->ndims = ndims;
541 }
542
543 /* Reallocate n threadids. Set the new extra ones to the end */
544 /* XXX Check logic */
pdl_reallocthreadids(pdl * it,int n)545 void pdl_reallocthreadids(pdl *it,int n) {
546 int i;
547 unsigned char *olds; int nold;
548 if(n <= it->nthreadids) {
549 it->nthreadids = n; it->threadids[n] = it->ndims; return;
550 }
551 nold = it->nthreadids; olds = it->threadids;
552 if(n >= PDL_NTHREADIDS-1) {
553 it->threadids = malloc(sizeof(*(it->threadids))*(n+1));
554 } else {
555 /* already is default */
556 }
557 it->nthreadids = n;
558
559 if(it->threadids != olds) {
560 for(i=0; i<nold && i<n; i++)
561 it->threadids[i] = olds[i];
562 }
563 if(olds != it->def_threadids) { free(olds); }
564
565 for(i=nold; i<it->nthreadids; i++) {
566 it->threadids[i] = it->ndims;
567 }
568 }
569
570 /* Calculate default increments and grow the PDL data */
571
pdl_resize_defaultincs(pdl * it)572 void pdl_resize_defaultincs(pdl *it) {
573 PDL_Indx inc = 1;
574 int i=0;
575 for(i=0; i<it->ndims; i++) {
576 it->dimincs[i] = inc; inc *= it->dims[i];
577 }
578 it->nvals = inc;
579 it->state &= ~PDL_ALLOCATED; /* Need to realloc when phys */
580 #ifdef DONT_OPTIMIZE
581 pdl_allocdata(it);
582 #endif
583 }
584
585 /* Init dims & incs - if *incs is NULL ignored (but space is always same for both) */
586
pdl_setdims(pdl * it,PDL_Indx * dims,int ndims)587 void pdl_setdims(pdl* it, PDL_Indx * dims, int ndims) {
588 int i;
589
590 pdl_reallocdims(it,ndims);
591
592 for(i=0; i<ndims; i++)
593 it->dims[i] = dims[i];
594
595 pdl_resize_defaultincs(it);
596
597 pdl_reallocthreadids(it,0); /* XXX Maybe trouble */
598 }
599
600 /* This is *not* careful! */
pdl_setdims_careful(pdl * it)601 void pdl_setdims_careful(pdl *it)
602 {
603 pdl_resize_defaultincs(it);
604 #ifdef DONT_OPTIMIZE
605 pdl_allocdata(it);
606 #endif
607 pdl_reallocthreadids(it,0); /* XXX For now */
608 }
609
pdl_print(pdl * it)610 void pdl_print(pdl *it) {
611 #ifdef FOO
612 int i;
613 printf("PDL %d: sv = %d, data = %d, datatype = %d, nvals = %d, ndims = %d\n",
614 (int)it, (int)(it->hash), (int)(it->data), it->datatype, it->nvals, it->ndims);
615 printf("Dims: ");
616 for(i=0; i<it->ndims; i++) {
617 printf("%d(%d) ",it->dims[i],it->dimincs[i]);
618 }
619 printf("\n");
620 #endif
621 }
622
623 /* pdl_get is now vaffine aware */
pdl_get(pdl * it,PDL_Indx * inds)624 PDL_Anyval pdl_get(pdl *it,PDL_Indx *inds) {
625 int i;
626 PDL_Indx *incs;
627 PDL_Indx offs=PDL_REPROFFS(it);
628 incs = PDL_VAFFOK(it) ? it->vafftrans->incs : it->dimincs;
629 for(i=0; i<it->ndims; i++)
630 offs += incs[i] * inds[i];
631 return pdl_get_offs(PDL_REPRP(it),offs);
632 }
633
pdl_get_offs(pdl * it,PDL_Indx offs)634 PDL_Anyval pdl_get_offs(pdl *it, PDL_Indx offs) {
635 PDL_Indx dummy1=offs+1; PDL_Indx dummy2=1;
636 return pdl_at(it->data, it->datatype, &offs, &dummy1, &dummy2, 0, 1);
637 }
638
pdl_put_offs(pdl * it,PDL_Indx offs,PDL_Anyval value)639 void pdl_put_offs(pdl *it, PDL_Indx offs, PDL_Anyval value) {
640 PDL_Indx dummy1=offs+1; PDL_Indx dummy2=1;
641 pdl_set(it->data, it->datatype, &offs, &dummy1, &dummy2, 0, 1, value);
642 }
643
644
pdl__addchildtrans(pdl * it,pdl_trans * trans,int nth)645 void pdl__addchildtrans(pdl *it,pdl_trans *trans,int nth)
646 {
647 int i; pdl_children *c;
648 trans->pdls[nth] = it;
649 c = &it->children;
650 do {
651 for(i=0; i<PDL_NCHILDREN; i++) {
652 if(! c->trans[i]) {
653 c->trans[i] = trans; return;
654 }
655 }
656 if(!c->next) break;
657 c=c->next;
658 } while(1) ;
659 c->next = malloc(sizeof(pdl_children));
660 c->next->trans[0] = trans;
661 for(i=1; i<PDL_NCHILDREN; i++)
662 c->next->trans[i] = 0;
663 c->next->next = 0;
664 }
665
666 /* Problem with this function: when transformation is destroyed,
667 * there may be several different children with the same name.
668 * Therefore, we cannot croak :(
669 */
pdl__removechildtrans(pdl * it,pdl_trans * trans,int nth,int all)670 void pdl__removechildtrans(pdl *it,pdl_trans *trans,int nth,int all)
671 {
672 int i; pdl_children *c; int flag = 0;
673 if(all) {
674 for(i=0; i<trans->vtable->nparents; i++)
675 if(trans->pdls[i] == it)
676 trans->pdls[i] = NULL;
677 } else {
678 trans->pdls[nth] = 0;
679 }
680 c = &it->children;
681 do {
682 for(i=0; i<PDL_NCHILDREN; i++) {
683 if(c->trans[i] == trans) {
684 c->trans[i] = NULL;
685 flag = 1;
686 if(!all) return;
687 /* return; Cannot return; might be many times
688 (e.g. $a+$a) */
689 }
690 }
691 c=c->next;
692 } while(c);
693 /* this might be due to a croak when performing the trans; so
694 warn only for now, otherwise we leave trans undestructed ! */
695 if(!flag)
696 pdl_warn("Child not found for pdl %d, %d\n",it, trans);
697 }
698
pdl__removeparenttrans(pdl * it,pdl_trans * trans,int nth)699 void pdl__removeparenttrans(pdl *it, pdl_trans *trans, int nth)
700 {
701 trans->pdls[nth] = 0;
702 it->trans = 0;
703 }
704
pdl_make_physdims(pdl * it)705 void pdl_make_physdims(pdl *it) {
706 int i;
707 int c = (it->state & (PDL_PARENTDIMSCHANGED | PDL_PARENTREPRCHANGED)) ;
708 PDLDEBUG_f(printf("Make_physdims %p\n",(void*)it));
709 PDL_CHKMAGIC(it);
710 if(!(it->state & (PDL_PARENTDIMSCHANGED | PDL_PARENTREPRCHANGED))) {
711 PDLDEBUG_f(printf("Make_physdims_exit (NOP) %p\n",(void*)it));
712 return;
713 }
714 it->state &= ~(PDL_PARENTDIMSCHANGED | PDL_PARENTREPRCHANGED);
715 /* the fact that a PARENTXXXCHANGED flag is set seems
716 to imply that this pdl has an associated trans ? */
717 for(i=0; i<it->trans->vtable->nparents; i++) {
718 pdl_make_physdims(it->trans->pdls[i]);
719 }
720 /* doesn't this mean that all children of this trans have
721 now their dims set and accordingly all those flags should
722 be reset? Otherwise redodims will be called for them again? */
723 PDLDEBUG_f(printf("Make_physdims: calling redodims %p on %p\n",
724 (void*)(it->trans),(void*)it));
725 it->trans->vtable->redodims(it->trans);
726 /* why this one? will the old allocated data be freed correctly? */
727 if((c & PDL_PARENTDIMSCHANGED) && (it->state & PDL_ALLOCATED)) {
728 it->state &= ~PDL_ALLOCATED;
729 }
730 PDLDEBUG_f(printf("Make_physdims_exit %p\n",(void*)it));
731 }
732
pdl_writeover(pdl * it)733 void pdl_writeover(pdl *it) {
734 pdl_make_physdims(it);
735 pdl_children_changesoon(it,PDL_PARENTDATACHANGED);
736 it->state &= ~PDL_PARENTDATACHANGED;
737 }
738
739 /* Order is important: do childtrans first, then parentrans. */
740
pdl_set_trans_childtrans(pdl * it,pdl_trans * trans,int nth)741 void pdl_set_trans_childtrans(pdl *it, pdl_trans *trans,int nth)
742 {
743 pdl__addchildtrans(it,trans,nth);
744 /* Determine if we want to do dataflow */
745 if(it->state & PDL_DATAFLOW_F)
746 trans->flags |= PDL_ITRANS_DO_DATAFLOW_F;
747 if(it->state & PDL_DATAFLOW_B)
748 trans->flags |= PDL_ITRANS_DO_DATAFLOW_B;
749 }
750
751 /* This is because for "+=" (a = a + b) we must check for
752 previous parent transformations and mutate if they exist
753 if no dataflow. */
754
pdl_set_trans_parenttrans(pdl * it,pdl_trans * trans,int nth)755 void pdl_set_trans_parenttrans(pdl *it, pdl_trans *trans,int nth)
756 {
757 int i; int nthind;
758 if((it->trans || is_parent_of(it,trans))
759 /* && (it->state & PDL_DATAFLOW_F) */ ) {
760 /* XXX What if in several places */
761 nthind=-1;
762 for(i=0; i<trans->vtable->nparents; i++)
763 if(trans->pdls[i] == it) nthind = i;
764 croak("Sorry, families not allowed now (i.e. You cannot modify dataflowing pdl)\n");
765 /* pdl_family_create(it,trans,nthind,nth); */
766 } else {
767 it->trans = trans;
768 it->state |= PDL_PARENTDIMSCHANGED | PDL_PARENTDATACHANGED ;
769 trans->pdls[nth] = it;
770 #ifdef FOOBARBAR
771 if(trans->flags & PDL_ITRANS_DO_DATAFLOW_F)
772 it->state |= PDL_DATAFLOW_F;
773 if(trans->flags & PDL_ITRANS_DO_DATAFLOW_B)
774 it->state |= PDL_DATAFLOW_B;
775 #endif
776 }
777 }
778
779 /* Called with a filled pdl_trans struct.
780 * Sets the parent and trans fields of the piddles correctly,
781 * creating families and the like if necessary.
782 * Alternatively may just execute transformation
783 * that would require families but is not dataflown.
784 */
pdl_make_trans_mutual(pdl_trans * trans)785 void pdl_make_trans_mutual(pdl_trans *trans)
786 {
787 int i;
788 int fflag=0;
789 int cfflag=0;
790 int pfflag=0;
791 PDL_TR_CHKMAGIC(trans);
792
793 /* Then, set our children. This is: */
794 /* First, determine whether any of our children already have
795 * a parent, and whether they need to be updated. If this is
796 * the case, we need to do some thinking. */
797
798 PDLDEBUG_f(printf("make_trans_mutual %p\n",(void*)trans));
799 for(i=trans->vtable->nparents; i<trans->vtable->npdls; i++) {
800 if(trans->pdls[i]->trans) fflag ++;
801 if(trans->pdls[i]->state & PDL_DATAFLOW_ANY) cfflag++;
802 }
803 for(i=0; i<trans->vtable->nparents; i++)
804 if(trans->pdls[i]->state & PDL_DATAFLOW_ANY)
805 pfflag++;
806
807 /* If children are flowing, croak. It's too difficult to handle
808 * properly */
809
810 if(cfflag)
811 croak("Sorry, cannot flowing families right now\n");
812
813 /* Same, if children have trans yet parents are flowing */
814 if(pfflag && fflag)
815 croak("Sorry, cannot flowing families right now (2)\n");
816
817 /* Now, if parents are not flowing, just execute the transformation */
818
819 if(!pfflag && !(trans->flags & PDL_ITRANS_DO_DATAFLOW_ANY)) {
820 int *wd = malloc(sizeof(int) * trans->vtable->npdls);
821
822 /* mark this transform as non mutual in case we croak during
823 ensuring it */
824 trans->flags |= PDL_ITRANS_NONMUTUAL;
825 for(i=trans->vtable->nparents; i<trans->vtable->npdls; i++) {
826 pdl_children_changesoon(trans->pdls[i],
827 wd[i]=(trans->pdls[i]->state & PDL_NOMYDIMS ?
828 PDL_PARENTDIMSCHANGED : PDL_PARENTDATACHANGED));
829 }
830 /* mark all pdls that have been given as nulls (PDL_NOMYDIMS)
831 as getting their dims from this trans */
832 for(i=trans->vtable->nparents; i<trans->vtable->npdls; i++) {
833 if(trans->pdls[i]->state & PDL_NOMYDIMS) {
834 trans->pdls[i]->state &= ~PDL_NOMYDIMS;
835 trans->pdls[i]->state |= PDL_MYDIMS_TRANS;
836 trans->pdls[i]->trans = trans;
837 }
838 }
839 #ifdef BARBARBAR /* Not done */
840 for(i=trans->vtable->nparents; i<trans->vtable->npdls; i++)
841 trans->pdls[i]->state |=
842 PDL_PARENTDIMSCHANGED | PDL_PARENTDATACHANGED;
843 #endif
844 if(!trans->vtable) {die("INVALID TRANS: has no vtable!\n");}
845
846 /* now actually perform the transformation, i.e. call
847 transform's redodims and readdata vtable entries
848 */
849 pdl__ensure_trans(trans,PDL_PARENTDIMSCHANGED); /* XXX Why? */
850
851 /* Es ist vollbracht */
852 for(i=trans->vtable->nparents; i<trans->vtable->npdls; i++) {
853 #ifndef DONT_VAFFINE
854 if( PDL_VAFFOK(trans->pdls[i]) &&
855 (trans->vtable->per_pdl_flags[i] & PDL_TPDL_VAFFINE_OK) ) {
856 if(wd[i] & PDL_PARENTDIMSCHANGED)
857 pdl_changed(trans->pdls[i],
858 PDL_PARENTDIMSCHANGED,0);
859 pdl_vaffinechanged(
860 trans->pdls[i],PDL_PARENTDATACHANGED);
861 } else
862 #endif
863 pdl_changed(trans->pdls[i],wd[i],0);
864 }
865 pdl_destroytransform_nonmutual(trans,0);
866 free(wd);
867 } else { /* do the full flowing transform */
868
869 PDLDEBUG_f(printf("make_trans_mutual flowing!\n"));
870 for(i=0; i<trans->vtable->nparents; i++)
871 pdl_set_trans_childtrans(trans->pdls[i],trans,i);
872 for(i=trans->vtable->nparents; i<trans->vtable->npdls; i++)
873 pdl_set_trans_parenttrans(trans->pdls[i],trans,i);
874 if(!(trans->flags & PDL_ITRANS_REVERSIBLE))
875 trans->flags &= ~PDL_ITRANS_DO_DATAFLOW_B;
876 for(i=trans->vtable->nparents; i<trans->vtable->npdls; i++) {
877 if(trans->pdls[i]->state & PDL_NOMYDIMS) {
878 trans->pdls[i]->state &= ~PDL_NOMYDIMS;
879 trans->pdls[i]->state |= PDL_MYDIMS_TRANS;
880 }
881 }
882 }
883
884 #ifdef FOO
885 /* If we are not flowing, we must disappear */
886 if(!(trans->flags & PDL_ITRANS_DO_DATAFLOW_ANY)) {
887 pdl_destroytransform(trans,1);
888 }
889 #endif
890
891 PDLDEBUG_f(printf("make_trans_mutual_exit %p\n",(void*)trans));
892
893 } /* pdl_make_trans_mutual() */
894
895
pdl_make_physical(pdl * it)896 void pdl_make_physical(pdl *it) {
897 int i, vaffinepar=0;
898 DECL_RECURSE_GUARD;
899
900 PDLDEBUG_f(printf("Make_physical %p\n",(void*)it));
901 PDL_CHKMAGIC(it);
902
903 START_RECURSE_GUARD;
904 if(it->state & PDL_ALLOCATED && !(it->state & PDL_ANYCHANGED)) {
905 goto mkphys_end;
906 }
907 if(!(it->state & PDL_ANYCHANGED)) {
908 pdl_allocdata(it);
909 goto mkphys_end;
910 }
911 if(!it->trans) {
912 ABORT_RECURSE_GUARD;
913 die("PDL Not physical but doesn't have parent");
914 }
915 #ifndef DONT_OPTIMIZE
916 #ifndef DONT_VAFFINE
917 if(it->trans->flags & PDL_ITRANS_ISAFFINE) {
918 if(!PDL_VAFFOK(it))
919 pdl_make_physvaffine(it);
920 }
921 if(PDL_VAFFOK(it)) {
922 PDLDEBUG_f(printf("Make_phys: VAFFOK\n"));
923 pdl_readdata_vaffine(it);
924 it->state &= (~PDL_ANYCHANGED);
925 PDLDEBUG_f(pdl_dump(it));
926 goto mkphys_end;
927 }
928 #endif
929 #endif
930 PDL_TR_CHKMAGIC(it->trans);
931 for(i=0; i<it->trans->vtable->nparents; i++) {
932 #ifndef DONT_OPTIMIZE
933 #ifndef DONT_VAFFINE
934 if(it->trans->vtable->per_pdl_flags[i] &
935 PDL_TPDL_VAFFINE_OK) {
936 pdl_make_physvaffine(it->trans->pdls[i]);
937 /* check if any of the parents is a vaffine */
938 vaffinepar = vaffinepar || (it->trans->pdls[i]->data != PDL_REPRP(it->trans->pdls[i]));
939 }
940 else
941 #endif
942 #endif
943 pdl_make_physical(it->trans->pdls[i]);
944 }
945 /* the next one is really strange:
946 *
947 * why do we need to call redodims if !(it->state & PDL_ALLOCATED) ???
948 * this results in a) redodims called twice if make_physdims had already been
949 * called for this piddle and results in associated memory leaks!
950 * On the other hand, if I comment out !(it->state & PDL_ALLOCATED)
951 * then we get errors for cases like
952 * $in = $lut->xchg(0,1)->index($im->dummy(0));
953 * $in .= pdl -5;
954 * Currently ugly fix: detect in initthreadstruct that it has been called before
955 * and free all pdl_thread related memory before reallocating
956 * NOTE: this does not catch leaks when additional memory was allocated from with
957 * redodims!!!!!
958 *
959 * The real question is: why do we need another call to
960 * redodims if !(it->state & PDL_ALLOCATED)??????
961 * changed it so that redodims only called if
962 * (!(it->state & PDL_ALLOCATED) && vaffinepar)
963 * i.e. at least one of the parent piddles is a real vaffine
964 * CS
965 */
966 if((!(it->state & PDL_ALLOCATED) && vaffinepar) ||
967 it->state & PDL_PARENTDIMSCHANGED ||
968 it->state & PDL_PARENTREPRCHANGED) {
969 it->trans->vtable->redodims(it->trans);
970 }
971 if(!(it->state & PDL_ALLOCATED)) {
972 pdl_allocdata(it);
973 }
974 /* Make parents physical first. XXX Needs more reasonable way */
975 /* Already done
976 * for(i=0; i<it->trans->vtable->nparents; i++) {
977 * pdl_make_physical(it->trans->pdls[i]);
978 * }
979 */
980 /*
981 * We think we made them physical or physvaffine already...
982 * for(i=0; i<it->trans->vtable->npdls; i++) {
983 * if(!(it->trans->pdls[i]->state & PDL_ALLOCATED)) {
984 * croak("Trying to readdata without physicality");
985 * }
986 *}
987 */
988 it->trans->vtable->readdata(it->trans);
989 it->state &= (~PDL_ANYCHANGED) & (~PDL_OPT_ANY_OK);
990
991 mkphys_end:
992 PDLDEBUG_f(printf("Make_physical_exit %p\n",(void*)it));
993 END_RECURSE_GUARD;
994 }
995
pdl_children_changesoon_c(pdl * it,int what)996 void pdl_children_changesoon_c(pdl *it,int what)
997 {
998 pdl_trans *t;
999 int i;
1000 PDL_DECL_CHILDLOOP(it);
1001 PDL_START_CHILDLOOP(it)
1002 t = PDL_CHILDLOOP_THISCHILD(it);
1003 if(!(t->flags & PDL_ITRANS_DO_DATAFLOW_F)) {
1004 pdl_destroytransform(t,1);
1005 } else {
1006 for(i=t->vtable->nparents; i<t->vtable->npdls; i++) {
1007 pdl_children_changesoon_c(t->pdls[i],what);
1008 }
1009 }
1010 PDL_END_CHILDLOOP(it)
1011 }
1012
1013 /* Change soon: if this is not writeback, separate from
1014 parent.
1015 If the children of this are not writeback, separate them.
1016 */
1017
pdl_children_changesoon(pdl * it,int what)1018 void pdl_children_changesoon(pdl *it, int what)
1019 {
1020 pdl_children *c; int i;
1021 if(it->trans &&
1022 !(it->trans->flags & PDL_ITRANS_DO_DATAFLOW_B)) {
1023 pdl_destroytransform(it->trans,1);
1024 } else if(it->trans) {
1025 if(!(it->trans->flags & PDL_ITRANS_REVERSIBLE)) {
1026 die("PDL: Internal error: Trying to reverse irreversible trans");
1027 }
1028 for(i=0; i<it->trans->vtable->nparents; i++)
1029 pdl_children_changesoon(it->trans->pdls[i],what);
1030 return;
1031 }
1032 pdl_children_changesoon_c(it,what);
1033 }
1034
1035 /* what should always be PARENTDATA */
pdl_vaffinechanged(pdl * it,int what)1036 void pdl_vaffinechanged(pdl *it, int what)
1037 {
1038 if(!PDL_VAFFOK(it)) {
1039 croak("Vaffine not ok!, trying to use vaffinechanged");
1040 }
1041 PDLDEBUG_f(printf("pdl_vaffinechanged: writing back data, triggered by pdl %p, using parent %p\n",(void*)it,(void*)(it->vafftrans->from)));
1042 pdl_changed(it->vafftrans->from,what,0);
1043 }
1044
1045 /* This is inefficient: _changed writes back, which it really should not,
1046 before a parent is used (?). */
pdl_changed(pdl * it,int what,int recursing)1047 void pdl_changed(pdl *it, int what, int recursing)
1048 {
1049 pdl_children *c; int i; int j;
1050
1051 PDLDEBUG_f(
1052 printf("pdl_changed: entry for pdl %p, what %d, recursing: %d\n",
1053 (void*)it,what,recursing);
1054 if (it->state & PDL_TRACEDEBUG)
1055 pdl_dump(it);
1056 );
1057
1058 /* XXX This might save time but is actually unsafe:
1059 * if a -> b -> c, and c made physical and a changed again,
1060 * the changedness doesn't propagate to c */
1061 /* if((it->state & what) == what) { return; } */
1062 if(recursing) {
1063 it->state |= what;
1064 /* The next one is commented out since it breaks
1065 PP functions with more (1) than 1 output arg
1066 (i.e. more than 2 children) (2) that are called
1067 with chained slices of the same parent
1068 and (3) require these args to be physicalized
1069 An example of this scenario (which actually
1070 occurred first in actual code with complex
1071 numbers) is in t/pptest.t (at the end).
1072
1073 Presumably the bit of code below that unsets the
1074 vafftransok flag was only inserted
1075 to make the 'foomethod' example work. It
1076 explores changing parameters of a transformation
1077 and making sure that everything flows correctly.
1078
1079 Based on this idea removing the statement below should
1080 not break anything and fix the problem with
1081 PP funcs described above (CS 190403) */
1082 /* it->state &= ~PDL_OPT_VAFFTRANSOK; */
1083 if(pdl__ismagic(it))
1084 pdl__call_magic(it,PDL_MAGIC_MARKCHANGED);
1085 }
1086 if(it->trans && !recursing && (it->trans->flags & PDL_ITRANS_DO_DATAFLOW_B)) {
1087 if((it->trans->flags & PDL_ITRANS_ISAFFINE) &&
1088 (PDL_VAFFOK(it))) {
1089 PDLDEBUG_f(printf("pdl_changed: calling writebackdata_vaffine (pdl %p)\n",(void*)it));
1090 pdl_writebackdata_vaffine(it);
1091 pdl_changed(it->vafftrans->from,what,0);
1092 } else {
1093 if(!it->trans->vtable->writebackdata) {
1094 die("Internal error: got so close to reversing irrev.");
1095 }
1096 PDLDEBUG_f(printf("pdl_changed: calling writebackdata from vtable, triggered by pdl %p, using trans %p\n",(void*)it,(void*)(it->trans)));
1097 it->trans->vtable->writebackdata(it->trans);
1098 for(i=0; i<it->trans->vtable->nparents; i++) {
1099 if((it->trans->vtable->per_pdl_flags[i] &
1100 PDL_TPDL_VAFFINE_OK) &&
1101 (it->trans->pdls[i]->trans) &&
1102 (it->trans->pdls[i]->trans->flags & PDL_ITRANS_ISAFFINE) &&
1103 (PDL_VAFFOK(it->trans->pdls[i]))
1104 ) {
1105 pdl_changed(it->trans->pdls[i]->vafftrans->from,what,0);
1106 } else {
1107 pdl_changed(it->trans->pdls[i],what,0);
1108 }
1109 }
1110 }
1111 } else {
1112 c=&it->children;
1113 do {
1114 for(i=0; i<PDL_NCHILDREN; i++) {
1115 if(c->trans[i]) {
1116 for(j=c->trans[i]->vtable->nparents;
1117 j<c->trans[i]->vtable->npdls;
1118 j++) {
1119 pdl_changed(c->trans[i]->pdls[j],what,1);
1120 }
1121 }
1122 }
1123 c=c->next;
1124 } while(c);
1125 }
1126 PDLDEBUG_f(printf("pdl_changed: exiting for pdl %p\n",(void*)it));
1127 }
1128
1129 /* This transformation changes soon, so make sure the children
1130 * who don't flow go away
1131 * XXX Should be able to specify which children. */
pdl_trans_changesoon(pdl_trans * trans,int what)1132 void pdl_trans_changesoon(pdl_trans *trans,int what)
1133 {
1134 int i;
1135 for(i=trans->vtable->nparents; i<trans->vtable->npdls; i++) {
1136 pdl_children_changesoon_c(trans->pdls[i],what);
1137 }
1138 }
1139
1140 /* Changed, just propagate changes to children
1141 * XXX should be able to specify which children */
pdl_trans_changed(pdl_trans * trans,int what)1142 void pdl_trans_changed(pdl_trans *trans,int what)
1143 {
1144 int i;
1145 for(i=trans->vtable->nparents; i<trans->vtable->npdls; i++) {
1146 pdl_changed(trans->pdls[i],what,1);
1147 }
1148 }
1149
1150 /* Make sure transformation is done */
pdl__ensure_trans(pdl_trans * trans,int what)1151 void pdl__ensure_trans(pdl_trans *trans,int what)
1152 {
1153 int j;
1154 /* Make parents physical */
1155 int flag=0;
1156 int par_pvaf=0;
1157 flag |= what;
1158
1159 PDL_TR_CHKMAGIC(trans);
1160
1161 for(j=0; j<trans->vtable->nparents; j++) {
1162 #ifndef DONT_OPTIMIZE
1163 #ifndef DONT_VAFFINE
1164 if(trans->vtable->per_pdl_flags[j] &
1165 PDL_TPDL_VAFFINE_OK) {
1166 par_pvaf++;
1167 if(!trans->pdls[j]) {return;} /* XXX!!! */
1168 pdl_make_physvaffine(trans->pdls[j]);
1169 } else {
1170 #endif
1171 #endif
1172 if(!trans->pdls[j]) {return;} /* XXX!!! */
1173 pdl_make_physical(trans->pdls[j]);
1174 }
1175 }
1176
1177 for(; j<trans->vtable->npdls; j++) {
1178 if(trans->pdls[j]->trans != trans) {
1179 #ifndef DONT_OPTIMIZE
1180 #ifndef DONT_VAFFINE
1181 if(trans->vtable->per_pdl_flags[j] &
1182 PDL_TPDL_VAFFINE_OK) {
1183 par_pvaf++;
1184 if(!trans->pdls[j]) {return;} /* XXX!!! */
1185 pdl_make_physvaffine(trans->pdls[j]);
1186 } else
1187 #endif
1188 #endif
1189 { if(!trans->pdls[j]) {return;} /* XXX!!! */
1190 PDLDEBUG_f(printf("not vaffine ok: %d\n",
1191 trans->vtable->per_pdl_flags[j]));
1192
1193 pdl_make_physical(trans->pdls[j]);
1194
1195 }
1196 }
1197 flag |= trans->pdls[j]->state & PDL_ANYCHANGED;
1198 }
1199
1200 if(flag & PDL_PARENTDIMSCHANGED) { /* redodims called here... */
1201 trans->vtable->redodims(trans);
1202 }
1203 for(j=0; j<trans->vtable->npdls; j++) {
1204 if(trans->pdls[j]->trans == trans)
1205 PDL_ENSURE_ALLOCATED(trans->pdls[j]);
1206 }
1207
1208 if(flag & (PDL_PARENTDATACHANGED | PDL_PARENTDIMSCHANGED)) {
1209 int i;
1210
1211 if(par_pvaf && (trans->flags & PDL_ITRANS_ISAFFINE)) {
1212 /* Attention: this assumes affine = p2child */
1213 /* need to signal that redodims has already been called */
1214 /* is it correct to also unset PDL_PARENTREPRCHANGED? */
1215 trans->pdls[1]->state &= ~(PDL_PARENTDIMSCHANGED |
1216 PDL_PARENTREPRCHANGED);
1217 pdl_make_physvaffine(((pdl_trans_affine *)(trans))->pdls[1]);
1218 pdl_readdata_vaffine(((pdl_trans_affine *)(trans))->pdls[1]);
1219 } else {
1220 #ifdef DONT_VAFFINE
1221 for(i=0; i<trans->vtable->npdls; i++) {
1222 if(!(trans->pdls[i]->state & PDL_ALLOCATED)) {
1223 croak("Trying to readdata without physicality");
1224 }
1225 }
1226 #endif
1227 trans->vtable->readdata(trans);
1228 }
1229 }
1230 for(j=trans->vtable->nparents; j<trans->vtable->npdls; j++) {
1231 trans->pdls[j]->state &= ~PDL_ANYCHANGED;
1232 }
1233 }
1234
pdl__ensure_transdims(pdl_trans * trans)1235 void pdl__ensure_transdims(pdl_trans *trans)
1236 {
1237 int j;
1238 int flag=0;
1239 PDL_TR_CHKMAGIC(trans);
1240 for(j=0; j<trans->vtable->nparents; j++) {
1241 pdl_make_physdims(trans->pdls[j]);
1242 }
1243 trans->vtable->redodims(trans);
1244 }
1245
1246 /* There is a potential problem here, calling
1247 pdl_destroy while the trans structure is not in a defined state.
1248 We shall ignore this problem for now and hope it goes away ;)
1249 (XXX FIX ME) */
1250 /* XXX Two next routines are memleaks */
1251 /* somehow this transform will call (implicitly) redodims twice on
1252 an unvaffined pdl; leads to memleak if redodims allocates stuff
1253 that is only freed in later call to freefunc */
pdl_destroytransform(pdl_trans * trans,int ensure)1254 void pdl_destroytransform(pdl_trans *trans,int ensure)
1255 {
1256 int j;
1257 pdl *foo;
1258 pdl *destbuffer[100];
1259 int ndest = 0;
1260
1261 PDLDEBUG_f(printf("entering pdl_destroytransform %p (ensure %d)\n",
1262 (void*)trans,ensure));
1263 if(100 < trans->vtable->npdls) {
1264 die("Huge trans");
1265 }
1266
1267 PDL_TR_CHKMAGIC(trans);
1268 if(!trans->vtable) {
1269 die("ZERO VTABLE DESTTRAN 0x%p %d\n",trans,ensure);
1270 }
1271 if(ensure) {
1272 PDLDEBUG_f(printf("pdl_destroytransform: ensure\n"));
1273 pdl__ensure_trans(trans,0);
1274 }
1275 for(j=0; j<trans->vtable->nparents; j++) {
1276 foo = trans->pdls[j];
1277 if(!foo) continue;
1278 PDL_CHKMAGIC(foo);
1279 PDLDEBUG_f(printf("pdl_removectransform(%p): %p %d\n",
1280 (void*)trans, (void*)(trans->pdls[j]), j));
1281 pdl__removechildtrans(trans->pdls[j],trans,j,1);
1282 if(!(foo->state & PDL_DESTROYING) && !foo->sv) {
1283 destbuffer[ndest++] = foo;
1284 }
1285 }
1286 for(; j<trans->vtable->npdls; j++) {
1287 foo = trans->pdls[j];
1288 PDL_CHKMAGIC(foo);
1289 PDLDEBUG_f(printf("pdl_removeptransform(%p): %p %d\n",
1290 (void*)trans, (void*)(trans->pdls[j]), j));
1291 pdl__removeparenttrans(trans->pdls[j],trans,j);
1292 if(foo->vafftrans) {
1293 PDLDEBUG_f(printf("pdl_removevafft: %p\n", (void*)foo));
1294 pdl_vafftrans_remove(foo);
1295 }
1296 if(!(foo->state & PDL_DESTROYING) && !foo->sv) {
1297 destbuffer[ndest++] = foo;
1298 }
1299 }
1300 PDL_TR_CHKMAGIC(trans);
1301 if(trans->vtable->freetrans) {
1302 PDLDEBUG_f(printf("call freetrans\n"));
1303 trans->vtable->freetrans(trans); /* Free malloced objects */
1304 }
1305 PDL_TR_CLRMAGIC(trans);
1306 trans->vtable = 0; /* Make sure no-one uses this */
1307 if(trans->freeproc) {
1308 PDLDEBUG_f(printf("call freeproc\n"));
1309 trans->freeproc(trans);
1310 } else {
1311 PDLDEBUG_f(printf("call free\n"));
1312 free(trans);
1313 }
1314
1315 for(j=0; j<ndest; j++) {
1316 pdl_destroy(destbuffer[j]);
1317 }
1318
1319 PDLDEBUG_f(printf("leaving pdl_destroytransform %p\n", (void*)trans));
1320
1321 }
1322
pdl_destroytransform_nonmutual(pdl_trans * trans,int ensure)1323 void pdl_destroytransform_nonmutual(pdl_trans *trans,int ensure)
1324 {
1325 int i;
1326
1327 PDLDEBUG_f(printf("entering pdl_destroytransform_nonmutual\n"));
1328
1329 PDL_TR_CHKMAGIC(trans);
1330 if(ensure) {
1331 pdl__ensure_trans(trans,PDL_PARENTDIMSCHANGED);
1332 }
1333 PDL_TR_CHKMAGIC(trans);
1334 for(i=trans->vtable->nparents; i<trans->vtable->npdls; i++) {
1335 trans->pdls[i]->state &= ~PDL_NOMYDIMS;
1336 if(trans->pdls[i]->trans == trans)
1337 trans->pdls[i]->trans = 0;
1338 }
1339 PDL_TR_CHKMAGIC(trans);
1340 if(trans->vtable->freetrans) {
1341 trans->vtable->freetrans(trans);
1342 }
1343 PDL_TR_CLRMAGIC(trans);
1344 trans->vtable = 0; /* Make sure no-one uses this */
1345 if(trans->freeproc) {
1346 trans->freeproc(trans);
1347 } else {
1348 free(trans);
1349 }
1350 PDLDEBUG_f(printf("leaving pdl_destroytransform_nonmutual\n"));
1351 }
1352
pdl_trans_mallocfreeproc(struct pdl_trans * tr)1353 void pdl_trans_mallocfreeproc(struct pdl_trans *tr) {
1354 free(tr);
1355 }
1356
1357 #ifndef DONT_OPTIMIZE
1358
1359 /* Recursive! */
pdl_vafftrans_remove(pdl * it)1360 void pdl_vafftrans_remove(pdl * it)
1361 {
1362 pdl_trans *t; int i;
1363 PDL_DECL_CHILDLOOP(it);
1364 PDL_START_CHILDLOOP(it)
1365 t = PDL_CHILDLOOP_THISCHILD(it);
1366 if(t->flags & PDL_ITRANS_ISAFFINE) {
1367 for(i=t->vtable->nparents; i<t->vtable->npdls; i++)
1368 pdl_vafftrans_remove(t->pdls[i]);
1369 }
1370 PDL_END_CHILDLOOP(it)
1371 pdl_vafftrans_free(it);
1372 }
1373
pdl_vafftrans_free(pdl * it)1374 void pdl_vafftrans_free(pdl *it)
1375 {
1376 if(it->vafftrans && it->vafftrans->incs)
1377 free(it->vafftrans->incs);
1378 if(it->vafftrans)
1379 free(it->vafftrans);
1380 it->vafftrans=0;
1381 it->state &= ~PDL_OPT_VAFFTRANSOK;
1382 }
1383
1384 /* Current assumptions: only
1385 * "slice" and "diagonal"-type things supported.
1386 *
1387 * We need to do careful testing for clump-type things.
1388 */
1389
1390 /* pdl_make_physvaffine can be called on *any* pdl -- vaffine or not --
1391 it will call make_physical as needed on those
1392 this function is the right one to call in any case if you want to
1393 make only those physical (i.e. allocating their own data, etc) which
1394 have to be and leave those vaffine with updated dims, etc, that do
1395 have an appropriate transformation of which they are a child
1396
1397 should probably have been called make_physcareful to point out what
1398 it really does
1399 */
pdl_make_physvaffine(pdl * it)1400 void pdl_make_physvaffine(pdl *it)
1401 {
1402 pdl_trans *t;
1403 pdl_trans_affine *at;
1404 pdl *parent;
1405 pdl *current;
1406 PDL_Indx *incsleft = 0;
1407 int i,j;
1408 PDL_Indx inc;
1409 PDL_Indx newinc;
1410 PDL_Indx ninced;
1411 int flag;
1412 int incsign;
1413
1414 PDLDEBUG_f(printf("Make_physvaffine %p\n",(void*)it));
1415
1416 pdl_make_physdims(it);
1417
1418 if(!it->trans) {
1419 pdl_make_physical(it);
1420 goto mkphys_vaff_end;
1421 /* croak("Trying to make physvaffine without parent!\n"); */
1422 }
1423 if(!(it->trans->flags & PDL_ITRANS_ISAFFINE)) {
1424 pdl_make_physical(it);
1425 goto mkphys_vaff_end;
1426 }
1427
1428 (void)PDL_ENSURE_VAFFTRANS(it);
1429 incsleft = malloc(sizeof(*incsleft)*it->ndims);
1430 PDLDEBUG_f(printf("vaff_malloc: got %p\n",(void*)incsleft));
1431 for(i=0; i<it->ndims; i++) {
1432 it->vafftrans->incs[i] = it->dimincs[i];
1433 }
1434
1435 flag=0;
1436 it->vafftrans->offs = 0;
1437 t=it->trans;
1438 current = it;
1439 while(t && (t->flags & PDL_ITRANS_ISAFFINE)) {
1440 PDL_Indx cur_offset = 0;
1441 at = (pdl_trans_affine *)t;
1442 parent = t->pdls[0];
1443 /* For all dimensions of the childest piddle */
1444 for(i=0; i<it->ndims; i++) {
1445 PDL_Indx offset_left = it->vafftrans->offs;
1446
1447 /* inc = the increment at the current stage */
1448 inc = it->vafftrans->incs[i];
1449 incsign = (inc >= 0 ? 1:-1);
1450 inc *= incsign;
1451 newinc = 0;
1452 /* For all dimensions of the current piddle */
1453 for(j=current->ndims-1; j>=0 && current->dimincs[j] != 0; j--) {
1454 cur_offset = offset_left / current->dimincs[j];
1455 offset_left -= cur_offset * current->dimincs[j];
1456 if(incsign < 0) {
1457 cur_offset = (current->dims[j]-1) - cur_offset;
1458 }
1459 /* If the absolute value > this so */
1460 /* we have a contribution from this dimension */
1461 if(inc >= current->dimincs[j]) {
1462 /* We used this many of this dim */
1463 ninced = inc / current->dimincs[j];
1464 if(cur_offset + it->dims[i]*ninced >
1465 current->dims[j]) {
1466 PDL_Indx foo =
1467 (cur_offset + it->dims[i]*ninced)*
1468 current->dimincs[j];
1469 int k;
1470 for(k=j+1; k<current->ndims; k++) {
1471 foo -= current->dimincs[k-1] *
1472 current->dims[k-1];
1473 if(foo<=0) break;
1474 if(at->incs[k] !=
1475 at->incs[k-1] *
1476 current->dims[k-1]) {
1477 /* XXXXX */
1478 flag=1;
1479 /*
1480 warn("Illegal vaffine; fix loop to break: %d %d %d k=%d s=%d, (%d+%d*%d>%d) %d %d %d %d.\n",at,current,it,
1481 k,incsign,cur_offset,it->dims[i],ninced,current->dims[j],current->dimincs[j],
1482 at->incs[k],at->incs[k-1],current->dims[k-1]);
1483 */
1484 /* croak("Illegal vaffine; fix loop to break.\n"); */
1485 }
1486 }
1487 }
1488 newinc += at->incs[j]*ninced;
1489 inc %= current->dimincs[j];
1490 }
1491 }
1492 incsleft[i] = incsign*newinc;
1493 }
1494
1495 if(flag) break;
1496 for(i=0; i<it->ndims; i++) {
1497 it->vafftrans->incs[i] = incsleft[i];
1498 }
1499 {
1500 PDL_Indx offset_left = it->vafftrans->offs;
1501 inc = it->vafftrans->offs;
1502 newinc = 0;
1503 for(j=current->ndims-1; j>=0 && current->dimincs[j] != 0; j--) {
1504 cur_offset = offset_left / current->dimincs[j];
1505 offset_left -= cur_offset * current->dimincs[j];
1506 newinc += at->incs[j]*cur_offset;
1507 }
1508 it->vafftrans->offs = newinc;
1509 it->vafftrans->offs += at->offs;
1510 }
1511 t = parent->trans;
1512 current = parent;
1513 }
1514 it->vafftrans->from = current;
1515 it->state |= PDL_OPT_VAFFTRANSOK;
1516 pdl_make_physical(current);
1517
1518 mkphys_vaff_end:
1519 PDLDEBUG_f(printf("vaff_malloc: %p\n",(void*)incsleft));
1520 if (incsleft != NULL) free(incsleft);
1521 PDLDEBUG_f(printf("Make_physvaffine_exit %p\n",(void*)it));
1522
1523 }
1524
pdl_vafftrans_alloc(pdl * it)1525 void pdl_vafftrans_alloc(pdl *it)
1526 {
1527 if(!it->vafftrans) {
1528 it->vafftrans = malloc(sizeof(*(it->vafftrans)));
1529 it->vafftrans->incs = 0;
1530 it->vafftrans->ndims = 0;
1531 }
1532 if(!it->vafftrans->incs || it->vafftrans->ndims < it->ndims ) {
1533 if(it->vafftrans->incs) free(it->vafftrans->incs);
1534 it->vafftrans->incs = malloc(sizeof(*(it->vafftrans->incs))
1535 * it->ndims);
1536 it->vafftrans->ndims = it->ndims;
1537 }
1538 }
1539
1540 #endif
1541