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

Use tree-il-srcv instead of tree-il-src

Browse source 
This prevents eager conversion to alists.
This commit is contained in:
Andy Wingo 2023-03-28 16:10:38 +02:00
parent b0a390db06
commit 2cd8b4160c
8 changed files with 32 additions and 29 deletions
Download patch file Download diff file Expand all files Collapse all files

14
module/language/cps/dump.scm
View file

@ -1,6 +1,6 @@
;;; Continuation-passing style (CPS) intermediate language (IL) ;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2013, 2014, 2015, 2017, 2018, 2019, 2020, 2021 Free Software Foundation, Inc. ;; Copyright (C) 2021,2023 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
@ -114,11 +114,13 @@
(define (format-name name) (if name (symbol->string name) "_")) (define (format-name name) (if name (symbol->string name) "_"))
(define (format-var var) (format #f "v~a" var)) (define (format-var var) (format #f "v~a" var))
(define (format-loc src) (define (format-loc src)
(and src (match src
(format #f "~a:~a:~a" (#f #f)
(or (assq-ref src 'filename) "<unknown>") (#(filename line column)
(1+ (assq-ref src 'line)) (format #f "~a:~a:~a"
(assq-ref src 'column)))) (or filename "<unknown>")
(1+ line)
column))))
(define (arg-list strs) (string-join strs ", ")) (define (arg-list strs) (string-join strs ", "))
(define (false-if-empty str) (if (string-null? str) #f str)) (define (false-if-empty str) (if (string-null? str) #f str))
(define (format-arity arity) (define (format-arity arity)

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

@ -1,4 +1,4 @@
;;;; Copyright (C) 2009-2014, 2017-2020, 2022 Free Software Foundation, Inc. ;;;; Copyright (C) 2009-2014,2017-2020,2022-2023 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
@ -22,6 +22,7 @@
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (system base syntax) #:use-module (system base syntax)
#:export ((tree-il-src/ensure-alist . tree-il-src) #:export ((tree-il-src/ensure-alist . tree-il-src)
(tree-il-src . tree-il-srcv)
<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

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

@ -71,7 +71,7 @@ given `tree-il' element."
(cdr results)))))) (cdr results))))))
;; Extending and shrinking the location stack. ;; Extending and shrinking the location stack.
(define (extend-locs x locs) (cons (tree-il-src x) locs)) (define (extend-locs x locs) (cons (tree-il-srcv x) locs))
(define (shrink-locs x locs) (cdr locs)) (define (shrink-locs x locs) (cdr locs))
(let ((results (let ((results
@ -114,7 +114,7 @@ given `tree-il' element."
;; accordingly. ;; accordingly.
(let ((refs (binding-info-refs info)) (let ((refs (binding-info-refs info))
(vars (binding-info-vars info)) (vars (binding-info-vars info))
(src (tree-il-src x))) (src (tree-il-srcv x)))
(define (extend inner-vars inner-names) (define (extend inner-vars inner-names)
(fold (lambda (var name vars) (fold (lambda (var name vars)
(vhash-consq var (list name src) vars)) (vhash-consq var (list name src) vars))
@ -499,7 +499,7 @@ given `tree-il' element."
(match (vhash-assq name defs) (match (vhash-assq name defs)
((_ . previous-definition) ((_ . previous-definition)
(warning 'shadowed-toplevel src name (warning 'shadowed-toplevel src name
(tree-il-src previous-definition)) (tree-il-srcv previous-definition))
defs) defs)
(#f (#f
(vhash-consq name x defs)))) (vhash-consq name x defs))))
@ -900,7 +900,7 @@ given `tree-il' element."
(values #f #f)))))))) (values #f #f))))))))
(let ((args (call-args call)) (let ((args (call-args call))
(src (tree-il-src call))) (src (tree-il-srcv call)))
(call-with-values (lambda () (arities proc)) (call-with-values (lambda () (arities proc))
(lambda (name arities) (lambda (name arities)
(define matches? (define matches?

4
module/language/tree-il/compile-bytecode.scm
View file

@ -1,6 +1,6 @@
;;; Lightweight compiler directly from Tree-IL to bytecode ;;; Lightweight compiler directly from Tree-IL to bytecode
;; Copyright (C) 2020, 2021 Free Software Foundation, Inc. ;; Copyright (C) 2020-2021,2023 Free Software Foundation, Inc.
;;; This library is free software; you can redistribute it and/or modify it ;;; This library is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU Lesser General Public License as published by ;;; under the terms of the GNU Lesser General Public License as published by
@ -638,7 +638,7 @@
(() (()
(let () (let ()
(define x-thunk (define x-thunk
(let ((src (tree-il-src exp))) (let ((src (tree-il-srcv exp)))
(make-lambda src '() (make-lambda src '()
(make-lambda-case src '() #f #f #f '() '() exp #f)))) (make-lambda-case src '() #f #f #f '() '() exp #f))))
(values (cons (make-closure 'init x-thunk #f '()) (values (cons (make-closure 'init x-thunk #f '())

10
module/language/tree-il/compile-cps.scm
View file

@ -1,6 +1,6 @@
;;; Continuation-passing style (CPS) intermediate language (IL) ;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2013-2015,2017-2021 Free Software Foundation, Inc. ;; Copyright (C) 2013-2015,2017-2021,2023 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
@ -1542,7 +1542,7 @@ use as the proc slot."
(define (init-default-value cps name sym subst init body) (define (init-default-value cps name sym subst init body)
(match (hashq-ref subst sym) (match (hashq-ref subst sym)
((orig-var subst-var box?) ((orig-var subst-var box?)
(let ((src (tree-il-src init))) (let ((src (tree-il-srcv init)))
(define (maybe-box cps k make-body) (define (maybe-box cps k make-body)
(if box? (if box?
(with-cps cps (with-cps cps
@ -2150,10 +2150,10 @@ use as the proc slot."
(lambda (cps thunk) (lambda (cps thunk)
(with-cps cps (with-cps cps
(letk kbody ($kargs () () (letk kbody ($kargs () ()
($continue krest (tree-il-src body) ($continue krest (tree-il-srcv body)
($primcall 'call-thunk/no-inline #f ($primcall 'call-thunk/no-inline #f
(thunk))))) (thunk)))))
(build-term ($prompt kbody khargs (tree-il-src body) (build-term ($prompt kbody khargs (tree-il-srcv body)
#f tag))))))) #f tag)))))))
(with-cps cps (with-cps cps
(letv prim vals apply) (letv prim vals apply)
@ -2394,7 +2394,7 @@ integer."
(letk kclause ($kclause ('() '() #f '() #f) kbody #f)) (letk kclause ($kclause ('() '() #f '() #f) kbody #f))
($ ((lambda (cps) ($ ((lambda (cps)
(let ((init (build-cont (let ((init (build-cont
($kfun (tree-il-src exp) '() init ktail kclause)))) ($kfun (tree-il-srcv exp) '() init ktail kclause))))
(with-cps (persistent-intmap (intmap-replace! cps kinit init)) (with-cps (persistent-intmap (intmap-replace! cps kinit init))
kinit)))))))) kinit))))))))

14
module/language/tree-il/debug.scm
View file

@ -1,6 +1,6 @@
;;; Tree-IL verifier ;;; Tree-IL verifier
;; Copyright (C) 2011, 2013, 2019 Free Software Foundation, Inc. ;; Copyright (C) 2011,2013,2019,2023 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
@ -244,9 +244,9 @@
(visit tail env)) (visit tail env))
(_ (_
(error "unexpected tree-il" exp))) (error "unexpected tree-il" exp)))
(let ((src (tree-il-src exp))) (match (tree-il-srcv exp)
(if (and src (not (and (list? src) (and-map pair? src) (#f #t)
(and-map symbol? (map car src))))) (#((or #f (? string?)) exact-integer? exact-integer?) #t)
(error "bad src")) (src (error "bad src" src)))
;; Return it, why not. ;; Return it, why not.
exp))) exp))

4
module/language/tree-il/letrectify.scm
View file

@ -1,6 +1,6 @@
;;; transformation of top-level bindings into letrec* ;;; transformation of top-level bindings into letrec*
;; Copyright (C) 2019-2021 Free Software Foundation, Inc. ;; Copyright (C) 2019-2021,2023 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
@ -190,7 +190,7 @@
(cons name names) (cons var vars) (cons val vals) (cons name names) (cons var vars) (cons val vals)
tail)) tail))
(_ (_
(make-letrec (tree-il-src tail) #t (make-letrec (tree-il-srcv tail) #t
(list name) (list var) (list val) (list name) (list var) (list val)
tail)))) tail))))

4
module/language/tree-il/peval.scm
View file

@ -1,6 +1,6 @@
;;; Tree-IL partial evaluator ;;; Tree-IL partial evaluator
;; Copyright (C) 2011-2014, 2017, 2019, 2020, 2021, 2022 Free Software Foundation, Inc. ;; Copyright (C) 2011-2014,2017,2019-2023 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
@ -110,7 +110,7 @@
"Discard all but the first value of X." "Discard all but the first value of X."
(if (singly-valued-expression? x) (if (singly-valued-expression? x)
x x
(make-primcall (tree-il-src x) 'values (list x)))) (make-primcall (tree-il-srcv x) 'values (list x))))
;; Peval will do a one-pass analysis on the source program to determine ;; Peval will do a one-pass analysis on the source program to determine
;; the set of assigned lexicals, and to identify unreferenced and ;; the set of assigned lexicals, and to identify unreferenced and