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

Excise use of record-case

Browse source 
This macro expands to field accessors, which in the case of tree-il-src
will force an eager conversion of the source info to alists.
This commit is contained in:
Andy Wingo 2023-03-28 16:33:24 +02:00
parent a3173e084e
commit b0a390db06
3 changed files with 106 additions and 113 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -122,24 +122,24 @@ given `tree-il' element."
inner-vars inner-vars
inner-names)) inner-names))
(record-case x (match x
((<lexical-ref> gensym) (($ <lexical-ref> src name gensym)
(make-binding-info vars (vhash-consq gensym #t refs))) (make-binding-info vars (vhash-consq gensym #t refs)))
((<lexical-set> gensym) (($ <lexical-set> src name gensym)
(make-binding-info vars (vhash-consq gensym #t refs))) (make-binding-info vars (vhash-consq gensym #t refs)))
((<lambda-case> req opt inits rest kw gensyms) (($ <lambda-case> src req opt rest kw inits gensyms body alt)
(let ((names `(,@req (let ((names `(,@req
,@(or opt '()) ,@(or opt '())
,@(if rest (list rest) '()) ,@(if rest (list rest) '())
,@(if kw (map cadr (cdr kw)) '())))) ,@(if kw (map cadr (cdr kw)) '()))))
(make-binding-info (extend gensyms names) refs))) (make-binding-info (extend gensyms names) refs)))
((<let> gensyms names) (($ <let> src names gensyms)
(make-binding-info (extend gensyms names) refs)) (make-binding-info (extend gensyms names) refs))
((<letrec> gensyms names) (($ <letrec> src in-order? names gensyms)
(make-binding-info (extend gensyms names) refs)) (make-binding-info (extend gensyms names) refs))
((<fix> gensyms names) (($ <fix> src names gensyms)
(make-binding-info (extend gensyms names) refs)) (make-binding-info (extend gensyms names) refs))
(else info)))) (_ info))))
(lambda (x info env locs) (lambda (x info env locs)
;; Leaving X's scope: shrink INFO's variable list ;; Leaving X's scope: shrink INFO's variable list
@ -169,16 +169,16 @@ given `tree-il' element."
;; names of variables that are now going out of scope. ;; names of variables that are now going out of scope.
;; It doesn't hurt as these are unique names, it just ;; It doesn't hurt as these are unique names, it just
;; makes REFS unnecessarily fat. ;; makes REFS unnecessarily fat.
(record-case x (match x
((<lambda-case> gensyms) (($ <lambda-case> src req opt rest kw inits gensyms)
(make-binding-info (shrink gensyms refs) refs)) (make-binding-info (shrink gensyms refs) refs))
((<let> gensyms) (($ <let> src names gensyms)
(make-binding-info (shrink gensyms refs) refs)) (make-binding-info (shrink gensyms refs) refs))
((<letrec> gensyms) (($ <letrec> src in-order? names gensyms)
(make-binding-info (shrink gensyms refs) refs)) (make-binding-info (shrink gensyms refs) refs))
((<fix> gensyms) (($ <fix> src names gensyms)
(make-binding-info (shrink gensyms refs) refs)) (make-binding-info (shrink gensyms refs) refs))
(else info)))) (_ info))))
(lambda (result env) #t) (lambda (result env) #t)
(make-binding-info vlist-null vlist-null))) (make-binding-info vlist-null vlist-null)))
@ -278,26 +278,26 @@ given `tree-il' element."
(let ((ctx (reference-graph-toplevel-context graph)) (let ((ctx (reference-graph-toplevel-context graph))
(refs (reference-graph-refs graph)) (refs (reference-graph-refs graph))
(defs (reference-graph-defs graph))) (defs (reference-graph-defs graph)))
(record-case x (match x
((<toplevel-ref> name src) (($ <toplevel-ref> src mod name)
(add-ref-from-context graph name)) (add-ref-from-context graph name))
((<toplevel-define> name src) (($ <toplevel-define> src mod name expr)
(let ((refs refs) (let ((refs refs)
(defs (vhash-consq name (or src (find pair? locs)) (defs (vhash-consq name (or src (find pair? locs))
defs))) defs)))
(make-reference-graph refs defs name))) (make-reference-graph refs defs name)))
((<toplevel-set> name src) (($ <toplevel-set> src mod name expr)
(add-ref-from-context graph name)) (add-ref-from-context graph name))
(else graph)))) (_ graph))))
(lambda (x graph env locs) (lambda (x graph env locs)
;; Leaving X's scope. ;; Leaving X's scope.
(record-case x (match x
((<toplevel-define>) (($ <toplevel-define>)
(let ((refs (reference-graph-refs graph)) (let ((refs (reference-graph-refs graph))
(defs (reference-graph-defs graph))) (defs (reference-graph-defs graph)))
(make-reference-graph refs defs #f))) (make-reference-graph refs defs #f)))
(else graph))) (_ graph)))
(lambda (graph env) (lambda (graph env)
;; Process the resulting reference graph: determine all private definitions ;; Process the resulting reference graph: determine all private definitions
@ -494,16 +494,16 @@ given `tree-il' element."
(make-tree-analysis (make-tree-analysis
(lambda (x defs env locs) (lambda (x defs env locs)
;; Going down into X. ;; Going down into X.
(record-case x (match x
((<toplevel-define> name) (($ <toplevel-define> src mod name expr)
(match (vhash-assq name defs) (match (vhash-assq name defs)
((_ . previous-definition) ((_ . previous-definition)
(warning 'shadowed-toplevel (tree-il-src x) name (warning 'shadowed-toplevel src name
(tree-il-src previous-definition)) (tree-il-src previous-definition))
defs) defs)
(#f (#f
(vhash-consq name x defs)))) (vhash-consq name x defs))))
(else defs))) (else defs)))
(lambda (x defs env locs) (lambda (x defs env locs)
;; Leaving X's scope. ;; Leaving X's scope.
@ -887,16 +887,16 @@ given `tree-il' element."
(arities '())) (arities '()))
(if (not proc) (if (not proc)
(values name (reverse arities)) (values name (reverse arities))
(record-case proc (match proc
((<lambda-case> req opt rest kw alternate) (($ <lambda-case> src req opt rest kw inits gensyms body alt)
(loop name alternate (loop name alt
(cons (list (len req) (len opt) rest (cons (list (len req) (len opt) rest
(and (pair? kw) (map car (cdr kw))) (and (pair? kw) (map car (cdr kw)))
(and (pair? kw) (car kw))) (and (pair? kw) (car kw)))
arities))) arities)))
((<lambda> meta body) (($ <lambda> src meta body)
(loop (assoc-ref meta 'name) body arities)) (loop (assoc-ref meta 'name) body arities))
(else (_
(values #f #f)))))))) (values #f #f))))))))
(let ((args (call-args call)) (let ((args (call-args call))
@ -935,38 +935,38 @@ given `tree-il' element."
(let ((toplevel-calls (toplevel-procedure-calls info)) (let ((toplevel-calls (toplevel-procedure-calls info))
(lexical-lambdas (lexical-lambdas info)) (lexical-lambdas (lexical-lambdas info))
(toplevel-lambdas (toplevel-lambdas info))) (toplevel-lambdas (toplevel-lambdas info)))
(record-case val (match val
((<lambda> body) (($ <lambda> src meta body)
(make-arity-info toplevel-calls (make-arity-info toplevel-calls
(vhash-consq lexical-name val (vhash-consq lexical-name val
lexical-lambdas) lexical-lambdas)
toplevel-lambdas)) toplevel-lambdas))
((<lexical-ref> gensym) (($ <lexical-ref> src name gensym)
;; lexical alias ;; lexical alias
(let ((val* (vhash-assq gensym lexical-lambdas))) (let ((val* (vhash-assq gensym lexical-lambdas)))
(if (pair? val*) (if (pair? val*)
(extend lexical-name (cdr val*) info) (extend lexical-name (cdr val*) info)
info))) info)))
((<toplevel-ref> name) (($ <toplevel-ref> src mod name)
;; top-level alias ;; top-level alias
(make-arity-info toplevel-calls (make-arity-info toplevel-calls
(vhash-consq lexical-name val (vhash-consq lexical-name val
lexical-lambdas) lexical-lambdas)
toplevel-lambdas)) toplevel-lambdas))
(else info)))) (_ info))))
(let ((toplevel-calls (toplevel-procedure-calls info)) (let ((toplevel-calls (toplevel-procedure-calls info))
(lexical-lambdas (lexical-lambdas info)) (lexical-lambdas (lexical-lambdas info))
(toplevel-lambdas (toplevel-lambdas info))) (toplevel-lambdas (toplevel-lambdas info)))
(record-case x (match x
((<toplevel-define> name exp) (($ <toplevel-define> src mod name exp)
(record-case exp (match exp
((<lambda> body) (($ <lambda> src' meta body)
(make-arity-info toplevel-calls (make-arity-info toplevel-calls
lexical-lambdas lexical-lambdas
(vhash-consq name exp toplevel-lambdas))) (vhash-consq name exp toplevel-lambdas)))
((<toplevel-ref> name) (($ <toplevel-ref> src' mod name)
;; alias for another toplevel ;; alias for another toplevel
(let ((proc (vhash-assq name toplevel-lambdas))) (let ((proc (vhash-assq name toplevel-lambdas)))
(make-arity-info toplevel-calls (make-arity-info toplevel-calls
@ -976,41 +976,39 @@ given `tree-il' element."
(cdr proc) (cdr proc)
exp) exp)
toplevel-lambdas)))) toplevel-lambdas))))
(else info))) (_ info)))
((<let> gensyms vals) (($ <let> src names gensyms vals)
(fold extend info gensyms vals)) (fold extend info gensyms vals))
((<letrec> gensyms vals) (($ <letrec> src in-order? names gensyms vals)
(fold extend info gensyms vals)) (fold extend info gensyms vals))
((<fix> gensyms vals) (($ <fix> src names gensyms vals)
(fold extend info gensyms vals)) (fold extend info gensyms vals))
((<call> proc args src) (($ <call> src proc args)
(record-case proc (match proc
((<lambda> body) (($ <lambda> src' meta body)
(validate-arity proc x #t) (validate-arity proc x #t)
info) info)
((<toplevel-ref> name) (($ <toplevel-ref> src' mod name)
(make-arity-info (vhash-consq name x toplevel-calls) (make-arity-info (vhash-consq name x toplevel-calls)
lexical-lambdas lexical-lambdas
toplevel-lambdas)) toplevel-lambdas))
((<lexical-ref> gensym) (($ <lexical-ref> src' name gensym)
(let ((proc (vhash-assq gensym lexical-lambdas))) (match (vhash-assq gensym lexical-lambdas)
(if (pair? proc) ((gensym . ($ <toplevel-ref> src'' mod name'))
(record-case (cdr proc) ;; alias to toplevel
((<toplevel-ref> name) (make-arity-info (vhash-consq name' x toplevel-calls)
;; alias to toplevel lexical-lambdas
(make-arity-info (vhash-consq name x toplevel-calls) toplevel-lambdas))
lexical-lambdas ((gensym . proc)
toplevel-lambdas)) (validate-arity proc x #t)
(else info)
(validate-arity (cdr proc) x #t) (#f
info)) ;; If GENSYM wasn't found, it may be because it's an
;; argument of the procedure being compiled.
;; If GENSYM wasn't found, it may be because it's an info)))
;; argument of the procedure being compiled. (_ info)))
info))) (_ info))))
(else info)))
(else info))))
(lambda (x info env locs) (lambda (x info env locs)
;; Up from X. ;; Up from X.
@ -1028,15 +1026,15 @@ given `tree-il' element."
(let ((toplevel-calls (toplevel-procedure-calls info)) (let ((toplevel-calls (toplevel-procedure-calls info))
(lexical-lambdas (lexical-lambdas info)) (lexical-lambdas (lexical-lambdas info))
(toplevel-lambdas (toplevel-lambdas info))) (toplevel-lambdas (toplevel-lambdas info)))
(record-case x (match x
((<let> gensyms vals) (($ <let> src names gensyms vals)
(fold shrink info gensyms vals)) (fold shrink info gensyms vals))
((<letrec> gensyms vals) (($ <letrec> src in-order? names gensyms vals)
(fold shrink info gensyms vals)) (fold shrink info gensyms vals))
((<fix> gensyms vals) (($ <fix> src names gensyms vals)
(fold shrink info gensyms vals)) (fold shrink info gensyms vals))
(else info)))) (_ info))))
(lambda (result env) (lambda (result env)
;; Post-processing: check all top-level procedure calls that have been ;; Post-processing: check all top-level procedure calls that have been

42
module/language/tree-il/fix-letrec.scm
View file

@ -1,6 +1,6 @@
;;; transformation of letrec into simpler forms ;;; transformation of letrec into simpler forms
;; Copyright (C) 2009-2013,2016,2019,2021 Free Software Foundation, Inc. ;; Copyright (C) 2009-2013,2016,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
@ -17,7 +17,6 @@
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (language tree-il fix-letrec) (define-module (language tree-il fix-letrec)
#:use-module (system base syntax)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-11) #:use-module (srfi srfi-11)
#:use-module (ice-9 match) #:use-module (ice-9 match)
@ -39,26 +38,22 @@
(define assigned (make-hash-table)) (define assigned (make-hash-table))
;; Functional hash sets would be nice. ;; Functional hash sets would be nice.
(fix-fold x (fix-fold x
(lambda (x) (match-lambda
(record-case x (($ <lexical-ref> src name gensym)
((<lexical-ref> gensym) (hashq-set! referenced gensym #t)
(hashq-set! referenced gensym #t) (values))
(values)) (($ <lexical-set> src name gensym)
((<lexical-set> gensym) (hashq-set! assigned gensym #t)
(hashq-set! assigned gensym #t) (values))
(values)) (_
(else (values)))
(values))))
(lambda (x) (lambda (x)
(values))) (values)))
(values referenced assigned)) (values referenced assigned))
(define (make-seq* src head tail) (define (make-seq* src head tail)
(record-case head (match head
((<lambda>) tail) ((or ($ <lambda>) ($ <const>) ($ <lexical-ref>) ($ <void>)) tail)
((<const>) tail)
((<lexical-ref>) tail)
((<void>) tail)
(else (make-seq src head tail)))) (else (make-seq src head tail))))
(define (free-variables expr cache) (define (free-variables expr cache)
@ -291,16 +286,15 @@
(define fv-cache (make-hash-table)) (define fv-cache (make-hash-table))
(post-order (post-order
(lambda (x) (lambda (x)
(record-case x (match x
;; Sets to unreferenced variables may be replaced by their ;; Sets to unreferenced variables may be replaced by their
;; expression, called for effect. ;; expression, called for effect.
((<lexical-set> gensym exp) (($ <lexical-set> src name gensym exp)
(if (hashq-ref referenced gensym) (if (hashq-ref referenced gensym)
x x
(make-seq* #f exp (make-void #f)))) (make-seq* #f exp (make-void #f))))
((<letrec> src in-order? names gensyms vals body) (($ <letrec> src in-order? names gensyms vals body)
(if in-order? (if in-order?
(match (reorder-bindings (map vector names gensyms vals)) (match (reorder-bindings (map vector names gensyms vals))
((#(names gensyms vals) ...) ((#(names gensyms vals) ...)
@ -309,12 +303,12 @@
(fix-term src #f names gensyms vals body (fix-term src #f names gensyms vals body
fv-cache referenced assigned))) fv-cache referenced assigned)))
((<let> src names gensyms vals body) (($ <let> src names gensyms vals body)
;; Apply the same algorithm to <let> that binds <lambda> ;; Apply the same algorithm to <let> that binds <lambda>
(if (or-map lambda? vals) (if (or-map lambda? vals)
(fix-term src #f names gensyms vals body (fix-term src #f names gensyms vals body
fv-cache referenced assigned) fv-cache referenced assigned)
x)) x))
(else x))) (_ x)))
x))) x)))

23
module/language/tree-il/primitives.scm
View file

@ -283,24 +283,25 @@
;; have the same semantics as the primitives. ;; have the same semantics as the primitives.
(unless (eq? mod the-root-module) (unless (eq? mod the-root-module)
(let collect-local-definitions ((x x)) (let collect-local-definitions ((x x))
(record-case x (match x
((<toplevel-define> name) (($ <toplevel-define> src mod name)
(hashq-set! local-definitions name #t)) (hashq-set! local-definitions name #t))
((<seq> head tail) (($ <seq> src head tail)
(collect-local-definitions head) (collect-local-definitions head)
(collect-local-definitions tail)) (collect-local-definitions tail))
(else #f)))) (_ #f))))
(post-order (post-order
(lambda (x) (lambda (x)
(or (or
(record-case x (match x
((<toplevel-ref> src name) ;; FIXME: Use `mod' field?
(($ <toplevel-ref> src mod* name)
(and=> (and (not (hashq-ref local-definitions name)) (and=> (and (not (hashq-ref local-definitions name))
(hashq-ref *interesting-primitive-vars* (hashq-ref *interesting-primitive-vars*
(module-variable mod name))) (module-variable mod name)))
(lambda (name) (make-primitive-ref src name)))) (lambda (name) (make-primitive-ref src name))))
((<module-ref> src mod name public?) (($ <module-ref> src mod name public?)
;; for the moment, we're disabling primitive resolution for ;; for the moment, we're disabling primitive resolution for
;; public refs because resolve-interface can raise errors. ;; public refs because resolve-interface can raise errors.
(and=> (and=> (resolve-module mod) (and=> (and=> (resolve-module mod)
@ -312,10 +313,10 @@
(module-variable m name)) (module-variable m name))
(lambda (name) (lambda (name)
(make-primitive-ref src name)))))) (make-primitive-ref src name))))))
((<call> src proc args) (($ <call> src proc args)
(and (primitive-ref? proc) (and (primitive-ref? proc)
(make-primcall src (primitive-ref-name proc) args))) (make-primcall src (primitive-ref-name proc) args)))
(else #f)) (_ #f))
x)) x))
x)) x))
@ -324,8 +325,8 @@
(define *primitive-expand-table* (make-hash-table)) (define *primitive-expand-table* (make-hash-table))
(define (expand-primcall x) (define (expand-primcall x)
(record-case x (match x
((<primcall> src name args) (($ <primcall> src name args)
(let ((expand (hashq-ref *primitive-expand-table* name))) (let ((expand (hashq-ref *primitive-expand-table* name)))
(or (and expand (apply expand src args)) (or (and expand (apply expand src args))
x))) x)))