guile-commits
[Top][All Lists]
Advanced

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

[Guile-commits] GNU Guile branch, master, updated. v2.1.0-259-g968a9ad


From: Andy Wingo
Subject: [Guile-commits] GNU Guile branch, master, updated. v2.1.0-259-g968a9ad
Date: Thu, 10 May 2012 15:13:01 +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=968a9add65c5e3a33ab9f5b7697051c5b9282060

The branch, master has been updated
       via  968a9add65c5e3a33ab9f5b7697051c5b9282060 (commit)
       via  67b699cc77d5e2f74daca77aa26b1ba8af0d0808 (commit)
      from  a3ded46520b35a8dbda22097b74792b8282d12ce (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 968a9add65c5e3a33ab9f5b7697051c5b9282060
Merge: a3ded46 67b699c
Author: Andy Wingo <address@hidden>
Date:   Thu May 10 13:02:11 2012 +0200

    Merge remote-tracking branch 'local-2.0/stable-2.0'
    
    Conflicts:
        libguile/vm-engine.c
        libguile/vm-i-system.c
        libguile/vm.c

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

Summary of changes:
 libguile/frames.c          |    7 ++-
 libguile/vm-engine.c       |   74 +++++++++++++++--------
 libguile/vm-i-system.c     |  145 +++++++++++++------------------------------
 libguile/vm.c              |   95 +++++++++--------------------
 module/system/vm/frame.scm |   19 ++++--
 5 files changed, 141 insertions(+), 199 deletions(-)

diff --git a/libguile/frames.c b/libguile/frames.c
index b57b129..b90b5a2 100644
--- a/libguile/frames.c
+++ b/libguile/frames.c
@@ -237,11 +237,16 @@ SCM_DEFINE (scm_frame_instruction_pointer, 
"frame-instruction-pointer", 1, 0, 0,
            "")
 #define FUNC_NAME s_scm_frame_instruction_pointer
 {
+  SCM program;
   const struct scm_objcode *c_objcode;
 
   SCM_VALIDATE_VM_FRAME (1, frame);
+  program = scm_frame_procedure (frame);
 
-  c_objcode = SCM_PROGRAM_DATA (scm_frame_procedure (frame));
+  if (!SCM_PROGRAM_P (program))
+    return SCM_INUM0;
+
+  c_objcode = SCM_PROGRAM_DATA (program);
   return scm_from_unsigned_integer ((SCM_VM_FRAME_IP (frame)
                                      - SCM_C_OBJCODE_BASE (c_objcode)));
 }
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 4b6c98a..1593102 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -104,31 +104,55 @@ VM_NAME (SCM vm, SCM program, SCM *argv, int nargs)
       NEXT;
     }
 
-  /* Initialization */
-  {
-    SCM prog = program;
-
-    /* Boot program */
-    program = vm_make_boot_program (nargs);
-
-    /* Initial frame */
-    CACHE_REGISTER ();
-    PUSH (SCM_PACK (fp)); /* dynamic link */
-    PUSH (SCM_PACK (0)); /* mvra */
-    PUSH (SCM_PACK (ip)); /* ra */
-    CACHE_PROGRAM ();
-    PUSH (program);
-    fp = sp + 1;
-    ip = SCM_C_OBJCODE_BASE (bp);
-    /* MV-call frame, function & arguments */
-    PUSH (SCM_PACK (0)); /* dynamic link */
-    PUSH (SCM_PACK (0)); /* mvra */
-    PUSH (SCM_PACK (0)); /* ra */
-    PUSH (prog);
-    VM_ASSERT (sp + nargs < stack_limit, vm_error_too_many_args (nargs));
-    while (nargs--)
-      PUSH (*argv++);
-  }
+  /* Initial frame */
+  CACHE_REGISTER ();
+  PUSH (SCM_PACK (fp)); /* dynamic link */
+  PUSH (SCM_PACK (0)); /* mvra */
+  PUSH (SCM_PACK (ip)); /* ra */
+  PUSH (boot_continuation);
+  fp = sp + 1;
+  ip = SCM_C_OBJCODE_BASE (SCM_PROGRAM_DATA (boot_continuation));
+
+  /* MV-call frame, function & arguments */
+  PUSH (SCM_PACK (fp)); /* dynamic link */
+  PUSH (SCM_PACK (ip + 1)); /* mvra */
+  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++);
+
+  PUSH_CONTINUATION_HOOK ();
+
+ apply:
+  program = fp[-1];
+  if (!SCM_PROGRAM_P (program))
+    {
+      if (SCM_STRUCTP (program) && SCM_STRUCT_APPLICABLE_P (program))
+        fp[-1] = SCM_STRUCT_PROCEDURE (program);
+      else if (SCM_HAS_TYP7 (program, scm_tc7_smob)
+               && SCM_SMOB_APPLICABLE_P (program))
+        {
+          /* (smob arg0 ... argN) => (apply-smob smob arg0 ... argN) */
+          int i;
+          PUSH (SCM_BOOL_F);
+          for (i = sp - fp; i >= 0; i--)
+            fp[i] = fp[i - 1];
+          fp[-1] = SCM_SMOB_DESCRIPTOR (program).apply_trampoline;
+        }
+      else
+        {
+          SYNC_ALL();
+          vm_error_wrong_type_apply (program);
+        }
+      goto apply;
+    }
+
+  CACHE_PROGRAM ();
+  ip = SCM_C_OBJCODE_BASE (bp);
+
+  APPLY_HOOK ();
 
   /* Let's go! */
   NEXT;
diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c
index ef559ae..a542e8e 100644
--- a/libguile/vm-i-system.c
+++ b/libguile/vm-i-system.c
@@ -777,33 +777,8 @@ VM_DEFINE_INSTRUCTION (55, call, "call", 1, -1, 1)
   nargs = FETCH ();
 
  vm_call:
-  program = sp[-nargs];
-
   VM_HANDLE_INTERRUPTS;
 
-  if (SCM_UNLIKELY (!SCM_PROGRAM_P (program)))
-    {
-      if (SCM_STRUCTP (program) && SCM_STRUCT_APPLICABLE_P (program))
-        {
-          sp[-nargs] = SCM_STRUCT_PROCEDURE (program);
-          goto vm_call;
-        }
-      else if (SCM_HAS_TYP7 (program, scm_tc7_smob)
-               && SCM_SMOB_APPLICABLE_P (program))
-        {
-          PUSH (program);
-          prepare_smob_call (sp, ++nargs, program);
-          goto vm_call;
-        }
-      else
-        {
-          SYNC_ALL();
-          vm_error_wrong_type_apply (program);
-        }
-    }
-
-  CACHE_PROGRAM ();
-
   {
     SCM *old_fp = fp;
 
@@ -817,8 +792,16 @@ VM_DEFINE_INSTRUCTION (55, call, "call", 1, -1, 1)
     SCM_FRAME_SET_MV_RETURN_ADDRESS (fp, 0);
   }
   
-  ip = SCM_C_OBJCODE_BASE (bp);
   PUSH_CONTINUATION_HOOK ();
+
+  program = fp[-1];
+
+  if (SCM_UNLIKELY (!SCM_PROGRAM_P (program)))
+    goto apply;
+
+  CACHE_PROGRAM ();
+  ip = SCM_C_OBJCODE_BASE (bp);
+
   APPLY_HOOK ();
   NEXT;
 }
@@ -828,53 +811,34 @@ VM_DEFINE_INSTRUCTION (56, tail_call, "tail-call", 1, -1, 
1)
   nargs = FETCH ();
 
  vm_tail_call:
-  program = sp[-nargs];
-
   VM_HANDLE_INTERRUPTS;
 
-  if (SCM_UNLIKELY (!SCM_PROGRAM_P (program)))
-    {
-      if (SCM_STRUCTP (program) && SCM_STRUCT_APPLICABLE_P (program))
-        {
-          sp[-nargs] = SCM_STRUCT_PROCEDURE (program);
-          goto vm_tail_call;
-        }
-      else if (SCM_HAS_TYP7 (program, scm_tc7_smob)
-               && SCM_SMOB_APPLICABLE_P (program))
-        {
-          PUSH (program);
-          prepare_smob_call (sp, ++nargs, program);
-          goto vm_tail_call;
-        }
-      else
-        {
-          SYNC_ALL();
-          vm_error_wrong_type_apply (program);
-        }
-    }
-  else
-    {
-      int i;
+  {
+    int i;
 #ifdef VM_ENABLE_STACK_NULLING
-      SCM *old_sp = sp;
-      CHECK_STACK_LEAK ();
+    SCM *old_sp = sp;
+    CHECK_STACK_LEAK ();
 #endif
 
-      /* switch programs */
-      CACHE_PROGRAM ();
-      /* shuffle down the program and the arguments */
-      for (i = -1, sp = sp - nargs + 1; i < nargs; i++)
-        SCM_FRAME_STACK_ADDRESS (fp)[i] = sp[i];
+    /* shuffle down the program and the arguments */
+    for (i = -1, sp = sp - nargs + 1; i < nargs; i++)
+      SCM_FRAME_STACK_ADDRESS (fp)[i] = sp[i];
 
-      sp = fp + i - 1;
+    sp = fp + i - 1;
 
-      NULLSTACK (old_sp - sp);
+    NULLSTACK (old_sp - sp);
+  }
 
-      ip = SCM_C_OBJCODE_BASE (bp);
+  program = fp[-1];
 
-      APPLY_HOOK ();
-      NEXT;
-    }
+  if (SCM_UNLIKELY (!SCM_PROGRAM_P (program)))
+    goto apply;
+
+  CACHE_PROGRAM ();
+  ip = SCM_C_OBJCODE_BASE (bp);
+
+  APPLY_HOOK ();
+  NEXT;
 }
 
 VM_DEFINE_INSTRUCTION (57, subr_call, "subr-call", 1, -1, -1)
@@ -1031,54 +995,33 @@ VM_DEFINE_INSTRUCTION (64, mv_call, "mv-call", 4, -1, 1)
 {
   scm_t_int32 offset;
   scm_t_uint8 *mvra;
+  SCM *old_fp = fp;
   
   nargs = FETCH ();
   FETCH_OFFSET (offset);
   mvra = ip + offset;
 
- vm_mv_call:
-  program = sp[-nargs];
-
   VM_HANDLE_INTERRUPTS;
 
-  if (SCM_UNLIKELY (!SCM_PROGRAM_P (program)))
-    {
-      if (SCM_STRUCTP (program) && SCM_STRUCT_APPLICABLE_P (program))
-        {
-          sp[-nargs] = SCM_STRUCT_PROCEDURE (program);
-          goto vm_mv_call;
-        }
-      else if (SCM_HAS_TYP7 (program, scm_tc7_smob)
-               && SCM_SMOB_APPLICABLE_P (program))
-        {
-          PUSH (program);
-          prepare_smob_call (sp, ++nargs, program);
-          goto vm_mv_call;
-        }
-      else
-        {
-          SYNC_ALL();
-          vm_error_wrong_type_apply (program);
-        }
-    }
+  fp = sp - nargs + 1;
+  
+  ASSERT (SCM_FRAME_DYNAMIC_LINK (fp) == 0);
+  ASSERT (SCM_FRAME_RETURN_ADDRESS (fp) == 0);
+  ASSERT (SCM_FRAME_MV_RETURN_ADDRESS (fp) == 0);
+  SCM_FRAME_SET_DYNAMIC_LINK (fp, old_fp);
+  SCM_FRAME_SET_RETURN_ADDRESS (fp, ip);
+  SCM_FRAME_SET_MV_RETURN_ADDRESS (fp, mvra);
+  
+  PUSH_CONTINUATION_HOOK ();
 
-  CACHE_PROGRAM ();
+  program = fp[-1];
 
-  {
-    SCM *old_fp = fp;
+  if (SCM_UNLIKELY (!SCM_PROGRAM_P (program)))
+    goto apply;
 
-    fp = sp - nargs + 1;
-  
-    ASSERT (SCM_FRAME_DYNAMIC_LINK (fp) == 0);
-    ASSERT (SCM_FRAME_RETURN_ADDRESS (fp) == 0);
-    ASSERT (SCM_FRAME_MV_RETURN_ADDRESS (fp) == 0);
-    SCM_FRAME_SET_DYNAMIC_LINK (fp, old_fp);
-    SCM_FRAME_SET_RETURN_ADDRESS (fp, ip);
-    SCM_FRAME_SET_MV_RETURN_ADDRESS (fp, mvra);
-  }
-  
+  CACHE_PROGRAM ();
   ip = SCM_C_OBJCODE_BASE (bp);
-  PUSH_CONTINUATION_HOOK ();
+
   APPLY_HOOK ();
   NEXT;
 }
diff --git a/libguile/vm.c b/libguile/vm.c
index b2d0731..37467f4 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -598,78 +598,14 @@ vm_error_free_variable ()
 #endif
 
 
-static SCM
-really_make_boot_program (long nargs)
-{
-  SCM u8vec;
-  scm_t_uint8 text[] = { scm_op_mv_call, 0, 0, 0, 1,
-                         scm_op_make_int8_1, scm_op_halt };
-  struct scm_objcode *bp;
-  SCM ret;
-
-  if (SCM_UNLIKELY (nargs > 255 || nargs < 0))
-    scm_misc_error ("vm-engine", "too many args when making boot procedure",
-                    scm_list_1 (scm_from_long (nargs)));
-
-  text[1] = (scm_t_uint8)nargs;
-
-  bp = scm_gc_malloc_pointerless (sizeof (struct scm_objcode) + sizeof (text),
-                                  "boot-program");
-  memcpy (SCM_C_OBJCODE_BASE (bp), text, sizeof (text));
-  bp->len = sizeof(text);
-  bp->metalen = 0;
 
-  u8vec = scm_c_take_gc_bytevector ((scm_t_int8*)bp,
-                                    sizeof (struct scm_objcode) + sizeof 
(text),
-                                    SCM_BOOL_F);
-  ret = scm_make_program (scm_bytecode_to_native_objcode (u8vec),
-                          SCM_BOOL_F, SCM_BOOL_F);
-  SCM_SET_CELL_WORD_0 (ret, SCM_CELL_WORD_0 (ret) | SCM_F_PROGRAM_IS_BOOT);
-
-  return ret;
-}
-#define NUM_BOOT_PROGS 8
-static SCM
-vm_make_boot_program (long nargs)
-{
-  static SCM programs[NUM_BOOT_PROGS] = { SCM_BOOL_F, };
-
-  if (SCM_UNLIKELY (scm_is_false (programs[0])))
-    {
-      int i;
-      for (i = 0; i < NUM_BOOT_PROGS; i++)
-        programs[i] = really_make_boot_program (i);
-    }
-  
-  if (SCM_LIKELY (nargs < NUM_BOOT_PROGS))
-    return programs[nargs];
-  else
-    return really_make_boot_program (nargs);
-}
+static SCM boot_continuation;
 
 
 /*
  * VM
  */
 
-/* We are calling a SMOB.  The calling code pushed the SMOB after the
-   args, and incremented nargs.  That nargs is passed here.  This
-   function's job is to replace the procedure with the trampoline, and
-   shuffle the smob itself to be argument 0.  This function must not
-   allocate or throw, as the VM registers are not synchronized.  */
-static void
-prepare_smob_call (SCM *sp, int nargs, SCM smob)
-{
-  SCM *args = sp - nargs + 1;
-
-  /* Shuffle args up.  */
-  while (nargs--)
-    args[nargs + 1] = args[nargs];
-
-  args[0] = smob;
-  args[-1] = SCM_SMOB_DESCRIPTOR (smob).apply_trampoline;
-}
-
 static SCM
 resolve_variable (SCM what, SCM program_module)
 {
@@ -1124,6 +1060,33 @@ SCM scm_load_compiled_with_vm (SCM file)
   return scm_c_vm_run (scm_the_vm (), program, NULL, 0);
 }
 
+  
+static SCM
+make_boot_program (void)
+{
+  struct scm_objcode *bp;
+  size_t bp_size;
+  SCM u8vec, ret;
+    
+  const scm_t_uint8 text[] = { 
+    scm_op_make_int8_1,
+    scm_op_halt
+  };
+
+  bp_size = sizeof (struct scm_objcode) + sizeof (text);
+  bp = scm_gc_malloc_pointerless (bp_size, "boot-program");
+  memcpy (SCM_C_OBJCODE_BASE (bp), text, sizeof (text));
+  bp->len = sizeof(text);
+  bp->metalen = 0;
+
+  u8vec = scm_c_take_gc_bytevector ((scm_t_int8*)bp, bp_size, SCM_BOOL_F);
+  ret = scm_make_program (scm_bytecode_to_native_objcode (u8vec),
+                          SCM_BOOL_F, SCM_BOOL_F);
+  SCM_SET_CELL_WORD_0 (ret, (SCM_CELL_WORD_0 (ret) | SCM_F_PROGRAM_IS_BOOT));
+
+  return ret;
+}
+
 void
 scm_bootstrap_vm (void)
 {
@@ -1137,6 +1100,8 @@ scm_bootstrap_vm (void)
   sym_regular = scm_from_latin1_symbol ("regular");
   sym_debug = scm_from_latin1_symbol ("debug");
 
+  boot_continuation = make_boot_program ();
+
 #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
   vm_stack_gc_kind =
     GC_new_kind (GC_new_free_list (),
diff --git a/module/system/vm/frame.scm b/module/system/vm/frame.scm
index 37f621b..f2ceae5 100644
--- a/module/system/vm/frame.scm
+++ b/module/system/vm/frame.scm
@@ -1,6 +1,6 @@
 ;;; Guile VM frame functions
 
-;;; Copyright (C) 2001, 2005, 2009, 2010, 2011 Free Software Foundation, Inc.
+;;; Copyright (C) 2001, 2005, 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
@@ -32,8 +32,10 @@
             frame-return-values))
 
 (define (frame-bindings frame)
-  (program-bindings-for-ip (frame-procedure frame)
-                           (frame-instruction-pointer frame)))
+  (let ((p (frame-procedure frame)))
+    (if (program? p)
+        (program-bindings-for-ip p (frame-instruction-pointer frame))
+        '())))
 
 (define (frame-lookup-binding frame var)
   (let lp ((bindings (frame-bindings frame)))
@@ -72,9 +74,11 @@
 
 (define (frame-next-source frame)
   (let ((proc (frame-procedure frame)))
-    (program-source proc
-                    (frame-instruction-pointer frame)
-                    (program-sources-pre-retire proc))))
+    (if (program? proc)
+        (program-source proc
+                        (frame-instruction-pointer frame)
+                        (program-sources-pre-retire proc))
+        '())))
 
 
 ;; Basically there are two cases to deal with here:
@@ -97,7 +101,8 @@
     (cons
      (or (procedure-name p) p)     
      (cond
-      ((program-arguments-alist p (frame-instruction-pointer frame))
+      ((and (program? p)
+            (program-arguments-alist p (frame-instruction-pointer frame)))
        ;; case 1
        => (lambda (arguments)
             (define (binding-ref sym i)


hooks/post-receive
-- 
GNU Guile



reply via email to

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