wingo pushed a commit to branch wip-tailify in repository guile. commit b0a390db065961f8b2c1ebecb1299cfc0dacfda3 Author: Andy Wingo <wi...@pobox.com> AuthorDate: Tue Mar 28 16:33:24 2023 +0200
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. --- module/language/tree-il/analyze.scm | 154 ++++++++++++++++----------------- module/language/tree-il/fix-letrec.scm | 42 ++++----- module/language/tree-il/primitives.scm | 23 ++--- 3 files changed, 106 insertions(+), 113 deletions(-) diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm index c259b27ae..c2d1f992e 100644 --- a/module/language/tree-il/analyze.scm +++ b/module/language/tree-il/analyze.scm @@ -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 diff --git a/module/language/tree-il/fix-letrec.scm b/module/language/tree-il/fix-letrec.scm index 12c1d500a..c1e399d59 100644 --- a/module/language/tree-il/fix-letrec.scm +++ b/module/language/tree-il/fix-letrec.scm @@ -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))) diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm index 1d85c0624..ef883ec9c 100644 --- a/module/language/tree-il/primitives.scm +++ b/module/language/tree-il/primitives.scm @@ -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)))