From e357e00e480ac3a7e6adee1f619b14fc4af9a423 Mon Sep 17 00:00:00 2001
From: wlott <wlott>
Date: Tue, 14 Jul 1992 03:45:04 +0000
Subject: [PATCH] When the policy is either safety>speed or debug-info=3, force
 the completion of all floating point ops before going on.  Also, don't store
 the floating point value into heap floats inside the pseudo-atomic in case it
 traps.

---
 compiler/hppa/float.lisp | 39 ++++++++++++++++++++++++++-------------
 1 file changed, 26 insertions(+), 13 deletions(-)

diff --git a/compiler/hppa/float.lisp b/compiler/hppa/float.lisp
index a7cb24163..5be45a695 100644
--- a/compiler/hppa/float.lisp
+++ b/compiler/hppa/float.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/hppa/float.lisp,v 1.1 1992/07/13 03:48:23 wlott Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/hppa/float.lisp,v 1.2 1992/07/14 03:45:04 wlott Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -73,8 +73,8 @@
   (:variant-vars size type data)
   (:note "float to pointer coercion")
   (:generator 13
-    (with-fixed-allocation (y ndescr type size)
-      (inst fsts x (- (* data word-bytes) other-pointer-type) y))))
+    (with-fixed-allocation (y ndescr type size))
+    (inst fsts x (- (* data word-bytes) other-pointer-type) y)))
 
 (macrolet ((frob (name sc &rest args)
 	     `(progn
@@ -146,9 +146,12 @@
   (:note "inline float arithmetic")
   (:vop-var vop)
   (:save-p :compute-only)
+  (:node-var node)
   (:generator 0
-    (note-this-location vop :internal-error)
-    (inst fbinop operation x y r)))
+    (inst fbinop operation x y r)
+    (when (policy node (or (= debug 3) (> safety speed)))
+      (note-next-instruction vop :internal-error)
+      (inst fsts fp-single-zero-tn 0 csp-tn))))
 
 (macrolet ((frob (name sc zero-sc ptype)
 	     `(define-vop (,name float-op)
@@ -187,9 +190,12 @@
 		(:note "inline float arithmetic")
 		(:vop-var vop)
 		(:save-p :compute-only)
+		(:node-var node)
 		(:generator 1
-		  (note-this-location vop :internal-error)
-		  ,inst))))
+		  ,inst
+		  (when (policy node (or (= debug 3) (> safety speed)))
+		    (note-next-instruction vop :internal-error)
+		    (inst fsts fp-single-zero-tn 0 csp-tn))))))
   (frob abs/single-float abs single-reg single-float
     (inst funop :abs x y))
   (frob abs/double-float abs double-reg double-float
@@ -212,9 +218,9 @@
   (:vop-var vop)
   (:save-p :compute-only)
   (:generator 3
-    (note-this-location vop :internal-error)
     ;; This is the condition to nullify the branch, so it is inverted.
     (inst fcmp (if not-p condition complement) x y)
+    (note-next-instruction vop :internal-error)
     (inst ftest)
     (inst b target :nullify t)))
 
@@ -252,9 +258,12 @@
 		(:translate ,translate)
 		(:vop-var vop)
 		(:save-p :compute-only)
+		(:node-var node)
 		(:generator 2
-		  (note-this-location vop :internal-error)
-		  (inst fcnvff x y)))))
+		  (inst fcnvff x y)
+		  (when (policy node (or (= debug 3) (> safety speed)))
+		    (note-next-instruction vop :internal-error)
+		    (inst fsts fp-single-zero-tn 0 csp-tn))))))
   (frob %single-float/double-float %single-float
     double-reg double-float
     single-reg single-float)
@@ -275,6 +284,7 @@
 		(:translate ,translate)
 		(:vop-var vop)
 		(:save-p :compute-only)
+		(:node-var node)
 		(:temporary (:scs (signed-stack) :from (:argument 0))
 			    stack-temp)
 		(:temporary (:scs (single-reg) :to (:result 0) :target y)
@@ -296,8 +306,10 @@
 			  (t
 			   (inst ldo offset zero-tn index)
 			   (inst fldx index nfp fp-temp)))
-		    (note-this-location vop :internal-error)
-		    (inst fcnvxf fp-temp y))))))
+		    (inst fcnvxf fp-temp y)
+		    (when (policy node (or (= debug 3) (> safety speed)))
+		      (note-next-instruction vop :internal-error)
+		      (inst fsts fp-single-zero-tn 0 csp-tn)))))))
   (frob %single-float/signed %single-float
     single-reg single-float)
   (frob %double-float/signed %double-float
@@ -329,12 +341,13 @@
 			    (signed-stack y)
 			    (signed-reg stack-temp)))
 			 (offset (* (tn-offset stack-tn) word-bytes)))
-		    (note-this-location vop :internal-error)
 		    (inst ,inst x fp-temp)
 		    (cond ((< offset (ash 1 4))
+			   (note-next-instruction vop :internal-error)
 			   (inst fsts fp-temp offset nfp))
 			  (t
 			   (inst ldo offset zero-tn index)
+			   (note-next-instruction vop :internal-error)
 			   (inst fstx fp-temp index nfp)))
 		    (unless (eq y stack-tn)
 		      (loadw y nfp (tn-offset stack-tn))))))))
-- 
GitLab