* libguile/objcodes.h: Bump for metadata format change.
* libguile/frames.h: Rework so we don't frob the program's nargs, nlocs,
etc at runtime. Instead we don't really know what's a local var, an
argument, or an intermediate value. It's a little unfortunate, but
this will allow for case-lambda, and eventually for good polymorphic
generic dispatch; and the nlocs etc can be heuristically
reconstructed. Such a reconstruction would be better done at the
Scheme level, though.
(SCM_FRAME_STACK_ADDRESS): New macro, the pointer to the base of the
stack elements (not counting the program).
(SCM_FRAME_UPPER_ADDRESS): Repurpose to be the address of the last
element in the bookkeeping part of the stack -- i.e. to point to the
return address.
* libguile/vm-engine.h:
* libguile/vm-i-system.c: Adapt to removal of stack_base. Though we
still detect stack-smashing underflow, we don't do so as precisely as
we did before, because now we only detect overwriting of the frame
metadata.
* libguile/vm-engine.c (vm_engine): Remove the stack_base variable. It
is unnecessary, and difficult to keep track of in the face of
case-lambda. Also fix miscommented "ra" and "mvra" pushes. Push the
vp->ip as the first ra...
* libguile/vm-i-system.c (halt): ...because here we can restore the
vp->ip instead of setting ip to 0. Allows us to introspect ips all
down the stack, including in recursive VM invocations.
* libguile/frames.h:
* libguile/frames.c (scm_vm_frame_stack): Removed, because it's getting
more difficult to tell what's an argument and what's a temporary stack
element.
(scm_vm_frame_num_locals): New accessor.
(scm_vm_frame_instruction_pointer): New accessor.
(scm_vm_frame_arguments): Defer to an implementation in Scheme.
(scm_vm_frame_num_locals scm_vm_frame_local_ref)
(scm_vm_frame_local_set_x): Since we can get not-yet-active frames on
the stack now, with our current calling convention, we have to add a
heuristic here to jump over those frames -- because frames have
pointers in them, not Scheme values.
* libguile/programs.h:
* libguile/programs.c (scm_program_arity): Remove, in favor of..
(scm_program_arities): ...this, which a list of arities, in a new
format, occupying a slot in the metadata.
* module/language/assembly/decompile-bytecode.scm (decode-load-program):
Fix mv-call decompilation.
* module/system/vm/frame.scm (vm-frame-bindings, vm-frame-binding-ref)
(vm-frame-binding-set!): New functions, to access bindings by name in
a frame.
(vm-frame-arguments): Function now implemented in Scheme. Commented
fairly extensively.
* module/system/vm/program.scm (program-bindings-by-index)
(program-bindings-for-ip): New accessors, parsing the program bindings
metadata into something more useful.
(program-arities, program-arguments): In a case-lambda world, we have
to assume that programs can have multiple arities. But it's tough to
detect this algorithmically; instead we're going to require that the
program metadata include information about the arities, and the parts
of the program that that metadata applies to.
(program-lambda-list): New accessor.
(write-program): Show multiple arities.
* module/language/glil/compile-assembly.scm (glil->assembly): Add
"arities" to the state of the compiler, and add arities entries as
appropriate.
/* Major and minor versions must be single characters. */
#define SCM_OBJCODE_MAJOR_VERSION 0
-#define SCM_OBJCODE_MINOR_VERSION F
+#define SCM_OBJCODE_MINOR_VERSION G
#define SCM_OBJCODE_MAJOR_VERSION_STRING \
SCM_CPP_STRINGIFY(SCM_OBJCODE_MAJOR_VERSION)
#define SCM_OBJCODE_MINOR_VERSION_STRING \
}
#undef FUNC_NAME
-SCM_DEFINE (scm_vm_frame_arguments, "vm-frame-arguments", 1, 0, 0,
- (SCM frame),
- "")
-#define FUNC_NAME s_scm_vm_frame_arguments
+SCM
+scm_vm_frame_arguments (SCM frame)
+#define FUNC_NAME "vm-frame-arguments"
{
- SCM *fp;
- int i;
- struct scm_objcode *bp;
- SCM ret;
+ static SCM var = SCM_BOOL_F;
SCM_VALIDATE_VM_FRAME (1, frame);
- fp = SCM_VM_FRAME_FP (frame);
- bp = SCM_PROGRAM_DATA (SCM_FRAME_PROGRAM (fp));
+ if (scm_is_false (var))
+ var = scm_c_module_lookup (scm_c_resolve_module ("system vm frame"),
+ "vm-frame-arguments");
- if (!bp->nargs)
- return SCM_EOL;
- else if (bp->nrest)
- ret = SCM_FRAME_VARIABLE (fp, bp->nargs - 1);
- else
- ret = scm_cons (SCM_FRAME_VARIABLE (fp, bp->nargs - 1), SCM_EOL);
-
- for (i = bp->nargs - 2; i >= 0; i--)
- ret = scm_cons (SCM_FRAME_VARIABLE (fp, i), ret);
-
- return ret;
+ return scm_call_1 (SCM_VARIABLE_REF (var), frame);
}
#undef FUNC_NAME
}
#undef FUNC_NAME
+/* The number of locals would be a simple thing to compute, if it weren't for
+ the presence of not-yet-active frames on the stack. So we have a cheap
+ heuristic to detect not-yet-active frames, and skip over them. Perhaps we
+ should represent them more usefully.
+ */
+SCM_DEFINE (scm_vm_frame_num_locals, "vm-frame-num-locals", 1, 0, 0,
+ (SCM frame),
+ "")
+#define FUNC_NAME s_scm_vm_frame_num_locals
+{
+ SCM *sp, *p;
+ unsigned int n = 0;
+
+ SCM_VALIDATE_VM_FRAME (1, frame);
+
+ sp = SCM_VM_FRAME_SP (frame);
+ p = SCM_FRAME_STACK_ADDRESS (SCM_VM_FRAME_FP (frame));
+ while (p <= sp)
+ {
+ if (p + 1 < sp && p[1] == (SCM)0)
+ /* skip over not-yet-active frame */
+ p += 3;
+ else
+ {
+ p++;
+ n++;
+ }
+ }
+ return scm_from_uint (n);
+}
+#undef FUNC_NAME
+
+/* Need same not-yet-active frame logic here as in vm-frame-num-locals */
SCM_DEFINE (scm_vm_frame_local_ref, "vm-frame-local-ref", 2, 0, 0,
(SCM frame, SCM index),
"")
#define FUNC_NAME s_scm_vm_frame_local_ref
{
- SCM *fp;
+ SCM *sp, *p;
+ unsigned int n = 0;
unsigned int i;
- struct scm_objcode *bp;
-
- SCM_VALIDATE_VM_FRAME (1, frame);
-
- fp = SCM_VM_FRAME_FP (frame);
- bp = SCM_PROGRAM_DATA (SCM_FRAME_PROGRAM (fp));
+ SCM_VALIDATE_VM_FRAME (1, frame);
SCM_VALIDATE_UINT_COPY (2, index, i);
- SCM_ASSERT_RANGE (2, index, i < bp->nargs + bp->nlocs);
- return SCM_FRAME_VARIABLE (fp, i);
+ sp = SCM_VM_FRAME_SP (frame);
+ p = SCM_FRAME_STACK_ADDRESS (SCM_VM_FRAME_FP (frame));
+ while (p <= sp)
+ {
+ if (p + 1 < sp && p[1] == (SCM)0)
+ /* skip over not-yet-active frame */
+ p += 3;
+ else if (n == i)
+ return *p;
+ else
+ {
+ p++;
+ n++;
+ }
+ }
+ SCM_OUT_OF_RANGE (SCM_ARG2, index);
}
#undef FUNC_NAME
+/* Need same not-yet-active frame logic here as in vm-frame-num-locals */
SCM_DEFINE (scm_vm_frame_local_set_x, "vm-frame-local-set!", 3, 0, 0,
(SCM frame, SCM index, SCM val),
"")
#define FUNC_NAME s_scm_vm_frame_local_set_x
{
- SCM *fp;
+ SCM *sp, *p;
+ unsigned int n = 0;
unsigned int i;
- struct scm_objcode *bp;
-
- SCM_VALIDATE_VM_FRAME (1, frame);
-
- fp = SCM_VM_FRAME_FP (frame);
- bp = SCM_PROGRAM_DATA (SCM_FRAME_PROGRAM (fp));
+ SCM_VALIDATE_VM_FRAME (1, frame);
SCM_VALIDATE_UINT_COPY (2, index, i);
- SCM_ASSERT_RANGE (2, index, i < bp->nargs + bp->nlocs);
- SCM_FRAME_VARIABLE (fp, i) = val;
+ sp = SCM_VM_FRAME_SP (frame);
+ p = SCM_FRAME_STACK_ADDRESS (SCM_VM_FRAME_FP (frame));
+ while (p <= sp)
+ {
+ if (p + 1 < sp && p[1] == (SCM)0)
+ /* skip over not-yet-active frame */
+ p += 3;
+ else if (n == i)
+ {
+ *p = val;
+ return SCM_UNSPECIFIED;
+ }
+ else
+ {
+ p++;
+ n++;
+ }
+ }
+ SCM_OUT_OF_RANGE (SCM_ARG2, index);
+}
+#undef FUNC_NAME
- return SCM_UNSPECIFIED;
+SCM_DEFINE (scm_vm_frame_instruction_pointer, "vm-frame-instruction-pointer", 1, 0, 0,
+ (SCM frame),
+ "")
+#define FUNC_NAME s_scm_vm_frame_instruction_pointer
+{
+ SCM_VALIDATE_VM_FRAME (1, frame);
+ return scm_from_ulong ((unsigned long)
+ (SCM_VM_FRAME_IP (frame)
+ - SCM_PROGRAM_DATA (scm_vm_frame_program (frame))->base));
}
#undef FUNC_NAME
}
#undef FUNC_NAME
-SCM_DEFINE (scm_vm_frame_stack, "vm-frame-stack", 1, 0, 0,
- (SCM frame),
- "")
-#define FUNC_NAME s_scm_vm_frame_stack
-{
- SCM *top, *bottom, ret = SCM_EOL;
-
- SCM_VALIDATE_VM_FRAME (1, frame);
-
- top = SCM_VM_FRAME_SP (frame);
- bottom = SCM_FRAME_UPPER_ADDRESS (SCM_VM_FRAME_FP (frame));
- while (bottom <= top)
- ret = scm_cons (*bottom++, ret);
-
- return ret;
-}
-#undef FUNC_NAME
-
extern SCM
scm_c_vm_frame_prev (SCM frame)
{
---------------
| ... |
- | Intermed. val. 0 | <- fp + bp->nargs + bp->nlocs = SCM_FRAME_UPPER_ADDRESS (fp)
- +==================+
+ | Intermed. val. 0 | <- fp + nargs + nlocs
+ +------------------+
| Local variable 1 |
- | Local variable 0 | <- fp + bp->nargs
+ | Local variable 0 | <- fp + nargs
| Argument 1 |
- | Argument 0 | <- fp
+ | Argument 0 | <- fp = SCM_FRAME_STACK_ADDRESS (fp)
| Program | <- fp - 1
- +------------------+
- | Return address |
+ +==================+
+ | Return address | <- SCM_FRAME_UPPER_ADDRESS (fp)
| MV return address|
| Dynamic link | <- fp - 4 = SCM_FRAME_DATA_ADDRESS (fp) = SCM_FRAME_LOWER_ADDRESS (fp)
+==================+
assumed to be as long as SCM objects. */
#define SCM_FRAME_DATA_ADDRESS(fp) (fp - 4)
-#define SCM_FRAME_UPPER_ADDRESS(fp) \
- (fp \
- + SCM_PROGRAM_DATA (SCM_FRAME_PROGRAM (fp))->nargs \
- + SCM_PROGRAM_DATA (SCM_FRAME_PROGRAM (fp))->nlocs)
+#define SCM_FRAME_STACK_ADDRESS(fp) (fp)
+#define SCM_FRAME_UPPER_ADDRESS(fp) (fp - 2)
#define SCM_FRAME_LOWER_ADDRESS(fp) (fp - 4)
#define SCM_FRAME_BYTE_CAST(x) ((scm_t_uint8 *) SCM_UNPACK (x))
(SCM_FRAME_STACK_CAST (SCM_FRAME_DATA_ADDRESS (fp)[0]))
#define SCM_FRAME_SET_DYNAMIC_LINK(fp, dl) \
((SCM_FRAME_DATA_ADDRESS (fp)[0])) = (SCM)(dl);
-#define SCM_FRAME_VARIABLE(fp,i) fp[i]
-#define SCM_FRAME_PROGRAM(fp) fp[-1]
+#define SCM_FRAME_VARIABLE(fp,i) SCM_FRAME_STACK_ADDRESS (fp)[i]
+#define SCM_FRAME_PROGRAM(fp) SCM_FRAME_STACK_ADDRESS (fp)[-1]
\f
/*
SCM_API SCM scm_vm_frame_program (SCM frame);
SCM_API SCM scm_vm_frame_arguments (SCM frame);
SCM_API SCM scm_vm_frame_source (SCM frame);
+SCM_API SCM scm_vm_frame_num_locals (SCM frame);
SCM_API SCM scm_vm_frame_local_ref (SCM frame, SCM index);
SCM_API SCM scm_vm_frame_local_set_x (SCM frame, SCM index, SCM val);
+SCM_API SCM scm_vm_frame_instruction_pointer (SCM frame);
SCM_API SCM scm_vm_frame_return_address (SCM frame);
SCM_API SCM scm_vm_frame_mv_return_address (SCM frame);
SCM_API SCM scm_vm_frame_dynamic_link (SCM frame);
-SCM_API SCM scm_vm_frame_stack (SCM frame);
SCM_API SCM scm_c_vm_frame_prev (SCM frame);
}
#undef FUNC_NAME
-SCM_DEFINE (scm_program_arity, "program-arity", 1, 0, 0,
- (SCM program),
- "")
-#define FUNC_NAME s_scm_program_arity
-{
- struct scm_objcode *p;
-
- SCM_VALIDATE_PROGRAM (1, program);
-
- p = SCM_PROGRAM_DATA (program);
- return scm_list_3 (SCM_I_MAKINUM (p->nargs),
- SCM_I_MAKINUM (p->nrest),
- SCM_I_MAKINUM (p->nlocs));
-}
-#undef FUNC_NAME
-
SCM_DEFINE (scm_program_objects, "program-objects", 1, 0, 0,
(SCM program),
"")
}
#undef FUNC_NAME
+SCM_DEFINE (scm_program_arities, "program-arities", 1, 0, 0,
+ (SCM program),
+ "")
+#define FUNC_NAME s_scm_program_arities
+{
+ SCM meta;
+
+ SCM_VALIDATE_PROGRAM (1, program);
+
+ meta = scm_program_meta (program);
+ if (scm_is_false (meta))
+ return SCM_BOOL_F;
+
+ return scm_caddr (scm_call_0 (meta));
+}
+#undef FUNC_NAME
+
SCM_DEFINE (scm_program_properties, "program-properties", 1, 0, 0,
(SCM program),
"")
if (scm_is_false (meta))
return SCM_EOL;
- return scm_cddr (scm_call_0 (meta));
+ return scm_cdddr (scm_call_0 (meta));
}
#undef FUNC_NAME
SCM_API SCM scm_program_p (SCM obj);
SCM_API SCM scm_program_base (SCM program);
-SCM_API SCM scm_program_arity (SCM program);
SCM_API SCM scm_program_meta (SCM program);
SCM_API SCM scm_program_bindings (SCM program);
SCM_API SCM scm_program_sources (SCM program);
SCM_API SCM scm_program_source (SCM program, SCM ip);
+SCM_API SCM scm_program_arities (SCM program);
SCM_API SCM scm_program_properties (SCM program);
SCM_API SCM scm_program_name (SCM program);
SCM_API SCM scm_program_objects (SCM program);
size_t free_vars_count = 0; /* length of FREE_VARS */
SCM *objects = NULL; /* constant objects */
size_t object_count = 0; /* length of OBJECTS */
- SCM *stack_base = vp->stack_base; /* stack base address */
SCM *stack_limit = vp->stack_limit; /* stack limit address */
/* Internal variables */
/* Initial frame */
CACHE_REGISTER ();
PUSH ((SCM)fp); /* dynamic link */
- PUSH (0); /* ra */
PUSH (0); /* mvra */
+ PUSH ((SCM)ip); /* ra */
CACHE_PROGRAM ();
PUSH (program);
fp = sp + 1;
INIT_FRAME ();
/* MV-call frame, function & arguments */
PUSH ((SCM)fp); /* dynamic link */
- PUSH (0); /* ra */
PUSH (0); /* mvra */
+ PUSH (0); /* ra */
PUSH (prog);
if (SCM_UNLIKELY (sp + nargs >= stack_limit))
goto vm_error_too_many_args;
ip = vp->ip; \
sp = vp->sp; \
fp = vp->fp; \
- stack_base = fp ? SCM_FRAME_UPPER_ADDRESS (fp) - 1 : vp->stack_base; \
}
#define SYNC_REGISTER() \
goto vm_error_stack_overflow
#define CHECK_UNDERFLOW() \
- if (sp < stack_base) \
+ if (sp < SCM_FRAME_UPPER_ADDRESS (fp)) \
goto vm_error_stack_underflow;
#define PUSH(x) do { sp++; CHECK_OVERFLOW (); *sp = x; } while (0)
/* New registers */ \
sp += bp->nlocs; \
CHECK_OVERFLOW (); \
- stack_base = sp; \
ip = bp->base; \
\
/* Init local variables */ \
}
{
- ASSERT (sp == stack_base);
- ASSERT (stack_base == SCM_FRAME_UPPER_ADDRESS (fp) - 1);
+#ifdef VM_ENABLE_STACK_NULLING
+ SCM *old_sp = sp;
+#endif
/* Restore registers */
sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1;
- ip = NULL;
+ /* Setting the ip here doesn't actually affect control flow, as the calling
+ code will restore its own registers, but it does help when walking the
+ stack */
+ ip = SCM_FRAME_RETURN_ADDRESS (fp);
fp = SCM_FRAME_DYNAMIC_LINK (fp);
- NULLSTACK (stack_base - sp);
+ NULLSTACK (old_sp - sp);
}
goto vm_done;
VM_DEFINE_INSTRUCTION (41, new_frame, "new-frame", 0, 0, 3)
{
+ /* NB: if you change this, see frames.c:vm-frame-num-locals */
+ /* and frames.h, vm-engine.c, etc of course */
PUSH ((SCM)fp); /* dynamic link */
PUSH (0); /* mvra */
PUSH (0); /* ra */
SCM ret;
POP (ret);
- ASSERT (sp == stack_base);
- ASSERT (stack_base == SCM_FRAME_UPPER_ADDRESS (fp) - 1);
+
+#ifdef VM_ENABLE_STACK_NULLING
+ SCM *old_sp = sp;
+#endif
/* Restore registers */
sp = SCM_FRAME_LOWER_ADDRESS (fp);
ip = SCM_FRAME_RETURN_ADDRESS (fp);
fp = SCM_FRAME_DYNAMIC_LINK (fp);
- {
+
#ifdef VM_ENABLE_STACK_NULLING
- int nullcount = stack_base - sp;
+ NULLSTACK (old_sp - sp);
#endif
- stack_base = SCM_FRAME_UPPER_ADDRESS (fp) - 1;
- NULLSTACK (nullcount);
- }
/* Set return value (sp is already pushed) */
*sp = ret;
EXIT_HOOK ();
RETURN_HOOK ();
- ASSERT (stack_base == SCM_FRAME_UPPER_ADDRESS (fp) - 1);
-
- /* data[1] is the mv return address */
if (nvalues != 1 && SCM_FRAME_MV_RETURN_ADDRESS (fp))
{
+ /* A multiply-valued continuation */
+ SCM *vals = sp - nvalues;
int i;
/* Restore registers */
sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1;
/* Push return values, and the number of values */
for (i = 0; i < nvalues; i++)
- *++sp = stack_base[1+i];
+ *++sp = vals[i+1];
*++sp = SCM_I_MAKINUM (nvalues);
- /* Finally set new stack_base */
- NULLSTACK (stack_base - sp + nvalues + 1);
- stack_base = SCM_FRAME_UPPER_ADDRESS (fp) - 1;
+ /* Finally null the end of the stack */
+ NULLSTACK (vals + nvalues - sp);
}
else if (nvalues >= 1)
{
break with guile tradition and try and do something sensible. (Also,
this block handles the single-valued return to an mv
continuation.) */
+ SCM *vals = sp - nvalues;
/* Restore registers */
sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1;
ip = SCM_FRAME_RETURN_ADDRESS (fp);
fp = SCM_FRAME_DYNAMIC_LINK (fp);
/* Push first value */
- *++sp = stack_base[1];
+ *++sp = vals[1];
- /* Finally set new stack_base */
- NULLSTACK (stack_base - sp + nvalues + 1);
- stack_base = SCM_FRAME_UPPER_ADDRESS (fp) - 1;
+ /* Finally null the end of the stack */
+ NULLSTACK (vals + nvalues - sp);
}
else
goto vm_error_no_values;
(else
(lp (cdr in) out filename)))))))
-(define (make-meta bindings sources tail)
+(define (make-meta bindings sources arities tail)
(if (and (null? bindings) (null? sources) (null? tail))
#f
(compile-assembly
(make-glil-program 0 0 0 '()
(list
- (make-glil-const `(,bindings ,sources ,@tail))
+ (make-glil-const `(,bindings ,sources ,arities ,@tail))
(make-glil-call 'return 1))))))
;; A functional stack of names of live variables.
(define (compile-assembly glil)
(receive (code . _)
- (glil->assembly glil #t '(()) '() '() #f -1)
+ (glil->assembly glil #t '(()) '() '() #f '() -1)
(car code)))
(define (make-object-table objects)
(and (not (null? objects))
(list->vector (cons #f objects))))
+;; arities := ((ip nreq [[nopt] [[rest?] [kw]]]]) ...)
+(define (begin-arity addr nreq nopt rest? kw arities)
+ (cons
+ (cond
+ (kw (list addr nreq nopt rest? kw))
+ (rest? (list addr nreq nopt rest?))
+ (nopt (list addr nreq nopt))
+ (nreq (list addr req))
+ (else (list addr)))
+ arities))
+
(define (glil->assembly glil toplevel? bindings
- source-alist label-alist object-alist addr)
+ source-alist label-alist object-alist arities addr)
(define (emit-code x)
- (values x bindings source-alist label-alist object-alist))
+ (values x bindings source-alist label-alist object-alist arities))
(define (emit-code/object x object-alist)
- (values x bindings source-alist label-alist object-alist))
+ (values x bindings source-alist label-alist object-alist arities))
+ (define (emit-code/arity x nreq nopt rest? kw)
+ (values x bindings source-alist label-alist object-alist
+ (begin-arity (addr+ addr x) nreq nopt rest? kw arities)))
(record-case glil
((<glil-program> nargs nrest nlocs meta body)
(define (process-body)
(let lp ((body body) (code '()) (bindings '(())) (source-alist '())
- (label-alist '()) (object-alist (if toplevel? #f '())) (addr 0))
+ (label-alist '()) (object-alist (if toplevel? #f '()))
+ (arities '()) (addr 0))
(cond
((null? body)
(values (reverse code)
(limn-sources (reverse! source-alist))
(reverse label-alist)
(and object-alist (map car (reverse object-alist)))
+ (reverse arities)
addr))
(else
- (receive (subcode bindings source-alist label-alist object-alist)
+ (receive (subcode bindings source-alist label-alist object-alist
+ arities)
(glil->assembly (car body) #f bindings
- source-alist label-alist object-alist addr)
+ source-alist label-alist object-alist
+ arities addr)
(lp (cdr body) (append (reverse subcode) code)
- bindings source-alist label-alist object-alist
+ bindings source-alist label-alist object-alist arities
(addr+ addr subcode)))))))
- (receive (code bindings sources labels objects len)
+ (receive (code bindings sources labels objects arities len)
(process-body)
- (let* ((meta (make-meta bindings sources meta))
+ (let* ((meta (make-meta bindings sources arities meta))
(meta-pad (if meta (modulo (- 8 (modulo len 8)) 8) 0))
(prog `(load-program ,nargs ,nrest ,nlocs ,labels
,(+ len meta-pad)
(open-binding bindings vars addr)
source-alist
label-alist
- object-alist))
+ object-alist
+ arities))
((<glil-mv-bind> vars rest)
(values `((truncate-values ,(length vars) ,(if rest 1 0)))
(open-binding bindings vars addr)
source-alist
label-alist
- object-alist))
+ object-alist
+ arities))
((<glil-unbind>)
(values '()
(close-binding bindings addr)
source-alist
label-alist
- object-alist))
+ object-alist
+ arities))
((<glil-source> props)
(values '()
bindings
(acons addr props source-alist)
label-alist
- object-alist))
+ object-alist
+ arities))
((<glil-void>)
(emit-code '((void))))
bindings
source-alist
(acons label (addr+ addr code) label-alist)
- object-alist)))
+ object-alist
+ arities)))
((<glil-branch> inst label)
(emit-code `((,inst ,label))))
((<glil-arity> nargs nrest label)
- (emit-code (if label
- (if (zero? nrest)
- `((br-if-nargs-ne ,(quotient nargs 256) ,label))
- `(,@(if (> nargs 1)
- `((br-if-nargs-lt ,(quotient (1- nargs) 256)
- ,(modulo (1- nargs 256))
- ,label))
- '())
- (push-rest-list ,(quotient (1- nargs) 256))))
- (if (zero? nrest)
- `((assert-nargs-ee ,(quotient nargs 256)
- ,(modulo nargs 256)))
- `(,@(if (> nargs 1)
- `((assert-nargs-ge ,(quotient (1- nargs) 256)
- ,(modulo (1- nargs) 256)))
- '())
- (push-rest-list ,(quotient (1- nargs) 256)
- ,(modulo (1- nargs) 256)))))))
+ (emit-code/arity
+ (if label
+ (if (zero? nrest)
+ `((br-if-nargs-ne ,(quotient nargs 256) ,label))
+ `(,@(if (> nargs 1)
+ `((br-if-nargs-lt ,(quotient (1- nargs) 256)
+ ,(modulo (1- nargs 256))
+ ,label))
+ '())
+ (push-rest-list ,(quotient (1- nargs) 256))))
+ (if (zero? nrest)
+ `((assert-nargs-ee ,(quotient nargs 256)
+ ,(modulo nargs 256)))
+ `(,@(if (> nargs 1)
+ `((assert-nargs-ge ,(quotient (1- nargs) 256)
+ ,(modulo (1- nargs) 256)))
+ '())
+ (push-rest-list ,(quotient (1- nargs) 256)
+ ,(modulo (1- nargs) 256)))))
+ (- nargs nrest) 0 (< 0 nrest) #f))
;; nargs is number of stack args to insn. probably should rename.
((<glil-call> inst nargs)
;;; Code:
(define-module (system vm frame)
+ #:use-module (system base pmatch)
#:use-module (system vm program)
#:use-module (system vm instruction)
#:use-module (system vm objcode)
#:export (vm-frame?
vm-frame-program
vm-frame-local-ref vm-frame-local-set!
+ vm-frame-instruction-pointer
vm-frame-return-address vm-frame-mv-return-address
vm-frame-dynamic-link
- vm-frame-stack
+ vm-frame-num-locals
+ vm-frame-bindings vm-frame-binding-ref vm-frame-binding-set!
+ vm-frame-arguments
vm-frame-number vm-frame-address
make-frame-chain
(load-extension "libguile" "scm_init_frames")
+(define (vm-frame-bindings frame)
+ (map (lambda (b)
+ (cons (binding:name b) (binding:index b)))
+ (program-bindings-for-ip (vm-frame-program frame)
+ (vm-frame-instruction-pointer frame))))
+
+(define (vm-frame-binding-set! frame var val)
+ (let ((i (assq-ref (vm-frame-bindings frame) var)))
+ (if i
+ (vm-frame-local-set! frame i val)
+ (error "variable not bound in frame" var frame))))
+
+(define (vm-frame-binding-ref frame var)
+ (let ((i (assq-ref (vm-frame-bindings frame) var)))
+ (if i
+ (vm-frame-local-ref frame i)
+ (error "variable not bound in frame" var frame))))
+
+;; Basically there are two cases to deal with here:
+;;
+;; 1. We've already parsed the arguments, and bound them to local
+;; variables. In a standard (lambda (a b c) ...) call, this doesn't
+;; involve any argument shuffling; but with rest, optional, or
+;; keyword arguments, the arguments as given to the procedure may
+;; not correspond to what's on the stack. We reconstruct the
+;; arguments using e.g. for the case above: `(,a ,b ,c). This works
+;; for rest arguments too: (a b . c) => `(,a ,b . ,c)
+;;
+;; 2. We have failed to parse the arguments. Perhaps it's the wrong
+;; number of arguments, or perhaps we're doing a typed dispatch and
+;; the types don't match. In that case the arguments are all on the
+;; stack, and nothing else is on the stack.
+(define (vm-frame-arguments frame)
+ (cond
+ ((program-lambda-list (vm-frame-program frame)
+ (vm-frame-instruction-pointer frame))
+ ;; case 1
+ => (lambda (formals)
+ (let lp ((formals formals))
+ (pmatch formals
+ (() '())
+ ((,x . ,rest) (guard (symbol? x))
+ (cons (vm-frame-binding-ref frame x) (lp rest)))
+ ((,x . ,rest)
+ ;; could be a keyword
+ (cons x (lp rest)))
+ (,rest (guard (symbol? rest))
+ (vm-frame-binding-ref frame rest))
+ (else (error "bad formals" formals))))))
+ (else
+ ;; case 2
+ (map (lambda (i)
+ (vm-frame-local-ref frame i))
+ (iota (vm-frame-num-locals frame))))))
+
;;;
;;; Frame chain
;;;
;;; Code:
(define-module (system vm program)
+ #:use-module (system base pmatch)
+ #:use-module (ice-9 optargs)
#:export (make-program
- arity:nargs arity:nrest arity:nlocs
-
make-binding binding:name binding:boxed? binding:index
binding:start binding:end
source:addr source:line source:column source:file
- program-bindings program-sources program-source
+ program-sources program-source
program-properties program-property program-documentation
- program-name program-arguments
+ program-name
+
+ program-bindings program-bindings-by-index program-bindings-for-ip
+ program-arities program-arguments program-lambda-list
- program-arity program-meta
+ program-meta
program-objcode program? program-objects
program-module program-base program-free-variables))
(load-extension "libguile" "scm_init_programs")
-(define arity:nargs car)
-(define arity:nrest cadr)
-(define arity:nlocs caddr)
-
(define (make-binding name boxed? index start end)
(list name boxed? index start end))
(define (binding:name b) (list-ref b 0))
(define (program-documentation prog)
(assq-ref (program-properties prog) 'documentation))
-(define (program-arguments prog)
- (let ((bindings (program-bindings prog))
- (nargs (arity:nargs (program-arity prog)))
- (rest? (not (zero? (arity:nrest (program-arity prog))))))
- (if bindings
- (let ((args (map binding:name (list-head bindings nargs))))
- (if rest?
- `((required . ,(list-head args (1- (length args))))
- (rest . ,(car (last-pair args))))
- `((required . ,args))))
- #f)))
-
-(define (program-bindings-as-lambda-list prog)
- (let ((bindings (program-bindings prog))
- (nargs (arity:nargs (program-arity prog)))
- (rest? (not (zero? (arity:nrest (program-arity prog))))))
- (if (not bindings)
- (if rest? (cons (1- nargs) 1) (list nargs))
- (let ((args (map binding:name (list-head bindings nargs))))
- (if rest?
- (apply cons* args)
- args)))))
+(define (collapse-locals locs)
+ (let lp ((ret '()) (locs locs))
+ (if (null? locs)
+ (map cdr (sort! ret
+ (lambda (x y) (< (car x) (car y)))))
+ (let ((b (car locs)))
+ (cond
+ ((assv-ref ret (binding:index b))
+ => (lambda (bindings)
+ (append! bindings (list b))
+ (lp ret (cdr locs))))
+ (else
+ (lp (acons (binding:index b) (list b) ret)
+ (cdr locs))))))))
+
+;; returns list of list of bindings
+;; (list-ref ret N) == bindings bound to the Nth local slot
+(define (program-bindings-by-index prog)
+ (cond ((program-bindings prog) => collapse-locals)
+ (else '())))
+
+(define (program-bindings-for-ip prog ip)
+ (let lp ((in (program-bindings-by-index prog)) (out '()))
+ (if (null? in)
+ (reverse out)
+ (lp (cdr in)
+ (let inner ((binds (car in)))
+ (cond ((null? binds) out)
+ ((<= (binding:start (car binds))
+ ip
+ (binding:end (car binds)))
+ (cons (car binds) out))
+ (else (inner (cdr binds)))))))))
+
+;; not exported; should it be?
+(define (program-arity prog ip)
+ (let ((arities (program-arities prog)))
+ (and arities
+ (let lp ((arities arities))
+ (cond ((null? arities) #f)
+ ((<= (caar arities) ip) (car arities))
+ (else (lp (cdr arities))))))))
+
+(define (arglist->arguments arglist)
+ (pmatch arglist
+ ((,req ,opt ,keyword ,allow-other-keys? ,rest . ,extents)
+ `((required . ,req)
+ (optional . ,opt)
+ (keyword . ,keyword)
+ (allow-other-keys? . ,allow-other-keys?)
+ (rest . ,rest)
+ (extents . ,extents)))
+ (else #f)))
+
+(define (arity:start a)
+ (pmatch a ((,ip . _) ip) (else (error "bad arity" a))))
+(define (arity:nreq a)
+ (pmatch a ((_ ,nreq . _) nreq) (else 0)))
+(define (arity:nopt a)
+ (pmatch a ((_ ,nreq ,nopt . _) nopt) (else 0)))
+(define (arity:rest? a)
+ (pmatch a ((_ ,nreq ,nopt ,rest? . _) rest?) (else #f)))
+(define (arity:kw a)
+ (pmatch a ((_ ,nreq ,nopt ,rest? (_ . ,kw)) kw) (else '())))
+(define (arity:allow-other-keys? a)
+ (pmatch a ((_ ,nreq ,nopt ,rest? (,aok . ,kw)) aok) (else #f)))
+
+(define (arity->arguments prog arity)
+ (define var-by-index
+ (let ((rbinds (map (lambda (x)
+ (cons (binding:index x) (binding:name x)))
+ (program-bindings-for-ip prog
+ (arity:start arity)))))
+ (lambda (i)
+ (assv-ref rbinds i))))
+
+ (let lp ((nreq (arity:nreq arity)) (req '())
+ (nopt (arity:nopt arity)) (opt '())
+ (rest? (arity:rest? arity)) (rest #f)
+ (n 0))
+ (cond
+ ((< 0 nreq)
+ (lp (1- nreq) (cons (var-by-index n) req)
+ nopt opt rest? rest (1+ n)))
+ ((< 0 nopt)
+ (lp nreq req
+ (1- nopt) (cons (var-by-index n) opt)
+ rest? rest (1+ n)))
+ (rest?
+ (lp nreq req nopt opt
+ #f (var-by-index n)
+ (1+ n)))
+ (else
+ `((required . ,(reverse req))
+ (optional . ,(reverse opt))
+ (keyword . ,(arity:kw arity))
+ (allow-other-keys? . ,(arity:allow-other-keys? arity))
+ (rest . ,rest))))))
+
+(define* (program-arguments prog #:optional ip)
+ (let ((arity (program-arity prog ip)))
+ (and arity
+ (arity->arguments prog arity))))
+
+(define* (program-lambda-list prog #:optional ip)
+ (and=> (program-arguments prog ip) arguments->lambda-list))
+
+(define (arguments->lambda-list arguments)
+ (let ((req (or (assq-ref arguments 'required) '()))
+ (opt (or (assq-ref arguments 'optional) '()))
+ (key (or (assq-ref arguments 'keyword) '()))
+ (rest (or (assq-ref arguments 'rest) '())))
+ `(,@req
+ ,@(if (pair? opt) (cons #:optional opt) '())
+ ,@(if (pair? key) (cons #:key key) '())
+ . ,rest)))
(define (write-program prog port)
- (format port "#<program ~a ~a>"
+ (format port "#<program ~a~a>"
(or (program-name prog)
(and=> (program-source prog 0)
(lambda (s)
(or (source:file s) "<unknown port>")
(source:line s) (source:column s))))
(number->string (object-address prog) 16))
- (program-bindings-as-lambda-list prog)))
+ (let ((arities (program-arities prog)))
+ (if (null? arities)
+ ""
+ (string-append
+ " " (string-join (map (lambda (a)
+ (object->string
+ (arguments->lambda-list
+ (arity->arguments prog a))))
+ arities)
+ " | "))))))
+
HCoop / bpt / guile.git / commitdiff