[Guile-commits] 04/08: Prepare for frames having separate virtual and machine return addrs

[Andy Wingo]

wingo pushed a commit to branch lightning
in repository guile.

commit b1705bd0f0181a6496223b26cb5da68fa470ccaa
Author: Andy Wingo <address@hidden>
Date:   Sun Jul 15 09:50:52 2018 +0200

    Prepare for frames having separate virtual and machine return addrs
    
    * libguile/frames.c (scm_frame_return_address): Use
      SCM_FRAME_VIRTUAL_RETURN_ADDRESS.
      (scm_c_frame_previous): Likewise.
    * libguile/frames.h: Update diagram for new names.
      (union scm_vm_stack_element): Rename "as_ip" to "as_vcode", and
      add "as_mcode" for machine code pointers.
      (SCM_FRAME_VIRTUAL_RETURN_ADDRESS)
      (SCM_FRAME_SET_VIRTUAL_RETURN_ADDRESS): Rename to these, from
      SCM_FRAME_RETURN_ADDRESS and SCM_FRAME_SET_RETURN_ADDRESS.
    * libguile/vm-engine.c (halt, call, call-label, return-values)
      (return-from-interrupt): Adapt to renamings.  Make "halt" have frame
      size as a parameter.
    * libguile/vm.c (scm_i_vm_mark_stack): Adapt to renaming.
      (push_interrupt_frame): Take mRA as additional argument.  In future we
      will set it as frame mRA.
      (capture_continuation): Adapt to renaming.
      (scm_call_n): Adapt to renaming and make frame size adjustable.
      (push_interrupt_frame, reinstate_continuation_x): Make frame size
      adjustable.
    * module/language/cps/slot-allocation.scm (allocate-slots): Make frame
      size adjustable.
    * libguile/intrinsics.h (scm_t_thread_mra_intrinsic): New type; use for
      push_interrupt_frame.
      (scm_t_thread_u8_scm_sp_vra_intrinsic): Rename from the same but was
      "ra" instead of "vra", and change type to uint32_t*.
    * module/system/vm/disassembler.scm (define-clobber-parser):
      Parameterize clobber set for calls by frame size.
---
 libguile/frames.c                       |  6 ++---
 libguile/frames.h                       | 46 +++++++++++++++++----------------
 libguile/intrinsics.c                   |  2 +-
 libguile/intrinsics.h                   | 13 +++++-----
 libguile/vm-engine.c                    | 23 +++++++++--------
 libguile/vm.c                           | 31 +++++++++++-----------
 module/language/cps/slot-allocation.scm |  8 +++---
 module/system/vm/disassembler.scm       |  3 ++-
 8 files changed, 70 insertions(+), 62 deletions(-)

diff --git a/libguile/frames.c b/libguile/frames.c
index 8452480..d989d62 100644
--- a/libguile/frames.c
+++ b/libguile/frames.c
@@ -366,8 +366,8 @@ SCM_DEFINE (scm_frame_return_address, 
"frame-return-address", 1, 0, 0,
 #define FUNC_NAME s_scm_frame_return_address
 {
   SCM_VALIDATE_VM_FRAME (1, frame);
-  return scm_from_uintptr_t ((uintptr_t) (SCM_FRAME_RETURN_ADDRESS
-                                              (SCM_VM_FRAME_FP (frame))));
+  return scm_from_uintptr_t ((uintptr_t) (SCM_FRAME_VIRTUAL_RETURN_ADDRESS
+                                          (SCM_VM_FRAME_FP (frame))));
 }
 #undef FUNC_NAME
 
@@ -404,7 +404,7 @@ scm_c_frame_previous (enum scm_vm_frame_kind kind, struct 
scm_frame *frame)
   new_sp = SCM_FRAME_PREVIOUS_SP (this_fp);
   frame->fp_offset = stack_top - new_fp;
   frame->sp_offset = stack_top - new_sp;
-  frame->ip = SCM_FRAME_RETURN_ADDRESS (this_fp);
+  frame->ip = SCM_FRAME_VIRTUAL_RETURN_ADDRESS (this_fp);
 
   if (scm_i_vm_is_boot_continuation_code (frame->ip))
     goto again;
diff --git a/libguile/frames.h b/libguile/frames.h
index bbc47d0..85e36a5 100644
--- a/libguile/frames.h
+++ b/libguile/frames.h
@@ -39,29 +39,30 @@
    Stack frame layout
    ------------------
 
-   | ...              |
-   +==================+ <- fp + 2 = SCM_FRAME_PREVIOUS_SP (fp)
-   | Dynamic link     |
-   +------------------+
-   | Return address   |
-   +==================+ <- fp
-   | Local 0          |
-   +------------------+
-   | Local 1          |
-   +------------------+
-   | ...              |
-   +------------------+
-   | Local N-1        |
-   \------------------/ <- sp
+   | ...                          |
+   +==============================+ <- fp + 2 = SCM_FRAME_PREVIOUS_SP (fp)
+   | Dynamic link                 |
+   +------------------------------+
+   | Virtual return address (vRA) |
+   +==============================+ <- fp
+   | Local 0                      |
+   +------------------------------+
+   | Local 1                      |
+   +------------------------------+
+   | ...                          |
+   +------------------------------+
+   | Local N-1                    |
+   \------------------------------/ <- sp
 
    The stack grows down.
 
    The calling convention is that a caller prepares a stack frame
-   consisting of the saved FP and the return address, followed by the
-   procedure and then the arguments to the call, in order.  Thus in the
-   beginning of a call, the procedure being called is in slot 0, the
-   first argument is in slot 1, and the SP points to the last argument.
-   The number of arguments, including the procedure, is thus FP - SP.
+   consisting of the saved FP and the saved virtual return address,
+   followed by the procedure and then the arguments to the call, in
+   order.  Thus in the beginning of a call, the procedure being called
+   is in slot 0, the first argument is in slot 1, and the SP points to
+   the last argument.  The number of arguments, including the procedure,
+   is thus FP - SP.
 
    After ensuring that the correct number of arguments have been passed,
    a function will set the stack pointer to point to the last local
@@ -90,7 +91,8 @@
 union scm_vm_stack_element
 {
   uintptr_t as_uint;
-  uint32_t *as_ip;
+  uint32_t *as_vcode;
+  uint8_t *as_mcode;
   SCM as_scm;
   double as_f64;
   uint64_t as_u64;
@@ -102,8 +104,8 @@ union scm_vm_stack_element
 };
 
 #define SCM_FRAME_PREVIOUS_SP(fp)      ((fp) + 2)
-#define SCM_FRAME_RETURN_ADDRESS(fp)    ((fp)[0].as_ip)
-#define SCM_FRAME_SET_RETURN_ADDRESS(fp, ra) ((fp)[0].as_ip = (ra))
+#define SCM_FRAME_VIRTUAL_RETURN_ADDRESS(fp)    ((fp)[0].as_vcode)
+#define SCM_FRAME_SET_VIRTUAL_RETURN_ADDRESS(fp, ra) ((fp)[0].as_vcode = (ra))
 #define SCM_FRAME_DYNAMIC_LINK(fp)      ((fp) + (fp)[1].as_uint)
 #define SCM_FRAME_SET_DYNAMIC_LINK(fp, dl) ((fp)[1].as_uint = ((dl) - (fp)))
 #define SCM_FRAME_SLOT(fp,i)            ((fp) - (i) - 1)
diff --git a/libguile/intrinsics.c b/libguile/intrinsics.c
index 75cf2f0..3175266 100644
--- a/libguile/intrinsics.c
+++ b/libguile/intrinsics.c
@@ -349,7 +349,7 @@ current_module (scm_thread *thread)
 
 static void
 push_prompt (scm_thread *thread, uint8_t escape_only_p,
-             SCM tag, const union scm_vm_stack_element *sp, void *ra)
+             SCM tag, const union scm_vm_stack_element *sp, uint32_t *ra)
 {
   struct scm_vm *vp = &thread->vm;
   scm_t_dynstack_prompt_flags flags;
diff --git a/libguile/intrinsics.h b/libguile/intrinsics.h
index 3c35749..3bd264f 100644
--- a/libguile/intrinsics.h
+++ b/libguile/intrinsics.h
@@ -61,10 +61,11 @@ typedef void (*scm_t_scm_noreturn_intrinsic) (SCM) 
SCM_NORETURN;
 typedef void (*scm_t_u32_noreturn_intrinsic) (uint32_t) SCM_NORETURN;
 typedef SCM (*scm_t_scm_from_thread_u64_intrinsic) (scm_thread*, uint64_t);
 typedef SCM (*scm_t_scm_from_thread_intrinsic) (scm_thread*);
-typedef void (*scm_t_thread_u8_scm_sp_ra_intrinsic) (scm_thread*,
-                                                     uint8_t, SCM,
-                                                     const union 
scm_vm_stack_element*,
-                                                     void*);
+typedef void (*scm_t_thread_u8_scm_sp_vra_intrinsic) (scm_thread*,
+                                                      uint8_t, SCM,
+                                                      const union 
scm_vm_stack_element*,
+                                                      uint32_t*);
+typedef void (*scm_t_thread_mra_intrinsic) (scm_thread*, uint8_t*);
 
 #define SCM_FOR_ALL_VM_INTRINSICS(M) \
   M(scm_from_scm_scm, add, "add", ADD) \
@@ -113,7 +114,7 @@ typedef void (*scm_t_thread_u8_scm_sp_ra_intrinsic) 
(scm_thread*,
   M(scm_from_thread_u32, cons_rest, "cons-rest", CONS_REST) \
   M(u32_from_thread_u32_u32, compute_kwargs_npositional, 
"compute-kwargs-npositional", COMPUTE_KWARGS_NPOSITIONAL) \
   M(thread_u32_u32_scm_u8_u8, bind_kwargs, "bind-kwargs", BIND_KWARGS) \
-  M(thread, push_interrupt_frame, "push-interrupt-frame", 
PUSH_INTERRUPT_FRAME) \
+  M(thread_mra, push_interrupt_frame, "push-interrupt-frame", 
PUSH_INTERRUPT_FRAME) \
   M(scm_from_scm_scm_scmp_sp, foreign_call, "foreign-call", FOREIGN_CALL) \
   M(thread_scm_noreturn, reinstate_continuation_x, "reinstate-continuation!", 
REINSTATE_CONTINUATION_X) \
   M(scm_from_thread, capture_continuation, "capture-continuation", 
CAPTURE_CONTINUATION) \
@@ -130,7 +131,7 @@ typedef void (*scm_t_thread_u8_scm_sp_ra_intrinsic) 
(scm_thread*,
   M(thread, apply_non_program, "apply-non-program", APPLY_NON_PROGRAM) \
   M(scm_from_thread_u64, allocate_words, "allocate-words", ALLOCATE_WORDS) \
   M(scm_from_thread, current_module, "current-module", CURRENT_MODULE) \
-  M(thread_u8_scm_sp_ra, push_prompt, "push-prompt", PUSH_PROMPT) \
+  M(thread_u8_scm_sp_vra, push_prompt, "push-prompt", PUSH_PROMPT) \
   /* Add new intrinsics here; also update scm_bootstrap_intrinsics.  */
 
 enum scm_vm_intrinsic
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index e9e1b47..cf4cab7 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -321,13 +321,14 @@ VM_NAME (scm_thread *thread)
    */
   VM_DEFINE_OP (0, halt, "halt", OP1 (X32))
     {
-      /* Boot closure in r0, empty frame in r1/r2, proc in r3, values from r4. 
 */
-
-      uint32_t nvals = FRAME_LOCALS_COUNT_FROM (4);
+      size_t frame_size = 2;
+      /* Boot closure, then empty frame, then callee, then values.  */
+      size_t first_value = 1 + frame_size + 1;
+      uint32_t nvals = FRAME_LOCALS_COUNT_FROM (first_value);
       SCM ret;
 
       if (nvals == 1)
-        ret = FP_REF (4);
+        ret = FP_REF (first_value);
       else
         {
           uint32_t n;
@@ -335,10 +336,10 @@ VM_NAME (scm_thread *thread)
           VM_ASSERT (nvals <= (UINTPTR_MAX >> 8), abort ());
           ret = scm_words ((nvals << 8) | scm_tc7_values, nvals + 1);
           for (n = 0; n < nvals; n++)
-            SCM_SET_CELL_OBJECT (ret, n+1, FP_REF (4 + n));
+            SCM_SET_CELL_OBJECT (ret, n+1, FP_REF (first_value + n));
         }
 
-      VP->ip = SCM_FRAME_RETURN_ADDRESS (VP->fp);
+      VP->ip = SCM_FRAME_VIRTUAL_RETURN_ADDRESS (VP->fp);
       VP->sp = SCM_FRAME_PREVIOUS_SP (VP->fp);
       VP->fp = SCM_FRAME_DYNAMIC_LINK (VP->fp);
 
@@ -371,7 +372,7 @@ VM_NAME (scm_thread *thread)
       old_fp = VP->fp;
       VP->fp = SCM_FRAME_SLOT (old_fp, proc - 1);
       SCM_FRAME_SET_DYNAMIC_LINK (VP->fp, old_fp);
-      SCM_FRAME_SET_RETURN_ADDRESS (VP->fp, ip + 2);
+      SCM_FRAME_SET_VIRTUAL_RETURN_ADDRESS (VP->fp, ip + 2);
 
       RESET_FRAME (nlocals);
 
@@ -414,7 +415,7 @@ VM_NAME (scm_thread *thread)
       old_fp = VP->fp;
       VP->fp = SCM_FRAME_SLOT (old_fp, proc - 1);
       SCM_FRAME_SET_DYNAMIC_LINK (VP->fp, old_fp);
-      SCM_FRAME_SET_RETURN_ADDRESS (VP->fp, ip + 3);
+      SCM_FRAME_SET_VIRTUAL_RETURN_ADDRESS (VP->fp, ip + 3);
 
       RESET_FRAME (nlocals);
 
@@ -576,7 +577,7 @@ VM_NAME (scm_thread *thread)
         RESET_FRAME (nlocals);
 
       old_fp = VP->fp;
-      ip = SCM_FRAME_RETURN_ADDRESS (VP->fp);
+      ip = SCM_FRAME_VIRTUAL_RETURN_ADDRESS (VP->fp);
       VP->fp = SCM_FRAME_DYNAMIC_LINK (VP->fp);
 
       /* Clear stack frame.  */
@@ -2373,7 +2374,7 @@ VM_NAME (scm_thread *thread)
         NEXT (1);
 
       SYNC_IP ();
-      CALL_INTRINSIC (push_interrupt_frame, (thread));
+      CALL_INTRINSIC (push_interrupt_frame, (thread, 0));
       CACHE_SP ();
       ip = (uint32_t *) vm_handle_interrupt_code;
       APPLY_HOOK ();
@@ -2388,7 +2389,7 @@ VM_NAME (scm_thread *thread)
   VM_DEFINE_OP (184, return_from_interrupt, "return-from-interrupt", OP1 (X32))
     {
       VP->sp = sp = SCM_FRAME_PREVIOUS_SP (VP->fp);
-      ip = SCM_FRAME_RETURN_ADDRESS (VP->fp);
+      ip = SCM_FRAME_VIRTUAL_RETURN_ADDRESS (VP->fp);
       VP->fp = SCM_FRAME_DYNAMIC_LINK (VP->fp);
 
       NEXT (0);
diff --git a/libguile/vm.c b/libguile/vm.c
index 7720afa..cf7b13c 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -710,7 +710,7 @@ scm_i_vm_mark_stack (struct scm_vm *vp, struct GC_ms_entry 
*mark_stack_ptr,
          Note that there may be other reasons to not have a dead slots
          map, e.g. if all of the frame's slots below the callee frame
          are live.  */
-      slot_map = find_slot_map (SCM_FRAME_RETURN_ADDRESS (fp), &cache);
+      slot_map = find_slot_map (SCM_FRAME_VIRTUAL_RETURN_ADDRESS (fp), &cache);
     }
 
   return_unused_stack_to_os (vp);
@@ -1011,24 +1011,25 @@ cons_rest (scm_thread *thread, uint32_t base)
 }
 
 static void
-push_interrupt_frame (scm_thread *thread)
+push_interrupt_frame (scm_thread *thread, uint8_t *mra)
 {
   union scm_vm_stack_element *old_fp;
+  size_t frame_overhead = 2;
   size_t old_frame_size = frame_locals_count (thread);
   SCM proc = scm_i_async_pop (thread);
 
   /* No PUSH_CONTINUATION_HOOK, as we can't usefully
      POP_CONTINUATION_HOOK because there are no return values.  */
 
-  /* Three slots: two for RA and dynamic link, one for proc.  */
-  alloc_frame (thread, old_frame_size + 3);
+  /* Reserve space for frame and callee.  */
+  alloc_frame (thread, old_frame_size + frame_overhead + 1);
 
   old_fp = thread->vm.fp;
-  thread->vm.fp = SCM_FRAME_SLOT (old_fp, old_frame_size + 1);
+  thread->vm.fp = SCM_FRAME_SLOT (old_fp, old_frame_size + frame_overhead - 1);
   SCM_FRAME_SET_DYNAMIC_LINK (thread->vm.fp, old_fp);
   /* Arrange to return to the same handle-interrupts opcode to handle
      any additional interrupts.  */
-  SCM_FRAME_SET_RETURN_ADDRESS (thread->vm.fp, thread->vm.ip);
+  SCM_FRAME_SET_VIRTUAL_RETURN_ADDRESS (thread->vm.fp, thread->vm.ip);
 
   SCM_FRAME_LOCAL (thread->vm.fp, 0) = proc;
 }
@@ -1069,7 +1070,7 @@ reinstate_continuation_x (scm_thread *thread, SCM cont)
   scm_t_contregs *continuation = scm_i_contregs (cont);
   struct scm_vm *vp = &thread->vm;
   struct scm_vm_cont *cp;
-  size_t n;
+  size_t n, i, frame_overhead = 2;
   union scm_vm_stack_element *argv;
   struct return_to_continuation_data data;
 
@@ -1091,11 +1092,11 @@ reinstate_continuation_x (scm_thread *thread, SCM cont)
 
   /* Now we have the continuation properly copied over.  We just need to
      copy on an empty frame and the return values, as the continuation
-     expects.  */
-  vm_push_sp (vp, vp->sp - 3 - n);
-  vp->sp[n+2].as_scm = SCM_BOOL_F;
-  vp->sp[n+1].as_scm = SCM_BOOL_F;
-  vp->sp[n].as_scm = SCM_BOOL_F;
+     expects.  The extra 1 is for the unused slot 0 that's part of the
+     multiple-value return convention.  */
+  vm_push_sp (vp, vp->sp - (frame_overhead + 1) - n);
+  for (i = 0; i < frame_overhead + 1; i++)
+    vp->sp[n+i].as_scm = SCM_BOOL_F;
   memcpy(vp->sp, argv, n * sizeof (union scm_vm_stack_element));
 
   vp->ip = cp->ra;
@@ -1111,7 +1112,7 @@ capture_continuation (scm_thread *thread)
     scm_i_vm_capture_stack (vp->stack_top,
                             SCM_FRAME_DYNAMIC_LINK (vp->fp),
                             SCM_FRAME_PREVIOUS_SP (vp->fp),
-                            SCM_FRAME_RETURN_ADDRESS (vp->fp),
+                            SCM_FRAME_VIRTUAL_RETURN_ADDRESS (vp->fp),
                             scm_dynstack_capture_all (&thread->dynstack),
                             0);
   return scm_i_make_continuation (thread, vm_cont);
@@ -1397,14 +1398,14 @@ scm_call_n (SCM proc, SCM *argv, size_t nargs)
   call_fp = vp->sp + call_nlocals;
   return_fp = call_fp + frame_size + return_nlocals;
 
-  SCM_FRAME_SET_RETURN_ADDRESS (return_fp, vp->ip);
+  SCM_FRAME_SET_VIRTUAL_RETURN_ADDRESS (return_fp, vp->ip);
   SCM_FRAME_SET_DYNAMIC_LINK (return_fp, vp->fp);
   SCM_FRAME_LOCAL (return_fp, 0) = vm_boot_continuation;
 
   vp->ip = (uint32_t *) vm_boot_continuation_code;
   vp->fp = call_fp;
 
-  SCM_FRAME_SET_RETURN_ADDRESS (call_fp, vp->ip);
+  SCM_FRAME_SET_VIRTUAL_RETURN_ADDRESS (call_fp, vp->ip);
   SCM_FRAME_SET_DYNAMIC_LINK (call_fp, return_fp);
   SCM_FRAME_LOCAL (call_fp, 0) = proc;
   for (i = 0; i < nargs; i++)
diff --git a/module/language/cps/slot-allocation.scm 
b/module/language/cps/slot-allocation.scm
index a7a9ab5..0febca5 100644
--- a/module/language/cps/slot-allocation.scm
+++ b/module/language/cps/slot-allocation.scm
@@ -807,11 +807,13 @@ are comparable with eqv?.  A tmp slot may be used."
                                                needs-slot)
                             empty-intset)))
 
+    (define frame-size 2)
+
     (define (empty-live-slots)
       #b0)
 
     (define (compute-call-proc-slot live-slots)
-      (+ 2 (find-first-trailing-zero live-slots)))
+      (+ frame-size (find-first-trailing-zero live-slots)))
 
     (define (compute-prompt-handler-proc-slot live-slots)
       (if (zero? live-slots)
@@ -927,7 +929,7 @@ are comparable with eqv?.  A tmp slot may be used."
                                                 (length results))))
                     (allocate* results result-slots slots post-live)))))
               ((slot-map) (compute-slot-map slots (intmap-ref live-out label)
-                                            (- proc-slot 2)))
+                                            (- proc-slot frame-size)))
               ((call) (make-call-alloc proc-slot slot-map)))
            (values slots
                    (intmap-add! call-allocs label call))))))
@@ -962,7 +964,7 @@ are comparable with eqv?.  A tmp slot may be used."
              (((handler-live) (compute-live-in-slots slots handler))
               ((proc-slot) (compute-prompt-handler-proc-slot handler-live))
               ((slot-map)  (compute-slot-map slots (intmap-ref live-in handler)
-                                             (- proc-slot 2)))
+                                             (- proc-slot frame-size)))
               ((result-vars) (match (get-cont kargs)
                                (($ $kargs names vars) vars)))
               ((value-slots) (integers (1+ proc-slot) (length result-vars)))
diff --git a/module/system/vm/disassembler.scm 
b/module/system/vm/disassembler.scm
index 2ab2bf5..f0b1a10 100644
--- a/module/system/vm/disassembler.scm
+++ b/module/system/vm/disassembler.scm
@@ -615,9 +615,10 @@ address of that offset."
                                   (lambda ()
                                     (disassemble-one code (/ pos 4)))
                                 (lambda (len elt)
+                                  (define frame-size 2)
                                   (match elt
                                     ((_ proc . _)
-                                     (let lp ((slot (- proc 2)))
+                                     (let lp ((slot (- proc frame-size)))
                                        (if (and nslots-in (< slot nslots-in))
                                            (cons slot (lp (1+ slot)))
                                            '())))))))))