mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-29 22:40:34 +02:00
Excise use of record-case
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
parent
a3173e084e
commit
b0a390db06
3 changed files with 106 additions and 113 deletions
|
|
@ -122,24 +122,24 @@ given `tree-il' element."
|
|||
inner-vars
|
||||
inner-names))
|
||||
|
||||
(record-case x
|
||||
((<lexical-ref> gensym)
|
||||
(match x
|
||||
(($ <lexical-ref> src name gensym)
|
||||
(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)))
|
||||
((<lambda-case> req opt inits rest kw gensyms)
|
||||
(($ <lambda-case> src req opt rest kw inits gensyms body alt)
|
||||
(let ((names `(,@req
|
||||
,@(or opt '())
|
||||
,@(if rest (list rest) '())
|
||||
,@(if kw (map cadr (cdr kw)) '()))))
|
||||
(make-binding-info (extend gensyms names) refs)))
|
||||
((<let> gensyms names)
|
||||
(($ <let> src names gensyms)
|
||||
(make-binding-info (extend gensyms names) refs))
|
||||
((<letrec> gensyms names)
|
||||
(($ <letrec> src in-order? names gensyms)
|
||||
(make-binding-info (extend gensyms names) refs))
|
||||
((<fix> gensyms names)
|
||||
(($ <fix> src names gensyms)
|
||||
(make-binding-info (extend gensyms names) refs))
|
||||
(else info))))
|
||||
(_ info))))
|
||||
|
||||
(lambda (x info env locs)
|
||||
;; 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.
|
||||
;; It doesn't hurt as these are unique names, it just
|
||||
;; makes REFS unnecessarily fat.
|
||||
(record-case x
|
||||
((<lambda-case> gensyms)
|
||||
(match x
|
||||
(($ <lambda-case> src req opt rest kw inits gensyms)
|
||||
(make-binding-info (shrink gensyms refs) refs))
|
||||
((<let> gensyms)
|
||||
(($ <let> src names gensyms)
|
||||
(make-binding-info (shrink gensyms refs) refs))
|
||||
((<letrec> gensyms)
|
||||
(($ <letrec> src in-order? names gensyms)
|
||||
(make-binding-info (shrink gensyms refs) refs))
|
||||
((<fix> gensyms)
|
||||
(($ <fix> src names gensyms)
|
||||
(make-binding-info (shrink gensyms refs) refs))
|
||||
(else info))))
|
||||
(_ info))))
|
||||
|
||||
(lambda (result env) #t)
|
||||
(make-binding-info vlist-null vlist-null)))
|
||||
|
|
@ -278,26 +278,26 @@ given `tree-il' element."
|
|||
(let ((ctx (reference-graph-toplevel-context graph))
|
||||
(refs (reference-graph-refs graph))
|
||||
(defs (reference-graph-defs graph)))
|
||||
(record-case x
|
||||
((<toplevel-ref> name src)
|
||||
(match x
|
||||
(($ <toplevel-ref> src mod name)
|
||||
(add-ref-from-context graph name))
|
||||
((<toplevel-define> name src)
|
||||
(($ <toplevel-define> src mod name expr)
|
||||
(let ((refs refs)
|
||||
(defs (vhash-consq name (or src (find pair? locs))
|
||||
defs)))
|
||||
(make-reference-graph refs defs name)))
|
||||
((<toplevel-set> name src)
|
||||
(($ <toplevel-set> src mod name expr)
|
||||
(add-ref-from-context graph name))
|
||||
(else graph))))
|
||||
(_ graph))))
|
||||
|
||||
(lambda (x graph env locs)
|
||||
;; Leaving X's scope.
|
||||
(record-case x
|
||||
((<toplevel-define>)
|
||||
(match x
|
||||
(($ <toplevel-define>)
|
||||
(let ((refs (reference-graph-refs graph))
|
||||
(defs (reference-graph-defs graph)))
|
||||
(make-reference-graph refs defs #f)))
|
||||
(else graph)))
|
||||
(_ graph)))
|
||||
|
||||
(lambda (graph env)
|
||||
;; Process the resulting reference graph: determine all private definitions
|
||||
|
|
@ -494,16 +494,16 @@ given `tree-il' element."
|
|||
(make-tree-analysis
|
||||
(lambda (x defs env locs)
|
||||
;; Going down into X.
|
||||
(record-case x
|
||||
((<toplevel-define> name)
|
||||
(match (vhash-assq name defs)
|
||||
((_ . previous-definition)
|
||||
(warning 'shadowed-toplevel (tree-il-src x) name
|
||||
(tree-il-src previous-definition))
|
||||
defs)
|
||||
(#f
|
||||
(vhash-consq name x defs))))
|
||||
(else defs)))
|
||||
(match x
|
||||
(($ <toplevel-define> src mod name expr)
|
||||
(match (vhash-assq name defs)
|
||||
((_ . previous-definition)
|
||||
(warning 'shadowed-toplevel src name
|
||||
(tree-il-src previous-definition))
|
||||
defs)
|
||||
(#f
|
||||
(vhash-consq name x defs))))
|
||||
(else defs)))
|
||||
|
||||
(lambda (x defs env locs)
|
||||
;; Leaving X's scope.
|
||||
|
|
@ -887,16 +887,16 @@ given `tree-il' element."
|
|||
(arities '()))
|
||||
(if (not proc)
|
||||
(values name (reverse arities))
|
||||
(record-case proc
|
||||
((<lambda-case> req opt rest kw alternate)
|
||||
(loop name alternate
|
||||
(match proc
|
||||
(($ <lambda-case> src req opt rest kw inits gensyms body alt)
|
||||
(loop name alt
|
||||
(cons (list (len req) (len opt) rest
|
||||
(and (pair? kw) (map car (cdr kw)))
|
||||
(and (pair? kw) (car kw)))
|
||||
arities)))
|
||||
((<lambda> meta body)
|
||||
(($ <lambda> src meta body)
|
||||
(loop (assoc-ref meta 'name) body arities))
|
||||
(else
|
||||
(_
|
||||
(values #f #f))))))))
|
||||
|
||||
(let ((args (call-args call))
|
||||
|
|
@ -935,38 +935,38 @@ given `tree-il' element."
|
|||
(let ((toplevel-calls (toplevel-procedure-calls info))
|
||||
(lexical-lambdas (lexical-lambdas info))
|
||||
(toplevel-lambdas (toplevel-lambdas info)))
|
||||
(record-case val
|
||||
((<lambda> body)
|
||||
(match val
|
||||
(($ <lambda> src meta body)
|
||||
(make-arity-info toplevel-calls
|
||||
(vhash-consq lexical-name val
|
||||
lexical-lambdas)
|
||||
toplevel-lambdas))
|
||||
((<lexical-ref> gensym)
|
||||
(($ <lexical-ref> src name gensym)
|
||||
;; lexical alias
|
||||
(let ((val* (vhash-assq gensym lexical-lambdas)))
|
||||
(if (pair? val*)
|
||||
(extend lexical-name (cdr val*) info)
|
||||
info)))
|
||||
((<toplevel-ref> name)
|
||||
(($ <toplevel-ref> src mod name)
|
||||
;; top-level alias
|
||||
(make-arity-info toplevel-calls
|
||||
(vhash-consq lexical-name val
|
||||
lexical-lambdas)
|
||||
toplevel-lambdas))
|
||||
(else info))))
|
||||
(_ info))))
|
||||
|
||||
(let ((toplevel-calls (toplevel-procedure-calls info))
|
||||
(lexical-lambdas (lexical-lambdas info))
|
||||
(toplevel-lambdas (toplevel-lambdas info)))
|
||||
|
||||
(record-case x
|
||||
((<toplevel-define> name exp)
|
||||
(record-case exp
|
||||
((<lambda> body)
|
||||
(match x
|
||||
(($ <toplevel-define> src mod name exp)
|
||||
(match exp
|
||||
(($ <lambda> src' meta body)
|
||||
(make-arity-info toplevel-calls
|
||||
lexical-lambdas
|
||||
(vhash-consq name exp toplevel-lambdas)))
|
||||
((<toplevel-ref> name)
|
||||
(($ <toplevel-ref> src' mod name)
|
||||
;; alias for another toplevel
|
||||
(let ((proc (vhash-assq name toplevel-lambdas)))
|
||||
(make-arity-info toplevel-calls
|
||||
|
|
@ -976,41 +976,39 @@ given `tree-il' element."
|
|||
(cdr proc)
|
||||
exp)
|
||||
toplevel-lambdas))))
|
||||
(else info)))
|
||||
((<let> gensyms vals)
|
||||
(_ info)))
|
||||
(($ <let> src names gensyms vals)
|
||||
(fold extend info gensyms vals))
|
||||
((<letrec> gensyms vals)
|
||||
(($ <letrec> src in-order? names gensyms vals)
|
||||
(fold extend info gensyms vals))
|
||||
((<fix> gensyms vals)
|
||||
(($ <fix> src names gensyms vals)
|
||||
(fold extend info gensyms vals))
|
||||
|
||||
((<call> proc args src)
|
||||
(record-case proc
|
||||
((<lambda> body)
|
||||
(($ <call> src proc args)
|
||||
(match proc
|
||||
(($ <lambda> src' meta body)
|
||||
(validate-arity proc x #t)
|
||||
info)
|
||||
((<toplevel-ref> name)
|
||||
(($ <toplevel-ref> src' mod name)
|
||||
(make-arity-info (vhash-consq name x toplevel-calls)
|
||||
lexical-lambdas
|
||||
toplevel-lambdas))
|
||||
((<lexical-ref> gensym)
|
||||
(let ((proc (vhash-assq gensym lexical-lambdas)))
|
||||
(if (pair? proc)
|
||||
(record-case (cdr proc)
|
||||
((<toplevel-ref> name)
|
||||
;; alias to toplevel
|
||||
(make-arity-info (vhash-consq name x toplevel-calls)
|
||||
lexical-lambdas
|
||||
toplevel-lambdas))
|
||||
(else
|
||||
(validate-arity (cdr proc) x #t)
|
||||
info))
|
||||
|
||||
;; If GENSYM wasn't found, it may be because it's an
|
||||
;; argument of the procedure being compiled.
|
||||
info)))
|
||||
(else info)))
|
||||
(else info))))
|
||||
(($ <lexical-ref> src' name gensym)
|
||||
(match (vhash-assq gensym lexical-lambdas)
|
||||
((gensym . ($ <toplevel-ref> src'' mod name'))
|
||||
;; alias to toplevel
|
||||
(make-arity-info (vhash-consq name' x toplevel-calls)
|
||||
lexical-lambdas
|
||||
toplevel-lambdas))
|
||||
((gensym . proc)
|
||||
(validate-arity proc x #t)
|
||||
info)
|
||||
(#f
|
||||
;; If GENSYM wasn't found, it may be because it's an
|
||||
;; argument of the procedure being compiled.
|
||||
info)))
|
||||
(_ info)))
|
||||
(_ info))))
|
||||
|
||||
(lambda (x info env locs)
|
||||
;; Up from X.
|
||||
|
|
@ -1028,15 +1026,15 @@ given `tree-il' element."
|
|||
(let ((toplevel-calls (toplevel-procedure-calls info))
|
||||
(lexical-lambdas (lexical-lambdas info))
|
||||
(toplevel-lambdas (toplevel-lambdas info)))
|
||||
(record-case x
|
||||
((<let> gensyms vals)
|
||||
(match x
|
||||
(($ <let> src names gensyms vals)
|
||||
(fold shrink info gensyms vals))
|
||||
((<letrec> gensyms vals)
|
||||
(($ <letrec> src in-order? names gensyms vals)
|
||||
(fold shrink info gensyms vals))
|
||||
((<fix> gensyms vals)
|
||||
(($ <fix> src names gensyms vals)
|
||||
(fold shrink info gensyms vals))
|
||||
|
||||
(else info))))
|
||||
(_ info))))
|
||||
|
||||
(lambda (result env)
|
||||
;; Post-processing: check all top-level procedure calls that have been
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; 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
|
||||
;;;; 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
|
||||
|
||||
(define-module (language tree-il fix-letrec)
|
||||
#:use-module (system base syntax)
|
||||
#:use-module (srfi srfi-1)
|
||||
#:use-module (srfi srfi-11)
|
||||
#:use-module (ice-9 match)
|
||||
|
|
@ -39,26 +38,22 @@
|
|||
(define assigned (make-hash-table))
|
||||
;; Functional hash sets would be nice.
|
||||
(fix-fold x
|
||||
(lambda (x)
|
||||
(record-case x
|
||||
((<lexical-ref> gensym)
|
||||
(hashq-set! referenced gensym #t)
|
||||
(values))
|
||||
((<lexical-set> gensym)
|
||||
(hashq-set! assigned gensym #t)
|
||||
(values))
|
||||
(else
|
||||
(values))))
|
||||
(match-lambda
|
||||
(($ <lexical-ref> src name gensym)
|
||||
(hashq-set! referenced gensym #t)
|
||||
(values))
|
||||
(($ <lexical-set> src name gensym)
|
||||
(hashq-set! assigned gensym #t)
|
||||
(values))
|
||||
(_
|
||||
(values)))
|
||||
(lambda (x)
|
||||
(values)))
|
||||
(values referenced assigned))
|
||||
|
||||
(define (make-seq* src head tail)
|
||||
(record-case head
|
||||
((<lambda>) tail)
|
||||
((<const>) tail)
|
||||
((<lexical-ref>) tail)
|
||||
((<void>) tail)
|
||||
(match head
|
||||
((or ($ <lambda>) ($ <const>) ($ <lexical-ref>) ($ <void>)) tail)
|
||||
(else (make-seq src head tail))))
|
||||
|
||||
(define (free-variables expr cache)
|
||||
|
|
@ -291,16 +286,15 @@
|
|||
(define fv-cache (make-hash-table))
|
||||
(post-order
|
||||
(lambda (x)
|
||||
(record-case x
|
||||
|
||||
(match x
|
||||
;; Sets to unreferenced variables may be replaced by their
|
||||
;; expression, called for effect.
|
||||
((<lexical-set> gensym exp)
|
||||
(($ <lexical-set> src name gensym exp)
|
||||
(if (hashq-ref referenced gensym)
|
||||
x
|
||||
(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?
|
||||
(match (reorder-bindings (map vector names gensyms vals))
|
||||
((#(names gensyms vals) ...)
|
||||
|
|
@ -309,12 +303,12 @@
|
|||
(fix-term src #f names gensyms vals body
|
||||
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>
|
||||
(if (or-map lambda? vals)
|
||||
(fix-term src #f names gensyms vals body
|
||||
fv-cache referenced assigned)
|
||||
x))
|
||||
|
||||
(else x)))
|
||||
(_ x)))
|
||||
x)))
|
||||
|
|
|
|||
|
|
@ -283,24 +283,25 @@
|
|||
;; have the same semantics as the primitives.
|
||||
(unless (eq? mod the-root-module)
|
||||
(let collect-local-definitions ((x x))
|
||||
(record-case x
|
||||
((<toplevel-define> name)
|
||||
(match x
|
||||
(($ <toplevel-define> src mod name)
|
||||
(hashq-set! local-definitions name #t))
|
||||
((<seq> head tail)
|
||||
(($ <seq> src head tail)
|
||||
(collect-local-definitions head)
|
||||
(collect-local-definitions tail))
|
||||
(else #f))))
|
||||
(_ #f))))
|
||||
|
||||
(post-order
|
||||
(lambda (x)
|
||||
(or
|
||||
(record-case x
|
||||
((<toplevel-ref> src name)
|
||||
(match x
|
||||
;; FIXME: Use `mod' field?
|
||||
(($ <toplevel-ref> src mod* name)
|
||||
(and=> (and (not (hashq-ref local-definitions name))
|
||||
(hashq-ref *interesting-primitive-vars*
|
||||
(module-variable mod 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
|
||||
;; public refs because resolve-interface can raise errors.
|
||||
(and=> (and=> (resolve-module mod)
|
||||
|
|
@ -312,10 +313,10 @@
|
|||
(module-variable m name))
|
||||
(lambda (name)
|
||||
(make-primitive-ref src name))))))
|
||||
((<call> src proc args)
|
||||
(($ <call> src proc args)
|
||||
(and (primitive-ref? proc)
|
||||
(make-primcall src (primitive-ref-name proc) args)))
|
||||
(else #f))
|
||||
(_ #f))
|
||||
x))
|
||||
x))
|
||||
|
||||
|
|
@ -324,8 +325,8 @@
|
|||
(define *primitive-expand-table* (make-hash-table))
|
||||
|
||||
(define (expand-primcall x)
|
||||
(record-case x
|
||||
((<primcall> src name args)
|
||||
(match x
|
||||
(($ <primcall> src name args)
|
||||
(let ((expand (hashq-ref *primitive-expand-table* name)))
|
||||
(or (and expand (apply expand src args))
|
||||
x)))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue