Simplified c2call-global by taking the type propagation for (SETF AREF)/AREF into separate functions

src/cmp/cmpcall.lsp

@@ -89,55 +89,18 @@
 ;;;   ARGS is the list of arguments
 ;;;   LOC is either NIL or the location of the function object
 ;;;
-(defun c2call-global (fname args loc return-type)
-  (case fname
-    (AREF
-     (let (etype (elttype (c1form-primary-type (car args))))
-       (when (or (and (eq elttype 'STRING)
-		      (setq elttype 'CHARACTER))
-		 (and (consp elttype)
-		      (or (eq (car elttype) 'ARRAY)
-			  (eq (car elttype) 'VECTOR))
-		      (setq elttype (second elttype))))
-	 (setq etype (type-and return-type elttype))
-	 (unless etype
-	   (cmpwarn "Type mismatch found in AREF. Expected output type ~s, array element type ~s." return-type elttype)
-	   (setq etype T))		; assume no information
-	 (setf return-type etype))))
-    (SYS:ASET				; (sys:aset value array i0 ... in)
-     (let (etype
-	   (valtype (c1form-primary-type (first args)))
-	   (elttype (c1form-primary-type (second args))))
-       (when (or (and (eq elttype 'STRING)
-		      (setq elttype 'CHARACTER))
-		 (and (consp elttype)
-		      (or (eq (car elttype) 'ARRAY)
-			  (eq (car elttype) 'VECTOR))
-		      (setq elttype (second elttype))))
-	 (setq etype (type-and return-type (type-and valtype elttype)))
-	 (unless etype
-	   (cmpwarn "Type mismatch found in (SETF AREF). Expected output type ~s, array element type ~s, value type ~s." return-type elttype valtype)
-	   (setq etype T))
-	 (setf return-type etype)
-	 (setf (c1form-type (first args)) etype)))))
-  (when (null loc)
-    (let ((fun (find fname *global-funs* :key #'fun-name :test #'same-fname-p)))
-      (when fun
-	(when (c2try-tail-recursive-call fun args)
-	  (return-from c2call-global))
-	(setf loc fun))))
-  (let ((*inline-blocks* 0))
-    (call-global fname loc (inline-args args) return-type)
-    (close-inline-blocks)))
+(defun c2call-global (fname args &optional (return-type (destination-type)))
+  (let ((fun (find fname *global-funs* :key #'fun-name :test #'same-fname-p)))
+    (when (and fun (c2try-tail-recursive-call fun args))
+      (return-from c2call-global))
+    (let ((*inline-blocks* 0))
+      (unwind-exit (call-global-loc fname fun (inline-args args) return-type))
+      (close-inline-blocks))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;
 ;;; CALL LOCATIONS
 ;;;
-
-(defun call-global (&rest args)
-  (unwind-exit (apply #'call-global-loc args)))
-
 ;;;
 ;;; call-global:
 ;;;   FNAME: the name of the function
@@ -145,29 +108,29 @@
 ;;;   ARGS: a list of typed locs with arguments
 ;;;   RETURN-TYPE: the type to which the output is coerced
 ;;;
-(defun call-global-loc (fname loc args return-type &aux found fd minarg maxarg)
+(defun call-global-loc (fname fun args return-type &aux loc found fd minarg maxarg)
   (cond
     ;; Check whether it is a global function that we cannot call directly.
-     ((and (or (null loc) (fun-global loc)) (not (inline-possible fname)))
+     ((and (or (null fun) (fun-global fun)) (not (inline-possible fname)))
       (call-unknown-global-loc fname nil args))
 
      ;; Open-codable function call.
-     ((and (or (null loc) (fun-global loc))
+     ((and (or (null fun) (fun-global fun))
 	   (setq loc (inline-function fname args return-type)))
       loc)
 
      ;; Call to a function defined in the same file. Direct calls are
      ;; only emitted for low or neutral values of DEBUG is >= 2.
      ((and (<= (cmp-env-optimization 'debug) 1)
-	   (or (fun-p loc)
-	       (and (null loc)
-		    (setf loc (find fname *global-funs* :test #'same-fname-p
+	   (or (fun-p fun)
+	       (and (null fun)
+		    (setf fun (find fname *global-funs* :test #'same-fname-p
 				      :key #'fun-name)))))
-      (call-loc fname loc args))
+      (call-loc fname fun args))
 
      ;; Call to a global (SETF ...) function
      ((not (symbolp fname))
-      (call-unknown-global-loc fname loc args))
+      (call-unknown-global-loc fname fun args))
 
      ;; Call to a function whose C language function name is known,
      ;; either because it has been proclaimed so, or because it belongs
@@ -182,7 +145,7 @@
      ((multiple-value-setq (found fd minarg maxarg) (si::mangle-name fname t))
       (call-exported-function-loc fname args fd minarg maxarg t))
 
-     (t (call-unknown-global-loc fname loc args))))
+     (t (call-unknown-global-loc fname fun args))))
 
 (defun call-loc (fname fun args)
   `(CALL-NORMAL ,fun ,(coerce-locs args)))

src/cmp/cmpeval.lsp

@@ -109,15 +109,15 @@
                            ;; loc and type are filled by c2expr
                            ))))))
 
-(defun c2expr (form &aux (name (c1form-name form)) (args (c1form-args form)))
-  (if (eq name 'CALL-GLOBAL)
-      (c2call-global (first args) (second args) nil (destination-type))
-      (let ((dispatch (get-sysprop name 'C2)))
-	(if (or (eq name 'LET) (eq name 'LET*))
-	    (let ((*volatile* (c1form-volatile* form)))
-	      (declare (special *volatile*))
-	      (apply dispatch args))
-	    (apply dispatch args)))))
+(defun c2expr (form)
+  (let* ((name (c1form-name form))
+         (args (c1form-args form))
+         (dispatch (get-sysprop name 'C2)))
+    (if (or (eq name 'LET) (eq name 'LET*))
+        (let ((*volatile* (c1form-volatile* form)))
+          (declare (special *volatile*))
+          (apply dispatch args))
+        (apply dispatch args))))
 
 (defun c2expr* (form)
   (let* ((*exit* (next-label))

src/cmp/cmpfun.lsp

@@ -49,11 +49,11 @@
 			     (t (wt char)))))
 		(wt "\"," stream-var ");")))
 	 (unwind-exit nil))
-	((eql string #\Newline) (c2call-global 'TERPRI (list stream) nil t))
-	(t (c2call-global
-	    'PRINC
-	    (list (make-c1form 'LOCATION *info* (add-object string))
-		  stream) nil t))))
+	((eql string #\Newline) (c2call-global 'TERPRI (list stream) t))
+	(t (c2call-global 'PRINC
+                          (list (make-c1form 'LOCATION *info* (add-object string))
+                                stream)
+                          t))))
 
 (defun c1terpri (args &aux stream)
   (check-args-number 'TERPRI args 0 1)

src/cmp/cmpinline.lsp

@@ -96,7 +96,7 @@
 		      (*lcl* *lcl*)
 		      (*temp* *temp*)
 		      (*destination* temp))
-		 (call-global fname nil arg-locs return-type)
+		 (unwind-exit (call-global-loc fname nil arg-locs return-type))
 		 (wt-label *exit*)
 		 (push
 		  (list (if (subtypep 'T return-type)

src/cmp/cmpprop.lsp

@@ -0,0 +1,46 @@
+;;;;  -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*-
+;;;;
+;;;;  Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya.
+;;;;  Copyright (c) 1990, Giuseppe Attardi.
+;;;;
+;;;;    This program is free software; you can redistribute it and/or
+;;;;    modify it under the terms of the GNU Library General Public
+;;;;    License as published by the Free Software Foundation; either
+;;;;    version 2 of the License, or (at your option) any later version.
+;;;;
+;;;;    See file '../Copyright' for full details.
+
+;;;; CMPPROP Type propagation.
+
+(in-package "COMPILER")
+
+(defun type-from-array-elt (array)
+  "Input is a lisp type representing a valid subtype of ARRAY. Output is
+either the array element type or NIL, denoting that we are not able to
+compute it. This version only handles the simplest cases."
+  (cond ((eq array 'string)
+         'character)
+        ((eq array 'base-string)
+         'base-char)
+        ((member array '(array vector simple-vector simple-array))
+         t)
+        ((atom array)
+         nil)
+        ((not (member (first array) '(array vector simple-vector simple-array)))
+         nil)
+        ((null (rest array))
+         t)
+        (t
+         (second array))))
+
+(def-type-propagator si::aset (fname obj array &rest indices)
+  (let* ((array-type (c1form-primary-type array))
+         (elt-type (or (type-from-array-elt array) t)))
+    (values (list* elt-type array-type (make-list (length indices) :initial-element 'si::index))
+            elt-type)))
+
+(def-type-propagator aref (fname array &rest indices)
+  (let* ((array-type (c1form-primary-type array))
+         (elt-type (or (type-from-array-elt array) t)))
+    (values (list* array-type (make-list (length indices) :initial-element 'si::index))
+            elt-type)))

src/cmp/cmptop.lsp

@@ -687,8 +687,7 @@
   (unless (and (not (fun-closure fun))
 	       (eq *destination* 'TRASH))
     (return-from c2fset
-      (c2call-global 'SI:FSET c1forms 'NIL
-		     (c1form-primary-type (second c1forms)))))
+      (c2call-global 'SI:FSET c1forms 'NIL (c1form-primary-type (second c1forms)))))
   (let ((*inline-blocks* 0)
 	(loc (data-empty-loc)))
     (push (list loc fname fun) *global-cfuns-array*)

src/cmp/cmptype.lsp

@@ -433,7 +433,7 @@
 
 (defmacro def-type-propagator (fname lambda-list &body body)
   `(put-sysprop ',fname 'C1TYPE-PROPAGATOR
-    #'(ext:lambda-block ,fname ,lambda-list ,body)))
+    #'(ext:lambda-block ,fname ,lambda-list ,@body)))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;

src/cmp/load.lsp.in

@@ -33,6 +33,7 @@
   "src:cmp;cmpnum.lsp"
   "src:cmp;cmpname.lsp"
   "src:cmp;cmpopt.lsp"
+  "src:cmp;cmpprop.lsp"
   "src:cmp;cmpclos.lsp"
   "src:cmp;cmpstructures.lsp"
   "src:cmp;cmparray.lsp"