--- a/src/code/bignum.lisp
+++ b/src/code/bignum.lisp
@@ -3697,3 +3697,29 @@ friends is working.
     (unless (= newlen len)
       (%bignum-set-length result newlen))
     result))
+
+;; Shift X left by Shift bits, shifting in bits from Carry-in.
+;; Basically treat x:carry-in as a 64-bit value and shift it left,
+;; returning the top bignum-type bits.
+(defun %shld (x carry-in shift)
+  (declare (type bignum-element-type x carry-in)
+	   (type (unsigned-byte 5) shift))
+  #+x86
+  (%shld x carry-in shift)
+  #-x86
+  (ldb (byte vm:word-bits 0)
+       (logior (ash x shift)
+	       (ash carry-in (- shift vm:word-bits)))))
+
+;; Shift X right by Shift bits, shifting in bits from Carry-in.
+;; Basically treat carry-in:x as a 64-bit value and shift it right,
+;; returning the low bignum-type bits.
+(defun %shrd (x carry-in shift)
+  (declare (type bignum-element-type x carry-in)
+	   (type (unsigned-byte 5) shift))
+  #+x86
+  (%shrd x carry-in shift)
+  #-x86
+  (ldb (byte vm:word-bits 0)
+		(logior (ash x (- shift))
+			(ash carry-in (- vm:word-bits shift)))))

--- a/src/compiler/generic/vm-fndb.lisp
+++ b/src/compiler/generic/vm-fndb.lisp
@@ -288,6 +288,13 @@
 	  (bignum-element-type (mod #+amd64 64 #-amd64 32)) bignum-element-type
   (foldable flushable movable))
 
+
+#+x86
+(defknown (bignum::%shld bignum::%shrd)
+    (bignum-element-type bignum-element-type (unsigned-byte 5))
+    bignum-element-type
+    (foldable flushable movable))
+    
 
 ;;;; Bit-bashing routines.
 

--- a/src/compiler/x86/arith.lisp
+++ b/src/compiler/x86/arith.lisp
@@ -1579,6 +1579,86 @@
     (inst mov tmp y)
     (inst shr tmp 18)
     (inst xor y tmp)))
+
+(define-vop (bignum-shld)
+  (:policy :fast-safe)
+  (:translate bignum::%shld)
+  (:args (x :scs (unsigned-reg) :target r)
+	 (shift-in :scs (unsigned-reg))
+	 (amount :scs (unsigned-reg) :target cl))
+  (:arg-types unsigned-num unsigned-num unsigned-num)
+  (:results (r :scs (unsigned-reg)))
+  (:result-types unsigned-num)
+  (:temporary (:sc unsigned-reg :from (:argument 0) :to (:result 0)) temp)
+  (:temporary (:sc unsigned-reg :offset ecx-offset
+		   :from (:argument 2) :to (:result 0)) cl)
+  (:generator 4
+    (move cl amount)
+    (cond ((location= x r)
+	   (inst shld x shift-in :cl))
+	  (t
+	   (move temp x)
+	   (inst shld temp shift-in :cl)
+	   (move r temp)))))
+  
+(define-vop (bignum-shld-c)
+  (:policy :fast-safe)
+  (:translate bignum::%shld)
+  (:args (x :scs (unsigned-reg) :target r)
+	 (shift-in :scs (unsigned-reg)))
+  (:info shift)
+  (:arg-types unsigned-num unsigned-num (:constant (unsigned-byte 5)))
+  (:results (r :scs (unsigned-reg)))
+  (:result-types unsigned-num)
+  (:temporary (:sc unsigned-reg :from (:argument 0) :to (:result 0)) temp)
+  (:generator 3
+    (cond ((location= x r)
+	   (inst shld x shift-in shift))
+	  (t
+	   (move temp x)
+	   (inst shld temp shift-in shift)
+	   (move r temp)))))
+
+(define-vop (bignum-shrd)
+  (:policy :fast-safe)
+  (:translate bignum::%shrd)
+  (:args (x :scs (unsigned-reg) :target r)
+	 (shift-in :scs (unsigned-reg))
+	 (amount :scs (unsigned-reg) :target cl))
+  (:arg-types unsigned-num unsigned-num unsigned-num)
+  (:results (r :scs (unsigned-reg)))
+  (:result-types unsigned-num)
+  (:temporary (:sc unsigned-reg :from (:argument 0) :to (:result 0)) temp)
+  (:temporary (:sc unsigned-reg :offset ecx-offset
+		   :from (:argument 2) :to (:result 0)) cl)
+  (:generator 4
+    (move cl amount)
+    (cond ((location= x r)
+	   (inst shrd x shift-in :cl))
+	  (t
+	   (move temp x)
+	   (inst shrd temp shift-in :cl)
+	   (move r temp)))))
+
+(define-vop (bignum-shrd-c)
+  (:policy :fast-safe)
+  (:translate bignum::%shrd)
+  (:args (x :scs (unsigned-reg))
+	 (shift-in :scs (unsigned-reg)))
+  (:info shift)
+  (:arg-types unsigned-num unsigned-num (:constant (unsigned-byte 5)))
+  (:results (r :scs (unsigned-reg)))
+  (:result-types unsigned-num)
+  (:temporary (:sc unsigned-reg :from (:argument 0) :to (:result 0)) temp)
+  (:generator 3
+    (cond ((location= x r)
+	   (inst shrd x shift-in shift))
+	  (t
+	   (move temp x)
+	   (inst shrd temp shift-in shift)
+	   (move r temp)))))
+
+
 
 ;;; Modular arithmetic
 ;;; logical operations