guile/guile-lightning lightning.c

[Marius Vollmer]

CVSROOT:        /cvs
Module name:    guile
Changes by:     Marius Vollmer <address@hidden> 01/04/05 17:35:02

Modified files:
        guile-lightning: lightning.c 

Log message:
        * lightning.c: Lotsa intricate stuff for efficiently invoking
        arbitrary procedure objects from compiled code.

CVSWeb URLs:
http://subversions.gnu.org/cgi-bin/cvsweb/guile/guile-lightning/lightning.c.diff?r1=1.5&r2=1.6

Patches:
Index: guile/guile-lightning/lightning.c
diff -u guile/guile-lightning/lightning.c:1.5 
guile/guile-lightning/lightning.c:1.6
--- guile/guile-lightning/lightning.c:1.5       Sun Apr  1 09:11:19 2001
+++ guile/guile-lightning/lightning.c   Thu Apr  5 17:35:02 2001
@@ -43,6 +43,7 @@
 #include <libguile/values.h>
 #include <lightning.h>
 #include <dlfcn.h>
+#include <stdarg.h>
 
 #include "disassemble.h"
 
@@ -100,8 +101,9 @@
 static SCM scm_tc16_code;
 
 #define CODE_P(x)    (SCM_NIMP(x) && SCM_CELL_WORD_0(x) == scm_tc16_code)
-#define CODE_VEC(x)  (SCM_CELL_OBJECT_1(x))
+#define CODE_INSN(x) ((jit_insn *)SCM_CELL_WORD_1(x))
 #define CODE_ENV(x)  (SCM_CELL_OBJECT_2(x))
+#define CODE_VEC(x)  (SCM_CELL_OBJECT_3(x))
 
 static SCM
 code_mark (SCM obj)
@@ -133,9 +135,9 @@
   SCM_DEFER_INTS;
   SCM_NEWCELL2 (z);
   SCM_SET_CELL_WORD_0 (z, scm_tc16_code);
-  SCM_SET_CELL_OBJECT_1 (z, codevector);
+  SCM_SET_CELL_WORD_1 (z, CODEVECTOR_DATA(codevector)->start);
   SCM_SET_CELL_OBJECT_2 (z, env);
-  SCM_SET_CELL_OBJECT_3 (z, SCM_BOOL_F);
+  SCM_SET_CELL_OBJECT_3 (z, codevector);
   SCM_ALLOW_INTS;
 
   return z;
@@ -210,13 +212,256 @@
 code_apply (SCM smob, SCM args)
 {
 #define FUNC_NAME "code_apply"
-  struct codevector *c;
   SCM_VALIDATE_LIST (SCM_ARG1, args);
-  c = CODEVECTOR_DATA (CODE_VEC (smob));
-  return call_tc (c->start, scm_reverse_x (args, SCM_EOL), CODE_ENV (smob));
+  return call_tc (CODE_INSN(smob),
+                 scm_reverse_x (args, SCM_EOL),
+                 CODE_ENV (smob));
 #undef FUNC_NAME
 }
 
+static SCM
+nlistify (int n, va_list ap)
+{
+  SCM l = SCM_EOL;
+  SCM *t = &l;
+  while (--n >= 0)
+    {
+      *t = scm_cons (va_arg (ap, SCM), SCM_EOL);
+      t = SCM_CDRLOC (*t);
+    }
+  return l;
+}
+
+static SCM
+nlistify2 (int n, SCM e1, SCM e2, va_list ap)
+{
+  SCM l = nlistify (n-2, ap);
+  if (n >= 2)
+    l = scm_cons (e2, l);
+  if (n >= 1)
+    l = scm_cons (e1, l);
+  return l;
+}
+
+SCM 
+scm_invoke (SCM proc, int _n, void *retaddress,
+           SCM arg1, SCM arg2, ...)
+{
+  // We MUST not change `n' and `retaddress', they are used by the
+  // caller.
+
+  int n;
+
+  SCM_ASRTGO (SCM_NIMP (proc), badproc);
+
+  n = _n / sizeof(SCM);
+
+ tail:
+  switch (SCM_TYP7 (proc))
+    {
+    case scm_tc7_subr_2o:
+      return (SCM_SUBRF (proc) (arg1, (n > 1)? arg2 : SCM_UNDEFINED));
+    case scm_tc7_subr_2:
+      SCM_ASRTGO (n == 2, wrongnumargs);
+      return (SCM_SUBRF (proc) (arg1, arg2));
+    case scm_tc7_subr_0:
+      SCM_ASRTGO (n == 0, wrongnumargs);
+      return (SCM_SUBRF (proc) ());
+    case scm_tc7_subr_1:
+      SCM_ASRTGO (n == 1, wrongnumargs);
+      return (SCM_SUBRF (proc) (arg1));
+    case scm_tc7_subr_1o:
+      SCM_ASRTGO (n <= 1, wrongnumargs);
+      return (SCM_SUBRF (proc) ((n < 1)? SCM_UNDEFINED : arg1));
+    case scm_tc7_cxr:
+      SCM_ASRTGO (n == 1, wrongnumargs);
+      if (SCM_SUBRF (proc))
+       {
+         if (SCM_INUMP (arg1))
+           {
+             return 
+               (scm_make_real (SCM_DSUBRF (proc) ((double) SCM_INUM (arg1))));
+           }
+         SCM_ASRTGO (SCM_NIMP (arg1), floerr);
+         if (SCM_REALP (arg1))
+           {
+             return 
+               (scm_make_real (SCM_DSUBRF (proc) (SCM_REAL_VALUE (arg1))));
+           }
+#ifdef SCM_BIGDIG
+         if (SCM_BIGP (arg1))
+           return (scm_make_real (SCM_DSUBRF (proc) (scm_big2dbl (arg1))));
+#endif
+       floerr:
+         SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1,
+                             SCM_ARG1, SCM_SYMBOL_CHARS (SCM_SNAME (proc)));
+       }
+      proc = SCM_SNAME (proc);
+      {
+       char *chrs = SCM_SYMBOL_CHARS (proc) + SCM_SYMBOL_LENGTH (proc) - 1;
+       while ('c' != *--chrs)
+         {
+           SCM_ASSERT (SCM_CONSP (arg1),
+                   arg1, SCM_ARG1, SCM_SYMBOL_CHARS (proc));
+           arg1 = ('a' == *chrs) ? SCM_CAR (arg1) : SCM_CDR (arg1);
+         }
+       return (arg1);
+      }
+    case scm_tc7_subr_3:
+      {
+       va_list ap;
+       SCM arg3;
+       SCM_ASRTGO (n == 3, wrongnumargs);
+       va_start (ap, arg2);
+       arg3 = va_arg (ap, SCM);
+       va_end (ap);
+       return (SCM_SUBRF (proc) (arg1, arg2, arg3));
+      }
+    case scm_tc7_lsubr:
+      {
+       va_list ap;
+       SCM x;
+       va_start (ap, arg2);
+       x = nlistify2 (n, arg1, arg2, ap);
+       va_end (ap);
+       return (SCM_SUBRF (proc) (x));
+      }
+    case scm_tc7_lsubr_2:
+      {
+       va_list ap;
+       SCM x;
+       SCM_ASRTGO (n >= 2, wrongnumargs);
+       va_start (ap, arg2);
+       x = nlistify (n-2, ap);
+       va_end (ap);
+       return (SCM_SUBRF (proc) (arg1, arg2, x));
+      }
+    case scm_tc7_asubr:
+      {
+       va_list ap;
+       SCM x;
+       if (n == 0)
+         return (SCM_SUBRF (proc) (SCM_UNDEFINED, SCM_UNDEFINED));
+       if (n == 1)
+         return (SCM_SUBRF (proc) (arg1, SCM_UNDEFINED));
+       x = SCM_SUBRF (proc) (arg1, arg2);
+       va_start (ap, arg2);
+       while (n > 2)
+         {
+           x = SCM_SUBRF (proc) (x, va_arg (ap, SCM));
+           n--;
+         }
+       va_end (ap);
+       return x;
+      }
+    case scm_tc7_rpsubr:
+      {
+       va_list ap;
+       SCM x;
+       if (n <= 1)
+         return (SCM_BOOL_T);
+       if (SCM_FALSEP (SCM_SUBRF (proc) (arg1, arg2)))
+         return SCM_BOOL_F;
+       if (n == 2)
+         return SCM_BOOL_T;
+       va_start (ap, arg2);
+       x = arg2;
+       while (n > 2)
+         {
+           SCM y = va_arg (ap, SCM);
+           if (SCM_FALSEP (SCM_SUBRF (proc) (x, y)))
+             {
+               va_end (ap);
+               return (SCM_BOOL_F);
+             }
+           x = y;
+           n--;
+         }
+       va_end (ap);
+       return (SCM_BOOL_T);
+      }
+    case scm_tcs_closures:
+      {
+       scm_misc_error ("invoke", 
+                       "can't invoke interpreted code"
+                       " from compiled code yet.", SCM_EOL);
+      }
+    case scm_tc7_smob:
+      {
+       if (!SCM_SMOB_APPLICABLE_P (proc))
+         goto badproc;
+       if (n == 0)
+         return (SCM_SMOB_APPLY_0 (proc));
+       else if (n == 1)
+         return (SCM_SMOB_APPLY_1 (proc, arg1));
+       else if (n == 2)
+         return (SCM_SMOB_APPLY_2 (proc, arg1, arg2));
+       else
+         {
+           va_list ap;
+           SCM x;
+           va_start (ap, arg2);
+           x = nlistify (n-2, ap);
+           va_end (ap);
+           return (SCM_SMOB_APPLY_3 (proc, arg1, arg2, x));
+         }
+      }
+    case scm_tc7_cclo:
+      {
+       /* XXX - this chickens out to scm_apply */
+       va_list ap;
+       SCM args;
+       va_start (ap, arg2);
+       args = nlistify2 (n, arg1, arg2, ap);
+       va_end (ap);
+       args = scm_cons (proc, args);
+       return scm_apply (SCM_CCLO_SUBR (proc), args, SCM_EOL);
+      }
+    case scm_tc7_pws:
+      {
+       proc = SCM_PROCEDURE (proc);
+       goto tail;
+      }
+    case scm_tcs_cons_gloc:
+      {
+       if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
+         {
+           va_list ap;
+           SCM x;
+           va_start (ap, arg2);
+           x = nlistify2 (n, arg1, arg2, ap);
+           va_end (ap);
+           return (scm_apply_generic (proc, x));
+         }
+       else if (!SCM_I_OPERATORP (proc))
+         goto badproc;
+       else
+         {
+           /* XXX - this chickens out to scm_apply */
+           va_list ap;
+           SCM args;
+           va_start (ap, arg2);
+           args = nlistify2 (n, arg1, arg2, ap);
+           va_end (ap);
+           args = scm_cons (proc, args);
+           proc = (SCM_I_ENTITYP (proc)
+                   ? SCM_ENTITY_PROCEDURE (proc)
+                   : SCM_OPERATOR_PROCEDURE (proc));
+           if (SCM_NIMP (proc))
+             return scm_apply (proc, args, SCM_EOL);
+           else
+             goto badproc;
+         }
+      }
+    wrongnumargs:
+      scm_wrong_num_args (proc);
+    default:
+    badproc:
+      scm_wrong_type_arg ("invoke", SCM_ARG1, proc);
+      return (arg1);
+    }
+}
+
 static void
 do_label_def (SCM label_hash, SCM label)
 {
@@ -314,7 +559,9 @@
 SCM_SYMBOL (sym_scm, "scm");
 SCM_SYMBOL (sym_subr, "subr");
 SCM_SYMBOL (sym_label, "label");
-SCM_SYMBOL (sym_proc, "proc");
+SCM_SYMBOL (sym_code, "code");
+SCM_SYMBOL (sym_var, "var");
+SCM_SYMBOL (sym_codetag, "codetag");
 
 static unsigned long
 imm2int (SCM imm, SCM label_hash, struct codevector *c)
@@ -344,15 +591,34 @@
                            SCM_LIST1 (imm));
          return (unsigned long)lab;
        }
-      else if (SCM_CAR (imm) == sym_proc)
+      else if (SCM_CAR (imm) == sym_code)
        {
          #define FUNC_NAME "assemble"
          SCM x = SCM_CADR (imm);
-         SCM_VALIDATE_SMOB (SCM_ARG1, x, code);
+         SCM_VALIDATE_SMOB (SCM_ARG1, x, codevector);
          c->protects = scm_cons (x, c->protects);
          return (unsigned long)CODEVECTOR_DATA(x)->start;
          #undef FUNC_NAME
        }
+      else if (SCM_CAR (imm) == sym_var)
+       {
+         #define FUNC_NAME "assemble"
+         SCM x = SCM_CADR (imm);
+         SCM_VALIDATE_VARIABLE (SCM_ARG1, x);
+         x = SCM_VARVCELL (x);
+         c->protects = scm_cons (x, c->protects);
+         return (unsigned long)SCM_CDRLOC(x);
+          #undef FUNC_NAME
+       }
+    }
+  else if (SCM_CONSP (imm) && SCM_CAR (imm) == sym_codetag)
+    {
+      return scm_tc16_code;
+    }
+  else if (SCM_STRINGP (imm))
+    {
+      c->protects = scm_cons (imm, c->protects);
+      return (unsigned long)SCM_STRING_CHARS (imm);
     }
   else if (SCM_NUMBERP (imm))
     return scm_num2ulong (imm, (char *)SCM_ARG1, "assemble");