From 04d973ac3303774c16b010436d48b431573dae89 Mon Sep 17 00:00:00 2001
From: Vincent St-Amour <stamourv@dino13.iro.umontreal.ca>
Date: Mon, 11 May 2009 16:00:36 -0400
Subject: [PATCH] Corrected shifts by multiples of 8 to conform with the new
 type system. Implemented routine-based shifting for the general case, and
 implemented the routine for 8-bit values (both left and right shift). To do
 that, support for rotation with carry was added to the code generation, along
 with some bit-oriented instructions (set, clear, toggles). Finally, a couple
 of bugs related to the rotation instructions were solved in the simulator.

---
 cfg.scm             | 98 ++++++++++++++++++++++++++++++++++++++++++-----------
 code-generation.scm | 44 ++++++++++++++++++++++++
 cte.scm             | 12 +++++--
 operators.scm       | 16 ++-------
 optimizations.scm   |  2 ++
 pic18-sim.scm       | 12 +++++--
 tests/general/vm2.c |  4 +--
 tests/math/lshift.c |  7 ++--
 tests/math/rshift.c |  8 ++---
 9 files changed, 155 insertions(+), 48 deletions(-)

diff --git a/cfg.scm b/cfg.scm
index 4060b8c..db98088 100644
--- a/cfg.scm
+++ b/cfg.scm
@@ -640,30 +640,50 @@
 	    ;; TODO for the general case, try to optimise the case where division and modulo are used together, since they are used together
 	    (error "modulo is only supported for powers of 2")))))
 
-  (define (shift id x y result)
-    (let ((bytes1 (value-bytes x))
-	  (bytes2 (value-bytes y))
-	  (bytes3 (value-bytes result))) ;; TODO not used for now, but will be once we cover all the cases
+  (define (shift id x y type result)
+    (let ((bytes1 (value-bytes (extend (expression x) type)))
+	  (bytes2 (value-bytes (extend (expression y) type)))
+	  (bytes3 (value-bytes result)))
       ;; if the second argument is a literal and a multiple of 8, we can simply
-      ;; chop bytes off or add padding to the first argument
+      ;; move the bytes around
       (let ((y0 (car bytes2)))
-	;; note: I assume that if the first byte is a literal, the others will
-	;; be as well. I doubt any other case could happen here.
 	(if (and (byte-lit? y0) (= (modulo (byte-lit-val y0) 8) 0))
-	    (let loop ((n (/ (byte-lit-val y0) 8)) ;; TODO only uses the first byte, but then again, shifting by 255 should be enough
-		       (x bytes1))
-	      (if (= n 0)
-		  (move-value (new-value x) result)
-		  (loop (- n 1)
-			(case id
-			  ((x<<y) (cons (new-byte-lit 0) x))
-			  ((x>>y) (cdr x))))))
-	    ;; TODO handle the other cases, at least the other literal cases
-	    ;; TODO for the general case, have a routine that does the loop, instead of having loops everywhere
-	    (error "shifting only implemented for literal multiples of 8")))))
+	    ;; uses only the first byte, but shifting by 255 should be enough
+	    (let ((n (/ (byte-lit-val y0) 8))
+		  (l (length bytes1))) ; same length for x and result
+	      (let loop ((i 0)
+			 (x bytes1))
+		(if (< i l)
+		    (case id
+		      ((x<<y)
+		       (move (if (< i n)
+				 (new-byte-lit 0) ; padding
+				 (car x))
+			     (list-ref bytes3 i))
+		       (loop (+ i 1) (if (< i n) x (cdr x))))
+		      ((x>>y)
+		       (move (if (<= l (+ i n))
+				 (new-byte-lit 0)
+				 (list-ref x (+ i n)))
+			     (list-ref bytes3 i))
+		       (loop (+ i 1) x))))))
+	    (let* ((lx (* 8 (length bytes1)))
+		   (op (string->symbol
+			(string-append "sh"
+				       (case id
+					 ((x<<y) "l")
+					 ((x>>y) "r"))
+				       (number->string lx))))
+		   (def-proc (car (memp (lambda (x) (eq? (def-id x) op))
+					initial-cte))))
+	      ;; TODO abstract the routine calling, since this is similar to the multiplication part
+	      (move-value (call (new-call (list x y)
+					  type
+					  def-proc))
+			  result))))))
 
   ;; bitwise and, or, xor
-  ;; TODO similar to add-sub and probably others, abstract multi-byte operations
+  ;; TODO similar to add-sub and probably others, abstract multi-byte ops
   (define (bitwise id value1 value2 result)
     (let loop ((bytes1 (value-bytes value1))
                (bytes2 (value-bytes value2))
@@ -812,7 +832,7 @@
 			 ((x/y)            (error "division not implemented yet")) ;; TODO optimize for powers of 2
 			 ((x%y)            (mod value-x value-y result))
 			 ((x&y |x\|y| x^y) (bitwise id value-x value-y result))
-			 ((x>>y x<<y)      (shift id value-x value-y result)))
+			 ((x>>y x<<y)      (shift id x y type result)))
 		       result))))
                 ((x=y)
                  (let* ((x       (subast1 ast))
@@ -926,6 +946,44 @@
 	   (emit (new-instr 'addc (get-register PRODH) z2 z2))
 	   (emit (new-instr 'addc z3 (new-byte-lit 0) z3))))
 	;; TODO have 16-32 and 32-32 ? needed for picobit ?
+
+	((shl8 shr8)
+	 ;; TODO loop for each, and clear the carry at each iteration
+	 (let ((x (car (get-bytes (car params))))
+	       (y (car (get-bytes (cadr params))))
+	       (z (car (value-bytes value)))
+	       (start-bb (new-bb))
+	       (loop-bb  (new-bb))
+	       (after-bb (new-bb)))
+	   (move x z)
+	   (gen-goto start-bb) ; fall through to the loop
+	   (in start-bb) ;; TODO have some hard coded cases as shortcuts for literal shifts
+	   ;; if we'd shift of 0, we're done
+	   (add-succ bb loop-bb) ; false
+	   (add-succ bb after-bb) ; true
+	   (emit (new-instr 'x==y y (new-byte-lit 0) #f))
+	   (in loop-bb) ;; TODO change the body of the loop for longer shifts FOO
+	   (emit (new-instr (case id ((shl8) 'shl) ((shr8) 'shr)) z #f z))
+	   ;; clear the carry, to avoid reinserting it in the register
+	   (emit (new-instr 'set ;; TODO set available at this level ? if so, use it also as a shortcut for some bitwise operations
+			    (get-register STATUS)
+			    (new-byte-lit 0)
+			    #f))
+	   (emit (new-instr 'sub y (new-byte-lit 1) y))
+	   (gen-goto start-bb)
+	   (in after-bb)))
+
+	((shl16)
+	 #f) ;; TODO
+
+	((shl32)
+	 #f) ;; TODO
+
+	((shr16)
+	 #f) ;; TODO
+
+	((shr32)
+	 #f) ;; TODO
 	)
       (return-with-no-new-bb proc)
       (set! current-def-proc #f)
diff --git a/code-generation.scm b/code-generation.scm
index fe7e97e..737476a 100644
--- a/code-generation.scm
+++ b/code-generation.scm
@@ -189,6 +189,18 @@
   (define (xorwf adr)
     (emit (list 'xorwf adr)))
 
+  (define (rlcf adr)
+    (emit (list 'rlcf adr)))
+  (define (rrcf adr)
+    (emit (list 'rrcf adr)))
+
+  (define (bcf adr bit)
+    (emit (list 'bcf adr bit)))
+  (define (bsf adr bit)
+    (emit (list 'bsf adr bit)))
+  (define (btf adr bit)
+    (emit (list 'btf adr bit)))
+
   (define (comf adr)
     (emit (list 'comf adr)))
   
@@ -376,6 +388,28 @@
 			      ((xor) (xorwf z))
 			      (else (error "...")))))
 
+			 ((shl shr)
+			  (let ((x (if (byte-lit? src1)
+				       (byte-lit-val src1)
+				       (byte-cell-adr src1)))
+				(z (byte-cell-adr dst)))
+			    (cond ((byte-lit? src1) (move-lit x z))
+				  ((not (= x z))    (move-reg x z)))
+			    (case (instr-id instr)
+			      ((shl) (rlcf z))
+			      ((shr) (rrcf z)))))
+
+			 ((set clear toggle)
+			  ;; bit operations
+			  (if (not (byte-lit? src2))
+			      (error "bit offset must be a literal"))
+			  (let ((x (byte-cell-adr src1))
+				(y (byte-lit-val src2)))
+			    (case (instr-id instr)
+			      ((set)    (bsf x y))
+			      ((clear)  (bcf x y))
+			      ((toggle) (btf x y)))))
+
 			 ((not)
 			  (let ((z (byte-cell-adr dst)))
 			    (if (byte-lit? src1)
@@ -493,6 +527,16 @@
        (iorwf (cadr instr)))
       ((xorwf)
        (xorwf (cadr instr)))
+      ((rlcf)
+       (rlcf (cadr instr)))
+      ((rrcf)
+       (rrcf (cadr instr)))
+      ((bcf)
+       (bcf (cadr instr) (caddr instr)))
+      ((bsf)
+       (bsf (cadr instr) (caddr instr)))
+      ((btf)
+       (btf (cadr instr) (caddr instr)))
       ((comf)
        (comf (cadr instr)))
       ((cpfseq)
diff --git a/cte.scm b/cte.scm
index 80f86a7..202a328 100644
--- a/cte.scm
+++ b/cte.scm
@@ -63,10 +63,16 @@
    (predefine-var 'SIXPIC_FSR1 'int16 (list FSR1L FSR1H))
    (predefine-var 'SIXPIC_FSR2 'int16 (list FSR2L FSR2H))
 	
-   ;; for multiplication
-   (predefine-routine 'mul8_8   'int16 '(byte  byte))
-   (predefine-routine 'mul16_8  'int24 '(int16 byte))
+   (predefine-routine 'mul8_8   'int16 '(int8  int8))
+   (predefine-routine 'mul16_8  'int24 '(int16 int8))
    (predefine-routine 'mul16_16 'int32 '(int16 int16))
+
+   (predefine-routine 'shl8  'int8 '(int8  int8))
+   (predefine-routine 'shl16 'int8 '(int16 int8))
+   (predefine-routine 'shl32 'int8 '(int32 int8))
+   (predefine-routine 'shr8  'int8 '(int8  int8))
+   (predefine-routine 'shr16 'int8 '(int16 int8))
+   (predefine-routine 'shr32 'int8 '(int32 int8))   
    ))
 
 (define (cte-extend cte bindings)
diff --git a/operators.scm b/operators.scm
index 3c9460a..daa9feb 100644
--- a/operators.scm
+++ b/operators.scm
@@ -153,26 +153,14 @@
 
 ;; TODO check with the C standard for the next 2
 (define-op2 'six.x<<y 'x<<y
-  (lambda (ast)
-    (if (not (literal? (subast2 ast)))
-	(error "only shifting by literals is supported"))
-    (let ((l1 (type->bytes (expr-type (subast1 ast))))
-	  (v2 (literal-val (subast2 ast))))
-      ;; we might have to add some bytes to the result
-      (bytes->type (+ l1 (ceiling (/ v2 8))))))
+  type-rule-int-op2
   (lambda (ast)
     ast)
   (lambda (ast)
     ...))
 
 (define-op2 'six.x>>y 'x>>y
-  (lambda (ast)
-    (if (not (literal? (subast2 ast)))
-	(error "only shifting by literals is supported"))
-    (let ((l1 (type->bytes (expr-type (subast1 ast))))
-	  (v2 (literal-val (subast2 ast))))
-      ;; we might be able to shave some bytes off
-      (bytes->type (- l1 (floor (/ v2 8))))))
+  type-rule-int-op2
   (lambda (ast)
     ast)
   (lambda (ast)
diff --git a/optimizations.scm b/optimizations.scm
index 410362a..32bbfde 100644
--- a/optimizations.scm
+++ b/optimizations.scm
@@ -163,6 +163,8 @@
     ;; and keep everything after
     (let loop ((instrs (reverse (bb-rev-instrs bb)))
 	       (new-instrs '()))
+      (if (null? instrs)
+	  (error "no jump in the bb:" bb))
       (let* ((head (car instrs))
 	     (op   (instr-id head)))
 	(if (or (eq? op 'return)
diff --git a/pic18-sim.scm b/pic18-sim.scm
index 41a93a3..f3012e9 100644
--- a/pic18-sim.scm
+++ b/pic18-sim.scm
@@ -556,8 +556,11 @@
 (decode-opcode #b001101 10
   (lambda (opcode)
     (byte-oriented opcode "rlcf" 'c-z-n
-     (lambda (f)
-       (+ (arithmetic-shift f 1) (carry))))))
+     (lambda (f) ;; TODO didn't set the carry before
+       (let ((r (+ (arithmetic-shift f 1) (carry))))
+	 ;; roll through the carry
+	 (if (> f #x7f) (set-carry-flag 1))
+	 r)))))
 
 (decode-opcode #b010001 10
   (lambda (opcode)
@@ -569,7 +572,10 @@
   (lambda (opcode)
     (byte-oriented opcode "rrcf" 'c-z-n
      (lambda (f)
-       (+ (arithmetic-shift f -1) (arithmetic-shift (carry) 7))))))
+       (let ((r (+ (arithmetic-shift f -1) (arithmetic-shift (carry) 7))))
+	 ;; roll through carry
+	 (if (= (bitwise-and f 1) 1) (set-carry-flag 1))
+	 r)))))
 
 (decode-opcode #b010000 10
   (lambda (opcode)
diff --git a/tests/general/vm2.c b/tests/general/vm2.c
index 1a1337b..2e46261 100644
--- a/tests/general/vm2.c
+++ b/tests/general/vm2.c
@@ -6,8 +6,8 @@
 byte SIXPIC_MEMORY_DIVIDE = 24;
 
 // program goes from 8 to 11
-byte pc = 8;
-byte mem = 36;
+pc = 8;
+mem = 36;
 
 byte loop = 1;
 
diff --git a/tests/math/lshift.c b/tests/math/lshift.c
index 7970a76..e275764 100644
--- a/tests/math/lshift.c
+++ b/tests/math/lshift.c
@@ -1,4 +1,7 @@
 // shift by literal multiples of 8
-byte x = 15;
+int16 x = 15;
 int16 y = x << 8;
-y + 2;
+int z = y + 2;
+z = z << 16;
+z = z + 259;
+z;
diff --git a/tests/math/rshift.c b/tests/math/rshift.c
index 4083ae0..9ee6fd6 100644
--- a/tests/math/rshift.c
+++ b/tests/math/rshift.c
@@ -1,4 +1,4 @@
-int16 x = 259;
-byte y = x >> 8;
-int16 z = x + 2;
-z;
+int x = #x01020304;
+x = x >> 16;
+x = x + #x1020;
+x;
-- 
2.11.4.GIT