/[guile]/guile/guile-core/libguile/eval.c
ViewVC logotype

Diff of /guile/guile-core/libguile/eval.c

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

revision 1.260 by ossau, Fri Mar 8 13:07:50 2002 UTC revision 1.261 by dirk, Sat Mar 9 20:15:16 2002 UTC
# Line 96  char *alloca (); Line 96  char *alloca ();
96  #include "libguile/root.h"  #include "libguile/root.h"
97  #include "libguile/vectors.h"  #include "libguile/vectors.h"
98  #include "libguile/fluids.h"  #include "libguile/fluids.h"
99    #include "libguile/goops.h"
100  #include "libguile/values.h"  #include "libguile/values.h"
101    
102  #include "libguile/validate.h"  #include "libguile/validate.h"
# Line 2042  dispatch: Line 2043  dispatch:
2043    
2044      nontoplevel_cdrxnoap:      nontoplevel_cdrxnoap:
2045        PREP_APPLY (SCM_UNDEFINED, SCM_EOL);        PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
     nontoplevel_cdrxbegin:  
2046        x = SCM_CDR (x);        x = SCM_CDR (x);
2047      nontoplevel_begin:      nontoplevel_begin:
2048        while (!SCM_NULLP (SCM_CDR (x)))        while (!SCM_NULLP (SCM_CDR (x)))
# Line 2430  dispatch: Line 2430  dispatch:
2430            RETURN (scm_makprom (scm_closure (SCM_CDR (x), env)));            RETURN (scm_makprom (scm_closure (SCM_CDR (x), env)));
2431    
2432          case (SCM_ISYMNUM (SCM_IM_DISPATCH)):          case (SCM_ISYMNUM (SCM_IM_DISPATCH)):
           proc = SCM_CADR (x); /* unevaluated operands */  
           PREP_APPLY (SCM_UNDEFINED, SCM_EOL);  
           if (SCM_IMP (proc))  
             arg2 = *scm_ilookup (proc, env);  
           else if (!SCM_CONSP (proc))  
             {  
               if (SCM_VARIABLEP (proc))  
                 arg2 = SCM_VARIABLE_REF (proc);  
               else  
                 arg2 = *scm_lookupcar (SCM_CDR (x), env, 1);  
             }  
           else  
             {  
               arg2 = scm_list_1 (EVALCAR (proc, env));  
               t.lloc = SCM_CDRLOC (arg2);  
               while (SCM_NIMP (proc = SCM_CDR (proc)))  
                 {  
                   *t.lloc = scm_list_1 (EVALCAR (proc, env));  
                   t.lloc = SCM_CDRLOC (*t.lloc);  
                 }  
             }  
             
         type_dispatch:  
           /* The type dispatch code is duplicated here  
            * (c.f. objects.c:scm_mcache_compute_cmethod) since that  
            * cuts down execution time for type dispatch to 50%.  
            */  
2433            {            {
2434              long i, n, end, mask;              /* If not done yet, evaluate the operand forms.  The result is a
2435              SCM z = SCM_CDDR (x);               * list of arguments stored in t.arg1, which is used to perform the
2436              n = SCM_INUM (SCM_CAR (z)); /* maximum number of specializers */               * function dispatch.  */
2437              proc = SCM_CADR (z);              SCM operand_forms = SCM_CADR (x);
2438                PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
2439              if (SCM_NIMP (proc))              if (SCM_ILOCP (operand_forms))
2440                {                t.arg1 = *scm_ilookup (operand_forms, env);
2441                  /* Prepare for linear search */              else if (SCM_VARIABLEP (operand_forms))
2442                  mask = -1;                t.arg1 = SCM_VARIABLE_REF (operand_forms);
2443                  i = 0;              else if (!SCM_CONSP (operand_forms))
2444                  end = SCM_VECTOR_LENGTH (proc);                t.arg1 = *scm_lookupcar (SCM_CDR (x), env, 1);
               }  
2445              else              else
2446                {                {
2447                  /* Compute a hash value */                  SCM tail = t.arg1 = scm_list_1 (EVALCAR (operand_forms, env));
2448                  long hashset = SCM_INUM (proc);                  operand_forms = SCM_CDR (operand_forms);
2449                  long j = n;                  while (!SCM_NULLP (operand_forms))
2450                  z = SCM_CDDR (z);                    {
2451                  mask = SCM_INUM (SCM_CAR (z));                      SCM new_tail = scm_list_1 (EVALCAR (operand_forms, env));
2452                  proc = SCM_CADR (z);                      SCM_SETCDR (tail, new_tail);
2453                  i = 0;                      tail = new_tail;
2454                  t.arg1 = arg2;                      operand_forms = SCM_CDR (operand_forms);
2455                  if (SCM_NIMP (t.arg1))                    }
2456                    do                }
2457              }
2458    
2459              /* The type dispatch code is duplicated below
2460               * (c.f. objects.c:scm_mcache_compute_cmethod) since that
2461               * cuts down execution time for type dispatch to 50%.  */
2462            type_dispatch: /* inputs: x, t.arg1 */
2463              /* Type dispatch means to determine from the types of the function
2464               * arguments (i. e. the 'signature' of the call), which method from
2465               * a generic function is to be called.  This process of selecting
2466               * the right method takes some time.  To speed it up, guile uses
2467               * caching:  Together with the macro call to dispatch the signatures
2468               * of some previous calls to that generic function from the same
2469               * place are stored (in the code!) in a cache that we call the
2470               * 'method cache'.  This is done since it is likely, that
2471               * consecutive calls to dispatch from that position in the code will
2472               * have the same signature.  Thus, the type dispatch works as
2473               * follows: First, determine a hash value from the signature of the
2474               * actual arguments.  Second, use this hash value as an index to
2475               * find that same signature in the method cache stored at this
2476               * position in the code.  If found, you have also found the
2477               * corresponding method that belongs to that signature.  If the
2478               * signature is not found in the method cache, you have to perform a
2479               * full search over all signatures stored with the generic
2480               * function.  */
2481            {
2482                unsigned long int specializers;
2483                unsigned long int hash_value;
2484                unsigned long int cache_end_pos;
2485                unsigned long int mask;
2486                SCM method_cache;
2487    
2488                {
2489                  SCM z = SCM_CDDR (x);
2490                  SCM tmp = SCM_CADR (z);
2491                  specializers = SCM_INUM (SCM_CAR (z));
2492    
2493                  /* Compute a hash value for searching the method cache.  There
2494                   * are two variants for computing the hash value, a (rather)
2495                   * complicated one, and a simple one.  For the complicated one
2496                   * explained below, tmp holds a number that is used in the
2497                   * computation.  */
2498                  if (SCM_INUMP (tmp))
2499                    {
2500                      /* Use the signature of the actual arguments to determine
2501                       * the hash value.  This is done as follows:  Each class has
2502                       * an array of random numbers, that are determined when the
2503                       * class is created.  The integer 'hashset' is an index into
2504                       * that array of random numbers.  Now, from all classes that
2505                       * are part of the signature of the actual arguments, the
2506                       * random numbers at index 'hashset' are taken and summed
2507                       * up, giving the hash value.  The value of 'hashset' is
2508                       * stored at the call to dispatch.  This allows to have
2509                       * different 'formulas' for calculating the hash value at
2510                       * different places where dispatch is called.  This allows
2511                       * to optimize the hash formula at every individual place
2512                       * where dispatch is called, such that hopefully the hash
2513                       * value that is computed will directly point to the right
2514                       * method in the method cache.  */
2515                      unsigned long int hashset = SCM_INUM (tmp);
2516                      unsigned long int counter = specializers + 1;
2517                      SCM tmp_arg = t.arg1;
2518                      hash_value = 0;
2519                      while (!SCM_NULLP (tmp_arg) && counter != 0)
2520                      {                      {
2521                        i += SCM_STRUCT_DATA (scm_class_of (SCM_CAR (t.arg1)))                        SCM class = scm_class_of (SCM_CAR (tmp_arg));
2522                             [scm_si_hashsets + hashset];                        hash_value += SCM_INSTANCE_HASH (class, hashset);
2523                        t.arg1 = SCM_CDR (t.arg1);                        tmp_arg = SCM_CDR (tmp_arg);
2524                          counter--;
2525                      }                      }
2526                    while (j-- && SCM_NIMP (t.arg1));                    z = SCM_CDDR (z);
2527                  i &= mask;                    method_cache = SCM_CADR (z);
2528                  end = i;                    mask = SCM_INUM (SCM_CAR (z));
2529                }                    hash_value &= mask;
2530                      cache_end_pos = hash_value;
2531                    }
2532                  else
2533                    {
2534                      /* This method of determining the hash value is much
2535                       * simpler:  Set the hash value to zero and just perform a
2536                       * linear search through the method cache.  */
2537                      method_cache = tmp;
2538                      mask = (unsigned long int) ((long) -1);
2539                      hash_value = 0;
2540                      cache_end_pos = SCM_VECTOR_LENGTH (method_cache);
2541                    }
2542                }
2543    
2544              /* Search for match  */              {
2545              do                /* Search the method cache for a method with a matching
2546                {                 * signature.  Start the search at position 'hash_value'.  The
2547                  long j = n;                 * hashing implementation uses linear probing for conflict
2548                  z = SCM_VELTS (proc)[i];                 * resolution, that is, if the signature in question is not
2549                  t.arg1 = arg2; /* list of arguments */                 * found at the starting index in the hash table, the next table
2550                  if (SCM_NIMP (t.arg1))                 * entry is tried, and so on, until in the worst case the whole
2551                    do                 * cache has been searched, but still the signature has not been
2552                   * found.  */
2553                  SCM z;
2554                  do
2555                    {
2556                      SCM args = t.arg1; /* list of arguments */
2557                      z = SCM_VELTS (method_cache)[hash_value];
2558                      while (!SCM_NULLP (args))
2559                      {                      {
2560                        /* More arguments than specifiers => CLASS != ENV */                        /* More arguments than specifiers => CLASS != ENV */
2561                        if (! SCM_EQ_P (scm_class_of (SCM_CAR (t.arg1)), SCM_CAR (z)))                        SCM class_of_arg = scm_class_of (SCM_CAR (args));
2562                          if (!SCM_EQ_P (class_of_arg, SCM_CAR (z)))
2563                          goto next_method;                          goto next_method;
2564                        t.arg1 = SCM_CDR (t.arg1);                        args = SCM_CDR (args);
2565                        z = SCM_CDR (z);                        z = SCM_CDR (z);
2566                      }                      }
2567                    while (j-- && SCM_NIMP (t.arg1));                    /* Fewer arguments than specifiers => CAR != ENV */
2568                  /* Fewer arguments than specifiers => CAR != ENV */                    if (SCM_NULLP (SCM_CAR (z)) || SCM_CONSP (SCM_CAR (z)))
2569                  if (!(SCM_IMP (SCM_CAR (z)) || SCM_CONSP (SCM_CAR (z))))                      goto apply_cmethod;
2570                    goto next_method;                  next_method:
2571                apply_cmethod:                    hash_value = (hash_value + 1) & mask;
2572                  env = EXTEND_ENV (SCM_CAR (SCM_CMETHOD_CODE (z)),                  } while (hash_value != cache_end_pos);
2573                                    arg2,  
2574                                    SCM_CMETHOD_ENV (z));                /* No appropriate method was found in the cache.  */
2575                  x = SCM_CMETHOD_CODE (z);                z = scm_memoize_method (x, t.arg1);
2576                  goto nontoplevel_cdrxbegin;  
2577                next_method:              apply_cmethod: /* inputs: z, t.arg1 */
2578                  i = (i + 1) & mask;                {
2579                } while (i != end);                  SCM formals = SCM_CMETHOD_FORMALS (z);
2580                                env = EXTEND_ENV (formals, t.arg1, SCM_CMETHOD_ENV (z));
2581              z = scm_memoize_method (x, arg2);                  x = SCM_CMETHOD_BODY (z);
2582              goto apply_cmethod;                  goto nontoplevel_begin;
2583                  }
2584                }
2585            }            }
2586    
2587          case (SCM_ISYMNUM (SCM_IM_SLOT_REF)):          case (SCM_ISYMNUM (SCM_IM_SLOT_REF)):
# Line 2806  evapply: Line 2865  evapply:
2865          if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)          if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
2866            {            {
2867              x = SCM_ENTITY_PROCEDURE (proc);              x = SCM_ENTITY_PROCEDURE (proc);
2868              arg2 = SCM_EOL;              t.arg1 = SCM_EOL;
2869              goto type_dispatch;              goto type_dispatch;
2870            }            }
2871          else if (!SCM_I_OPERATORP (proc))          else if (!SCM_I_OPERATORP (proc))
# Line 2951  evapply: Line 3010  evapply:
3010              {              {
3011                x = SCM_ENTITY_PROCEDURE (proc);                x = SCM_ENTITY_PROCEDURE (proc);
3012  #ifdef DEVAL  #ifdef DEVAL
3013                arg2 = debug.info->a.args;                t.arg1 = debug.info->a.args;
3014  #else  #else
3015                arg2 = scm_list_1 (t.arg1);                t.arg1 = scm_list_1 (t.arg1);
3016  #endif  #endif
3017                goto type_dispatch;                goto type_dispatch;
3018              }              }
# Line 3047  evapply: Line 3106  evapply:
3106              {              {
3107                x = SCM_ENTITY_PROCEDURE (proc);                x = SCM_ENTITY_PROCEDURE (proc);
3108  #ifdef DEVAL  #ifdef DEVAL
3109                arg2 = debug.info->a.args;                t.arg1 = debug.info->a.args;
3110  #else  #else
3111                arg2 = scm_list_2 (t.arg1, arg2);                t.arg1 = scm_list_2 (t.arg1, arg2);
3112  #endif  #endif
3113                goto type_dispatch;                goto type_dispatch;
3114              }              }
# Line 3259  evapply: Line 3318  evapply:
3318          if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)          if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
3319            {            {
3320  #ifdef DEVAL  #ifdef DEVAL
3321              arg2 = debug.info->a.args;              t.arg1 = debug.info->a.args;
3322  #else  #else
3323              arg2 = scm_cons2 (t.arg1, arg2, scm_eval_args (x, env, proc));              t.arg1 = scm_cons2 (t.arg1, arg2, scm_eval_args (x, env, proc));
3324  #endif  #endif
3325              x = SCM_ENTITY_PROCEDURE (proc);              x = SCM_ENTITY_PROCEDURE (proc);
3326              goto type_dispatch;              goto type_dispatch;

Legend:
Removed from v.1.260  
changed lines
  Added in v.1.261

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