mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-29 19:30:36 +02:00
Code Activity

psyntax: Pass source vectors to tree-il constructors.

Browse source 
Avoiding systematic conversion from source vectors to property alists
saves 20% on the final heap size of a process doing:

  (compile-file FILE #:optimization-level 1)

where FILE is large.

* module/language/tree-il.scm (tree-il-src/ensure-alist): New procedure
with setter.  Export as 'tree-il-src'.
* module/ice-9/psyntax.scm (build-void, build-call)
(build-conditional, build-lexical-reference, build-lexical-assignment)
(build-global-reference, build-global-assignment)
(build-global-definition, build-simple-lambda, build-case-lambda)
(build-lambda-case, build-primcall, build-primref)
(build-data, build-sequence, build-let, build-named-let)
(build-letrec, expand-body): Remove (sourcev->alist src) calls.
* module/ice-9/psyntax-pp.scm: Regenerate.
* module/language/tree-il/analyze.scm (shadowed-toplevel-analysis): Use
'tree-il-src' instead of accessing the 'src' slot directly.
* module/system/vm/assembler.scm (link-debug): Adjust so PC can be
followed by a vector or an alist.
This commit is contained in:
Ludovic Courtès 2022-02-06 17:44:51 +01:00
parent d656176f06
commit de1ac71850
5 changed files with 105 additions and 116 deletions
Download patch file Download diff file Expand all files Collapse all files

136
module/ice-9/psyntax-pp.scm
View file

@ -146,24 +146,19 @@
(let ((meta (lambda-meta val))) (let ((meta (lambda-meta val)))
(if (not (assq 'name meta)) (if (not (assq 'name meta))
(set-lambda-meta! val (acons 'name name meta))))))) (set-lambda-meta! val (acons 'name name meta)))))))
(build-void (lambda (sourcev) (make-void (sourcev->alist sourcev)))) (build-void (lambda (sourcev) (make-void sourcev)))
(build-call (build-call
(lambda (sourcev fun-exp arg-exps) (lambda (sourcev fun-exp arg-exps)
(make-call (sourcev->alist sourcev) fun-exp arg-exps))) (make-call sourcev fun-exp arg-exps)))
(build-conditional (build-conditional
(lambda (sourcev test-exp then-exp else-exp) (lambda (sourcev test-exp then-exp else-exp)
(make-conditional (make-conditional sourcev test-exp then-exp else-exp)))
(sourcev->alist sourcev)
test-exp
then-exp
else-exp)))
(build-lexical-reference (build-lexical-reference
(lambda (type sourcev name var) (lambda (type sourcev name var) (make-lexical-ref sourcev name var)))
(make-lexical-ref (sourcev->alist sourcev) name var)))
(build-lexical-assignment (build-lexical-assignment
(lambda (sourcev name var exp) (lambda (sourcev name var exp)
(maybe-name-value! name exp) (maybe-name-value! name exp)
(make-lexical-set (sourcev->alist sourcev) name var exp))) (make-lexical-set sourcev name var exp)))
(analyze-variable (analyze-variable
(lambda (mod var modref-cont bare-cont) (lambda (mod var modref-cont bare-cont)
(if (not mod) (if (not mod)
@ -189,10 +184,8 @@
(analyze-variable (analyze-variable
mod mod
var var
(lambda (mod var public?) (lambda (mod var public?) (make-module-ref sourcev mod var public?))
(make-module-ref (sourcev->alist sourcev) mod var public?)) (lambda (mod var) (make-toplevel-ref sourcev mod var)))))
(lambda (mod var)
(make-toplevel-ref (sourcev->alist sourcev) mod var)))))
(build-global-assignment (build-global-assignment
(lambda (sourcev var exp mod) (lambda (sourcev var exp mod)
(maybe-name-value! var exp) (maybe-name-value! var exp)
@ -200,57 +193,36 @@
mod mod
var var
(lambda (mod var public?) (lambda (mod var public?)
(make-module-set (sourcev->alist sourcev) mod var public? exp)) (make-module-set sourcev mod var public? exp))
(lambda (mod var) (lambda (mod var) (make-toplevel-set sourcev mod var exp)))))
(make-toplevel-set (sourcev->alist sourcev) mod var exp)))))
(build-global-definition (build-global-definition
(lambda (sourcev mod var exp) (lambda (sourcev mod var exp)
(maybe-name-value! var exp) (maybe-name-value! var exp)
(make-toplevel-define (make-toplevel-define sourcev (and mod (cdr mod)) var exp)))
(sourcev->alist sourcev)
(and mod (cdr mod))
var
exp)))
(build-simple-lambda (build-simple-lambda
(lambda (src req rest vars meta exp) (lambda (src req rest vars meta exp)
(make-lambda (make-lambda
(sourcev->alist src) src
meta meta
(make-lambda-case src req #f rest #f '() vars exp #f)))) (make-lambda-case src req #f rest #f '() vars exp #f))))
(build-case-lambda (build-case-lambda
(lambda (src meta body) (make-lambda (sourcev->alist src) meta body))) (lambda (src meta body) (make-lambda src meta body)))
(build-lambda-case (build-lambda-case
(lambda (src req opt rest kw inits vars body else-case) (lambda (src req opt rest kw inits vars body else-case)
(make-lambda-case (make-lambda-case src req opt rest kw inits vars body else-case)))
(sourcev->alist src)
req
opt
rest
kw
inits
vars
body
else-case)))
(build-primcall (build-primcall
(lambda (src name args) (lambda (src name args) (make-primcall src name args)))
(make-primcall (sourcev->alist src) name args))) (build-primref (lambda (src name) (make-primitive-ref src name)))
(build-primref (build-data (lambda (src exp) (make-const src exp)))
(lambda (src name) (make-primitive-ref (sourcev->alist src) name)))
(build-data (lambda (src exp) (make-const (sourcev->alist src) exp)))
(build-sequence (build-sequence
(lambda (src exps) (lambda (src exps)
(if (null? (cdr exps)) (if (null? (cdr exps))
(car exps) (car exps)
(make-seq (make-seq src (car exps) (build-sequence #f (cdr exps))))))
(sourcev->alist src)
(car exps)
(build-sequence #f (cdr exps))))))
(build-let (build-let
(lambda (src ids vars val-exps body-exp) (lambda (src ids vars val-exps body-exp)
(for-each maybe-name-value! ids val-exps) (for-each maybe-name-value! ids val-exps)
(if (null? vars) (if (null? vars) body-exp (make-let src ids vars val-exps body-exp))))
body-exp
(make-let (sourcev->alist src) ids vars val-exps body-exp))))
(build-named-let (build-named-let
(lambda (src ids vars val-exps body-exp) (lambda (src ids vars val-exps body-exp)
(let ((f (car vars)) (f-name (car ids)) (vars (cdr vars)) (ids (cdr ids))) (let ((f (car vars)) (f-name (car ids)) (vars (cdr vars)) (ids (cdr ids)))
@ -258,7 +230,7 @@
(maybe-name-value! f-name proc) (maybe-name-value! f-name proc)
(for-each maybe-name-value! ids val-exps) (for-each maybe-name-value! ids val-exps)
(make-letrec (make-letrec
(sourcev->alist src) src
#f #f
(list f-name) (list f-name)
(list f) (list f)
@ -270,13 +242,7 @@
body-exp body-exp
(begin (begin
(for-each maybe-name-value! ids val-exps) (for-each maybe-name-value! ids val-exps)
(make-letrec (make-letrec src in-order? ids vars val-exps body-exp)))))
(sourcev->alist src)
in-order?
ids
vars
val-exps
body-exp)))))
(source-annotation (lambda (x) (and (syntax? x) (syntax-sourcev x)))) (source-annotation (lambda (x) (and (syntax? x) (syntax-sourcev x))))
(extend-env (extend-env
(lambda (labels bindings r) (lambda (labels bindings r)
@ -1075,15 +1041,13 @@
(lp (cdr var-ids) (lp (cdr var-ids)
(cdr vars) (cdr vars)
(cdr vals) (cdr vals)
(make-seq (sourcev->alist src) ((car vals)) tail))) (make-seq src ((car vals)) tail)))
(else (else
(let ((var-ids (let ((var-ids
(map (lambda (id) (if id (syntax->datum id) '_)) (reverse var-ids))) (map (lambda (id) (if id (syntax->datum id) '_)) (reverse var-ids)))
(vars (map (lambda (var) (or var (gen-label))) (reverse vars))) (vars (map (lambda (var) (or var (gen-label))) (reverse vars)))
(vals (map (lambda (expand-expr id) (vals (map (lambda (expand-expr id)
(if id (if id (expand-expr) (make-seq src (expand-expr) (build-void src))))
(expand-expr)
(make-seq (sourcev->alist src) (expand-expr) (build-void src))))
(reverse vals) (reverse vals)
(reverse var-ids)))) (reverse var-ids))))
(build-letrec src #t var-ids vars vals tail))))))) (build-letrec src #t var-ids vars vals tail)))))))
@ -1608,11 +1572,11 @@
s s
mod mod
get-formals get-formals
(map (lambda (tmp-680b775fb37a463-1 (map (lambda (tmp-680b775fb37a463-1061
tmp-680b775fb37a463 tmp-680b775fb37a463-1060
tmp-680b775fb37a463-105f) tmp-680b775fb37a463-105f)
(cons tmp-680b775fb37a463-105f (cons tmp-680b775fb37a463-105f
(cons tmp-680b775fb37a463 tmp-680b775fb37a463-1))) (cons tmp-680b775fb37a463-1060 tmp-680b775fb37a463-1061)))
e2* e2*
e1* e1*
args*))) args*)))
@ -1964,8 +1928,10 @@
(apply (lambda (args e1 e2) (apply (lambda (args e1 e2)
(build-it (build-it
'() '()
(map (lambda (tmp-680b775fb37a463-68b tmp-680b775fb37a463-68a tmp-680b775fb37a463) (map (lambda (tmp-680b775fb37a463-68b
(cons tmp-680b775fb37a463 tmp-680b775fb37a463-68a
tmp-680b775fb37a463-689)
(cons tmp-680b775fb37a463-689
(cons tmp-680b775fb37a463-68a tmp-680b775fb37a463-68b))) (cons tmp-680b775fb37a463-68a tmp-680b775fb37a463-68b)))
e2 e2
e1 e1
@ -2918,9 +2884,11 @@
#f #f
k k
'() '()
(map (lambda (tmp-680b775fb37a463-1 tmp-680b775fb37a463 tmp-680b775fb37a463-117f) (map (lambda (tmp-680b775fb37a463-1181
(list (cons tmp-680b775fb37a463-117f tmp-680b775fb37a463) tmp-680b775fb37a463-1180
tmp-680b775fb37a463-1)) tmp-680b775fb37a463-117f)
(list (cons tmp-680b775fb37a463-117f tmp-680b775fb37a463-1180)
tmp-680b775fb37a463-1181))
template template
pattern pattern
keyword))) keyword)))
@ -2936,8 +2904,10 @@
#f #f
k k
(list docstring) (list docstring)
(map (lambda (tmp-680b775fb37a463-119a tmp-680b775fb37a463-1 tmp-680b775fb37a463) (map (lambda (tmp-680b775fb37a463-119a
(list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1) tmp-680b775fb37a463-1199
tmp-680b775fb37a463-1198)
(list (cons tmp-680b775fb37a463-1198 tmp-680b775fb37a463-1199)
tmp-680b775fb37a463-119a)) tmp-680b775fb37a463-119a))
template template
pattern pattern
@ -3125,8 +3095,8 @@
(apply (lambda (p) (apply (lambda (p)
(if (= lev 0) (if (= lev 0)
(quasilist* (quasilist*
(map (lambda (tmp-680b775fb37a463) (map (lambda (tmp-680b775fb37a463-1282)
(list "value" tmp-680b775fb37a463)) (list "value" tmp-680b775fb37a463-1282))
p) p)
(quasi q lev)) (quasi q lev))
(quasicons (quasicons
@ -3149,8 +3119,8 @@
(apply (lambda (p) (apply (lambda (p)
(if (= lev 0) (if (= lev 0)
(quasiappend (quasiappend
(map (lambda (tmp-680b775fb37a463) (map (lambda (tmp-680b775fb37a463-1287)
(list "value" tmp-680b775fb37a463)) (list "value" tmp-680b775fb37a463-1287))
p) p)
(quasi q lev)) (quasi q lev))
(quasicons (quasicons
@ -3318,8 +3288,8 @@
(apply (lambda (y z) (f z (lambda (ls) (k (append y ls))))) tmp-1) (apply (lambda (y z) (f z (lambda (ls) (k (append y ls))))) tmp-1)
(let ((else tmp)) (let ((else tmp))
(let ((tmp x)) (let ((tmp x))
(let ((t-680b775fb37a463 tmp)) (let ((t-680b775fb37a463-1306 tmp))
(list "list->vector" t-680b775fb37a463))))))))))))))))) (list "list->vector" t-680b775fb37a463-1306)))))))))))))))))
(emit (lambda (x) (emit (lambda (x)
(let ((tmp x)) (let ((tmp x))
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") any)))) (let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") any))))
@ -3332,9 +3302,9 @@
(let ((tmp-1 (map emit x))) (let ((tmp-1 (map emit x)))
(let ((tmp ($sc-dispatch tmp-1 'each-any))) (let ((tmp ($sc-dispatch tmp-1 'each-any)))
(if tmp (if tmp
(apply (lambda (t-680b775fb37a463) (apply (lambda (t-680b775fb37a463-1315)
(cons (make-syntax 'list '((top)) '(hygiene guile)) (cons (make-syntax 'list '((top)) '(hygiene guile))
t-680b775fb37a463)) t-680b775fb37a463-1315))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3350,10 +3320,10 @@
(let ((tmp-1 (list (emit (car x*)) (f (cdr x*))))) (let ((tmp-1 (list (emit (car x*)) (f (cdr x*)))))
(let ((tmp ($sc-dispatch tmp-1 '(any any)))) (let ((tmp ($sc-dispatch tmp-1 '(any any))))
(if tmp (if tmp
(apply (lambda (t-680b775fb37a463-1 t-680b775fb37a463) (apply (lambda (t-680b775fb37a463-1329 t-680b775fb37a463-1328)
(list (make-syntax 'cons '((top)) '(hygiene guile)) (list (make-syntax 'cons '((top)) '(hygiene guile))
t-680b775fb37a463-1 t-680b775fb37a463-1329
t-680b775fb37a463)) t-680b775fb37a463-1328))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3366,9 +3336,9 @@
(let ((tmp-1 (map emit x))) (let ((tmp-1 (map emit x)))
(let ((tmp ($sc-dispatch tmp-1 'each-any))) (let ((tmp ($sc-dispatch tmp-1 'each-any)))
(if tmp (if tmp
(apply (lambda (t-680b775fb37a463) (apply (lambda (t-680b775fb37a463-1335)
(cons (make-syntax 'append '((top)) '(hygiene guile)) (cons (make-syntax 'append '((top)) '(hygiene guile))
t-680b775fb37a463)) t-680b775fb37a463-1335))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3381,9 +3351,9 @@
(let ((tmp-1 (map emit x))) (let ((tmp-1 (map emit x)))
(let ((tmp ($sc-dispatch tmp-1 'each-any))) (let ((tmp ($sc-dispatch tmp-1 'each-any)))
(if tmp (if tmp
(apply (lambda (t-680b775fb37a463) (apply (lambda (t-680b775fb37a463-1341)
(cons (make-syntax 'vector '((top)) '(hygiene guile)) (cons (make-syntax 'vector '((top)) '(hygiene guile))
t-680b775fb37a463)) t-680b775fb37a463-1341))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f

44
module/ice-9/psyntax.scm
View file

@ -287,24 +287,24 @@
;; output constructors ;; output constructors
(define build-void (define build-void
(lambda (sourcev) (lambda (sourcev)
(make-void (sourcev->alist sourcev)))) (make-void sourcev)))
(define build-call (define build-call
(lambda (sourcev fun-exp arg-exps) (lambda (sourcev fun-exp arg-exps)
(make-call (sourcev->alist sourcev) fun-exp arg-exps))) (make-call sourcev fun-exp arg-exps)))
(define build-conditional (define build-conditional
(lambda (sourcev test-exp then-exp else-exp) (lambda (sourcev test-exp then-exp else-exp)
(make-conditional (sourcev->alist sourcev) test-exp then-exp else-exp))) (make-conditional sourcev test-exp then-exp else-exp)))
(define build-lexical-reference (define build-lexical-reference
(lambda (type sourcev name var) (lambda (type sourcev name var)
(make-lexical-ref (sourcev->alist sourcev) name var))) (make-lexical-ref sourcev name var)))
(define build-lexical-assignment (define build-lexical-assignment
(lambda (sourcev name var exp) (lambda (sourcev name var exp)
(maybe-name-value! name exp) (maybe-name-value! name exp)
(make-lexical-set (sourcev->alist sourcev) name var exp))) (make-lexical-set sourcev name var exp)))
(define (analyze-variable mod var modref-cont bare-cont) (define (analyze-variable mod var modref-cont bare-cont)
(if (not mod) (if (not mod)
@ -330,9 +330,9 @@
(analyze-variable (analyze-variable
mod var mod var
(lambda (mod var public?) (lambda (mod var public?)
(make-module-ref (sourcev->alist sourcev) mod var public?)) (make-module-ref sourcev mod var public?))
(lambda (mod var) (lambda (mod var)
(make-toplevel-ref (sourcev->alist sourcev) mod var))))) (make-toplevel-ref sourcev mod var)))))
(define build-global-assignment (define build-global-assignment
(lambda (sourcev var exp mod) (lambda (sourcev var exp mod)
@ -340,18 +340,18 @@
(analyze-variable (analyze-variable
mod var mod var
(lambda (mod var public?) (lambda (mod var public?)
(make-module-set (sourcev->alist sourcev) mod var public? exp)) (make-module-set sourcev mod var public? exp))
(lambda (mod var) (lambda (mod var)
(make-toplevel-set (sourcev->alist sourcev) mod var exp))))) (make-toplevel-set sourcev mod var exp)))))
(define build-global-definition (define build-global-definition
(lambda (sourcev mod var exp) (lambda (sourcev mod var exp)
(maybe-name-value! var exp) (maybe-name-value! var exp)
(make-toplevel-define (sourcev->alist sourcev) (and mod (cdr mod)) var exp))) (make-toplevel-define sourcev (and mod (cdr mod)) var exp)))
(define build-simple-lambda (define build-simple-lambda
(lambda (src req rest vars meta exp) (lambda (src req rest vars meta exp)
(make-lambda (sourcev->alist src) (make-lambda src
meta meta
;; hah, a case in which kwargs would be nice. ;; hah, a case in which kwargs would be nice.
(make-lambda-case (make-lambda-case
@ -360,7 +360,7 @@
(define build-case-lambda (define build-case-lambda
(lambda (src meta body) (lambda (src meta body)
(make-lambda (sourcev->alist src) meta body))) (make-lambda src meta body)))
(define build-lambda-case (define build-lambda-case
;; req := (name ...) ;; req := (name ...)
@ -374,31 +374,31 @@
;; the body of a lambda: anything, already expanded ;; the body of a lambda: anything, already expanded
;; else: lambda-case | #f ;; else: lambda-case | #f
(lambda (src req opt rest kw inits vars body else-case) (lambda (src req opt rest kw inits vars body else-case)
(make-lambda-case (sourcev->alist src) req opt rest kw inits vars body else-case))) (make-lambda-case src req opt rest kw inits vars body else-case)))
(define build-primcall (define build-primcall
(lambda (src name args) (lambda (src name args)
(make-primcall (sourcev->alist src) name args))) (make-primcall src name args)))
(define build-primref (define build-primref
(lambda (src name) (lambda (src name)
(make-primitive-ref (sourcev->alist src) name))) (make-primitive-ref src name)))
(define (build-data src exp) (define (build-data src exp)
(make-const (sourcev->alist src) exp)) (make-const src exp))
(define build-sequence (define build-sequence
(lambda (src exps) (lambda (src exps)
(if (null? (cdr exps)) (if (null? (cdr exps))
(car exps) (car exps)
(make-seq (sourcev->alist src) (car exps) (build-sequence #f (cdr exps)))))) (make-seq src (car exps) (build-sequence #f (cdr exps))))))
(define build-let (define build-let
(lambda (src ids vars val-exps body-exp) (lambda (src ids vars val-exps body-exp)
(for-each maybe-name-value! ids val-exps) (for-each maybe-name-value! ids val-exps)
(if (null? vars) (if (null? vars)
body-exp body-exp
(make-let (sourcev->alist src) ids vars val-exps body-exp)))) (make-let src ids vars val-exps body-exp))))
(define build-named-let (define build-named-let
(lambda (src ids vars val-exps body-exp) (lambda (src ids vars val-exps body-exp)
@ -410,7 +410,7 @@
(maybe-name-value! f-name proc) (maybe-name-value! f-name proc)
(for-each maybe-name-value! ids val-exps) (for-each maybe-name-value! ids val-exps)
(make-letrec (make-letrec
(sourcev->alist src) #f src #f
(list f-name) (list f) (list proc) (list f-name) (list f) (list proc)
(build-call src (build-lexical-reference 'fun src f-name f) (build-call src (build-lexical-reference 'fun src f-name f)
val-exps)))))) val-exps))))))
@ -421,7 +421,7 @@
body-exp body-exp
(begin (begin
(for-each maybe-name-value! ids val-exps) (for-each maybe-name-value! ids val-exps)
(make-letrec (sourcev->alist src) in-order? ids vars val-exps body-exp))))) (make-letrec src in-order? ids vars val-exps body-exp)))))
(define-syntax-rule (build-lexical-var src id) (define-syntax-rule (build-lexical-var src id)
@ -1616,7 +1616,7 @@
((null? var-ids) tail) ((null? var-ids) tail)
((not (car var-ids)) ((not (car var-ids))
(lp (cdr var-ids) (cdr vars) (cdr vals) (lp (cdr var-ids) (cdr vars) (cdr vals)
(make-seq (sourcev->alist src) ((car vals)) tail))) (make-seq src ((car vals)) tail)))
(else (else
(let ((var-ids (map (lambda (id) (let ((var-ids (map (lambda (id)
(if id (syntax->datum id) '_)) (if id (syntax->datum id) '_))
@ -1626,7 +1626,7 @@
(vals (map (lambda (expand-expr id) (vals (map (lambda (expand-expr id)
(if id (if id
(expand-expr) (expand-expr)
(make-seq (sourcev->alist src) (make-seq src
(expand-expr) (expand-expr)
(build-void src)))) (build-void src))))
(reverse vals) (reverse var-ids)))) (reverse vals) (reverse var-ids))))

19
module/language/tree-il.scm
View file

@ -1,4 +1,4 @@
;;;; Copyright (C) 2009-2014, 2017-2020 Free Software Foundation, Inc. ;;;; Copyright (C) 2009-2014, 2017-2020, 2022 Free Software Foundation, Inc.
;;;; ;;;;
;;;; This library is free software; you can redistribute it and/or ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
@ -21,8 +21,7 @@
#:use-module (srfi srfi-11) #:use-module (srfi srfi-11)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (system base syntax) #:use-module (system base syntax)
#:export (tree-il-src #:export ((tree-il-src/ensure-alist . tree-il-src)
<void> void? make-void void-src <void> void? make-void void-src
<const> const? make-const const-src const-exp <const> const? make-const const-src const-exp
<primitive-ref> primitive-ref? make-primitive-ref primitive-ref-src primitive-ref-name <primitive-ref> primitive-ref? make-primitive-ref primitive-ref-src primitive-ref-name
@ -136,6 +135,20 @@
(<prompt> escape-only? tag body handler) (<prompt> escape-only? tag body handler)
(<abort> tag args tail)) (<abort> tag args tail))
(define tree-il-src/ensure-alist
(make-procedure-with-setter
(lambda (tree)
"Return the source location of TREE as a source property alist."
;; psyntax gives us "source vectors"; convert them lazily to reduce
;; allocations.
(match (tree-il-src tree)
(#(file line column)
`((filename . ,file) (line . ,line) (column . ,column)))
(src
src)))
(lambda (tree src)
(set! (tree-il-src tree) src))))
;; A helper. ;; A helper.

8
module/language/tree-il/analyze.scm
View file

@ -1,6 +1,6 @@
;;; Diagnostic warnings for Tree-IL ;;; Diagnostic warnings for Tree-IL
;; Copyright (C) 2001,2008-2014,2016,2018-2021 Free Software Foundation, Inc. ;; Copyright (C) 2001,2008-2014,2016,2018-2022 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
@ -346,11 +346,11 @@ given `tree-il' element."
(lambda (x defs env locs) (lambda (x defs env locs)
;; Going down into X. ;; Going down into X.
(record-case x (record-case x
((<toplevel-define> name src) ((<toplevel-define> name)
(match (vhash-assq name defs) (match (vhash-assq name defs)
((_ . previous-definition) ((_ . previous-definition)
(warning 'shadowed-toplevel src name (warning 'shadowed-toplevel (tree-il-src x) name
(toplevel-define-src previous-definition)) (tree-il-src previous-definition))
defs) defs)
(#f (#f
(vhash-consq name x defs)))) (vhash-consq name x defs))))

14
module/system/vm/assembler.scm
View file

@ -2821,10 +2821,16 @@ procedure with label @var{rw-init}. @var{rw-init} may be false. If
(let lp ((sources (asm-sources asm)) (out '())) (let lp ((sources (asm-sources asm)) (out '()))
(match sources (match sources
(((pc . s) . sources) (((pc . location) . sources)
(let ((file (assq-ref s 'filename)) (let-values (((file line col)
(line (assq-ref s 'line)) ;; Usually CPS records contain a "source
(col (assq-ref s 'column))) ;; vector" coming from tree-il, but some might
;; contain a source property alist.
(match location
(#(file line col) (values file line col))
(lst (values (assq-ref lst 'filename)
(assq-ref lst 'line)
(assq-ref lst 'column))))))
(lp sources (lp sources
;; Guile line and column numbers are 0-indexed, but ;; Guile line and column numbers are 0-indexed, but
;; they are 1-indexed for DWARF. ;; they are 1-indexed for DWARF.