[Guile-commits] 01/07: Excise use of `record-case`

[Andy Wingo]

wingo pushed a commit to branch wip-tailify
in repository guile.

commit b0a390db065961f8b2c1ebecb1299cfc0dacfda3
Author: Andy Wingo <wingo@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)))