guile-commits
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[Guile-commits] GNU Guile branch, wip-rtl, updated. v2.1.0-265-gec7299a


From: Andy Wingo
Subject: [Guile-commits] GNU Guile branch, wip-rtl, updated. v2.1.0-265-gec7299a
Date: Fri, 11 May 2012 15:59:43 +0000

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=ec7299a5a2117d08681b198b0ecd8caf76420f50

The branch, wip-rtl has been updated
       via  ec7299a5a2117d08681b198b0ecd8caf76420f50 (commit)
       via  6d8588b5f32bb06e5956572a4e9bea01ab834cdc (commit)
      from  6ecfa5f7819853558f57b2dad7282e56ac2b0c2f (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit ec7299a5a2117d08681b198b0ecd8caf76420f50
Author: Andy Wingo <address@hidden>
Date:   Fri May 11 17:59:30 2012 +0200

    fix various bugs in the rtl.
    
    A WIP in need of rebase, once comments come in.

commit 6d8588b5f32bb06e5956572a4e9bea01ab834cdc
Author: Andy Wingo <address@hidden>
Date:   Fri May 11 17:58:23 2012 +0200

    adapt wrong-num-args protocol
    
    * libguile/vm-i-system.c (assert-nargs-ee, assert-nargs-ge)
      (assert-nargs-ee/locals): Pass the number of args to the error procedure.
    
    * libguile/vm.c (vm_error_wrong_num_args): Adapt.  Set the sp.  Not
      needed for the stack VM, but helps the register VM.

-----------------------------------------------------------------------

Summary of changes:
 libguile/frames.c        |   12 +++++++++++-
 libguile/procprop.c      |    8 ++++++++
 libguile/procs.c         |    3 ++-
 libguile/programs.h      |    1 +
 libguile/vm-engine.c     |   46 +++++++++++++++++++++++++++++++---------------
 libguile/vm-i-system.c   |    6 +++---
 libguile/vm.c            |    6 ++++--
 module/system/vm/rtl.scm |    2 +-
 8 files changed, 61 insertions(+), 23 deletions(-)

diff --git a/libguile/frames.c b/libguile/frames.c
index 0338d18..45df99d 100644
--- a/libguile/frames.c
+++ b/libguile/frames.c
@@ -129,11 +129,21 @@ SCM_DEFINE (scm_frame_num_locals, "frame-num-locals", 1, 
0, 0,
            "")
 #define FUNC_NAME s_scm_frame_num_locals
 {
-  SCM *sp, *p;
+  SCM *fp, *sp, *p;
   unsigned int n = 0;
 
   SCM_VALIDATE_VM_FRAME (1, frame);
 
+  fp = SCM_VM_FRAME_FP (frame);
+  sp = SCM_VM_FRAME_SP (frame);
+  p = SCM_FRAME_STACK_ADDRESS (SCM_VM_FRAME_FP (frame));
+
+  if (SCM_RTL_PROGRAM_P (fp[-1])) 
+    {
+      n = SCM_RTL_PROGRAM_NUM_LOCALS (fp[-1]);
+      return scm_from_uint32 ((sp - p < n) ? (sp - p) : n);
+    }
+
   sp = SCM_VM_FRAME_SP (frame);
   p = SCM_FRAME_STACK_ADDRESS (SCM_VM_FRAME_FP (frame));
   while (p <= sp)
diff --git a/libguile/procprop.c b/libguile/procprop.c
index ff4648d..d37495b 100644
--- a/libguile/procprop.c
+++ b/libguile/procprop.c
@@ -82,6 +82,14 @@ scm_i_procedure_arity (SCM proc, int *req, int *opt, int 
*rest)
 
           return 1;
         }
+      else if (SCM_RTL_PROGRAM_P (proc))
+        {
+          *req = 0;
+          *opt = 0;
+          *rest = 1;
+
+          return 1;
+        }
       else
         return 0;
     }
diff --git a/libguile/procs.c b/libguile/procs.c
index 7a2f491..244691c 100644
--- a/libguile/procs.c
+++ b/libguile/procs.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1997,1999,2000,2001, 2006, 2008, 2009, 2010, 2011 
Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1999,2000,2001, 2006, 2008, 2009, 2010, 2011, 
2012 Free Software Foundation, Inc.
  * 
  * This library is free software; you can redistribute it and/or
  * modify it under the terms of the GNU Lesser General Public License
@@ -47,6 +47,7 @@ SCM_DEFINE (scm_procedure_p, "procedure?", 1, 0, 0,
 #define FUNC_NAME s_scm_procedure_p
 {
   return scm_from_bool (SCM_PROGRAM_P (obj)
+                        || SCM_RTL_PROGRAM_P (obj)
                         || (SCM_STRUCTP (obj) && SCM_STRUCT_APPLICABLE_P (obj))
                         || (SCM_HAS_TYP7 (obj, scm_tc7_smob)
                             && SCM_SMOB_APPLICABLE_P (obj)));
diff --git a/libguile/programs.h b/libguile/programs.h
index 027e442..ce04c71 100644
--- a/libguile/programs.h
+++ b/libguile/programs.h
@@ -29,6 +29,7 @@
 #define SCM_RTL_PROGRAM_P(x) (SCM_HAS_TYP7 (x, scm_tc7_rtl_program))
 #define SCM_RTL_PROGRAM_CODE(x) ((struct scm_rtl_objcode*) SCM_CELL_WORD_1 (x))
 #define SCM_RTL_PROGRAM_ENTRY(x) (SCM_RTL_PROGRAM_CODE (x)->text)
+#define SCM_RTL_PROGRAM_NUM_LOCALS(x) (SCM_RTL_PROGRAM_CODE (x)->nlocals)
 #define SCM_RTL_PROGRAM_FREE_VARIABLES(x) (SCM_CELL_OBJECT_LOC (x, 2))
 #define SCM_RTL_PROGRAM_FREE_VARIABLE_REF(x,i) (SCM_RTL_PROGRAM_FREE_VARIABLES 
(x)[i])
 #define SCM_RTL_PROGRAM_FREE_VARIABLE_SET(x,i,v) 
(SCM_RTL_PROGRAM_FREE_VARIABLES (x)[i]=(v))
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 85c9ad5..25e5a5d 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -475,8 +475,19 @@ VM_NAME (SCM vm, SCM program, SCM *argv, int nargs)
       NEXT;
     }
 
-  /* Initial frame */
   CACHE_REGISTER ();
+
+  /* Since it's possible to receive the arguments on the stack itself,
+     and indeed the RTL VM invokes us that way, shuffle up the
+     arguments first.  */
+  VM_ASSERT (sp + 8 + nargs < stack_limit, vm_error_too_many_args (nargs));
+  {
+    int i;
+    for (i = nargs - 1; i >= 0; i--)
+      sp[9 + i] = argv[i];
+  }
+
+  /* Initial frame */
   PUSH (SCM_PACK (fp)); /* dynamic link */
   PUSH (SCM_PACK (0)); /* mvra */
   PUSH (SCM_PACK (ip)); /* ra */
@@ -490,9 +501,7 @@ VM_NAME (SCM vm, SCM program, SCM *argv, int nargs)
   PUSH (SCM_PACK (ip)); /* ra */
   PUSH (program);
   fp = sp + 1;
-  VM_ASSERT (sp + nargs < stack_limit, vm_error_too_many_args (nargs));
-  while (nargs--)
-    PUSH (*argv++);
+  sp += nargs;
 
   PUSH_CONTINUATION_HOOK ();
 
@@ -644,11 +653,14 @@ VM_NAME (SCM vm, SCM program, SCM *argv, int nargs)
 #define SYNC_IP() \
   vp->ip = (scm_t_uint8 *) (ip)
 
+#define SYNC_SP() \
+  vp->sp = vp->fp - 1 + SCM_RTL_PROGRAM_NUM_LOCALS (fp[-1])
+
 #define SYNC_REGISTER() \
   SYNC_IP()
 #define SYNC_BEFORE_GC() /* Only FP needed to trace GC */
 #define SYNC_ALL() /* FP already saved */ \
-  SYNC_IP()
+  SYNC_IP(); SYNC_SP()
 
 #define CACHE_REGISTER()                        \
   do {                                          \
@@ -950,7 +962,16 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
        continuation, and 4 + nargs for the procedure application.  */
     base = vp->sp;
     nargs = nargs_;
+
+    /* Since it's possible to receive the arguments on the stack itself,
+       and indeed the regular VM invokes us that way, shuffle up the
+       arguments first.  */
     CHECK_OVERFLOW (4 + 4 + nargs);
+    {
+      int i;
+      for (i = nargs - 1; i >= 0; i--)
+        base[8 + i] = argv[i];
+    }
 
     /* Initial frame, saving previous fp and ip, with the boot
        continuation.  */
@@ -967,11 +988,6 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
     base[6] = SCM_PACK (ip); /* ra */
     base[7] = program;
     fp = &base[8];
-    {
-      int i;
-      for (i = 0; i < nargs; i++)
-        fp[i] = argv[i];
-    }
   }
 
  apply:
@@ -1527,14 +1543,14 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t 
nargs_)
     {
       scm_t_uint32 expected;
       SCM_UNPACK_RTL_24 (op, expected);
-      VM_ASSERT (nargs == expected, vm_error_wrong_num_args (SCM_FRAME_PROGRAM 
(fp)));
+      VM_ASSERT (nargs == expected, vm_error_wrong_num_args (vm, 
SCM_FRAME_PROGRAM (fp), nargs));
       NEXT (1);
     }
   VM_DEFINE_OP (17, assert_nargs_ge, "assert-nargs-ge", OP1 (U8_U24))
     {
       scm_t_uint32 expected;
       SCM_UNPACK_RTL_24 (op, expected);
-      VM_ASSERT (nargs >= expected, vm_error_wrong_num_args (SCM_FRAME_PROGRAM 
(fp)));
+      VM_ASSERT (nargs >= expected, vm_error_wrong_num_args (vm, 
SCM_FRAME_PROGRAM (fp), nargs));
       NEXT (1);
     }
 
@@ -1550,7 +1566,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t 
nargs_)
       SCM_UNPACK_RTL_24 (op, nlocals);
 
       // FIXME: extend the stack!
-      VM_ASSERT (fp + nlocals > stack_limit, abort());
+      VM_ASSERT (fp + nlocals < stack_limit, abort());
 
       while (nlocals-- > nargs)
         LOCAL_SET (nlocals, SCM_UNDEFINED);
@@ -1567,9 +1583,9 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t 
nargs_)
     {
       scm_t_uint16 expected, nlocals;
       SCM_UNPACK_RTL_12_12 (op, expected, nlocals);
-      VM_ASSERT (nargs == expected, vm_error_wrong_num_args (SCM_FRAME_PROGRAM 
(fp)));
+      VM_ASSERT (nargs == expected, vm_error_wrong_num_args (vm, 
SCM_FRAME_PROGRAM (fp), nargs));
       // FIXME: extend the stack!
-      VM_ASSERT (fp + expected + nlocals > stack_limit, abort());
+      VM_ASSERT (fp + expected + nlocals < stack_limit, abort());
       while (nlocals--)
         LOCAL_SET (expected + nlocals, SCM_UNDEFINED);
       NEXT (1);
diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c
index a542e8e..f6db312 100644
--- a/libguile/vm-i-system.c
+++ b/libguile/vm-i-system.c
@@ -586,7 +586,7 @@ VM_DEFINE_INSTRUCTION (46, assert_nargs_ee, 
"assert-nargs-ee", 2, 0, 0)
   n = FETCH () << 8;
   n += FETCH ();
   VM_ASSERT (sp - (fp - 1) == n,
-             vm_error_wrong_num_args (program));
+             vm_error_wrong_num_args (vm, program, sp - (fp - 1)));
   NEXT;
 }
 
@@ -596,7 +596,7 @@ VM_DEFINE_INSTRUCTION (47, assert_nargs_ge, 
"assert-nargs-ge", 2, 0, 0)
   n = FETCH () << 8;
   n += FETCH ();
   VM_ASSERT (sp - (fp - 1) >= n,
-             vm_error_wrong_num_args (program));
+             vm_error_wrong_num_args (vm, program, sp - (fp - 1)));
   NEXT;
 }
 
@@ -1562,7 +1562,7 @@ VM_DEFINE_INSTRUCTION (95, assert_nargs_ee_locals, 
"assert-nargs-ee/locals", 1,
   n = FETCH ();
 
   VM_ASSERT (sp - (fp - 1) == (n & 0x7),
-             vm_error_wrong_num_args (program));
+             vm_error_wrong_num_args (vm, program, sp - (fp - 1)));
 
   old_sp = sp;
   sp += (n >> 3);
diff --git a/libguile/vm.c b/libguile/vm.c
index 4a534b6..26cc6d1 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -394,7 +394,7 @@ static void vm_error_kwargs_length_not_even (SCM proc) 
SCM_NORETURN SCM_NOINLINE
 static void vm_error_kwargs_invalid_keyword (SCM proc) SCM_NORETURN 
SCM_NOINLINE;
 static void vm_error_kwargs_unrecognized_keyword (SCM proc) SCM_NORETURN 
SCM_NOINLINE;
 static void vm_error_too_many_args (int nargs) SCM_NORETURN SCM_NOINLINE;
-static void vm_error_wrong_num_args (SCM proc) SCM_NORETURN SCM_NOINLINE;
+static void vm_error_wrong_num_args (SCM vm, SCM proc, int nargs) SCM_NORETURN 
SCM_NOINLINE;
 static void vm_error_wrong_type_apply (SCM proc) SCM_NORETURN SCM_NOINLINE;
 static void vm_error_stack_overflow (struct scm_vm *vp) SCM_NORETURN 
SCM_NOINLINE;
 static void vm_error_stack_underflow (void) SCM_NORETURN SCM_NOINLINE;
@@ -492,8 +492,10 @@ vm_error_too_many_args (int nargs)
 }
 
 static void
-vm_error_wrong_num_args (SCM proc)
+vm_error_wrong_num_args (SCM vm, SCM proc, int nargs)
 {
+  struct scm_vm *vp = SCM_VM_DATA (vm);
+  vp->sp = vp->fp - 1 + nargs;
   scm_wrong_num_args (proc);
 }
 
diff --git a/module/system/vm/rtl.scm b/module/system/vm/rtl.scm
index b9d8814..b461d19 100644
--- a/module/system/vm/rtl.scm
+++ b/module/system/vm/rtl.scm
@@ -33,7 +33,7 @@
 (define-syntax-rule (pack-u8-s24 x y)
   (logior x (ash (cond
                   ((< 0 (- y) #x800000)
-                   (+ y #xffffff))
+                   (+ y #x1000000))
                   ((<= 0 y #xffffff)
                    y)
                   (else (error "out of range" y)))


hooks/post-receive
-- 
GNU Guile



reply via email to

[Prev in Thread] Current Thread [Next in Thread]