From 2aed3c117c2d667ecca1e38a016f2cb4b524ab50 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Sun, 6 Feb 2022 17:44:51 +0100 Subject: [PATCH] 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. --- module/ice-9/psyntax-pp.scm | 136 +++++++++++----------------- module/ice-9/psyntax.scm | 44 ++++----- module/language/tree-il.scm | 19 +++- module/language/tree-il/analyze.scm | 8 +- module/system/vm/assembler.scm | 14 ++- 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? make-void void-src const? make-const const-src const-exp primitive-ref? make-primitive-ref primitive-ref-src primitive-ref-name @@ -136,6 +135,20 @@ ( escape-only? tag body handler) ( 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 - (( name src) + (( 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.