From 20ac97795e6a345cfa135cb642aae3c2e5363548 Mon Sep 17 00:00:00 2001
From: Juan Jose Garcia Ripoll <jjgarcia@users.sourceforge.net>
Date: Wed, 9 Jan 2013 15:53:16 +0100
Subject: [PATCH] Simplified the inliners for ldb, ldb-test and mask-field
 introducing a new macro that introduces the type checks and optimizes out
 constant values.

---
 src/cmp/cmpopt-bits.lsp | 38 ++++++++++++++------------------------
 src/cmp/cmptype.lsp     | 15 +++++++++++++++
 src/cmp/sysfun.lsp      |  5 -----
 3 files changed, 29 insertions(+), 29 deletions(-)

diff --git a/src/cmp/cmpopt-bits.lsp b/src/cmp/cmpopt-bits.lsp
index 03a6cd40b..de66ade93 100644
--- a/src/cmp/cmpopt-bits.lsp
+++ b/src/cmp/cmpopt-bits.lsp
@@ -28,22 +28,10 @@
 
 (define-compiler-macro ldb (&whole whole bytespec integer)
   (if (inline-bytespec bytespec)
-      (let ((size (second bytespec))
-	    (pos (third bytespec)))
-	(cond ((and (integerp size)
-		    (integerp pos)
-		    (<= (+ size pos) #.(integer-length most-positive-fixnum))
-		    (policy-assume-right-type)
-		    (subtypep (result-type integer) 'FIXNUM))
-	       `(truly-the fixnum (ldb1 ,size ,pos ,integer)))
-	      ((or (policy-assume-right-type)
-		   (typep pos 'unsigned-byte))
-	       `(logand (lognot (ash -1 ,size)) (ash ,integer (- ,pos))))
-	      (t
-	       (with-clean-symbols (%pos)
-		 `(let ((%pos (optional-type-assertion ,pos unsigned-byte)))	     
-		    (logand (lognot (ash -1 ,size))
-			    (ash ,integer (- %pos))))))))
+      (with-clean-symbols (%pos %size)
+	`(with-let-type-check ((%size ,(second bytespec) unsigned-byte)
+			       (%pos ,(third bytespec) unsigned-byte))
+	   (logand (lognot (ash -1 %size)) (ash ,integer (- %pos)))))
       whole))
 
 (define-compiler-macro ldb-test (&whole whole bytespec integer)
@@ -53,11 +41,11 @@
 
 (define-compiler-macro mask-field (&whole whole bytespec integer)
   (if (inline-bytespec bytespec)
-      (let ((size (second bytespec))
-	    (pos (third bytespec)))
-	`(logand (ash (lognot (ash -1 ,size))
-		      (optional-type-check ,pos unsigned-byte))
-		 ,integer))
+      (with-clean-symbols (%pos %size)
+	`(with-let-type-check ((%size ,(second bytespec) unsigned-byte)
+			       (%pos ,(third bytespec) unsigned-byte))
+	   (logand (ash (lognot (ash -1 %size)) %pos)
+		   ,integer)))
       whole))
 
 #+(or)
@@ -65,9 +53,11 @@
   (if (inline-bytespec bytespec)
       (let ((size (second bytespec))
 	    (pos (third bytespec)))
-	`(logand (ash (lognot (ash -1 ,size))
-		      (optional-type-assertion ,pos unsigned-byte))
-		 ,integer))
+	(with-clean-symbols (%pos %size)
+	  `(with-let-type-check ((%size ,(second bytespec) unsigned-byte)
+				 (%pos ,(third bytespec) unsigned-byte))
+	     (logand (ash (lognot (ash -1 %size)) %pos)
+		     ,integer))))
       whole))
 
 ;;;
diff --git a/src/cmp/cmptype.lsp b/src/cmp/cmptype.lsp
index d2017067a..df232a642 100644
--- a/src/cmp/cmptype.lsp
+++ b/src/cmp/cmptype.lsp
@@ -204,3 +204,18 @@
       value
       `(assert-type-if-known ,value ,type)))
 
+(defmacro with-let-type-check (triplets &body body &environment env)
+  (flet ((wrap (let-or-macro var value body)
+	   `(,let-or-macro ((,var ',value))
+	      ,body)))
+    (loop with body = `(progn ,@body)
+       for (var value type) in (reverse triplets)
+       do (setf body
+		(if (policy-assume-right-type)
+		    (wrap 'symbol-macrolet var value body)
+		    (let ((new-value (extract-constant-value value env)))
+		      (if (or (eq new-value env) ; not constant
+			      (not (typep new-value type)))
+			  (wrap 'let var `(assert-type-if-known ,value ,type) body)
+			  (wrap 'symbol-macrolet var value body)))))
+       finally (return body))))
diff --git a/src/cmp/sysfun.lsp b/src/cmp/sysfun.lsp
index e87958473..871a07f61 100644
--- a/src/cmp/sysfun.lsp
+++ b/src/cmp/sysfun.lsp
@@ -798,11 +798,6 @@
 (def-inline ext:fixnump :always (t) :bool "ECL_FIXNUMP(#0)")
 (def-inline ext:fixnump :always (fixnum) :bool "1")
 
-(def-inline c::ldb1 :always (fixnum fixnum fixnum) :fixnum
- "((((~((cl_fixnum)-1 << (#0))) << (#1)) & (cl_fixnum)(#2)) >> (#1))")
-(def-inline c::ldb1 :always (fixnum fixnum fixnum) t
- "ecl_make_fixnum((((~((cl_fixnum)-1 << (#0))) << (#1)) & (cl_fixnum)(#2)) >> (#1))")
-
 ;; Functions only available with threads
 #+threads
 (def-inline mp:lock-count :unsafe (mp:lock) fixnum "((#0)->lock.count)")