/[gcl]/gcl/o/funlink.c
ViewVC logotype

Diff of /gcl/o/funlink.c

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.16 by camm, Sat Mar 1 22:37:37 2003 UTC revision 1.17 by mjthomas, Mon Jul 7 04:53:14 2003 UTC
# Line 10  Fast linking method for kcl by W. Schelt Line 10  Fast linking method for kcl by W. Schelt
10  #include "sfun_argd.h"  #include "sfun_argd.h"
11  #include "page.h"  #include "page.h"
12    
13    #undef DO_FUNLINK_DEBUG
14    
15  static int  static int
16  clean_link_array(object *,object *);  clean_link_array(object *,object *);
17    
# Line 25  int Rset = 0; Line 27  int Rset = 0;
27  /* cleanup link */  /* cleanup link */
28  void  void
29  call_or_link(object sym, void **link )  call_or_link(object sym, void **link )
30  {object fun;  {
31   fun = sym->s.s_gfdef;      object fun;
32  #if 0      fun = sym->s.s_gfdef;
33   fprintf ( stderr, "call_or_link: fun %x\n", fun );  #ifdef DO_FUNLINK_DEBUG
34        fprintf ( stderr, "call_or_link: fun %x START\n", fun );
35  #endif  #endif
36   if (fun == OBJNULL) {FEinvalid_function(sym); return;}      if (fun == OBJNULL) {
37   if (type_of(fun) == t_cclosure          FEinvalid_function(sym);
38       && (fun->cc.cc_turbo))  #ifdef DO_FUNLINK_DEBUG
39     {if (Rset==0) {MMccall(fun, fun->cc.cc_turbo);}          fprintf ( stderr, "call_or_link: fun %x ERROR END\n", fun );
40      else (*(fun)->cf.cf_self)(fun->cc.cc_turbo);  #endif
41      return;}          return;
42   if (Rset==0) funcall(fun);      }
43     else      if ( type_of ( fun ) == t_cclosure && (fun->cc.cc_turbo) ) {
44     if (type_of(fun) == t_cfun)          if ( Rset ==0 ) {
45         { (void) vpush_extend( link,sLAlink_arrayA->s.s_dbind);              MMccall ( fun, fun->cc.cc_turbo );
46            (void) vpush_extend( *link,sLAlink_arrayA->s.s_dbind);                  } else {
47           *link = (void *) (fun->cf.cf_self);              (*(fun)->cf.cf_self)(fun->cc.cc_turbo);
48            }
49    #ifdef DO_FUNLINK_DEBUG
50            fprintf ( stderr, "call_or_link: fun %x END 1\n", fun );
51    #endif
52        return;
53        }
54        if ( Rset == 0 ) {
55            funcall(fun);
56        } else {
57            if ( type_of(fun) == t_cfun ) {
58                (void) vpush_extend ( link,sLAlink_arrayA->s.s_dbind );
59                (void) vpush_extend ( *link,sLAlink_arrayA->s.s_dbind );    
60                *link = (void *) (fun->cf.cf_self);
61  #if 0  #if 0
62           fprintf ( stderr, "call_or_link: cf %x\n", fun->cf );              fprintf ( stderr, "call_or_link: cf %x\n", fun->cf );
63           fprintf ( stderr, "call_or_link: cf_name %x\n", fun->cf.cf_name );              fprintf ( stderr, "call_or_link: cf_name %x\n", fun->cf.cf_name );
64           fprintf ( stderr, "call_or_link: cf_data %x\n", fun->cf.cf_data );              fprintf ( stderr, "call_or_link: cf_data %x\n", fun->cf.cf_data );
65           fprintf ( stderr, "call_or_link: cf_self %x\n", fun->cf.cf_self );              fprintf ( stderr, "call_or_link: cf_self %x\n", fun->cf.cf_self );
66           fflush ( stderr );              fflush ( stderr );
67           fprintf ( stderr, "call_or_link: staddr %x\n", fun->cf.cf_name->st.st_self );              fprintf ( stderr, "call_or_link: staddr %x\n", fun->cf.cf_name->st.st_self );
68           fprintf ( stderr, "call_or_link: ststring %s\n", fun->cf.cf_name->st.st_self );              fprintf ( stderr, "call_or_link: ststring %s\n", fun->cf.cf_name->st.st_self );
69           fflush ( stderr );              fflush ( stderr );
70  #endif          #endif        
71           (*(void (*)())(fun->cf.cf_self))();              ( *(void (*)()) (fun->cf.cf_self)) ();
72         }          } else {
73     else funcall(fun);}              funcall(fun);
74            }
75        }
76    #ifdef DO_FUNLINK_DEBUG
77        fprintf ( stderr, "call_or_link: fun %x END 2\n", fun );
78    #endif
79    }
80    
81  void  void
82  call_or_link_closure(object sym, void **link, void **ptr)  call_or_link_closure ( object sym, void **link, void **ptr )
83  {object fun;  {
84   fun = sym->s.s_gfdef;      object fun;
85   if (fun == OBJNULL) {FEinvalid_function(sym); return;}  #ifdef DO_FUNLINK_DEBUG
86   if (type_of(fun) == t_cclosure      fprintf ( stderr, "call_or_link_closure: fun %x START\n", fun );
87       && (fun->cc.cc_turbo))  #endif
88     {if (Rset) {      fun = sym->s.s_gfdef;
89       (void) vpush_extend( link,sLAlink_arrayA->s.s_dbind);      if (fun == OBJNULL) {
90       (void) vpush_extend( *link,sLAlink_arrayA->s.s_dbind);  #ifdef DO_FUNLINK_DEBUG
91       *ptr = (void *)(fun->cc.cc_turbo);          fprintf ( stderr, "call_or_link: fun %x ERROR END\n", fun );
92       *link = (void *) (fun->cf.cf_self);  #endif
93       MMccall(fun, fun->cc.cc_turbo);}          FEinvalid_function(sym);
94      else          return;
95        {MMccall(fun, fun->cc.cc_turbo);}      }
96      return;}      if ( type_of ( fun ) == t_cclosure && ( fun->cc.cc_turbo ) ) {
97   if (Rset==0) funcall(fun);          if ( Rset ) {
98     else              (void) vpush_extend ( link, sLAlink_arrayA->s.s_dbind );
99       /* can't do this if invoking foo(a) is illegal when foo is not defined              (void) vpush_extend ( *link, sLAlink_arrayA->s.s_dbind );
100          to take any arguments.   In the majority of C's this is legal */              *ptr = (void *) ( fun->cc.cc_turbo );
101                    *link = (void *) ( fun->cf.cf_self );
102     if (type_of(fun) == t_cfun)              MMccall (fun, fun->cc.cc_turbo);
103         { (void) vpush_extend( link,sLAlink_arrayA->s.s_dbind);          } else {
104            (void) vpush_extend( *link,sLAlink_arrayA->s.s_dbind);                      MMccall ( fun, fun->cc.cc_turbo );
105           *link = (void *) (fun->cf.cf_self);          }
106           (*(void (*)())(fun->cf.cf_self))();  #ifdef DO_FUNLINK_DEBUG
107         }          fprintf ( stderr, "call_or_link: fun %x END 1\n", fun );
108     else funcall(fun);}  #endif
109            return;
110        }
111        if ( Rset == 0 ) {
112            funcall ( fun );
113        } else {
114            /* can't do this if invoking foo(a) is illegal when foo is not defined
115               to take any arguments.   In the majority of C's this is legal */
116            
117            if ( type_of ( fun ) == t_cfun ) {
118                (void) vpush_extend ( link, sLAlink_arrayA->s.s_dbind );
119                (void) vpush_extend ( *link, sLAlink_arrayA->s.s_dbind );    
120                *link = (void *) (fun->cf.cf_self);
121                ( *(void (*)()) (fun->cf.cf_self) ) ();
122            } else {
123                funcall(fun);
124            }
125        }
126    #ifdef DO_FUNLINK_DEBUG
127        fprintf ( stderr, "call_or_link: fun %x END 2\n", fun );
128    #endif
129    }
130    
131  /* for pushing item into an array, where item is an address if array-type = t  /* for pushing item into an array, where item is an address if array-type = t
132  or a fixnum if array-type = fixnum */  or a fixnum if array-type = fixnum */
# Line 91  or a fixnum if array-type = fixnum */ Line 134  or a fixnum if array-type = fixnum */
134  #define SET_ITEM(ar,ind,val) (*((object *)(&((ar)->ust.ust_self[ind]))))= val  #define SET_ITEM(ar,ind,val) (*((object *)(&((ar)->ust.ust_self[ind]))))= val
135  static int      static int    
136  vpush_extend(void *item, object ar)  vpush_extend(void *item, object ar)
137  { register int ind = ar->ust.ust_fillp;  { register int ind;
138    #ifdef DO_FUNLINK_DEBUG
139     fprintf ( stderr, "vpush_extend: item %x, ar %x\n", item, ar );
140    #endif
141     ind = ar->ust.ust_fillp;  
142   AGAIN:   AGAIN:
143    if (ind < ar->ust.ust_dim)    if (ind < ar->ust.ust_dim)
144     {SET_ITEM(ar,ind,item);     {SET_ITEM(ar,ind,item);
# Line 106  vpush_extend(void *item, object ar) Line 153  vpush_extend(void *item, object ar)
153        ar->ust.ust_dim=newdim;        ar->ust.ust_dim=newdim;
154        ar->ust.ust_self=newself;        ar->ust.ust_self=newself;
155        goto AGAIN;        goto AGAIN;
156      }}      }
157    #ifdef DO_FUNLINK_DEBUG
158     fprintf ( stderr, "vpush_extend: item %x, ar %x END\n", item, ar );
159    #endif
160    }
161    
162    
163  /* if we unlink a bunch of functions, this will mean there are some  /* if we unlink a bunch of functions, this will mean there are some
# Line 117  static int number_unlinked=0; Line 168  static int number_unlinked=0;
168  static void  static void
169  delete_link(void *address, object link_ar)  delete_link(void *address, object link_ar)
170  {object *ar,*ar_end,*p;  {object *ar,*ar_end,*p;
171    #ifdef DO_FUNLINK_DEBUG
172     fprintf ( stderr, "delete_link: address %x, link_ar %x START\n", address, link_ar );
173    #endif
174   p=0;   p=0;
175   ar = link_ar->v.v_self;   ar = link_ar->v.v_self;
176   ar_end = (object *)&(link_ar->ust.ust_self[link_ar->v.v_fillp]);   ar_end = (object *)&(link_ar->ust.ust_self[link_ar->v.v_fillp]);
# Line 129  delete_link(void *address, object link_a Line 183  delete_link(void *address, object link_a
183       ar=ar+2;}       ar=ar+2;}
184   if (number_unlinked > 40)   if (number_unlinked > 40)
185     link_ar->v.v_fillp=     link_ar->v.v_fillp=
186       clean_link_array(link_ar->v.v_self,ar_end); }       clean_link_array(link_ar->v.v_self,ar_end);
187    #ifdef DO_FUNLINK_DEBUG
188     fprintf ( stderr, "delete_link: address %x, link_ar %x END\n", address, link_ar );
189    #endif
190    }
191    
192    
193  DEFUN_NEW("USE-FAST-LINKS",object,fSuse_fast_links,SI,1,2,NONE,OO,OO,OO,OO,(object flag,...),  DEFUN_NEW("USE-FAST-LINKS",object,fSuse_fast_links,SI,1,2,NONE,OO,OO,OO,OO,(object flag,...),
# Line 219  static int Line 277  static int
277  clean_link_array(object *ar, object *ar_end)  clean_link_array(object *ar, object *ar_end)
278  {int i=0;  {int i=0;
279   object *orig;   object *orig;
280    #ifdef DO_FUNLINK_DEBUG
281     fprintf ( stderr, "clean_link_array: ar %x, ar_end %x START\n", ar, ar_end );
282    #endif
283   orig=ar;   orig=ar;
284   number_unlinked=0;   number_unlinked=0;
285    while( ar<ar_end)    while( ar<ar_end)
# Line 228  clean_link_array(object *ar, object *ar_ Line 289  clean_link_array(object *ar, object *ar_
289         }         }
290     else ar=ar+2;           else ar=ar+2;      
291      }      }
292    #ifdef DO_FUNLINK_DEBUG
293     fprintf ( stderr, "clean_link_array: ar %x, ar_end %x END\n", ar, ar_end );
294    #endif
295   return(i*sizeof(object *));   return(i*sizeof(object *));
296   }   }
297    
# Line 246  clean_link_array(object *ar, object *ar_ Line 310  clean_link_array(object *ar, object *ar_
310  object  object
311  c_apply_n(object (*fn)(), int n, object *x)  c_apply_n(object (*fn)(), int n, object *x)
312  {object res=Cnil;  {object res=Cnil;
313    #ifdef DO_FUNLINK_DEBUG
314        fprintf ( stderr, "c_apply_n: n %d, x %x START\n", n, x );
315    #endif
316   switch(n){   switch(n){
317      case 0:  res=LCAST(fn)();break;      case 0:  res=LCAST(fn)();break;
318      case 1:  res=LCAST(fn)(x[0]);break;      case 1:  res=LCAST(fn)(x[0]);break;
# Line 567  c_apply_n(object (*fn)(), int n, object Line 634  c_apply_n(object (*fn)(), int n, object
634    default: FEerror("Exceeded call-arguments-limit ",0);    default: FEerror("Exceeded call-arguments-limit ",0);
635    }    }
636    
637    #ifdef DO_FUNLINK_DEBUG
638        fprintf ( stderr, "c_apply_n: res %x END\n", n, res );
639    #endif
640   return res;   return res;
641  }  }
642        
# Line 578  static object Line 648  static object
648  call_proc(object sym, void **link, int argd, va_list ll)  call_proc(object sym, void **link, int argd, va_list ll)
649  {object fun;  {object fun;
650   int nargs;   int nargs;
651    #ifdef DO_FUNLINK_DEBUG
652        fprintf ( stderr, "call_proc: sym %x START\n", sym );
653    #endif
654   check_type_symbol(&sym);   check_type_symbol(&sym);
655   fun=sym->s.s_gfdef;   fun=sym->s.s_gfdef;
656   if (fun && (type_of(fun)==t_sfun   if (fun && (type_of(fun)==t_sfun
# Line 705  object Line 778  object
778  call_proc_new(object sym, void **link, int argd, object first, va_list ll)  call_proc_new(object sym, void **link, int argd, object first, va_list ll)
779  {object fun;  {object fun;
780   int nargs;   int nargs;
781    #ifdef DO_FUNLINK_DEBUG
782        fprintf ( stderr, "call_proc_new: sym %x START\n", sym );
783    #endif
784   check_type_symbol(&sym);   check_type_symbol(&sym);
785   fun=sym->s.s_gfdef;   fun=sym->s.s_gfdef;
786   if (fun && (type_of(fun)==t_sfun   if (fun && (type_of(fun)==t_sfun

Legend:
Removed from v.1.16  
changed lines
  Added in v.1.17

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26