Remove old optimizer for rplacd. Added type propagators for PROGV, WITH-STACKS, STACK-PUSH-VALUES, PSETQ, STRUCTURE-SET

src/cmp/cmpfun.lsp

@@ -87,23 +87,6 @@
 	  (t
 	   (c1funcall (list* '#'APPLY args))))))
 
-(defun c1rplacd (args)
-  (check-args-number 'RPLACD args 2 2)
-  (make-c1form* 'RPLACD :args (c1args* args)))
-
-(defun c2rplacd (args)
-  (let* ((*inline-blocks* 0)
-         (*temp* *temp*)
-         (args (coerce-locs (inline-args args)))
-         (x (first args))
-         (y (second args)))
-    (when (safe-compile)
-      (wt-nl "if (ecl_unlikely(ATOM(" x ")))"
-             "FEtype_error_cons(" x ");"))
-    (wt-nl "ECL_CONS_CDR(" x ") = " y ";")
-    (unwind-exit x)
-    (close-inline-blocks)))
-
 ;;----------------------------------------------------------------------
 ;; We transform BOOLE into the individual operations, which have
 ;; inliners

src/cmp/cmpprop.lsp

@@ -234,12 +234,38 @@ of the occurrences in those lists."
 (defun p1progn (c1form assumptions forms)
   (p1propagate-list forms assumptions))
 
+(defun p1progv (c1form assumptions variables values body)
+  (let (type)
+    (multiple-value-setq (type assumptions)
+      (p1propagate variables assumptions))
+    (multiple-value-setq (type assumptions)
+      (p1propagate values assumptions))
+    (p1propagate body assumptions)))
+
 (defun p1setq (c1form assumptions var c1form)
   (multiple-value-bind (value-type assumptions)
       (p1propagate c1form assumptions)
     (values (type-and (var-type var) (values-type-primary-type value-type))
 	    assumptions)))
 
+(defun p1psetq (c1form assumptions vars c1forms)
+  (loop for variable in vars
+     for new-type in (loop with new-type
+                        for form in c1forms
+                        do (multiple-value-setq (new-type assumptions)
+                             (p1propagate form assumptions))
+                        collect new-type)
+     do (type-and (var-type variable) new-type))
+  (values 'null assumptions))
+
+(defun p1with-stack (c1form assumptions body)
+  (p1propagate body assumptions))
+
+(defun p1stack-push-values (c1form assumptions form inline)
+  (multiple-value-bind (form-type assumptions)
+      (p1propagate form assumptions)
+    (values nil assumptions)))
+
 (defvar *tagbody-depth* -1
   "If n > 0, limit the number of passes to converge tagbody forms. If
 -1, let the compiler do as many passes as it wishes. Complexity grows
@@ -282,6 +308,14 @@ as 2^*tagbody-limit* in the worst cases.")
     (p1propagate body assumptions)
     (values output-type assumptions)))
 
+(defun p1structure-set (c1form assumptions structure symbol vv-index value)
+  (multiple-value-bind (structure-type assumptions)
+      (p1propagate structure assumptions)
+    (multiple-value-bind (slot-type assumptions)
+        (p1propagate value assumptions)
+      (let ((old-slot-type (c1form-primary-type c1form)))
+        (values (type-and old-slot-type slot-type) assumptions)))))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (defun type-from-array-elt (array &aux name)

src/cmp/cmptables.lsp

@@ -78,7 +78,6 @@
     (princ . c1princ) ; c1
     (terpri . c1terpri) ; c1
     (apply . c1apply) ; c1
-    (rplacd . c1rplacd) ; c1
     ))
 
 (defconstant +t1-dispatch-alist+
@@ -186,7 +185,6 @@
     (sys:structure-set . c2structure-set) ; c2
 
     (c2princ . c2princ) ; c2
-    (rplacd . c2rplacd) ; c2
     ))
 
 (defconstant +t2-dispatch-alist+
@@ -215,7 +213,9 @@
     (multiple-value-bind . p1multiple-value-bind)
     (multiple-value-setq . p1multiple-value-setq)
     (progn . p1progn)
+    (progv . p1progv)
     (setq . p1setq)
+    (psetq . p1psetq)
     (tagbody . p1tagbody)
     (go . p1go)
     (unwind-protect . p1unwind-protect)
@@ -228,6 +228,9 @@
     (function . p1trivial)
     (funcall . p1trivial)
     (load-time-value . p1trivial)
+    (c::with-stack . p1with-stack)
+    (c::stack-push-values . p1stack-push-values)
+    (c::structure-set . p1structure-set)
     ))
 
 (defun make-dispatch-table (alist)