From acd8b21295ed72f01cc0658ffea12ebca30cf559 Mon Sep 17 00:00:00 2001
From: cracauer <cracauer>
Date: Wed, 12 Feb 2003 18:35:29 +0000
Subject: [PATCH] Fix a problem with the consing-free allocation counter.  If
 you allocate more than most-positive-fixnum bytes between two GCs, do a
 normal, possibly consing addition instead of the fast dfixnum increment.

Also clean up the exports of the dfixnum package and define a new
operator to increment a dfixnum by any integer.

Tested: full ITA testsuite, tried the profiler, tried various
allocation patterns which failed before this fix.
---
 code/dfixnum.lisp | 49 ++++++++++++++++++++++++++++++++++++-----------
 code/gc.lisp      | 14 +++++++++-----
 2 files changed, 47 insertions(+), 16 deletions(-)

diff --git a/code/dfixnum.lisp b/code/dfixnum.lisp
index b7c707366..aa05b30c0 100644
--- a/code/dfixnum.lisp
+++ b/code/dfixnum.lisp
@@ -5,7 +5,7 @@
 ;;; and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/dfixnum.lisp,v 1.2 2002/12/20 17:39:36 toy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/dfixnum.lisp,v 1.3 2003/02/12 18:35:29 cracauer Rel $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -24,16 +24,29 @@
 ;;; Compatibility: Runs in any valid Common Lisp.
 
 (defpackage "DFIXNUM"
-  (:export "DFIXNUM" "MAKE-DFIXNUM" dfparttype
-	   "DFIXNUM-INC-DF" "DFIXNUM-INC-HF"
-	   "DFIXNUM-SET-FROM-NUMBER" "DFIXNUM-MAKE-FROM-NUMBER"
-	   "DFIXNUM-INTEGER" "DFIXNUM-SINGLE-FLOAT"
-	   dfixnum-set-df
-	   dfixnum-dec-df dfixnum-dec-hf
-	   dfixnum-single-float dfixnum-single-float-inline
-	   dfixnum-set-single-float dfixnum-inc-single-float
-	   dfixnum-set-pair dfixnum-inc-pair dfixnum-pair-integer
-	   dfixnum-dec-pair dfixnum-copy-pair))
+  (:export
+
+   ;; types
+   dfixnum dfparttype
+
+   ;; constructing
+   make-dfixnum
+   dfixnum-make-from-number
+   
+   ;; arthmetic with our datatypes
+   dfixnum-inc-df dfixnum-inc-hf
+   dfixnum-set-df dfixnum-dec-df dfixnum-dec-hf
+
+
+   ;; operations with normal datatypes
+   dfixnum-set-from-number dfixnum-inc-integer
+   dfixnum-set-single-float dfixnum-inc-single-float
+   dfixnum-integer dfixnum-single-float
+   dfixnum-single-float dfixnum-single-float-inline
+
+   ;; operations on pairs instead of the dfixnum struct
+   dfixnum-set-pair dfixnum-inc-pair dfixnum-pair-integer
+   dfixnum-dec-pair dfixnum-copy-pair))
 
 (in-package "DFIXNUM")
 
@@ -110,6 +123,20 @@
     (setf (dfixnum-l v) low))
   v)
 
+(defun dfixnum-inc-integer (df i)
+  "increments dfixnum by an interger which may be bigger than fixnum.
+   May cons"
+  (declare (type dfixnum df) (integer i) (optimize (ext:inhibit-warnings 3)))
+  (let ((carry (+ (dfixnum-l df) (mod i dfmax))))
+    (setf (dfixnum-l df) (mod carry dfmax))
+    (if (> carry dfmax)
+	(setf carry 1)
+	(setf carry 0))
+    (setf (dfixnum-h df)
+	  (+ (dfixnum-h df)
+	     (ash i (- dfbits))
+	     carry))))
+
 (defun dfixnum-set-from-number (df i)
   (declare (type dfixnum df) (optimize (ext:inhibit-warnings 3)))
   (setf (dfixnum-h df) (ash i (- dfbits)))
diff --git a/code/gc.lisp b/code/gc.lisp
index 4e64446a3..84c8b0fd4 100644
--- a/code/gc.lisp
+++ b/code/gc.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/gc.lisp,v 1.32 2003/01/28 02:49:15 toy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/gc.lisp,v 1.33 2003/02/12 18:35:29 cracauer Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -438,7 +438,8 @@
 	    (let* ((post-gc-dyn-usage (dynamic-usage))
 		   (bytes-freed (- pre-gc-dyn-usage post-gc-dyn-usage)))
 	      (when *last-bytes-in-use*
-		#+nil(when verbose-p
+		#+nil
+		(when verbose-p
 		  (format
 		   t "~&Adjusting *last-bytes-in-use* from ~:D to ~:D, gen ~d, pre ~:D ~%"
 		   *last-bytes-in-use*
@@ -446,9 +447,12 @@
 		   gen
 		   pre-gc-dyn-usage)
 		  (force-output))
-		(dfixnum:dfixnum-inc-hf
-		 *total-bytes-consed*
-		 (- pre-gc-dyn-usage *last-bytes-in-use*))
+		(let ((correction (- pre-gc-dyn-usage *last-bytes-in-use*)))
+		  (if (<= correction dfixnum::dfmax)
+		      (dfixnum:dfixnum-inc-hf *total-bytes-consed* correction)
+		      ;; give up on not consing
+		      (dfixnum:dfixnum-inc-integer *total-bytes-consed*
+						   correction)))
 		(setq *last-bytes-in-use* post-gc-dyn-usage))
 	      (setf *need-to-collect-garbage* nil)
 	      (setf *gc-trigger*
-- 
GitLab