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

@@ -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)

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))

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)