From: Guillermo J. Rozas <edu/mit/csail/zurich/gjr>
Date: Thu, 1 Jul 1993 03:14:14 +0000 (+0000)
Subject: Teach the peephole optimizer to handle DEPI, and friends, and some
X-Git-Tag: 20090517-FFI~8241
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=e5fd07a063f3ce6f05536981d872d01d95d4f34e;p=mit-scheme.git

Teach the peephole optimizer to handle DEPI, and friends, and some
FLOPs.
---

diff --git a/v7/src/compiler/machines/spectrum/lapopt.scm b/v7/src/compiler/machines/spectrum/lapopt.scm
index 1582af004..6dcb63635 100644
--- a/v7/src/compiler/machines/spectrum/lapopt.scm
+++ b/v7/src/compiler/machines/spectrum/lapopt.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: lapopt.scm,v 1.12 1993/06/25 22:56:49 gjr Exp $
+$Id: lapopt.scm,v 1.13 1993/07/01 03:14:14 gjr Exp $
 
 Copyright (c) 1991-1993 Massachusetts Institute of Technology
 
@@ -39,6 +39,10 @@ MIT in each case. |#
 
 ;;;; An instruction classifier and decomposer
 
+(define-integrable (float-reg reg)
+  reg					; ignore
+  (+ 32 reg))
+
 (define (classify-instruction instr)
   ;; returns: type target source-1 source-2 offset
   ;; This needs the following:
@@ -115,6 +119,50 @@ MIT in each case. |#
 		   false))
 	  ((memq opcode '(NOP))
 	   (values 'ALU false false false false))
+	  ((memq opcode '(VDEPI DEPI ZVDEPI ZDEPI))
+	   (values 'ALU
+		   (car (last-pair instr))
+		   false
+		   false
+		   false))
+	  ((memq opcode '(EXTRU EXTRS DEP ZDEP))
+	   (values 'ALU
+		   (list-ref instr 5)
+		   (list-ref instr 2)
+		   false
+		   false))
+	  ((memq opcode '(VEXTRU VEXTRS VDEP ZVDEP))
+	   (values 'ALU
+		   (list-ref instr 4)
+		   (list-ref instr 2)
+		   false
+		   false))
+	  ((memq opcode '(FCPY FABS FSQRT FRND))
+	   ;; source target
+	   (values 'FALU
+		   (float-reg (list-ref instr 3))
+		   (float-reg (list-ref instr 2))
+		   false
+		   false))
+	  ((memq opcode '(FADD FSUB FMPY FDIV FREM))
+	   ;; source1 source2 target
+	   (values 'FALU
+		   (float-reg (list-ref instr 4))
+		   (float-reg (list-ref instr 2))
+		   (float-reg (list-ref instr 3))
+		   false))
+	  ((eq? opcode 'FSTDS)
+	   ;; source (offset n m base)
+	   (let* ((offset (list-ref instr 3))
+		  (base (cadddr offset)))
+	     (values 'MEMORY
+		     (and (or (memq 'MA (cadr instr))
+			      (memq 'MB (cadr instr)))
+			  base)
+		     base
+		     (float-reg (list-ref instr 2))
+		     (cadr offset))))
+
 	  #|
 	  ((memq opcode '(B BL GATE))
 	   <>)
@@ -199,7 +247,9 @@ MIT in each case. |#
   ;; (COMBT (<) ...)
   (and (pair? (cadr instr))
        (not (memq (car instr)
-		  '(B BL BV BLR BLE BE)))))
+		  '(B BL BV BLR BLE BE)))
+       ;; or SGL, or QUAD, but not used now.
+       (not (memq 'DBL (cadr instr)))))
 
 (define (find-or-label instrs)
   (and (not (null? instrs))
@@ -281,7 +331,8 @@ MIT in each case. |#
 	   (with-values
 	       (lambda () (classify-instruction (car next)))
 	     (lambda (type target src1 src2 offset)
-	       (if (or (not (memq type '(MEMORY ALU)))
+	       offset			; ignored
+	       (if (or (not (memq type '(MEMORY ALU FALU)))
 		       (eq? target regnum:stack-pointer))
 		   (values (fix-simple-return ret frame junk)
 			   rest)
@@ -373,7 +424,8 @@ MIT in each case. |#
     (if (and instr
 	     (with-values (lambda () (classify-instruction instr))
 	       (lambda (type tgt src1 src2 offset)
-		 (or (eq? type 'ALU)
+		 tgt src1 src2		; ignored
+		 (or (memq type '(ALU FALU))
 		     (and (eq? type 'MEMORY)
 			  (offset-fits? offset (car instr))))))
 	     (not (skips? instr))