From 9f2da346bb56bce5f12a2438021362c4fa51dbe3 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= <daniel@turtleware.eu>
Date: Mon, 11 Sep 2023 13:00:38 +0200
Subject: [PATCH] cmp: fcall: more through type propagation

We do the type propagation in the appropriate pass and in order. We also ensure
that all arguments have the type propagated and (when applicable) narrowed.
---
 src/cmp/cmppass1-call.lsp | 37 +++++++++++--------------------------
 src/cmp/cmpprop.lsp       | 24 +++++++++++++++++++++++-
 src/cmp/cmptype.lsp       | 10 ++++++++--
 3 files changed, 42 insertions(+), 29 deletions(-)

diff --git a/src/cmp/cmppass1-call.lsp b/src/cmp/cmppass1-call.lsp
index c188cee64..30c750e5f 100644
--- a/src/cmp/cmppass1-call.lsp
+++ b/src/cmp/cmppass1-call.lsp
@@ -12,8 +12,10 @@
 (defun unoptimized-funcall (fun arguments)
   (let ((fun-form (c1expr fun))
         (fun-args (c1args* arguments)))
-    (make-c1form* 'FCALL :sp-change t :side-effects t
-                         :args fun-form fun-args nil :unknown)))
+    (make-c1form* 'FCALL
+                  :sp-change t
+                  :side-effects t
+                  :args fun-form fun-args nil :unknown)))
 
 (defun optimized-lambda-call (lambda-form arguments apply-p)
   (multiple-value-bind (bindings body)
@@ -89,7 +91,8 @@
     ;; More complicated case.
     (t
      (make-c1form* 'MCALL
-                   :sp-change t :side-effects t
+                   :sp-change t
+                   :side-effects t
                    :args (c1expr (first args)) (c1args* (rest args))))))
 
 (defun c1apply (args)
@@ -172,25 +175,10 @@
                (declared-inline-p fname)
                (plusp *inline-max-depth*))
       (return-from c1call-local (inline-local lambda fun args))))
-  (let* ((forms (c1args* args))
-         (return-type (or (get-local-return-type fun) 'T))
-         (arg-types (get-local-arg-types fun)))
-    ;; Add type information to the arguments.
-    (when arg-types
-      (let ((fl nil))
-        (dolist (form forms)
-          (cond ((endp arg-types) (push form fl))
-                (t (push (and-form-type (car arg-types) form (car args)
-                                        :safe "In a call to ~a" fname)
-                         fl)
-                   (pop arg-types)
-                   (pop args))))
-        (setq forms (nreverse fl))))
-    (make-c1form* 'FCALL
-                  :sp-change t ; conservative estimate
-                  :side-effects t ; conservative estimate
-                  :type return-type
-                  :args (c1expr `(function ,fname)) forms fun :local)))
+  (make-c1form* 'FCALL
+                :sp-change t ; conservative estimate
+                :side-effects t ; conservative estimate
+                :args (c1expr `(function ,fname)) (c1args* args) fun :local))
 
 (defun c1call-global (fname args)
   (let* ((forms (c1args* args)))
@@ -204,10 +192,7 @@
     (make-c1form* 'FCALL
                   :sp-change (function-may-change-sp fname)
                   :side-effects (function-may-have-side-effects fname)
-                  :type (propagate-types fname forms)
-                  :args (c1expr `(function ,fname)) forms fname :global
-                  ;; loc and type are filled by c2expr
-                  )))
+                  :args (c1expr `(function ,fname)) forms fname :global)))
 
 (defun c1call-constant-fold (fname forms)
   (when (and (si:get-sysprop fname 'pure)
diff --git a/src/cmp/cmpprop.lsp b/src/cmp/cmpprop.lsp
index 4b478ef52..843534154 100644
--- a/src/cmp/cmpprop.lsp
+++ b/src/cmp/cmpprop.lsp
@@ -91,7 +91,29 @@
     values-type))
 
 (defun p1fcall (c1form fun args fun-val call-type)
-  (p1trivial c1form fun args fun-val call-type))
+  (declare (ignore fun))
+  (p1propagate fun)
+  (p1propagate-list args)
+  (ecase call-type
+    (:global
+     (propagate-types fun-val args))
+    (:local
+     (flet ((and-form-type (type form)
+              (and-form-type type form (c1form-form form)
+                             :safe "In a call to ~a" (fun-name fun-val))))
+       (loop with local-arg-types = (get-local-arg-types fun-val)
+             for arg-form in args
+             for arg-type = (pop local-arg-types)
+             when arg-type
+               do (and-form-type arg-type arg-form)
+             do (p1propagate arg-form))
+       (let ((dcl-return (or (get-local-return-type fun-val) '(VALUES &REST T)))
+             (fun-return (fun-return-type fun-val)))
+         (and-call-type dcl-return c1form)
+         (and-call-type fun-return c1form)
+         (p1trivial c1form))))
+    (:unknown
+     (p1trivial c1form))))
 
 (defun p1catch (c1form tag body)
   (declare (ignore c1form))
diff --git a/src/cmp/cmptype.lsp b/src/cmp/cmptype.lsp
index 155a0b02a..7fe8c6598 100644
--- a/src/cmp/cmptype.lsp
+++ b/src/cmp/cmptype.lsp
@@ -18,8 +18,7 @@
 
 ;;;
 ;;; and-form-type
-;;;   returns a copy of form whose type is the type-and of type and the form's
-;;;   type
+;;;   updates the FORM type to its intersection with TYPE
 ;;;
 (defun and-form-type (type form original-form &optional (mode :safe)
                       (format-string "") &rest format-args)
@@ -33,6 +32,13 @@
                  format-args original-form type2 type))
     form))
 
+;;;
+;;; and-call-type
+;;;   updates the FORM type to its many-values intersection with TYPE
+;;; 
+(defun and-call-type (type form)
+  (setf (c1form-type form) (values-type-and type (c1form-type form))))
+
 (defun default-init (var &optional warn)
   (declare (ignore warn))
   (let ((new-value (cdr (assoc (var-type var)