psyntax: Pass source vectors to tree-il constructors.wip-tree-il-sourcev

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.

5 files changed, 105 insertions, 116 deletions

diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm
index 80be7249a..a6b7fd1c4 100644
--- a/module/ice-9/psyntax-pp.scm
+++ b/module/ice-9/psyntax-pp.scm
@@ -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
diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm
index 35758ab4c..3a885e507 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -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))))
diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm
index 974fce29e..a7dc3c079 100644
--- a/module/language/tree-il.scm
+++ b/module/language/tree-il.scm
@@ -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.
diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm
index 1567e3ec5..7918b9ddd 100644
--- a/module/language/tree-il/analyze.scm
+++ b/module/language/tree-il/analyze.scm
@@ -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))))
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index be1b79e34..77ffb5aa1 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -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.