mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-11 14:21:10 +02:00
Code Activity

fix recording of source locations

Browse source 
* module/language/scheme/translate.scm (translate, trans)
  (make-pmatch-transformers): When recursing into subexpressions, get the
  appropriate source location information.
  (location): Include the source filename in the location information.

* module/system/il/compile.scm (codegen): Record source locations in more
  cases. (This information ends up being part of the procedure metadata,
  not the actual codepath.)

* module/system/il/glil.scm (unparse): Don't destructure the source
  locations (it's a vector now).
This commit is contained in:
Andy Wingo 2008-08-03 14:03:47 +02:00
parent 427d4a0c51
commit 96969dc1d6
3 changed files with 43 additions and 40 deletions
Download patch file Download diff file Expand all files Collapse all files

10
module/language/scheme/translate.scm
View file

@ -33,7 +33,7 @@
(define (translate x e) (define (translate x e)
(call-with-ghil-environment (make-ghil-mod e) '() (call-with-ghil-environment (make-ghil-mod e) '()
(lambda (env vars) (lambda (env vars)
(make-ghil-lambda env #f vars #f (trans env #f x))))) (make-ghil-lambda env #f vars #f (trans env (location x) x)))))
;;; ;;;
@ -80,7 +80,7 @@
(else #f)))) (else #f))))
(define (trans e l x) (define (trans e l x)
(define (retrans x) (trans e l x)) (define (retrans x) (trans e (location x) x))
(cond ((pair? x) (cond ((pair? x)
(let ((head (car x)) (tail (cdr x))) (let ((head (car x)) (tail (cdr x)))
(cond (cond
@ -120,7 +120,7 @@
(clauses (cdr clause))) (clauses (cdr clause)))
`(cons ',sym `(cons ',sym
(lambda (,env ,loc ,exp) (lambda (,env ,loc ,exp)
(define (,retranslate x) (trans ,env ,loc x)) (define (,retranslate x) (trans ,env (location x) x))
(pmatch (cdr ,exp) (pmatch (cdr ,exp)
,@clauses ,@clauses
(else (syntax-error ,loc (format #f "bad ~A" ',sym) ,exp))))))) (else (syntax-error ,loc (format #f "bad ~A" ',sym) ,exp)))))))
@ -340,4 +340,6 @@
(and (pair? x) (and (pair? x)
(let ((props (source-properties x))) (let ((props (source-properties x)))
(and (not (null? props)) (and (not (null? props))
(cons (assq-ref props 'line) (assq-ref props 'column)))))) (vector (assq-ref props 'line)
(assq-ref props 'column)
(assq-ref props 'filename))))))

71
module/system/il/compile.scm
View file

@ -106,11 +106,13 @@
(define (codegen ghil) (define (codegen ghil)
(let ((stack '())) (let ((stack '()))
(define (push-code! code) (define (push-code! loc code)
(if loc (set! stack (cons (make-glil-source loc) stack)))
(set! stack (cons code stack))) (set! stack (cons code stack)))
(define (push-bindings! vars) (define (push-bindings! loc vars)
(if (not (null? vars)) (if (not (null? vars))
(push-code! (push-code!
loc
(make-glil-bind (make-glil-bind
(map list (map list
(map ghil-var-name vars) (map ghil-var-name vars)
@ -118,13 +120,12 @@
(map ghil-var-index vars)))))) (map ghil-var-index vars))))))
(define (comp tree tail drop) (define (comp tree tail drop)
(define (push-label! label) (define (push-label! label)
(push-code! (make-glil-label label))) (push-code! #f (make-glil-label label)))
(define (push-branch! inst label) (define (push-branch! loc inst label)
(push-code! (make-glil-branch inst label))) (push-code! loc (make-glil-branch inst label)))
(define (push-call! loc inst args) (define (push-call! loc inst args)
(for-each comp-push args) (for-each comp-push args)
(push-code! (make-glil-call inst (length args))) (push-code! loc (make-glil-call inst (length args))))
(push-code! (make-glil-source loc)))
;; possible tail position ;; possible tail position
(define (comp-tail tree) (comp tree tail drop)) (define (comp-tail tree) (comp tree tail drop))
;; push the result ;; push the result
@ -133,20 +134,20 @@
(define (comp-drop tree) (comp tree #f #t)) (define (comp-drop tree) (comp tree #f #t))
;; drop the result if unnecessary ;; drop the result if unnecessary
(define (maybe-drop) (define (maybe-drop)
(if drop (push-code! *ia-drop*))) (if drop (push-code! #f *ia-drop*)))
;; return here if necessary ;; return here if necessary
(define (maybe-return) (define (maybe-return)
(if tail (push-code! *ia-return*))) (if tail (push-code! #f *ia-return*)))
;; return this code if necessary ;; return this code if necessary
(define (return-code! code) (define (return-code! loc code)
(if (not drop) (push-code! code)) (if (not drop) (push-code! loc code))
(maybe-return)) (maybe-return))
;; return void if necessary ;; return void if necessary
(define (return-void!) (define (return-void!)
(return-code! *ia-void*)) (return-code! #f *ia-void*))
;; return object if necessary ;; return object if necessary
(define (return-object! obj) (define (return-object! loc obj)
(return-code! (make-glil-const #:obj obj))) (return-code! loc (make-glil-const #:obj obj)))
;; ;;
;; dispatch ;; dispatch
(record-case tree (record-case tree
@ -154,7 +155,7 @@
(return-void!)) (return-void!))
((<ghil-quote> env loc obj) ((<ghil-quote> env loc obj)
(return-object! obj)) (return-object! loc obj))
((<ghil-quasiquote> env loc exp) ((<ghil-quasiquote> env loc exp)
(let loop ((x exp)) (let loop ((x exp))
@ -166,7 +167,7 @@
((pair? x) ((pair? x)
(loop (car x)) (loop (car x))
(loop (cdr x)) (loop (cdr x))
(push-code! (make-glil-call 'cons 2))) (push-code! #f (make-glil-call 'cons 2)))
((record? x) ((record? x)
(record-case x (record-case x
((<ghil-unquote> env loc exp) ((<ghil-unquote> env loc exp)
@ -175,21 +176,21 @@
(comp-push exp) (comp-push exp)
(push-call! #f 'list-break '())))) (push-call! #f 'list-break '()))))
(else (else
(push-code! (make-glil-const #:obj x))))) (push-code! #f (make-glil-const #:obj x)))))
(maybe-drop) (maybe-drop)
(maybe-return)) (maybe-return))
((<ghil-ref> env loc var) ((<ghil-ref> env loc var)
(return-code! (make-glil-var 'ref env var))) (return-code! loc (make-glil-var 'ref env var)))
((<ghil-set> env loc var val) ((<ghil-set> env loc var val)
(comp-push val) (comp-push val)
(push-code! (make-glil-var 'set env var)) (push-code! loc (make-glil-var 'set env var))
(return-void!)) (return-void!))
((<ghil-define> env loc var val) ((<ghil-define> env loc var val)
(comp-push val) (comp-push val)
(push-code! (make-glil-var 'define env var)) (push-code! loc (make-glil-var 'define env var))
(return-void!)) (return-void!))
((<ghil-if> env loc test then else) ((<ghil-if> env loc test then else)
@ -201,9 +202,9 @@
;; L2: ;; L2:
(let ((L1 (make-label)) (L2 (make-label))) (let ((L1 (make-label)) (L2 (make-label)))
(comp-push test) (comp-push test)
(push-branch! 'br-if-not L1) (push-branch! loc 'br-if-not L1)
(comp-tail then) (comp-tail then)
(if (not tail) (push-branch! 'br L2)) (if (not tail) (push-branch! #f 'br L2))
(push-label! L1) (push-label! L1)
(comp-tail else) (comp-tail else)
(if (not tail) (push-label! L2)))) (if (not tail) (push-label! L2))))
@ -218,18 +219,18 @@
;; L2: ;; L2:
(let ((L1 (make-label)) (L2 (make-label))) (let ((L1 (make-label)) (L2 (make-label)))
(if (null? exps) (if (null? exps)
(return-object! #t) (return-object! loc #t)
(do ((exps exps (cdr exps))) (do ((exps exps (cdr exps)))
((null? (cdr exps)) ((null? (cdr exps))
(comp-tail (car exps)) (comp-tail (car exps))
(if (not tail) (push-branch! 'br L2)) (if (not tail) (push-branch! #f 'br L2))
(push-label! L1) (push-label! L1)
(return-object! #f) (return-object! #f #f)
(if (not tail) (push-label! L2)) (if (not tail) (push-label! L2))
(maybe-drop) (maybe-drop)
(maybe-return)) (maybe-return))
(comp-push (car exps)) (comp-push (car exps))
(push-branch! 'br-if-not L1))))) (push-branch! #f 'br-if-not L1)))))
((<ghil-or> env loc exps) ((<ghil-or> env loc exps)
;; EXP ;; EXP
@ -241,7 +242,7 @@
;; L1: ;; L1:
(let ((L1 (make-label))) (let ((L1 (make-label)))
(if (null? exps) (if (null? exps)
(return-object! #f) (return-object! loc #f)
(do ((exps exps (cdr exps))) (do ((exps exps (cdr exps)))
((null? (cdr exps)) ((null? (cdr exps))
(comp-tail (car exps)) (comp-tail (car exps))
@ -250,7 +251,7 @@
(maybe-return)) (maybe-return))
(comp-push (car exps)) (comp-push (car exps))
(push-call! #f 'dup '()) (push-call! #f 'dup '())
(push-branch! 'br-if L1) (push-branch! #f 'br-if L1)
(push-call! #f 'drop '()))))) (push-call! #f 'drop '())))))
((<ghil-begin> env loc exps) ((<ghil-begin> env loc exps)
@ -268,14 +269,14 @@
;; (set VARS)... ;; (set VARS)...
;; BODY ;; BODY
(for-each comp-push vals) (for-each comp-push vals)
(push-bindings! vars) (push-bindings! loc vars)
(for-each (lambda (var) (push-code! (make-glil-var 'set env var))) (for-each (lambda (var) (push-code! #f (make-glil-var 'set env var)))
(reverse vars)) (reverse vars))
(comp-tail body) (comp-tail body)
(push-code! (make-glil-unbind))) (push-code! #f (make-glil-unbind)))
((<ghil-lambda> env loc vars rest body) ((<ghil-lambda> env loc vars rest body)
(return-code! (codegen tree))) (return-code! loc (codegen tree)))
((<ghil-inline> env loc inline args) ((<ghil-inline> env loc inline args)
;; ARGS... ;; ARGS...
@ -303,7 +304,7 @@
(finalize-index! locs) (finalize-index! locs)
(finalize-index! exts) (finalize-index! exts)
;; meta bindings ;; meta bindings
(push-bindings! vars) (push-bindings! #f vars)
;; export arguments ;; export arguments
(do ((n 0 (1+ n)) (do ((n 0 (1+ n))
(l vars (cdr l))) (l vars (cdr l)))
@ -311,8 +312,8 @@
(let ((v (car l))) (let ((v (car l)))
(case (ghil-var-kind v) (case (ghil-var-kind v)
((external) ((external)
(push-code! (make-glil-argument 'ref n)) (push-code! #f (make-glil-argument 'ref n))
(push-code! (make-glil-external 'set 0 (ghil-var-index v))))))) (push-code! #f (make-glil-external 'set 0 (ghil-var-index v)))))))
;; compile body ;; compile body
(comp body #t #f) (comp body #t #f)
;; create GLIL ;; create GLIL

2
module/system/il/glil.scm
View file

@ -172,7 +172,7 @@
,@(map unparse body))) ,@(map unparse body)))
((<glil-bind> vars) `(@bind ,@vars)) ((<glil-bind> vars) `(@bind ,@vars))
((<glil-unbind>) `(@unbind)) ((<glil-unbind>) `(@unbind))
((<glil-source> loc) `(@source ,(car loc) ,(cdr loc))) ((<glil-source> loc) `(@source ,loc))
;; constants ;; constants
((<glil-void>) `(void)) ((<glil-void>) `(void))
((<glil-const> obj) `(const ,obj)) ((<glil-const> obj) `(const ,obj))