mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-29 19:30:36 +02:00
psyntax: Pass source vectors to tree-il constructors.
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
parent
d656176f06
commit
de1ac71850
5 changed files with 105 additions and 116 deletions
|
|
@ -146,24 +146,19 @@
|
|||
(let ((meta (lambda-meta val)))
|
||||
(if (not (assq '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
|
||||
(lambda (sourcev fun-exp arg-exps)
|
||||
(make-call (sourcev->alist sourcev) fun-exp arg-exps)))
|
||||
(make-call sourcev fun-exp arg-exps)))
|
||||
(build-conditional
|
||||
(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)))
|
||||
(build-lexical-reference
|
||||
(lambda (type sourcev name var)
|
||||
(make-lexical-ref (sourcev->alist sourcev) name var)))
|
||||
(lambda (type sourcev name var) (make-lexical-ref sourcev name var)))
|
||||
(build-lexical-assignment
|
||||
(lambda (sourcev name var exp)
|
||||
(maybe-name-value! name exp)
|
||||
(make-lexical-set (sourcev->alist sourcev) name var exp)))
|
||||
(make-lexical-set sourcev name var exp)))
|
||||
(analyze-variable
|
||||
(lambda (mod var modref-cont bare-cont)
|
||||
(if (not mod)
|
||||
|
|
@ -189,10 +184,8 @@
|
|||
(analyze-variable
|
||||
mod
|
||||
var
|
||||
(lambda (mod var public?)
|
||||
(make-module-ref (sourcev->alist sourcev) mod var public?))
|
||||
(lambda (mod var)
|
||||
(make-toplevel-ref (sourcev->alist sourcev) mod var)))))
|
||||
(lambda (mod var public?) (make-module-ref sourcev mod var public?))
|
||||
(lambda (mod var) (make-toplevel-ref sourcev mod var)))))
|
||||
(build-global-assignment
|
||||
(lambda (sourcev var exp mod)
|
||||
(maybe-name-value! var exp)
|
||||
|
|
@ -200,57 +193,36 @@
|
|||
mod
|
||||
var
|
||||
(lambda (mod var public?)
|
||||
(make-module-set (sourcev->alist sourcev) mod var public? exp))
|
||||
(lambda (mod var)
|
||||
(make-toplevel-set (sourcev->alist sourcev) mod var exp)))))
|
||||
(make-module-set sourcev mod var public? exp))
|
||||
(lambda (mod var) (make-toplevel-set sourcev mod var exp)))))
|
||||
(build-global-definition
|
||||
(lambda (sourcev mod 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)))
|
||||
(build-simple-lambda
|
||||
(lambda (src req rest vars meta exp)
|
||||
(make-lambda
|
||||
(sourcev->alist src)
|
||||
src
|
||||
meta
|
||||
(make-lambda-case src req #f rest #f '() vars exp #f))))
|
||||
(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
|
||||
(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)))
|
||||
(build-primcall
|
||||
(lambda (src name args)
|
||||
(make-primcall (sourcev->alist src) name args)))
|
||||
(build-primref
|
||||
(lambda (src name) (make-primitive-ref (sourcev->alist src) name)))
|
||||
(build-data (lambda (src exp) (make-const (sourcev->alist src) exp)))
|
||||
(lambda (src name args) (make-primcall src name args)))
|
||||
(build-primref (lambda (src name) (make-primitive-ref src name)))
|
||||
(build-data (lambda (src exp) (make-const src exp)))
|
||||
(build-sequence
|
||||
(lambda (src exps)
|
||||
(if (null? (cdr 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))))))
|
||||
(build-let
|
||||
(lambda (src ids vars val-exps body-exp)
|
||||
(for-each maybe-name-value! ids val-exps)
|
||||
(if (null? vars)
|
||||
body-exp
|
||||
(make-let (sourcev->alist src) ids vars val-exps body-exp))))
|
||||
(if (null? vars) body-exp (make-let src ids vars val-exps body-exp))))
|
||||
(build-named-let
|
||||
(lambda (src ids vars val-exps body-exp)
|
||||
(let ((f (car vars)) (f-name (car ids)) (vars (cdr vars)) (ids (cdr ids)))
|
||||
|
|
@ -258,7 +230,7 @@
|
|||
(maybe-name-value! f-name proc)
|
||||
(for-each maybe-name-value! ids val-exps)
|
||||
(make-letrec
|
||||
(sourcev->alist src)
|
||||
src
|
||||
#f
|
||||
(list f-name)
|
||||
(list f)
|
||||
|
|
@ -270,13 +242,7 @@
|
|||
body-exp
|
||||
(begin
|
||||
(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)))))
|
||||
(source-annotation (lambda (x) (and (syntax? x) (syntax-sourcev x))))
|
||||
(extend-env
|
||||
(lambda (labels bindings r)
|
||||
|
|
@ -1075,15 +1041,13 @@
|
|||
(lp (cdr var-ids)
|
||||
(cdr vars)
|
||||
(cdr vals)
|
||||
(make-seq (sourcev->alist src) ((car vals)) tail)))
|
||||
(make-seq src ((car vals)) tail)))
|
||||
(else
|
||||
(let ((var-ids
|
||||
(map (lambda (id) (if id (syntax->datum id) '_)) (reverse var-ids)))
|
||||
(vars (map (lambda (var) (or var (gen-label))) (reverse vars)))
|
||||
(vals (map (lambda (expand-expr id)
|
||||
(if id
|
||||
(expand-expr)
|
||||
(make-seq (sourcev->alist src) (expand-expr) (build-void src))))
|
||||
(if id (expand-expr) (make-seq src (expand-expr) (build-void src))))
|
||||
(reverse vals)
|
||||
(reverse var-ids))))
|
||||
(build-letrec src #t var-ids vars vals tail)))))))
|
||||
|
|
@ -1608,11 +1572,11 @@
|
|||
s
|
||||
mod
|
||||
get-formals
|
||||
(map (lambda (tmp-680b775fb37a463-1
|
||||
tmp-680b775fb37a463
|
||||
(map (lambda (tmp-680b775fb37a463-1061
|
||||
tmp-680b775fb37a463-1060
|
||||
tmp-680b775fb37a463-105f)
|
||||
(cons tmp-680b775fb37a463-105f
|
||||
(cons tmp-680b775fb37a463 tmp-680b775fb37a463-1)))
|
||||
(cons tmp-680b775fb37a463-1060 tmp-680b775fb37a463-1061)))
|
||||
e2*
|
||||
e1*
|
||||
args*)))
|
||||
|
|
@ -1964,8 +1928,10 @@
|
|||
(apply (lambda (args e1 e2)
|
||||
(build-it
|
||||
'()
|
||||
(map (lambda (tmp-680b775fb37a463-68b tmp-680b775fb37a463-68a tmp-680b775fb37a463)
|
||||
(cons tmp-680b775fb37a463
|
||||
(map (lambda (tmp-680b775fb37a463-68b
|
||||
tmp-680b775fb37a463-68a
|
||||
tmp-680b775fb37a463-689)
|
||||
(cons tmp-680b775fb37a463-689
|
||||
(cons tmp-680b775fb37a463-68a tmp-680b775fb37a463-68b)))
|
||||
e2
|
||||
e1
|
||||
|
|
@ -2918,9 +2884,11 @@
|
|||
#f
|
||||
k
|
||||
'()
|
||||
(map (lambda (tmp-680b775fb37a463-1 tmp-680b775fb37a463 tmp-680b775fb37a463-117f)
|
||||
(list (cons tmp-680b775fb37a463-117f tmp-680b775fb37a463)
|
||||
tmp-680b775fb37a463-1))
|
||||
(map (lambda (tmp-680b775fb37a463-1181
|
||||
tmp-680b775fb37a463-1180
|
||||
tmp-680b775fb37a463-117f)
|
||||
(list (cons tmp-680b775fb37a463-117f tmp-680b775fb37a463-1180)
|
||||
tmp-680b775fb37a463-1181))
|
||||
template
|
||||
pattern
|
||||
keyword)))
|
||||
|
|
@ -2936,8 +2904,10 @@
|
|||
#f
|
||||
k
|
||||
(list docstring)
|
||||
(map (lambda (tmp-680b775fb37a463-119a tmp-680b775fb37a463-1 tmp-680b775fb37a463)
|
||||
(list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1)
|
||||
(map (lambda (tmp-680b775fb37a463-119a
|
||||
tmp-680b775fb37a463-1199
|
||||
tmp-680b775fb37a463-1198)
|
||||
(list (cons tmp-680b775fb37a463-1198 tmp-680b775fb37a463-1199)
|
||||
tmp-680b775fb37a463-119a))
|
||||
template
|
||||
pattern
|
||||
|
|
@ -3125,8 +3095,8 @@
|
|||
(apply (lambda (p)
|
||||
(if (= lev 0)
|
||||
(quasilist*
|
||||
(map (lambda (tmp-680b775fb37a463)
|
||||
(list "value" tmp-680b775fb37a463))
|
||||
(map (lambda (tmp-680b775fb37a463-1282)
|
||||
(list "value" tmp-680b775fb37a463-1282))
|
||||
p)
|
||||
(quasi q lev))
|
||||
(quasicons
|
||||
|
|
@ -3149,8 +3119,8 @@
|
|||
(apply (lambda (p)
|
||||
(if (= lev 0)
|
||||
(quasiappend
|
||||
(map (lambda (tmp-680b775fb37a463)
|
||||
(list "value" tmp-680b775fb37a463))
|
||||
(map (lambda (tmp-680b775fb37a463-1287)
|
||||
(list "value" tmp-680b775fb37a463-1287))
|
||||
p)
|
||||
(quasi q lev))
|
||||
(quasicons
|
||||
|
|
@ -3318,8 +3288,8 @@
|
|||
(apply (lambda (y z) (f z (lambda (ls) (k (append y ls))))) tmp-1)
|
||||
(let ((else tmp))
|
||||
(let ((tmp x))
|
||||
(let ((t-680b775fb37a463 tmp))
|
||||
(list "list->vector" t-680b775fb37a463)))))))))))))))))
|
||||
(let ((t-680b775fb37a463-1306 tmp))
|
||||
(list "list->vector" t-680b775fb37a463-1306)))))))))))))))))
|
||||
(emit (lambda (x)
|
||||
(let ((tmp x))
|
||||
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") any))))
|
||||
|
|
@ -3332,9 +3302,9 @@
|
|||
(let ((tmp-1 (map emit x)))
|
||||
(let ((tmp ($sc-dispatch tmp-1 'each-any)))
|
||||
(if tmp
|
||||
(apply (lambda (t-680b775fb37a463)
|
||||
(apply (lambda (t-680b775fb37a463-1315)
|
||||
(cons (make-syntax 'list '((top)) '(hygiene guile))
|
||||
t-680b775fb37a463))
|
||||
t-680b775fb37a463-1315))
|
||||
tmp)
|
||||
(syntax-violation
|
||||
#f
|
||||
|
|
@ -3350,10 +3320,10 @@
|
|||
(let ((tmp-1 (list (emit (car x*)) (f (cdr x*)))))
|
||||
(let ((tmp ($sc-dispatch tmp-1 '(any any))))
|
||||
(if tmp
|
||||
(apply (lambda (t-680b775fb37a463-1 t-680b775fb37a463)
|
||||
(apply (lambda (t-680b775fb37a463-1329 t-680b775fb37a463-1328)
|
||||
(list (make-syntax 'cons '((top)) '(hygiene guile))
|
||||
t-680b775fb37a463-1
|
||||
t-680b775fb37a463))
|
||||
t-680b775fb37a463-1329
|
||||
t-680b775fb37a463-1328))
|
||||
tmp)
|
||||
(syntax-violation
|
||||
#f
|
||||
|
|
@ -3366,9 +3336,9 @@
|
|||
(let ((tmp-1 (map emit x)))
|
||||
(let ((tmp ($sc-dispatch tmp-1 'each-any)))
|
||||
(if tmp
|
||||
(apply (lambda (t-680b775fb37a463)
|
||||
(apply (lambda (t-680b775fb37a463-1335)
|
||||
(cons (make-syntax 'append '((top)) '(hygiene guile))
|
||||
t-680b775fb37a463))
|
||||
t-680b775fb37a463-1335))
|
||||
tmp)
|
||||
(syntax-violation
|
||||
#f
|
||||
|
|
@ -3381,9 +3351,9 @@
|
|||
(let ((tmp-1 (map emit x)))
|
||||
(let ((tmp ($sc-dispatch tmp-1 'each-any)))
|
||||
(if tmp
|
||||
(apply (lambda (t-680b775fb37a463)
|
||||
(apply (lambda (t-680b775fb37a463-1341)
|
||||
(cons (make-syntax 'vector '((top)) '(hygiene guile))
|
||||
t-680b775fb37a463))
|
||||
t-680b775fb37a463-1341))
|
||||
tmp)
|
||||
(syntax-violation
|
||||
#f
|
||||
|
|
|
|||
|
|
@ -287,24 +287,24 @@
|
|||
;; output constructors
|
||||
(define build-void
|
||||
(lambda (sourcev)
|
||||
(make-void (sourcev->alist sourcev))))
|
||||
(make-void sourcev)))
|
||||
|
||||
(define build-call
|
||||
(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
|
||||
(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
|
||||
(lambda (type sourcev name var)
|
||||
(make-lexical-ref (sourcev->alist sourcev) name var)))
|
||||
(make-lexical-ref sourcev name var)))
|
||||
|
||||
(define build-lexical-assignment
|
||||
(lambda (sourcev name var 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)
|
||||
(if (not mod)
|
||||
|
|
@ -330,9 +330,9 @@
|
|||
(analyze-variable
|
||||
mod var
|
||||
(lambda (mod var public?)
|
||||
(make-module-ref (sourcev->alist sourcev) mod var public?))
|
||||
(make-module-ref sourcev mod var public?))
|
||||
(lambda (mod var)
|
||||
(make-toplevel-ref (sourcev->alist sourcev) mod var)))))
|
||||
(make-toplevel-ref sourcev mod var)))))
|
||||
|
||||
(define build-global-assignment
|
||||
(lambda (sourcev var exp mod)
|
||||
|
|
@ -340,18 +340,18 @@
|
|||
(analyze-variable
|
||||
mod var
|
||||
(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)
|
||||
(make-toplevel-set (sourcev->alist sourcev) mod var exp)))))
|
||||
(make-toplevel-set sourcev mod var exp)))))
|
||||
|
||||
(define build-global-definition
|
||||
(lambda (sourcev mod 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
|
||||
(lambda (src req rest vars meta exp)
|
||||
(make-lambda (sourcev->alist src)
|
||||
(make-lambda src
|
||||
meta
|
||||
;; hah, a case in which kwargs would be nice.
|
||||
(make-lambda-case
|
||||
|
|
@ -360,7 +360,7 @@
|
|||
|
||||
(define build-case-lambda
|
||||
(lambda (src meta body)
|
||||
(make-lambda (sourcev->alist src) meta body)))
|
||||
(make-lambda src meta body)))
|
||||
|
||||
(define build-lambda-case
|
||||
;; req := (name ...)
|
||||
|
|
@ -374,31 +374,31 @@
|
|||
;; the body of a lambda: anything, already expanded
|
||||
;; else: lambda-case | #f
|
||||
(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
|
||||
(lambda (src name args)
|
||||
(make-primcall (sourcev->alist src) name args)))
|
||||
(make-primcall src name args)))
|
||||
|
||||
(define build-primref
|
||||
(lambda (src name)
|
||||
(make-primitive-ref (sourcev->alist src) name)))
|
||||
(make-primitive-ref src name)))
|
||||
|
||||
(define (build-data src exp)
|
||||
(make-const (sourcev->alist src) exp))
|
||||
(make-const src exp))
|
||||
|
||||
(define build-sequence
|
||||
(lambda (src exps)
|
||||
(if (null? (cdr 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
|
||||
(lambda (src ids vars val-exps body-exp)
|
||||
(for-each maybe-name-value! ids val-exps)
|
||||
(if (null? vars)
|
||||
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
|
||||
(lambda (src ids vars val-exps body-exp)
|
||||
|
|
@ -410,7 +410,7 @@
|
|||
(maybe-name-value! f-name proc)
|
||||
(for-each maybe-name-value! ids val-exps)
|
||||
(make-letrec
|
||||
(sourcev->alist src) #f
|
||||
src #f
|
||||
(list f-name) (list f) (list proc)
|
||||
(build-call src (build-lexical-reference 'fun src f-name f)
|
||||
val-exps))))))
|
||||
|
|
@ -421,7 +421,7 @@
|
|||
body-exp
|
||||
(begin
|
||||
(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)
|
||||
|
|
@ -1616,7 +1616,7 @@
|
|||
((null? var-ids) tail)
|
||||
((not (car var-ids))
|
||||
(lp (cdr var-ids) (cdr vars) (cdr vals)
|
||||
(make-seq (sourcev->alist src) ((car vals)) tail)))
|
||||
(make-seq src ((car vals)) tail)))
|
||||
(else
|
||||
(let ((var-ids (map (lambda (id)
|
||||
(if id (syntax->datum id) '_))
|
||||
|
|
@ -1626,7 +1626,7 @@
|
|||
(vals (map (lambda (expand-expr id)
|
||||
(if id
|
||||
(expand-expr)
|
||||
(make-seq (sourcev->alist src)
|
||||
(make-seq src
|
||||
(expand-expr)
|
||||
(build-void src))))
|
||||
(reverse vals) (reverse var-ids))))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
;;;; modify it under the terms of the GNU Lesser General Public
|
||||
|
|
@ -21,8 +21,7 @@
|
|||
#:use-module (srfi srfi-11)
|
||||
#:use-module (ice-9 match)
|
||||
#:use-module (system base syntax)
|
||||
#:export (tree-il-src
|
||||
|
||||
#:export ((tree-il-src/ensure-alist . tree-il-src)
|
||||
<void> void? make-void void-src
|
||||
<const> const? make-const const-src const-exp
|
||||
<primitive-ref> primitive-ref? make-primitive-ref primitive-ref-src primitive-ref-name
|
||||
|
|
@ -136,6 +135,20 @@
|
|||
(<prompt> escape-only? tag body handler)
|
||||
(<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.
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; 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
|
||||
;;;; modify it under the terms of the GNU Lesser General Public
|
||||
|
|
@ -346,11 +346,11 @@ given `tree-il' element."
|
|||
(lambda (x defs env locs)
|
||||
;; Going down into X.
|
||||
(record-case x
|
||||
((<toplevel-define> name src)
|
||||
((<toplevel-define> name)
|
||||
(match (vhash-assq name defs)
|
||||
((_ . previous-definition)
|
||||
(warning 'shadowed-toplevel src name
|
||||
(toplevel-define-src previous-definition))
|
||||
(warning 'shadowed-toplevel (tree-il-src x) name
|
||||
(tree-il-src previous-definition))
|
||||
defs)
|
||||
(#f
|
||||
(vhash-consq name x defs))))
|
||||
|
|
|
|||
|
|
@ -2821,10 +2821,16 @@ procedure with label @var{rw-init}. @var{rw-init} may be false. If
|
|||
|
||||
(let lp ((sources (asm-sources asm)) (out '()))
|
||||
(match sources
|
||||
(((pc . s) . sources)
|
||||
(let ((file (assq-ref s 'filename))
|
||||
(line (assq-ref s 'line))
|
||||
(col (assq-ref s 'column)))
|
||||
(((pc . location) . sources)
|
||||
(let-values (((file line col)
|
||||
;; Usually CPS records contain a "source
|
||||
;; 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
|
||||
;; Guile line and column numbers are 0-indexed, but
|
||||
;; they are 1-indexed for DWARF.
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue