guile.diff 4.95 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157
diff --git a/libguile/Makefile.am b/libguile/Makefile.am
index be430bf..ed654aa 100644
--- a/libguile/Makefile.am
+++ b/libguile/Makefile.am
@@ -420,7 +420,7 @@ DOT_DOC_FILES = 				\
 
 EXTRA_DOT_DOC_FILES = @EXTRA_DOT_DOC_FILES@
 
-DOT_I_FILES = vm-i-system.i vm-i-scheme.i vm-i-loader.i
+DOT_I_FILES = vm-i-system.i vm-i-scheme.i vm-i-loader.i vm-i-subr.i
 
 .c.i:
 	$(AM_V_GEN)$(GREP) '^VM_DEFINE' $< > $@
@@ -455,7 +455,7 @@ noinst_HEADERS = conv-integer.i.c conv-uinteger.i.c		\
 		 private-gc.h private-options.h
 
 # vm instructions
-noinst_HEADERS += vm-engine.c vm-i-system.c vm-i-scheme.c vm-i-loader.c
+noinst_HEADERS += vm-engine.c vm-i-system.c vm-i-scheme.c vm-i-loader.c vm-i-subr.c
 
 libguile_@GUILE_EFFECTIVE_VERSION@_la_DEPENDENCIES = @LIBLOBJS@
 
diff --git a/libguile/instructions.c b/libguile/instructions.c
index ef4a9ce..d17df80 100644
--- a/libguile/instructions.c
+++ b/libguile/instructions.c
@@ -67,6 +67,7 @@ fetch_instruction_table ()
 #include <libguile/vm-i-system.i>
 #include <libguile/vm-i-scheme.i>
 #include <libguile/vm-i-loader.i>
+#include <libguile/vm-i-subr.i>
 #undef VM_INSTRUCTION_TO_TABLE
       for (i = 0; i < SCM_VM_NUM_INSTRUCTIONS; i++)
         {
diff --git a/libguile/instructions.h b/libguile/instructions.h
index a226322..63eb6e0 100644
--- a/libguile/instructions.h
+++ b/libguile/instructions.h
@@ -30,6 +30,7 @@ enum scm_opcode {
 #include <libguile/vm-i-system.i>
 #include <libguile/vm-i-scheme.i>
 #include <libguile/vm-i-loader.i>
+#include <libguile/vm-i-subr.i>
 #undef VM_INSTRUCTION_TO_OPCODE
 };
 
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index c90458d..173ce76 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -34,6 +34,13 @@
 
 #include "vm-engine.h"
 
+typedef   SCM (*subr_type)() ;
+
+subr_type fast0[256];
+subr_type fast1[256];
+subr_type fast2[256];
+subr_type fast3[256];
+subr_type fast4[256];
 
 static SCM
 VM_NAME (SCM vm, SCM program, SCM *argv, int nargs)
@@ -79,6 +86,7 @@ VM_NAME (SCM vm, SCM program, SCM *argv, int nargs)
 #include <libguile/vm-i-system.i>
 #include <libguile/vm-i-scheme.i>
 #include <libguile/vm-i-loader.i>
+#include <libguile/vm-i-subr.i>
 #undef jump_table
 #undef VM_INSTRUCTION_TO_LABEL
     }
@@ -127,6 +135,8 @@ VM_NAME (SCM vm, SCM program, SCM *argv, int nargs)
 #include "vm-i-system.c"
 #include "vm-i-scheme.c"
 #include "vm-i-loader.c"
+#include "vm-i-subr.c"
+
 
 #ifndef HAVE_LABELS_AS_VALUES
   default:
diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c
index 21fa5a1..c014dac 100644
--- a/libguile/vm-i-system.c
+++ b/libguile/vm-i-system.c
@@ -939,6 +939,7 @@ VM_DEFINE_INSTRUCTION (55, subr_call, "subr-call", 1, -1, -1)
     }
 }
 
+
 VM_DEFINE_INSTRUCTION (56, smob_call, "smob-call", 1, -1, -1)
 {
   SCM smob, ret;
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 41ce924..1e8bab9 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -390,6 +390,14 @@ If there is no handler at all, Guile prints an error and then exits."
 (define bound-identifier=? #f)
 (define free-identifier=? #f)
 
+(define fast-call-set! #f)
+(define fast-call-0    #f)
+(define fast-call-1    #f)
+(define fast-call-2    #f)
+(define fast-call-3    #f)
+(define fast-call-4    #f)
+(define gp-fpair!?     #f)
+
 ;; $sc-dispatch is an implementation detail of psyntax. It is used by
 ;; expanded macros, to dispatch an input against a set of patterns.
 (define $sc-dispatch #f)
diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm
index a9f6df9..557c389 100644
--- a/module/language/tree-il/compile-glil.scm
+++ b/module/language/tree-il/compile-glil.scm
@@ -78,7 +78,14 @@
 (define *primcall-ops* (make-hash-table))
 (for-each
  (lambda (x) (hash-set! *primcall-ops* (car x) (cdr x)))
- '(((eq? . 2) . eq?)
+ '(((fast-call-0 . 1) . fast-call-0)
+   ((fast-call-1 . 2) . fast-call-1)
+   ((fast-call-2 . 3) . fast-call-2)
+   ((fast-call-3 . 4) . fast-call-3)
+   ((fast-call-4 . 5) . fast-call-4)
+   ((fast-call-set! . 3) . fast-call-set!)
+   ((gp-fpair!? . 2) . gp-fpair!?)
+   ((eq? . 2) . eq?)
    ((eqv? . 2) . eqv?)
    ((equal? . 2) . equal?)
    ((= . 2) . ee?)
diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm
index 2039faa..492584a 100644
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -32,7 +32,9 @@
             singly-valued-primitive?))
 
 (define *interesting-primitive-names* 
-  '(apply @apply
+  '(fast-call-0  fast-call-1 fast-call-2 fast-call-3 fast-call-4 fast-call-set!
+    gp-fpair!?
+    apply @apply
     call-with-values @call-with-values
     call-with-current-continuation @call-with-current-continuation
     call/cc
@@ -161,7 +163,8 @@
 
 ;; Primitives that only return one value.
 (define *singly-valued-primitives* 
-  '(eq? eqv? equal?
+  '(fast-call-0 fast-call-1 fast-call-2 fast-call-3 fast-call-4 fast-call-set!
+    eq? eqv? equal?
     memq memv
     = < > <= >= zero?
     + * - / 1- 1+ quotient remainder modulo