From 147f9978bad51368d4283c8ed5ca54e0afc0a205 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 8 Nov 2013 16:31:29 +0100 Subject: [PATCH] Rewrite (system xref) to work with RTL programs * module/system/xref.scm (nested-procedures): New helper. (program-callee-rev-vars): Rewrite using fold-program-code and nested-procedures. (add-sources, forget-sources): Use match instead of pmatch. Use nested-procedures. --- module/system/xref.scm | 143 +++++++++++++++++++---------------------- 1 file changed, 66 insertions(+), 77 deletions(-) diff --git a/module/system/xref.scm b/module/system/xref.scm index b6211d84c..65d0fed5f 100644 --- a/module/system/xref.scm +++ b/module/system/xref.scm @@ -17,9 +17,10 @@ (define-module (system xref) - #:use-module (system base pmatch) #:use-module (system base compile) #:use-module (system vm program) + #:use-module (system vm disassembler) + #:use-module (ice-9 match) #:use-module (srfi srfi-1) #:export (*xref-ignored-modules* procedure-callees @@ -31,59 +32,54 @@ ;;; The cross-reference database: who calls whom. ;;; +(define (nested-procedures prog) + (define (cons-uniq x y) + (if (memq x y) y (cons x y))) + (if (rtl-program? prog) + (reverse + (fold-program-code (lambda (elt out) + (match elt + (('static-ref dst proc) + (if (rtl-program? proc) + (fold cons-uniq + (cons proc out) + (nested-procedures prog)) + out)) + (_ out))) + (list prog) + prog)) + (list prog))) + (define (program-callee-rev-vars prog) (define (cons-uniq x y) (if (memq x y) y (cons x y))) - (cond - ((program-objects prog) - => (lambda (objects) - (let ((n (vector-length objects)) - (progv (make-vector (vector-length objects) #f)) - (asm (decompile (program-objcode prog) #:to 'assembly))) - (pmatch asm - ((load-program ,labels ,len . ,body) - (for-each - (lambda (x) - (pmatch x - ((toplevel-ref ,n) (vector-set! progv n #t)) - ((toplevel-set ,n) (vector-set! progv n #t)))) - body))) - (let lp ((i 0) (out '())) - (cond - ((= i n) out) - ((program? (vector-ref objects i)) - (lp (1+ i) - (fold cons-uniq out - (program-callee-rev-vars (vector-ref objects i))))) - ((vector-ref progv i) - (let ((obj (vector-ref objects i))) - (if (variable? obj) - (lp (1+ i) (cons-uniq obj out)) - ;; otherwise it's an unmemoized binding - (pmatch obj - (,sym (guard (symbol? sym)) - (let ((v (module-variable (or (program-module prog) - the-root-module) - sym))) - (lp (1+ i) (if v (cons-uniq v out) out)))) - ((,mod ,sym ,public?) - ;; hm, hacky. - (let* ((m (nested-ref-module (resolve-module '() #f) - mod)) - (v (and m - (module-variable - (if public? - (module-public-interface m) - m) - sym)))) - (lp (1+ i) - (if v (cons-uniq v out) out)))))))) - (else (lp (1+ i) out))))))) - (else '()))) + (fold (lambda (prog out) + (fold-program-code + (lambda (elt out) + (match elt + (('toplevel-box dst var mod sym bound?) + (let ((var (or var (and mod (module-variable mod sym))))) + (if var + (cons-uniq var out) + out))) + (('module-box dst var public? mod-name sym bound?) + (let ((var (or var + (module-variable (if public? + (resolve-interface mod-name) + (resolve-module mod-name)) + sym)))) + (if var + (cons-uniq var out) + out))) + (_ out))) + out + prog)) + '() + (nested-procedures prog))) (define (procedure-callee-rev-vars proc) (cond - ((program? proc) (program-callee-rev-vars proc)) + ((rtl-program? proc) (program-callee-rev-vars proc)) (else '()))) (define (procedure-callees prog) @@ -186,10 +182,10 @@ pair of the form (module-name . variable-name), " (let ((v (cond ((variable? var) var) ((symbol? var) (module-variable (current-module) var)) (else - (pmatch var - ((,modname . ,sym) + (match var + ((modname . sym) (module-variable (resolve-module modname) sym)) - (else + (_ (error "expected a variable, symbol, or (modname . sym)" var))))))) (untaint-modules) (hashq-ref *callers-db* v '()))) @@ -255,39 +251,32 @@ pair of the form (module-name . variable-name), " sources) ;; Actually add the source entries. (for-each (lambda (source) - (pmatch source - ((,ip ,file ,line . ,col) + (match source + ((ip file line . col) (add-source proc file line db)) - (else (error "unexpected source format" source)))) + (_ (error "unexpected source format" source)))) sources))) ;; Add source entries for nested procedures. (for-each (lambda (obj) - (if (procedure? obj) - (add-sources obj mod-name *closure-sources-db*))) - (or (and (program? proc) - (and=> (program-objects proc) vector->list)) - '())))) + (add-sources obj mod-name *closure-sources-db*)) + (cdr (nested-procedures proc))))) (define (forget-sources proc mod-name db) (let ((mod-table (hash-ref *module-sources-db* mod-name))) - (if mod-table - (begin - ;; Forget source entries. - (for-each (lambda (source) - (pmatch source - ((,ip ,file ,line . ,col) - (forget-source proc file line db)) - (else (error "unexpected source format" source)))) - (hashq-ref mod-table proc '())) - ;; Forget the proc. - (hashq-remove! mod-table proc) - ;; Forget source entries for nested procedures. - (for-each (lambda (obj) - (if (procedure? obj) - (forget-sources obj mod-name *closure-sources-db*))) - (or (and (program? proc) - (and=> (program-objects proc) vector->list)) - '())))))) + (when mod-table + ;; Forget source entries. + (for-each (lambda (source) + (match source + ((ip file line . col) + (forget-source proc file line db)) + (_ (error "unexpected source format" source)))) + (hashq-ref mod-table proc '())) + ;; Forget the proc. + (hashq-remove! mod-table proc) + ;; Forget source entries for nested procedures. + (for-each (lambda (obj) + (forget-sources obj mod-name *closure-sources-db*)) + (cdr (nested-procedures proc)))))) (define (untaint-sources) (define (untaint m)