runtime and debugging support for callee-parsed procedure args
* 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.
This commit is contained in:
Andy Wingo
parent
1e2a8c266d
commit
6c6a44390b
11 changed files with 411 additions and 188 deletions
|
|
@ -68,13 +68,13 @@
|
|||
(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.
|
||||
|
|
@ -128,24 +128,39 @@
|
|||
|
||||
(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)
|
||||
|
|
@ -153,18 +168,21 @@
|
|||
(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)
|
||||
|
|
@ -205,28 +223,32 @@
|
|||
(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))))
|
||||
|
|
@ -351,30 +373,33 @@
|
|||
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)
|
||||
|
|
|
|||
|
|
@ -19,6 +19,7 @@
|
|||
;;; 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)
|
||||
|
|
@ -26,10 +27,13 @@
|
|||
#: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
|
||||
|
|
@ -44,6 +48,61 @@
|
|||
|
||||
(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
|
||||
;;;
|
||||
|
|
|
|||
|
|
@ -19,28 +19,27 @@
|
|||
;;; 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))
|
||||
|
|
@ -64,31 +63,125 @@
|
|||
(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 (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))))))))
|
||||
|
||||
(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)))))
|
||||
;; 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)
|
||||
|
|
@ -97,4 +190,14 @@
|
|||
(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)
|
||||
" | "))))))
|
||||
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue