1 /****************************************************************************
2 **
3 ** This file is part of GAP, a system for computational discrete algebra.
4 **
5 ** Copyright of GAP belongs to its developers, whose names are too numerous
6 ** to list here. Please refer to the COPYRIGHT file for details.
7 **
8 ** SPDX-License-Identifier: GPL-2.0-or-later
9 **
10 ** This file contains the functions for the function call mechanism package.
11 **
12 ** For a description of what the function call mechanism is about see the
13 ** declaration part of this package.
14 **
15 ** Each function is represented by a function bag (of type 'T_FUNCTION'),
16 ** which has the following format.
17 **
18 ** +-------+-------+- - - -+-------+
19 ** |handler|handler| |handler| (for all functions)
20 ** | 0 | 1 | | 7 |
21 ** +-------+-------+- - - -+-------+
22 **
23 ** +-------+-------+-------+-------+
24 ** | name | number| args &| prof- | (for all functions)
25 ** | func. | args | locals| iling |
26 ** +-------+-------+-------+-------+
27 **
28 ** +-------+-------+-------+-------+
29 ** | number| body | envir-| funcs.| (only for interpreted functions)
30 ** | locals| func. | onment| exprs.|
31 ** +-------+-------+-------+-------+
32 **
33 ** ...what the handlers are..
34 ** ...what the other components are...
35 */
36
37 #include "calls.h"
38
39 #include "bool.h"
40 #include "code.h"
41 #include "error.h"
42 #ifdef USE_GASMAN
43 #include "gasman_intern.h"
44 #endif
45 #include "gvars.h"
46 #include "integer.h"
47 #include "io.h"
48 #include "lists.h"
49 #include "modules.h"
50 #include "opers.h"
51 #include "plist.h"
52 #include "saveload.h"
53 #include "stats.h"
54 #include "stringobj.h"
55 #include "vars.h"
56
57 #ifdef HPCGAP
58 #include "hpc/thread.h"
59 #endif
60
SET_NAME_FUNC(Obj func,Obj name)61 void SET_NAME_FUNC(Obj func, Obj name)
62 {
63 GAP_ASSERT(name == 0 || IS_STRING_REP(name));
64 FUNC(func)->name = name;
65 }
66
NAMI_FUNC(Obj func,Int i)67 Obj NAMI_FUNC(Obj func, Int i)
68 {
69 return ELM_LIST(NAMS_FUNC(func),i);
70 }
71
72
73 /****************************************************************************
74 **
75 *F COUNT_PROF( <prof> ) . . . . . . . . number of invocations of a function
76 *F TIME_WITH_PROF( <prof> ) . . . . . . time with children in a function
77 *F TIME_WOUT_PROF( <prof> ) . . . . . . time without children in a function
78 *F STOR_WITH_PROF( <prof> ) . . . . storage with children in a function
79 *F STOR_WOUT_PROF( <prof> ) . . . . storage without children in a function
80 *V LEN_PROF . . . . . . . . . . . length of a profiling bag for a function
81 **
82 ** With each function we associate two time measurements. First the *time
83 ** spent by this function without its children*, i.e., the amount of time
84 ** during which this function was active. Second the *time spent by this
85 ** function with its children*, i.e., the amount of time during which this
86 ** function was either active or suspended.
87 **
88 ** Likewise with each function we associate the two storage measurements,
89 ** the storage spent by this function without its children and the storage
90 ** spent by this function with its children.
91 **
92 ** These macros make it possible to access the various components of a
93 ** profiling information bag <prof> for a function <func>.
94 **
95 ** 'COUNT_PROF(<prof>)' is the number of calls to the function <func>.
96 ** 'TIME_WITH_PROF(<prof>) is the time spent while the function <func> was
97 ** either active or suspended. 'TIME_WOUT_PROF(<prof>)' is the time spent
98 ** while the function <func> was active. 'STOR_WITH_PROF(<prof>)' is the
99 ** amount of storage allocated while the function <func> was active or
100 ** suspended. 'STOR_WOUT_PROF(<prof>)' is the amount of storage allocated
101 ** while the function <func> was active. 'LEN_PROF' is the length of a
102 ** profiling information bag.
103 */
104 #define COUNT_PROF(prof) (INT_INTOBJ(ELM_PLIST(prof,1)))
105 #define TIME_WITH_PROF(prof) (INT_INTOBJ(ELM_PLIST(prof,2)))
106 #define TIME_WOUT_PROF(prof) (INT_INTOBJ(ELM_PLIST(prof,3)))
107 #define STOR_WITH_PROF(prof) (UInt8_ObjInt(ELM_PLIST(prof,4)))
108 #define STOR_WOUT_PROF(prof) (UInt8_ObjInt(ELM_PLIST(prof,5)))
109
110 #define SET_COUNT_PROF(prof,n) SET_ELM_PLIST(prof,1,INTOBJ_INT(n))
111 #define SET_TIME_WITH_PROF(prof,n) SET_ELM_PLIST(prof,2,INTOBJ_INT(n))
112 #define SET_TIME_WOUT_PROF(prof,n) SET_ELM_PLIST(prof,3,INTOBJ_INT(n))
113
SET_STOR_WITH_PROF(Obj prof,UInt8 n)114 static inline void SET_STOR_WITH_PROF(Obj prof, UInt8 n)
115 {
116 SET_ELM_PLIST(prof,4,ObjInt_Int8(n));
117 CHANGED_BAG(prof);
118 }
119
SET_STOR_WOUT_PROF(Obj prof,UInt8 n)120 static inline void SET_STOR_WOUT_PROF(Obj prof, UInt8 n)
121 {
122 SET_ELM_PLIST(prof,5,ObjInt_Int8(n));
123 CHANGED_BAG(prof);
124 }
125
126 #define LEN_PROF 5
127
128
129 /****************************************************************************
130 **
131 *F * * * * wrapper for functions with variable number of arguments * * * * *
132 */
133
134 /****************************************************************************
135 **
136 *F DoWrap0args( <self> ) . . . . . . . . . . . wrap up 0 arguments in a list
137 **
138 ** 'DoWrap<i>args' accepts the <i> arguments <arg1>, <arg2>, and so on,
139 ** wraps them up in a list, and then calls <self> again via 'CALL_XARGS',
140 ** passing this list. 'DoWrap<i>args' are the handlers for callees that
141 ** accept a variable number of arguments. Note that there is no
142 ** 'DoWrapXargs' handler, since in this case the function call mechanism
143 ** already requires that the passed arguments are collected in a list.
144 */
DoWrap0args(Obj self)145 static Obj DoWrap0args(Obj self)
146 {
147 Obj result; /* value of function call, result */
148 Obj args; /* arguments list */
149
150 /* make the arguments list */
151 args = NEW_PLIST( T_PLIST, 0 );
152
153 /* call the variable number of arguments function */
154 result = CALL_XARGS( self, args );
155 return result;
156 }
157
158
159 /****************************************************************************
160 **
161 *F DoWrap1args( <self>, <arg1> ) . . . . . . . wrap up 1 arguments in a list
162 */
DoWrap1args(Obj self,Obj arg1)163 static Obj DoWrap1args(Obj self, Obj arg1)
164 {
165 Obj result; /* value of function call, result */
166 Obj args; /* arguments list */
167
168 /* make the arguments list */
169 args = NEW_PLIST( T_PLIST, 1 );
170 SET_LEN_PLIST( args, 1 );
171 SET_ELM_PLIST( args, 1, arg1 );
172
173 /* call the variable number of arguments function */
174 result = CALL_XARGS( self, args );
175 return result;
176 }
177
178
179 /****************************************************************************
180 **
181 *F DoWrap2args( <self>, <arg1>, ... ) . . . . wrap up 2 arguments in a list
182 */
DoWrap2args(Obj self,Obj arg1,Obj arg2)183 static Obj DoWrap2args(Obj self, Obj arg1, Obj arg2)
184 {
185 Obj result; /* value of function call, result */
186 Obj args; /* arguments list */
187
188 /* make the arguments list */
189 args = NEW_PLIST( T_PLIST, 2 );
190 SET_LEN_PLIST( args, 2 );
191 SET_ELM_PLIST( args, 1, arg1 );
192 SET_ELM_PLIST( args, 2, arg2 );
193
194 /* call the variable number of arguments function */
195 result = CALL_XARGS( self, args );
196 return result;
197 }
198
199
200 /****************************************************************************
201 **
202 *F DoWrap3args( <self>, <arg1>, ... ) . . . . wrap up 3 arguments in a list
203 */
DoWrap3args(Obj self,Obj arg1,Obj arg2,Obj arg3)204 static Obj DoWrap3args(Obj self, Obj arg1, Obj arg2, Obj arg3)
205 {
206 Obj result; /* value of function call, result */
207 Obj args; /* arguments list */
208
209 /* make the arguments list */
210 args = NEW_PLIST( T_PLIST, 3 );
211 SET_LEN_PLIST( args, 3 );
212 SET_ELM_PLIST( args, 1, arg1 );
213 SET_ELM_PLIST( args, 2, arg2 );
214 SET_ELM_PLIST( args, 3, arg3 );
215
216 /* call the variable number of arguments function */
217 result = CALL_XARGS( self, args );
218 return result;
219 }
220
221
222 /****************************************************************************
223 **
224 *F DoWrap4args( <self>, <arg1>, ... ) . . . . wrap up 4 arguments in a list
225 */
DoWrap4args(Obj self,Obj arg1,Obj arg2,Obj arg3,Obj arg4)226 static Obj DoWrap4args(Obj self, Obj arg1, Obj arg2, Obj arg3, Obj arg4)
227 {
228 Obj result; /* value of function call, result */
229 Obj args; /* arguments list */
230
231 /* make the arguments list */
232 args = NEW_PLIST( T_PLIST, 4 );
233 SET_LEN_PLIST( args, 4 );
234 SET_ELM_PLIST( args, 1, arg1 );
235 SET_ELM_PLIST( args, 2, arg2 );
236 SET_ELM_PLIST( args, 3, arg3 );
237 SET_ELM_PLIST( args, 4, arg4 );
238
239 /* call the variable number of arguments function */
240 result = CALL_XARGS( self, args );
241 return result;
242 }
243
244
245 /****************************************************************************
246 **
247 *F DoWrap5args( <self>, <arg1>, ... ) . . . . wrap up 5 arguments in a list
248 */
249 static Obj
DoWrap5args(Obj self,Obj arg1,Obj arg2,Obj arg3,Obj arg4,Obj arg5)250 DoWrap5args(Obj self, Obj arg1, Obj arg2, Obj arg3, Obj arg4, Obj arg5)
251 {
252 Obj result; /* value of function call, result */
253 Obj args; /* arguments list */
254
255 /* make the arguments list */
256 args = NEW_PLIST( T_PLIST, 5 );
257 SET_LEN_PLIST( args, 5 );
258 SET_ELM_PLIST( args, 1, arg1 );
259 SET_ELM_PLIST( args, 2, arg2 );
260 SET_ELM_PLIST( args, 3, arg3 );
261 SET_ELM_PLIST( args, 4, arg4 );
262 SET_ELM_PLIST( args, 5, arg5 );
263
264 /* call the variable number of arguments function */
265 result = CALL_XARGS( self, args );
266 return result;
267 }
268
269
270 /****************************************************************************
271 **
272 *F DoWrap6args( <self>, <arg1>, ... ) . . . . wrap up 6 arguments in a list
273 */
DoWrap6args(Obj self,Obj arg1,Obj arg2,Obj arg3,Obj arg4,Obj arg5,Obj arg6)274 static Obj DoWrap6args(
275 Obj self, Obj arg1, Obj arg2, Obj arg3, Obj arg4, Obj arg5, Obj arg6)
276 {
277 Obj result; /* value of function call, result */
278 Obj args; /* arguments list */
279
280 /* make the arguments list */
281 args = NEW_PLIST( T_PLIST, 6 );
282 SET_LEN_PLIST( args, 6 );
283 SET_ELM_PLIST( args, 1, arg1 );
284 SET_ELM_PLIST( args, 2, arg2 );
285 SET_ELM_PLIST( args, 3, arg3 );
286 SET_ELM_PLIST( args, 4, arg4 );
287 SET_ELM_PLIST( args, 5, arg5 );
288 SET_ELM_PLIST( args, 6, arg6 );
289
290 /* call the variable number of arguments function */
291 result = CALL_XARGS( self, args );
292 return result;
293 }
294
295
296 /****************************************************************************
297 **
298 *F * * wrapper for functions with do not support the number of arguments * *
299 */
300
301 /****************************************************************************
302 **
303 *F DoFail0args( <self> ) . . . . . . fail a function call with 0 arguments
304 **
305 ** 'DoFail<i>args' accepts the <i> arguments <arg1>, <arg2>, and so on, and
306 ** signals an error, because the function for which they are installed
307 ** expects another number of arguments. 'DoFail<i>args' are the handlers in
308 ** the other slots of a function.
309 */
310
311 /* Pull this out to avoid repetition, since it gets a little more complex in
312 the presence of partially variadic functions */
313
NargError(Obj func,Int actual)314 NORETURN static void NargError(Obj func, Int actual)
315 {
316 Int narg = NARG_FUNC(func);
317
318 if (narg >= 0) {
319 assert(narg != actual);
320 ErrorMayQuitNrArgs(narg, actual);
321 } else {
322 assert(-narg-1 > actual);
323 ErrorMayQuitNrAtLeastArgs(-narg - 1, actual);
324 }
325 }
326
DoFail0args(Obj self)327 static Obj DoFail0args(Obj self)
328 {
329 NargError(self, 0);
330 }
331
332
333 /****************************************************************************
334 **
335 *F DoFail1args( <self>,<arg1> ) . . . fail a function call with 1 arguments
336 */
DoFail1args(Obj self,Obj arg1)337 static Obj DoFail1args(Obj self, Obj arg1)
338 {
339 NargError(self, 1);
340 }
341
342
343 /****************************************************************************
344 **
345 *F DoFail2args( <self>, <arg1>, ... ) fail a function call with 2 arguments
346 */
DoFail2args(Obj self,Obj arg1,Obj arg2)347 static Obj DoFail2args(Obj self, Obj arg1, Obj arg2)
348 {
349 NargError(self, 2);
350 }
351
352
353 /****************************************************************************
354 **
355 *F DoFail3args( <self>, <arg1>, ... ) fail a function call with 3 arguments
356 */
DoFail3args(Obj self,Obj arg1,Obj arg2,Obj arg3)357 static Obj DoFail3args(Obj self, Obj arg1, Obj arg2, Obj arg3)
358 {
359 NargError(self, 3);
360 }
361
362
363 /****************************************************************************
364 **
365 *F DoFail4args( <self>, <arg1>, ... ) fail a function call with 4 arguments
366 */
DoFail4args(Obj self,Obj arg1,Obj arg2,Obj arg3,Obj arg4)367 static Obj DoFail4args(Obj self, Obj arg1, Obj arg2, Obj arg3, Obj arg4)
368 {
369 NargError(self, 4);
370 }
371
372
373 /****************************************************************************
374 **
375 *F DoFail5args( <self>, <arg1>, ... ) fail a function call with 5 arguments
376 */
377 static Obj
DoFail5args(Obj self,Obj arg1,Obj arg2,Obj arg3,Obj arg4,Obj arg5)378 DoFail5args(Obj self, Obj arg1, Obj arg2, Obj arg3, Obj arg4, Obj arg5)
379 {
380 NargError(self, 5);
381 }
382
383
384 /****************************************************************************
385 **
386 *F DoFail6args( <self>, <arg1>, ... ) fail a function call with 6 arguments
387 */
DoFail6args(Obj self,Obj arg1,Obj arg2,Obj arg3,Obj arg4,Obj arg5,Obj arg6)388 static Obj DoFail6args(
389 Obj self, Obj arg1, Obj arg2, Obj arg3, Obj arg4, Obj arg5, Obj arg6)
390 {
391 NargError(self, 6);
392 }
393
394
395 /****************************************************************************
396 **
397 *F DoFailXargs( <self>, <args> ) . . fail a function call with X arguments
398 */
DoFailXargs(Obj self,Obj args)399 static Obj DoFailXargs(Obj self, Obj args)
400 {
401 NargError(self, LEN_LIST(args));
402 }
403
404
405 /****************************************************************************
406 **
407 *F * * * * * * * * * * * * * wrapper for profiling * * * * * * * * * * * * *
408 */
409
410 /****************************************************************************
411 **
412 *V TimeDone . . . . . . amount of time spent for completed function calls
413 **
414 ** 'TimeDone' is the amount of time spent for all function calls that have
415 ** already been completed.
416 */
417 static UInt TimeDone;
418
419
420 /****************************************************************************
421 **
422 *V StorDone . . . . . amount of storage spent for completed function calls
423 **
424 ** 'StorDone' is the amount of storage spent for all function call that have
425 ** already been completed.
426 */
427 static UInt8 StorDone;
428
429
430 /****************************************************************************
431 **
432 *F DoProf0args( <self> ) . . . . . . . . profile a function with 0 arguments
433 **
434 ** 'DoProf<i>args' accepts the <i> arguments <arg1>, <arg2>, and so on, and
435 ** calls the function through the secondary handler. It also updates the
436 ** profiling information in the profiling information bag of the called
437 ** function. 'DoProf<i>args' are the primary handlers for all functions
438 ** when profiling is requested.
439 */
DoProfNNNargs(Obj self,Int n,Obj arg1,Obj arg2,Obj arg3,Obj arg4,Obj arg5,Obj arg6)440 static ALWAYS_INLINE Obj DoProfNNNargs (
441 Obj self,
442 Int n,
443 Obj arg1,
444 Obj arg2,
445 Obj arg3,
446 Obj arg4,
447 Obj arg5,
448 Obj arg6 )
449
450 {
451 Obj result; /* value of function call, result */
452 Obj prof; /* profiling bag */
453 UInt timeElse; /* time spent elsewhere */
454 UInt timeCurr; /* time spent in current funcs. */
455 UInt8 storElse; /* storage spent elsewhere */
456 UInt8 storCurr; /* storage spent in current funcs. */
457
458 /* get the profiling bag */
459 prof = PROF_FUNC( PROF_FUNC( self ) );
460
461 /* time and storage spent so far while this function what not active */
462 timeElse = SyTime() - TIME_WITH_PROF(prof);
463 storElse = SizeAllBags - STOR_WITH_PROF(prof);
464
465 /* time and storage spent so far by all currently suspended functions */
466 timeCurr = SyTime() - TimeDone;
467 storCurr = SizeAllBags - StorDone;
468
469 /* call the real function */
470 switch (n) {
471 case 0: result = CALL_0ARGS_PROF( self ); break;
472 case 1: result = CALL_1ARGS_PROF( self, arg1 ); break;
473 case 2: result = CALL_2ARGS_PROF( self, arg1, arg2 ); break;
474 case 3: result = CALL_3ARGS_PROF( self, arg1, arg2, arg3 ); break;
475 case 4: result = CALL_4ARGS_PROF( self, arg1, arg2, arg3, arg4 ); break;
476 case 5: result = CALL_5ARGS_PROF( self, arg1, arg2, arg3, arg4, arg5 ); break;
477 case 6: result = CALL_6ARGS_PROF( self, arg1, arg2, arg3, arg4, arg5, arg6 ); break;
478 case -1: result = CALL_XARGS_PROF( self, arg1 ); break;
479 default: result = 0; GAP_ASSERT(0);
480 }
481
482 /* number of invocation of this function */
483 SET_COUNT_PROF( prof, COUNT_PROF(prof) + 1 );
484
485 /* time and storage spent in this function and its children */
486 SET_TIME_WITH_PROF( prof, SyTime() - timeElse );
487 SET_STOR_WITH_PROF( prof, SizeAllBags - storElse );
488
489 /* time and storage spent by this invocation of this function */
490 timeCurr = SyTime() - TimeDone - timeCurr;
491 SET_TIME_WOUT_PROF( prof, TIME_WOUT_PROF(prof) + timeCurr );
492 TimeDone += timeCurr;
493 storCurr = SizeAllBags - StorDone - storCurr;
494 SET_STOR_WOUT_PROF( prof, STOR_WOUT_PROF(prof) + storCurr );
495 StorDone += storCurr;
496
497 /* return the result from the function */
498 return result;
499 }
500
DoProf0args(Obj self)501 static Obj DoProf0args (
502 Obj self )
503 {
504 return DoProfNNNargs(self, 0, 0, 0, 0, 0, 0, 0);
505 }
506
507
508 /****************************************************************************
509 **
510 *F DoProf1args( <self>, <arg1>) . . . . profile a function with 1 arguments
511 */
DoProf1args(Obj self,Obj arg1)512 static Obj DoProf1args (
513 Obj self,
514 Obj arg1 )
515 {
516 return DoProfNNNargs(self, 1, arg1, 0, 0, 0, 0, 0);
517 }
518
519
520 /****************************************************************************
521 **
522 *F DoProf2args( <self>, <arg1>, ... ) . profile a function with 2 arguments
523 */
DoProf2args(Obj self,Obj arg1,Obj arg2)524 static Obj DoProf2args (
525 Obj self,
526 Obj arg1,
527 Obj arg2 )
528 {
529 return DoProfNNNargs(self, 2, arg1, arg2, 0, 0, 0, 0);
530 }
531
532
533 /****************************************************************************
534 **
535 *F DoProf3args( <self>, <arg1>, ... ) . profile a function with 3 arguments
536 */
DoProf3args(Obj self,Obj arg1,Obj arg2,Obj arg3)537 static Obj DoProf3args (
538 Obj self,
539 Obj arg1,
540 Obj arg2,
541 Obj arg3 )
542 {
543 return DoProfNNNargs(self, 3, arg1, arg2, arg3, 0, 0, 0);
544 }
545
546
547 /****************************************************************************
548 **
549 *F DoProf4args( <self>, <arg1>, ... ) . profile a function with 4 arguments
550 */
DoProf4args(Obj self,Obj arg1,Obj arg2,Obj arg3,Obj arg4)551 static Obj DoProf4args (
552 Obj self,
553 Obj arg1,
554 Obj arg2,
555 Obj arg3,
556 Obj arg4 )
557 {
558 return DoProfNNNargs(self, 4, arg1, arg2, arg3, arg4, 0, 0);
559 }
560
561
562 /****************************************************************************
563 **
564 *F DoProf5args( <self>, <arg1>, ... ) . profile a function with 5 arguments
565 */
DoProf5args(Obj self,Obj arg1,Obj arg2,Obj arg3,Obj arg4,Obj arg5)566 static Obj DoProf5args (
567 Obj self,
568 Obj arg1,
569 Obj arg2,
570 Obj arg3,
571 Obj arg4,
572 Obj arg5 )
573 {
574 return DoProfNNNargs(self, 5, arg1, arg2, arg3, arg4, arg5, 0);
575 }
576
577
578 /****************************************************************************
579 **
580 *F DoProf6args( <self>, <arg1>, ... ) . profile a function with 6 arguments
581 */
DoProf6args(Obj self,Obj arg1,Obj arg2,Obj arg3,Obj arg4,Obj arg5,Obj arg6)582 static Obj DoProf6args (
583 Obj self,
584 Obj arg1,
585 Obj arg2,
586 Obj arg3,
587 Obj arg4,
588 Obj arg5,
589 Obj arg6 )
590 {
591 return DoProfNNNargs(self, 6, arg1, arg2, arg3, arg4, arg5, arg6);
592 }
593
594
595 /****************************************************************************
596 **
597 *F DoProfXargs( <self>, <args> ) . . . . profile a function with X arguments
598 */
DoProfXargs(Obj self,Obj args)599 static Obj DoProfXargs (
600 Obj self,
601 Obj args )
602 {
603 return DoProfNNNargs(self, -1, args, 0, 0, 0, 0, 0);
604 }
605
606
607 /****************************************************************************
608 **
609 *F * * * * * * * * * * * * * create a new function * * * * * * * * * * * * *
610 */
611
612 /****************************************************************************
613 **
614 *F InitHandlerFunc( <handler>, <cookie> ) . . . . . . . . register a handler
615 **
616 ** Every handler should be registered (once) before it is installed in any
617 ** function bag. This is needed so that it can be identified when loading a
618 ** saved workspace. <cookie> should be a unique C string, identifying the
619 ** handler
620 */
621 #ifndef MAX_HANDLERS
622 #define MAX_HANDLERS 20000
623 #endif
624
625 typedef struct {
626 ObjFunc hdlr;
627 const Char * cookie;
628 }
629 TypeHandlerInfo;
630
631 static UInt HandlerSortingStatus = 0;
632
633 static TypeHandlerInfo HandlerFuncs[MAX_HANDLERS];
634 static UInt NHandlerFuncs = 0;
635
InitHandlerFunc(ObjFunc hdlr,const Char * cookie)636 void InitHandlerFunc (
637 ObjFunc hdlr,
638 const Char * cookie )
639 {
640 if ( NHandlerFuncs >= MAX_HANDLERS ) {
641 Panic("No room left for function handler");
642 }
643
644 for (UInt i = 0; i < NHandlerFuncs; i++)
645 if (!strcmp(HandlerFuncs[i].cookie, cookie))
646 Pr("Duplicate cookie %s\n", (Int)cookie, 0L);
647
648 HandlerFuncs[NHandlerFuncs].hdlr = hdlr;
649 HandlerFuncs[NHandlerFuncs].cookie = cookie;
650 HandlerSortingStatus = 0; /* no longer sorted by handler or cookie */
651 NHandlerFuncs++;
652 }
653
654
655
656 /****************************************************************************
657 **
658 *f CheckHandlersBag( <bag> ) . . . . . . check that handlers are initialised
659 */
660 #ifdef USE_GASMAN
661
CheckHandlersBag(Bag bag)662 static void CheckHandlersBag(
663 Bag bag )
664 {
665 UInt i;
666 UInt j;
667 ObjFunc hdlr;
668
669 if ( TNUM_BAG(bag) == T_FUNCTION ) {
670 for ( j = 0; j < 8; j++ ) {
671 hdlr = HDLR_FUNC(bag,j);
672
673 /* zero handlers are used in a few odd places */
674 if ( hdlr != 0 ) {
675 for ( i = 0; i < NHandlerFuncs; i++ ) {
676 if ( hdlr == HandlerFuncs[i].hdlr )
677 break;
678 }
679 if ( i == NHandlerFuncs ) {
680 Pr("Unregistered Handler %d args ", j, 0L);
681 PrintObj(NAME_FUNC(bag));
682 Pr("\n",0L,0L);
683 }
684 }
685 }
686 }
687 }
688
CheckAllHandlers(void)689 void CheckAllHandlers(void)
690 {
691 CallbackForAllBags(CheckHandlersBag);
692 }
693
IsLessHandlerInfo(TypeHandlerInfo * h1,TypeHandlerInfo * h2,UInt byWhat)694 static int IsLessHandlerInfo (
695 TypeHandlerInfo * h1,
696 TypeHandlerInfo * h2,
697 UInt byWhat )
698 {
699 switch (byWhat) {
700 case 1:
701 /* cast to please Irix CC and HPUX CC */
702 return (UInt)(h1->hdlr) < (UInt)(h2->hdlr);
703 case 2:
704 return strcmp(h1->cookie, h2->cookie) < 0;
705 default:
706 ErrorQuit( "Invalid sort mode %u", (Int)byWhat, 0L );
707 }
708 }
709
SortHandlers(UInt byWhat)710 void SortHandlers( UInt byWhat )
711 {
712 TypeHandlerInfo tmp;
713 UInt len, h, i, k;
714 if (HandlerSortingStatus == byWhat)
715 return;
716 len = NHandlerFuncs;
717 h = 1;
718 while ( 9*h + 4 < len )
719 { h = 3*h + 1; }
720 while ( 0 < h ) {
721 for ( i = h; i < len; i++ ) {
722 tmp = HandlerFuncs[i];
723 k = i;
724 while ( h <= k && IsLessHandlerInfo(&tmp, HandlerFuncs+(k-h), byWhat))
725 {
726 HandlerFuncs[k] = HandlerFuncs[k-h];
727 k -= h;
728 }
729 HandlerFuncs[k] = tmp;
730 }
731 h = h / 3;
732 }
733 HandlerSortingStatus = byWhat;
734 }
735
CookieOfHandler(ObjFunc hdlr)736 const Char * CookieOfHandler (
737 ObjFunc hdlr )
738 {
739 UInt i, top, bottom, middle;
740
741 if ( HandlerSortingStatus != 1 ) {
742 for ( i = 0; i < NHandlerFuncs; i++ ) {
743 if ( hdlr == HandlerFuncs[i].hdlr )
744 return HandlerFuncs[i].cookie;
745 }
746 return (Char *)0L;
747 }
748 else {
749 top = NHandlerFuncs;
750 bottom = 0;
751 while ( top >= bottom ) {
752 middle = (top + bottom)/2;
753 if ( (UInt)(hdlr) < (UInt)(HandlerFuncs[middle].hdlr) )
754 top = middle-1;
755 else if ( (UInt)(hdlr) > (UInt)(HandlerFuncs[middle].hdlr) )
756 bottom = middle+1;
757 else
758 return HandlerFuncs[middle].cookie;
759 }
760 return (Char *)0L;
761 }
762 }
763
HandlerOfCookie(const Char * cookie)764 ObjFunc HandlerOfCookie(
765 const Char * cookie )
766 {
767 Int i,top,bottom,middle;
768 Int res;
769 if (HandlerSortingStatus != 2)
770 {
771 for (i = 0; i < NHandlerFuncs; i++)
772 {
773 if (strcmp(cookie, HandlerFuncs[i].cookie) == 0)
774 return HandlerFuncs[i].hdlr;
775 }
776 return (ObjFunc)0L;
777 }
778 else
779 {
780 top = NHandlerFuncs;
781 bottom = 0;
782 while (top >= bottom) {
783 middle = (top + bottom)/2;
784 res = strcmp(cookie,HandlerFuncs[middle].cookie);
785 if (res < 0)
786 top = middle-1;
787 else if (res > 0)
788 bottom = middle+1;
789 else
790 return HandlerFuncs[middle].hdlr;
791 }
792 return (ObjFunc)0L;
793 }
794 }
795
796 #endif
797
798
799 /****************************************************************************
800 **
801 *F NewFunction( <name>, <narg>, <nams>, <hdlr> ) . . . . make a new function
802 **
803 ** 'NewFunction' creates and returns a new function. <name> must be a GAP
804 ** string containing the name of the function. <narg> must be the number of
805 ** arguments, where -1 means a variable number of arguments. <nams> must be
806 ** a GAP list containg the names of the arguments. <hdlr> must be the
807 ** C function (accepting <self> and the <narg> arguments) that will be
808 ** called to execute the function.
809 */
NewFunction(Obj name,Int narg,Obj nams,ObjFunc hdlr)810 Obj NewFunction (
811 Obj name,
812 Int narg,
813 Obj nams,
814 ObjFunc hdlr )
815 {
816 return NewFunctionT( T_FUNCTION, sizeof(FuncBag), name, narg, nams, hdlr );
817 }
818
819
820 /****************************************************************************
821 **
822 *F NewFunctionC( <name>, <narg>, <nams>, <hdlr> ) . . . make a new function
823 **
824 ** 'NewFunctionC' does the same as 'NewFunction', but expects <name> and
825 ** <nams> as C strings.
826 */
NewFunctionC(const Char * name,Int narg,const Char * nams,ObjFunc hdlr)827 Obj NewFunctionC (
828 const Char * name,
829 Int narg,
830 const Char * nams,
831 ObjFunc hdlr )
832 {
833 return NewFunction(MakeImmString(name), narg, ArgStringToList(nams), hdlr);
834 }
835
836
837 /****************************************************************************
838 **
839 *F NewFunctionT( <type>, <size>, <name>, <narg>, <nams>, <hdlr> )
840 **
841 ** 'NewFunctionT' does the same as 'NewFunction', but allows to specify the
842 ** <type> and <size> of the newly created bag.
843 */
NewFunctionT(UInt type,UInt size,Obj name,Int narg,Obj nams,ObjFunc hdlr)844 Obj NewFunctionT (
845 UInt type,
846 UInt size,
847 Obj name,
848 Int narg,
849 Obj nams,
850 ObjFunc hdlr )
851 {
852 Obj func; /* function, result */
853 Obj prof; /* profiling bag */
854
855
856 /* make the function object */
857 func = NewBag( type, size );
858
859 /* create a function with a fixed number of arguments */
860 if ( narg >= 0 ) {
861 SET_HDLR_FUNC(func, 0, DoFail0args);
862 SET_HDLR_FUNC(func, 1, DoFail1args);
863 SET_HDLR_FUNC(func, 2, DoFail2args);
864 SET_HDLR_FUNC(func, 3, DoFail3args);
865 SET_HDLR_FUNC(func, 4, DoFail4args);
866 SET_HDLR_FUNC(func, 5, DoFail5args);
867 SET_HDLR_FUNC(func, 6, DoFail6args);
868 SET_HDLR_FUNC(func, 7, DoFailXargs);
869 SET_HDLR_FUNC(func, (narg <= 6 ? narg : 7), hdlr );
870 }
871
872 /* create a function with a variable number of arguments */
873 else {
874 SET_HDLR_FUNC(func, 0, (narg >= -1) ? DoWrap0args : DoFail0args);
875 SET_HDLR_FUNC(func, 1, (narg >= -2) ? DoWrap1args : DoFail1args);
876 SET_HDLR_FUNC(func, 2, (narg >= -3) ? DoWrap2args : DoFail2args);
877 SET_HDLR_FUNC(func, 3, (narg >= -4) ? DoWrap3args : DoFail3args);
878 SET_HDLR_FUNC(func, 4, (narg >= -5) ? DoWrap4args : DoFail4args);
879 SET_HDLR_FUNC(func, 5, (narg >= -6) ? DoWrap5args : DoFail5args);
880 SET_HDLR_FUNC(func, 6, (narg >= -7) ? DoWrap6args : DoFail6args);
881 SET_HDLR_FUNC(func, 7, hdlr);
882 }
883
884 /* enter the arguments and the names */
885 SET_NAME_FUNC(func, name ? ImmutableString(name) : 0);
886 SET_NARG_FUNC(func, narg);
887 SET_NAMS_FUNC(func, nams);
888 SET_NLOC_FUNC(func, 0);
889 #ifdef HPCGAP
890 if (nams) MakeBagPublic(nams);
891 #endif
892 CHANGED_BAG(func);
893
894 /* enter the profiling bag */
895 prof = NEW_PLIST( T_PLIST, LEN_PROF );
896 SET_LEN_PLIST( prof, LEN_PROF );
897 SET_COUNT_PROF( prof, 0 );
898 SET_TIME_WITH_PROF( prof, 0 );
899 SET_TIME_WOUT_PROF( prof, 0 );
900 SET_STOR_WITH_PROF( prof, 0 );
901 SET_STOR_WOUT_PROF( prof, 0 );
902 SET_PROF_FUNC(func, prof);
903 CHANGED_BAG(func);
904
905 /* return the function bag */
906 return func;
907 }
908
909
910 /****************************************************************************
911 **
912 *F ArgStringToList( <nams_c> )
913 **
914 ** 'ArgStringToList' takes a C string <nams_c> containing a list of comma
915 ** separated argument names, and turns it into a plist of strings, ready
916 ** to be passed to 'NewFunction' as <nams>.
917 */
ArgStringToList(const Char * nams_c)918 Obj ArgStringToList(const Char *nams_c) {
919 Obj tmp; /* argument name as an object */
920 Obj nams_o; /* nams as an object */
921 UInt len; /* length */
922 UInt i, k, l; /* loop variables */
923
924 /* convert the arguments list to an object */
925 len = 0;
926 for ( k = 0; nams_c[k] != '\0'; k++ ) {
927 if ( (0 == k || nams_c[k-1] == ' ' || nams_c[k-1] == ',')
928 && ( nams_c[k ] != ' ' && nams_c[k ] != ',') ) {
929 len++;
930 }
931 }
932 nams_o = NEW_PLIST( T_PLIST, len );
933 SET_LEN_PLIST( nams_o, len );
934 k = 0;
935 for ( i = 1; i <= len; i++ ) {
936 while ( nams_c[k] == ' ' || nams_c[k] == ',' ) {
937 k++;
938 }
939 l = k;
940 while ( nams_c[l] != ' ' && nams_c[l] != ',' && nams_c[l] != '\0' ) {
941 l++;
942 }
943 tmp = MakeImmStringWithLen(nams_c + k, l - k);
944 SET_ELM_PLIST( nams_o, i, tmp );
945 CHANGED_BAG( nams_o );
946 k = l;
947 }
948
949 return nams_o;
950 }
951
952
953 /****************************************************************************
954 **
955 *F * * * * * * * * * * * * * type and print function * * * * * * * * * * * *
956 */
957
958 /****************************************************************************
959 **
960 *F TypeFunction( <func> ) . . . . . . . . . . . . . . . type of a function
961 **
962 ** 'TypeFunction' returns the type of the function <func>.
963 **
964 ** 'TypeFunction' is the function in 'TypeObjFuncs' for functions.
965 */
966 static Obj TYPE_FUNCTION;
967 static Obj TYPE_OPERATION;
968 static Obj TYPE_FUNCTION_WITH_NAME;
969 static Obj TYPE_OPERATION_WITH_NAME;
970
TypeFunction(Obj func)971 static Obj TypeFunction(Obj func)
972 {
973 if (NAME_FUNC(func) == 0)
974 return (IS_OPERATION(func) ? TYPE_OPERATION : TYPE_FUNCTION);
975 else
976 return (IS_OPERATION(func) ? TYPE_OPERATION_WITH_NAME : TYPE_FUNCTION_WITH_NAME);
977 }
978
979
980 /****************************************************************************
981 **
982 *F PrintFunction( <func> ) . . . . . . . . . . . . . . . print a function
983 **
984 */
985
986 static Obj PrintOperation;
987
PrintFunction(Obj func)988 void PrintFunction (
989 Obj func )
990 {
991 Int narg; /* number of arguments */
992 Int nloc; /* number of locals */
993 UInt i; /* loop variable */
994 UInt isvarg; /* does function have varargs? */
995
996 isvarg = 0;
997
998 if ( IS_OPERATION(func) ) {
999 CALL_1ARGS( PrintOperation, func );
1000 return;
1001 }
1002
1003 #ifdef HPCGAP
1004 /* print 'function (' or 'atomic function (' */
1005 if (LCKS_FUNC(func)) {
1006 Pr("%5>atomic function%< ( %>",0L,0L);
1007 } else
1008 Pr("%5>function%< ( %>",0L,0L);
1009 #else
1010 /* print 'function (' */
1011 Pr("%5>function%< ( %>",0L,0L);
1012 #endif
1013
1014 /* print the arguments */
1015 narg = NARG_FUNC(func);
1016 if (narg < 0) {
1017 isvarg = 1;
1018 narg = -narg;
1019 }
1020
1021 for ( i = 1; i <= narg; i++ ) {
1022 #ifdef HPCGAP
1023 if (LCKS_FUNC(func)) {
1024 const Char * locks = CONST_CSTR_STRING(LCKS_FUNC(func));
1025 switch(locks[i-1]) {
1026 case LOCK_QUAL_READONLY:
1027 Pr("%>readonly %<", 0L, 0L);
1028 break;
1029 case LOCK_QUAL_READWRITE:
1030 Pr("%>readwrite %<", 0L, 0L);
1031 break;
1032 }
1033 }
1034 #endif
1035 if ( NAMS_FUNC(func) != 0 )
1036 Pr( "%H", (Int)NAMI_FUNC( func, (Int)i ), 0L );
1037 else
1038 Pr( "<<arg-%d>>", (Int)i, 0L );
1039 if(isvarg && i == narg) {
1040 Pr("...", 0L, 0L);
1041 }
1042 if ( i != narg ) Pr("%<, %>",0L,0L);
1043 }
1044 Pr(" %<)\n",0L,0L);
1045
1046 // print the body
1047 if (IsKernelFunction(func)) {
1048 PrintKernelFunction(func);
1049 }
1050 else {
1051 /* print the locals */
1052 nloc = NLOC_FUNC(func);
1053 if ( nloc >= 1 ) {
1054 Pr("%>local ",0L,0L);
1055 for ( i = 1; i <= nloc; i++ ) {
1056 if ( NAMS_FUNC(func) != 0 )
1057 Pr( "%H", (Int)NAMI_FUNC( func, (Int)(narg+i) ), 0L );
1058 else
1059 Pr( "<<loc-%d>>", (Int)i, 0L );
1060 if ( i != nloc ) Pr("%<, %>",0L,0L);
1061 }
1062 Pr("%<;\n",0L,0L);
1063 }
1064
1065 // print the code
1066 Obj oldLVars;
1067 SWITCH_TO_NEW_LVARS(func, narg, NLOC_FUNC(func), oldLVars);
1068 PrintStat( OFFSET_FIRST_STAT );
1069 SWITCH_TO_OLD_LVARS( oldLVars );
1070 }
1071 Pr("%4<\n",0L,0L);
1072
1073 /* print 'end' */
1074 Pr("end",0L,0L);
1075 }
1076
PrintKernelFunction(Obj func)1077 void PrintKernelFunction(Obj func)
1078 {
1079 GAP_ASSERT(IsKernelFunction(func));
1080 Obj body = BODY_FUNC(func);
1081 Obj filename = body ? GET_FILENAME_BODY(body) : 0;
1082 if (filename) {
1083 if ( GET_LOCATION_BODY(body) ) {
1084 Pr("<<kernel code>> from %g:%g",
1085 (Int)filename,
1086 (Int)GET_LOCATION_BODY(body));
1087 }
1088 else if ( GET_STARTLINE_BODY(body) ) {
1089 Pr("<<compiled GAP code>> from %g:%d",
1090 (Int)filename,
1091 GET_STARTLINE_BODY(body));
1092 }
1093 }
1094 else {
1095 Pr("<<kernel or compiled code>>", 0, 0);
1096 }
1097 }
1098
1099
1100 /****************************************************************************
1101 **
1102 *F FiltIS_FUNCTION( <self>, <func> ) . . . . . . . . . . . test for function
1103 **
1104 ** 'FiltIS_FUNCTION' implements the internal function 'IsFunction'.
1105 **
1106 ** 'IsFunction( <func> )'
1107 **
1108 ** 'IsFunction' returns 'true' if <func> is a function and 'false'
1109 ** otherwise.
1110 */
1111 static Obj IsFunctionFilt;
1112
FiltIS_FUNCTION(Obj self,Obj obj)1113 static Obj FiltIS_FUNCTION(Obj self, Obj obj)
1114 {
1115 if ( TNUM_OBJ(obj) == T_FUNCTION ) {
1116 return True;
1117 }
1118 else if ( TNUM_OBJ(obj) < FIRST_EXTERNAL_TNUM ) {
1119 return False;
1120 }
1121 else {
1122 return DoFilter( self, obj );
1123 }
1124 }
1125
1126
1127 /****************************************************************************
1128 **
1129 *F FuncCALL_FUNC_LIST( <self>, <func>, <list> ) . . . . . . call a function
1130 **
1131 ** 'FuncCALL_FUNC_LIST' implements the internal function 'CallFuncList'.
1132 **
1133 ** 'CallFuncList( <func>, <list> )'
1134 **
1135 ** 'CallFuncList' calls the function <func> with the arguments list <list>,
1136 ** i.e., it is equivalent to '<func>( <list>[1], <list>[2]... )'.
1137 */
1138 Obj CallFuncListOper;
1139 static Obj CallFuncListWrapOper;
1140
CallFuncList(Obj func,Obj list)1141 Obj CallFuncList ( Obj func, Obj list )
1142 {
1143 Obj result; /* result */
1144 Obj list2; /* list of arguments */
1145 Obj arg; /* one argument */
1146 UInt i; /* loop variable */
1147
1148
1149 if (TNUM_OBJ(func) == T_FUNCTION) {
1150
1151 /* call the function */
1152 if ( LEN_LIST(list) == 0 ) {
1153 result = CALL_0ARGS( func );
1154 }
1155 else if ( LEN_LIST(list) == 1 ) {
1156 result = CALL_1ARGS( func, ELMV_LIST(list,1) );
1157 }
1158 else if ( LEN_LIST(list) == 2 ) {
1159 result = CALL_2ARGS( func, ELMV_LIST(list,1), ELMV_LIST(list,2) );
1160 }
1161 else if ( LEN_LIST(list) == 3 ) {
1162 result = CALL_3ARGS( func, ELMV_LIST(list,1), ELMV_LIST(list,2),
1163 ELMV_LIST(list,3) );
1164 }
1165 else if ( LEN_LIST(list) == 4 ) {
1166 result = CALL_4ARGS( func, ELMV_LIST(list,1), ELMV_LIST(list,2),
1167 ELMV_LIST(list,3), ELMV_LIST(list,4) );
1168 }
1169 else if ( LEN_LIST(list) == 5 ) {
1170 result = CALL_5ARGS( func, ELMV_LIST(list,1), ELMV_LIST(list,2),
1171 ELMV_LIST(list,3), ELMV_LIST(list,4),
1172 ELMV_LIST(list,5) );
1173 }
1174 else if ( LEN_LIST(list) == 6 ) {
1175 result = CALL_6ARGS( func, ELMV_LIST(list,1), ELMV_LIST(list,2),
1176 ELMV_LIST(list,3), ELMV_LIST(list,4),
1177 ELMV_LIST(list,5), ELMV_LIST(list,6) );
1178 }
1179 else {
1180 list2 = NEW_PLIST( T_PLIST, LEN_LIST(list) );
1181 SET_LEN_PLIST( list2, LEN_LIST(list) );
1182 for ( i = 1; i <= LEN_LIST(list); i++ ) {
1183 arg = ELMV_LIST( list, (Int)i );
1184 SET_ELM_PLIST( list2, i, arg );
1185 }
1186 result = CALL_XARGS( func, list2 );
1187 }
1188 } else {
1189 result = DoOperation2Args(CallFuncListOper, func, list);
1190 }
1191 /* return the result */
1192 return result;
1193
1194 }
1195
FuncCALL_FUNC_LIST(Obj self,Obj func,Obj list)1196 static Obj FuncCALL_FUNC_LIST(Obj self, Obj func, Obj list)
1197 {
1198 /* check that the second argument is a list */
1199 RequireSmallList("CallFuncList", list);
1200 return CallFuncList(func, list);
1201 }
1202
FuncCALL_FUNC_LIST_WRAP(Obj self,Obj func,Obj list)1203 static Obj FuncCALL_FUNC_LIST_WRAP(Obj self, Obj func, Obj list)
1204 {
1205 Obj retval, retlist;
1206 /* check that the second argument is a list */
1207 RequireSmallList("CallFuncListWrap", list);
1208 retval = CallFuncList(func, list);
1209
1210 if (retval == 0)
1211 {
1212 retlist = NewImmutableEmptyPlist();
1213 }
1214 else
1215 {
1216 retlist = NEW_PLIST(T_PLIST, 1);
1217 SET_LEN_PLIST(retlist, 1);
1218 SET_ELM_PLIST(retlist, 1, retval);
1219 CHANGED_BAG(retlist);
1220 }
1221 return retlist;
1222 }
1223
1224 /****************************************************************************
1225 **
1226 *F * * * * * * * * * * * * * * * utility functions * * * * * * * * * * * * *
1227 */
1228
1229 /****************************************************************************
1230 **
1231 *F AttrNAME_FUNC( <self>, <func> ) . . . . . . . . . . . name of a function
1232 */
1233 static Obj NameFuncAttr;
1234 static Obj SET_NAME_FUNC_Oper;
1235
AttrNAME_FUNC(Obj self,Obj func)1236 static Obj AttrNAME_FUNC(Obj self, Obj func)
1237 {
1238 Obj name;
1239
1240 if ( TNUM_OBJ(func) == T_FUNCTION ) {
1241 name = NAME_FUNC(func);
1242 if ( name == 0 ) {
1243 name = MakeImmString("unknown");
1244 SET_NAME_FUNC(func, name);
1245 CHANGED_BAG(func);
1246 }
1247 return name;
1248 }
1249 else {
1250 return DoAttribute( self, func );
1251 }
1252 }
1253
FuncSET_NAME_FUNC(Obj self,Obj func,Obj name)1254 static Obj FuncSET_NAME_FUNC(Obj self, Obj func, Obj name)
1255 {
1256 RequireStringRep("SET_NAME_FUNC", name);
1257
1258 if (TNUM_OBJ(func) == T_FUNCTION ) {
1259 SET_NAME_FUNC(func, ImmutableString(name));
1260 CHANGED_BAG(func);
1261 } else
1262 DoOperation2Args(SET_NAME_FUNC_Oper, func, name);
1263 return (Obj) 0;
1264 }
1265
1266
1267 /****************************************************************************
1268 **
1269 *F FuncNARG_FUNC( <self>, <func> ) . . . . number of arguments of a function
1270 */
1271 static Obj NARG_FUNC_Oper;
1272
FuncNARG_FUNC(Obj self,Obj func)1273 static Obj FuncNARG_FUNC(Obj self, Obj func)
1274 {
1275 if ( TNUM_OBJ(func) == T_FUNCTION ) {
1276 return INTOBJ_INT( NARG_FUNC(func) );
1277 }
1278 else {
1279 return DoOperation1Args( self, func );
1280 }
1281 }
1282
1283
1284 /****************************************************************************
1285 **
1286 *F FuncNAMS_FUNC( <self>, <func> ) . . . . names of local vars of a function
1287 */
1288 static Obj NAMS_FUNC_Oper;
1289
FuncNAMS_FUNC(Obj self,Obj func)1290 static Obj FuncNAMS_FUNC(Obj self, Obj func)
1291 {
1292 Obj nams;
1293 if ( TNUM_OBJ(func) == T_FUNCTION ) {
1294 nams = NAMS_FUNC(func);
1295 return (nams != (Obj)0) ? nams : Fail;
1296 }
1297 else {
1298 return DoOperation1Args( self, func );
1299 }
1300 }
1301
1302 /****************************************************************************
1303 **
1304 *F FuncLOCKS_FUNC( <self>, <func> ) . . . . locking status of a possibly
1305 ** atomic function
1306 */
1307 static Obj LOCKS_FUNC_Oper;
1308
FuncLOCKS_FUNC(Obj self,Obj func)1309 static Obj FuncLOCKS_FUNC(Obj self, Obj func)
1310 {
1311 #ifdef HPCGAP
1312 Obj locks;
1313 if (TNUM_OBJ(func) == T_FUNCTION) {
1314 locks = LCKS_FUNC(func);
1315 if (locks == (Obj)0)
1316 return Fail;
1317 else
1318 return locks;
1319 }
1320 else {
1321 return DoOperation1Args(self, func);
1322 }
1323 #else
1324 return Fail;
1325 #endif
1326 }
1327
1328
1329 /****************************************************************************
1330 **
1331 *F FuncPROF_FUNC( <self>, <func> ) . . . . . . profiling info of a function
1332 */
1333 static Obj PROF_FUNC_Oper;
1334
FuncPROF_FUNC(Obj self,Obj func)1335 static Obj FuncPROF_FUNC(Obj self, Obj func)
1336 {
1337 Obj prof;
1338
1339 if ( TNUM_OBJ(func) == T_FUNCTION ) {
1340 prof = PROF_FUNC(func);
1341 if ( TNUM_OBJ(prof) == T_FUNCTION ) {
1342 return PROF_FUNC(prof);
1343 } else {
1344 return prof;
1345 }
1346 }
1347 else {
1348 return DoOperation1Args( self, func );
1349 }
1350 }
1351
1352
1353 /****************************************************************************
1354 **
1355 *F FuncCLEAR_PROFILE_FUNC( <self>, <func> ) . . . . . . . . . clear profile
1356 */
FuncCLEAR_PROFILE_FUNC(Obj self,Obj func)1357 static Obj FuncCLEAR_PROFILE_FUNC(Obj self, Obj func)
1358 {
1359 Obj prof;
1360
1361 RequireFunction("CLEAR_PROFILE_FUNC", func);
1362
1363 /* clear profile info */
1364 prof = PROF_FUNC(func);
1365 if ( prof == 0 ) {
1366 ErrorQuit( "<func> has corrupted profile info", 0L, 0L );
1367 }
1368 if ( TNUM_OBJ(prof) == T_FUNCTION ) {
1369 prof = PROF_FUNC(prof);
1370 }
1371 if ( prof == 0 ) {
1372 ErrorQuit( "<func> has corrupted profile info", 0L, 0L );
1373 }
1374 SET_COUNT_PROF( prof, 0 );
1375 SET_TIME_WITH_PROF( prof, 0 );
1376 SET_TIME_WOUT_PROF( prof, 0 );
1377 SET_STOR_WITH_PROF( prof, 0 );
1378 SET_STOR_WOUT_PROF( prof, 0 );
1379
1380 return (Obj)0;
1381 }
1382
1383
1384 /****************************************************************************
1385 **
1386 *F FuncPROFILE_FUNC( <self>, <func> ) . . . . . . . . . . . . start profile
1387 */
FuncPROFILE_FUNC(Obj self,Obj func)1388 static Obj FuncPROFILE_FUNC(Obj self, Obj func)
1389 {
1390 Obj prof;
1391 Obj copy;
1392
1393 RequireFunction("PROFILE_FUNC", func);
1394
1395 /* uninstall trace handler */
1396 ChangeDoOperations( func, 0 );
1397
1398 /* install profiling */
1399 prof = PROF_FUNC(func);
1400
1401 /* install new handlers */
1402 if ( TNUM_OBJ(prof) != T_FUNCTION ) {
1403 copy = NewBag( TNUM_OBJ(func), SIZE_OBJ(func) );
1404 SET_HDLR_FUNC(copy,0, HDLR_FUNC(func,0));
1405 SET_HDLR_FUNC(copy,1, HDLR_FUNC(func,1));
1406 SET_HDLR_FUNC(copy,2, HDLR_FUNC(func,2));
1407 SET_HDLR_FUNC(copy,3, HDLR_FUNC(func,3));
1408 SET_HDLR_FUNC(copy,4, HDLR_FUNC(func,4));
1409 SET_HDLR_FUNC(copy,5, HDLR_FUNC(func,5));
1410 SET_HDLR_FUNC(copy,6, HDLR_FUNC(func,6));
1411 SET_HDLR_FUNC(copy,7, HDLR_FUNC(func,7));
1412 SET_NAME_FUNC(copy, NAME_FUNC(func));
1413 SET_NARG_FUNC(copy, NARG_FUNC(func));
1414 SET_NAMS_FUNC(copy, NAMS_FUNC(func));
1415 SET_PROF_FUNC(copy, PROF_FUNC(func));
1416 SET_NLOC_FUNC(copy, NLOC_FUNC(func));
1417 SET_HDLR_FUNC(func,0, DoProf0args);
1418 SET_HDLR_FUNC(func,1, DoProf1args);
1419 SET_HDLR_FUNC(func,2, DoProf2args);
1420 SET_HDLR_FUNC(func,3, DoProf3args);
1421 SET_HDLR_FUNC(func,4, DoProf4args);
1422 SET_HDLR_FUNC(func,5, DoProf5args);
1423 SET_HDLR_FUNC(func,6, DoProf6args);
1424 SET_HDLR_FUNC(func,7, DoProfXargs);
1425 SET_PROF_FUNC(func, copy);
1426 CHANGED_BAG(func);
1427 }
1428
1429 return (Obj)0;
1430 }
1431
1432
1433 /****************************************************************************
1434 **
1435 *F FuncIS_PROFILED_FUNC( <self>, <func> ) . . check if function is profiled
1436 */
FuncIS_PROFILED_FUNC(Obj self,Obj func)1437 static Obj FuncIS_PROFILED_FUNC(Obj self, Obj func)
1438 {
1439 RequireFunction("IS_PROFILED_FUNC", func);
1440 return ( TNUM_OBJ(PROF_FUNC(func)) != T_FUNCTION ) ? False : True;
1441 }
1442
FuncFILENAME_FUNC(Obj self,Obj func)1443 static Obj FuncFILENAME_FUNC(Obj self, Obj func)
1444 {
1445 RequireFunction("FILENAME_FUNC", func);
1446
1447 if (BODY_FUNC(func)) {
1448 Obj fn = GET_FILENAME_BODY(BODY_FUNC(func));
1449 if (fn)
1450 return fn;
1451 }
1452 return Fail;
1453 }
1454
FuncSTARTLINE_FUNC(Obj self,Obj func)1455 static Obj FuncSTARTLINE_FUNC(Obj self, Obj func)
1456 {
1457 RequireFunction("STARTLINE_FUNC", func);
1458
1459 if (BODY_FUNC(func)) {
1460 UInt sl = GET_STARTLINE_BODY(BODY_FUNC(func));
1461 if (sl)
1462 return INTOBJ_INT(sl);
1463 }
1464 return Fail;
1465 }
1466
FuncENDLINE_FUNC(Obj self,Obj func)1467 static Obj FuncENDLINE_FUNC(Obj self, Obj func)
1468 {
1469 RequireFunction("ENDLINE_FUNC", func);
1470
1471 if (BODY_FUNC(func)) {
1472 UInt el = GET_ENDLINE_BODY(BODY_FUNC(func));
1473 if (el)
1474 return INTOBJ_INT(el);
1475 }
1476 return Fail;
1477 }
1478
FuncLOCATION_FUNC(Obj self,Obj func)1479 static Obj FuncLOCATION_FUNC(Obj self, Obj func)
1480 {
1481 RequireFunction("LOCATION_FUNC", func);
1482
1483 if (BODY_FUNC(func)) {
1484 Obj sl = GET_LOCATION_BODY(BODY_FUNC(func));
1485 if (sl)
1486 return sl;
1487 }
1488 return Fail;
1489 }
1490
1491 /****************************************************************************
1492 **
1493 *F FuncUNPROFILE_FUNC( <self>, <func> ) . . . . . . . . . . . stop profile
1494 */
FuncUNPROFILE_FUNC(Obj self,Obj func)1495 static Obj FuncUNPROFILE_FUNC(Obj self, Obj func)
1496 {
1497 Obj prof;
1498
1499 RequireFunction("UNPROFILE_FUNC", func);
1500
1501 /* uninstall trace handler */
1502 ChangeDoOperations( func, 0 );
1503
1504 /* profiling is active, restore handlers */
1505 prof = PROF_FUNC(func);
1506 if ( TNUM_OBJ(prof) == T_FUNCTION ) {
1507 for (Int i = 0; i <= 7; i++)
1508 SET_HDLR_FUNC(func, i, HDLR_FUNC(prof, i));
1509 SET_PROF_FUNC(func, PROF_FUNC(prof));
1510 CHANGED_BAG(func);
1511 }
1512
1513 return (Obj)0;
1514 }
1515
1516
1517 /****************************************************************************
1518 *
1519 *F FuncIsKernelFunction( <self>, <func> )
1520 **
1521 ** 'FuncIsKernelFunction' returns Fail if <func> is not a function, True if
1522 ** <func> is a kernel function, and False otherwise.
1523 */
FuncIsKernelFunction(Obj self,Obj func)1524 static Obj FuncIsKernelFunction(Obj self, Obj func)
1525 {
1526 if (!IS_FUNC(func))
1527 return Fail;
1528 return IsKernelFunction(func) ? True : False;
1529 }
1530
IsKernelFunction(Obj func)1531 Int IsKernelFunction(Obj func)
1532 {
1533 GAP_ASSERT(IS_FUNC(func));
1534 return (BODY_FUNC(func) == 0) ||
1535 (SIZE_OBJ(BODY_FUNC(func)) == sizeof(BodyHeader));
1536 }
1537
1538
1539 /* Returns a measure of the size of a GAP function */
FuncFUNC_BODY_SIZE(Obj self,Obj func)1540 static Obj FuncFUNC_BODY_SIZE(Obj self, Obj func)
1541 {
1542 RequireFunction("FUNC_BODY_SIZE", func);
1543 Obj body = BODY_FUNC(func);
1544 if (body == 0)
1545 return INTOBJ_INT(0);
1546 return ObjInt_UInt(SIZE_BAG(body));
1547 }
1548
1549 #ifdef USE_GASMAN
1550
SaveHandler(ObjFunc hdlr)1551 static void SaveHandler(ObjFunc hdlr)
1552 {
1553 const Char * cookie;
1554 if (hdlr == (ObjFunc)0)
1555 SaveCStr("");
1556 else {
1557 cookie = CookieOfHandler(hdlr);
1558 if (!cookie) {
1559 Pr("No cookie for Handler -- workspace will be corrupt\n", 0, 0);
1560 SaveCStr("");
1561 }
1562 else
1563 SaveCStr(cookie);
1564 }
1565 }
1566
1567
LoadHandler(void)1568 static ObjFunc LoadHandler( void )
1569 {
1570 Char buf[256];
1571 LoadCStr(buf, 256);
1572 if (buf[0] == '\0')
1573 return (ObjFunc) 0;
1574 else
1575 return HandlerOfCookie(buf);
1576 }
1577
1578 /****************************************************************************
1579 **
1580 *F SaveFunction( <func> ) . . . . . . . . . . . . . . . . . save a function
1581 **
1582 */
SaveFunction(Obj func)1583 static void SaveFunction(Obj func)
1584 {
1585 const FuncBag * header = CONST_FUNC(func);
1586 for (UInt i = 0; i < ARRAY_SIZE(header->handlers); i++)
1587 SaveHandler(header->handlers[i]);
1588 SaveSubObj(header->name);
1589 SaveSubObj(header->nargs);
1590 SaveSubObj(header->namesOfArgsAndLocals);
1591 SaveSubObj(header->prof);
1592 SaveSubObj(header->nloc);
1593 SaveSubObj(header->body);
1594 SaveSubObj(header->envi);
1595 if (IS_OPERATION(func))
1596 SaveOperationExtras( func );
1597 }
1598
1599 /****************************************************************************
1600 **
1601 *F LoadFunction( <func> ) . . . . . . . . . . . . . . . . . load a function
1602 **
1603 */
LoadFunction(Obj func)1604 static void LoadFunction(Obj func)
1605 {
1606 FuncBag * header = FUNC(func);
1607 for (UInt i = 0; i < ARRAY_SIZE(header->handlers); i++)
1608 header->handlers[i] = LoadHandler();
1609 header->name = LoadSubObj();
1610 header->nargs = LoadSubObj();
1611 header->namesOfArgsAndLocals = LoadSubObj();
1612 header->prof = LoadSubObj();
1613 header->nloc = LoadSubObj();
1614 header->body = LoadSubObj();
1615 header->envi = LoadSubObj();
1616 if (IS_OPERATION(func))
1617 LoadOperationExtras( func );
1618 }
1619
1620 #endif
1621
1622 /****************************************************************************
1623 **
1624 *F MarkFunctionSubBags( <bag> ) . . . . . . . marking function for functions
1625 **
1626 ** 'MarkFunctionSubBags' is the marking function for bags of type 'T_FUNCTION'.
1627 */
MarkFunctionSubBags(Obj func)1628 static void MarkFunctionSubBags(Obj func)
1629 {
1630 // the first eight slots are pointers to C functions, so we need
1631 // to skip those for marking
1632 UInt size = SIZE_BAG(func) / sizeof(Obj) - 8;
1633 const Bag * data = CONST_PTR_BAG(func) + 8;
1634 MarkArrayOfBags(data, size);
1635 }
1636
1637
1638 /****************************************************************************
1639 **
1640 *F * * * * * * * * * * * * * initialize module * * * * * * * * * * * * * * *
1641 */
1642
1643
1644 /****************************************************************************
1645 **
1646 *V BagNames . . . . . . . . . . . . . . . . . . . . . . . list of bag names
1647 */
1648 static StructBagNames BagNames[] = {
1649 { T_FUNCTION, "function" },
1650 { -1, "" }
1651 };
1652
1653
1654 /****************************************************************************
1655 **
1656 *V GVarFilts . . . . . . . . . . . . . . . . . . . list of filters to export
1657 */
1658 static StructGVarFilt GVarFilts [] = {
1659
1660 GVAR_FILT(IS_FUNCTION, "obj", &IsFunctionFilt),
1661 { 0, 0, 0, 0, 0 }
1662
1663 };
1664
1665
1666 /****************************************************************************
1667 **
1668 *V GVarAttrs . . . . . . . . . . . . . . . . . list of attributes to export
1669 */
1670 static StructGVarAttr GVarAttrs [] = {
1671
1672 GVAR_ATTR(NAME_FUNC, "func", &NameFuncAttr),
1673 { 0, 0, 0, 0, 0 }
1674
1675 };
1676
1677
1678 /****************************************************************************
1679 **
1680 *V GVarOpers . . . . . . . . . . . . . . . . . list of operations to export
1681 */
1682 static StructGVarOper GVarOpers [] = {
1683
1684 GVAR_OPER(CALL_FUNC_LIST, 2, "func, list", &CallFuncListOper),
1685 GVAR_OPER(CALL_FUNC_LIST_WRAP, 2, "func, list", &CallFuncListWrapOper),
1686 GVAR_OPER(SET_NAME_FUNC, 2, "func, name", &SET_NAME_FUNC_Oper),
1687 GVAR_OPER(NARG_FUNC, 1, "func", &NARG_FUNC_Oper),
1688 GVAR_OPER(NAMS_FUNC, 1, "func", &NAMS_FUNC_Oper),
1689 GVAR_OPER(LOCKS_FUNC, 1, "func", &LOCKS_FUNC_Oper),
1690 GVAR_OPER(PROF_FUNC, 1, "func", &PROF_FUNC_Oper),
1691 { 0, 0, 0, 0, 0, 0 }
1692
1693 };
1694
1695
1696 /****************************************************************************
1697 **
1698 *V GVarFuncs . . . . . . . . . . . . . . . . . . list of functions to export
1699 */
1700 static StructGVarFunc GVarFuncs[] = {
1701
1702 GVAR_FUNC(CLEAR_PROFILE_FUNC, 1, "func"),
1703 GVAR_FUNC(IS_PROFILED_FUNC, 1, "func"),
1704 GVAR_FUNC(PROFILE_FUNC, 1, "func"),
1705 GVAR_FUNC(UNPROFILE_FUNC, 1, "func"),
1706 GVAR_FUNC(IsKernelFunction, 1, "func"),
1707 GVAR_FUNC(FILENAME_FUNC, 1, "func"),
1708 GVAR_FUNC(LOCATION_FUNC, 1, "func"),
1709 GVAR_FUNC(STARTLINE_FUNC, 1, "func"),
1710 GVAR_FUNC(ENDLINE_FUNC, 1, "func"),
1711
1712 GVAR_FUNC(FUNC_BODY_SIZE, 1, "func"),
1713
1714 { 0, 0, 0, 0, 0 }
1715
1716 };
1717
1718
1719 /****************************************************************************
1720 **
1721 *F InitKernel( <module> ) . . . . . . . . initialise kernel data structures
1722 */
InitKernel(StructInitInfo * module)1723 static Int InitKernel (
1724 StructInitInfo * module )
1725 {
1726 // set the bag type names (for error messages and debugging)
1727 InitBagNamesFromTable( BagNames );
1728
1729 /* install the marking functions */
1730 InitMarkFuncBags(T_FUNCTION, MarkFunctionSubBags);
1731
1732 #ifdef HPCGAP
1733 /* Allocate functions in the public region */
1734 MakeBagTypePublic(T_FUNCTION);
1735 #endif
1736
1737 /* install the type functions */
1738 ImportGVarFromLibrary( "TYPE_FUNCTION", &TYPE_FUNCTION );
1739 ImportGVarFromLibrary( "TYPE_OPERATION", &TYPE_OPERATION );
1740 ImportGVarFromLibrary( "TYPE_FUNCTION_WITH_NAME", &TYPE_FUNCTION_WITH_NAME );
1741 ImportGVarFromLibrary( "TYPE_OPERATION_WITH_NAME", &TYPE_OPERATION_WITH_NAME );
1742 TypeObjFuncs[ T_FUNCTION ] = TypeFunction;
1743
1744 /* init filters and functions */
1745 InitHdlrFiltsFromTable( GVarFilts );
1746 InitHdlrAttrsFromTable( GVarAttrs );
1747 InitHdlrOpersFromTable( GVarOpers );
1748 InitHdlrFuncsFromTable( GVarFuncs );
1749
1750 #ifdef USE_GASMAN
1751 /* and the saving function */
1752 SaveObjFuncs[ T_FUNCTION ] = SaveFunction;
1753 LoadObjFuncs[ T_FUNCTION ] = LoadFunction;
1754 #endif
1755
1756 /* install the printer */
1757 InitFopyGVar( "PRINT_OPERATION", &PrintOperation );
1758 PrintObjFuncs[ T_FUNCTION ] = PrintFunction;
1759
1760
1761 /* initialise all 'Do<Something><N>args' handlers, give the most */
1762 /* common ones short cookies to save space in in the saved workspace */
1763 InitHandlerFunc( DoFail0args, "f0" );
1764 InitHandlerFunc( DoFail1args, "f1" );
1765 InitHandlerFunc( DoFail2args, "f2" );
1766 InitHandlerFunc( DoFail3args, "f3" );
1767 InitHandlerFunc( DoFail4args, "f4" );
1768 InitHandlerFunc( DoFail5args, "f5" );
1769 InitHandlerFunc( DoFail6args, "f6" );
1770 InitHandlerFunc( DoFailXargs, "f7" );
1771
1772 InitHandlerFunc( DoWrap0args, "w0" );
1773 InitHandlerFunc( DoWrap1args, "w1" );
1774 InitHandlerFunc( DoWrap2args, "w2" );
1775 InitHandlerFunc( DoWrap3args, "w3" );
1776 InitHandlerFunc( DoWrap4args, "w4" );
1777 InitHandlerFunc( DoWrap5args, "w5" );
1778 InitHandlerFunc( DoWrap6args, "w6" );
1779
1780 InitHandlerFunc( DoProf0args, "p0" );
1781 InitHandlerFunc( DoProf1args, "p1" );
1782 InitHandlerFunc( DoProf2args, "p2" );
1783 InitHandlerFunc( DoProf3args, "p3" );
1784 InitHandlerFunc( DoProf4args, "p4" );
1785 InitHandlerFunc( DoProf5args, "p5" );
1786 InitHandlerFunc( DoProf6args, "p6" );
1787 InitHandlerFunc( DoProfXargs, "pX" );
1788
1789 /* return success */
1790 return 0;
1791 }
1792
1793
1794 /****************************************************************************
1795 **
1796 *F InitLibrary( <module> ) . . . . . . . initialise library data structures
1797 */
InitLibrary(StructInitInfo * module)1798 static Int InitLibrary(StructInitInfo * module)
1799 {
1800 /* init filters and functions */
1801 InitGVarFiltsFromTable( GVarFilts );
1802 InitGVarAttrsFromTable( GVarAttrs );
1803 InitGVarOpersFromTable( GVarOpers );
1804 InitGVarFuncsFromTable( GVarFuncs );
1805
1806 /* return success */
1807 return 0;
1808 }
1809
1810
1811 /****************************************************************************
1812 **
1813 *F InitInfoCalls() . . . . . . . . . . . . . . . . . table of init functions
1814 */
1815 static StructInitInfo module = {
1816 // init struct using C99 designated initializers; for a full list of
1817 // fields, please refer to the definition of StructInitInfo
1818 .type = MODULE_BUILTIN,
1819 .name = "calls",
1820 .initKernel = InitKernel,
1821 .initLibrary = InitLibrary,
1822 };
1823
InitInfoCalls(void)1824 StructInitInfo * InitInfoCalls ( void )
1825 {
1826 return &module;
1827 }
1828