Skip to content
Snippets Groups Projects
Commit 770c71a4 authored by wlott's avatar wlott
Browse files

Added explicit gc-trigger test.

parent e18e2806
No related branches found
No related tags found
No related merge requests found
......@@ -7,7 +7,7 @@
;;; Scott Fahlman (FAHLMAN@CMUC).
;;; **********************************************************************
;;;
;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/rt/alloc.lisp,v 1.3 1991/04/23 17:23:50 chiles Exp $
;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/rt/alloc.lisp,v 1.4 1991/10/22 16:43:17 wlott Exp $
;;;
;;; Allocation VOPs for the IBM RT port.
;;;
......@@ -72,7 +72,9 @@
(storew null-tn ptr
cons-cdr-slot list-pointer-type)))
(assert (null (tn-ref-across things)))
(move result res))))))))
(move result res))
(load-symbol-value ndescr *internal-gc-trigger*)
(inst tlt ndescr alloc)))))))
(define-vop (list list-or-list*)
(:variant nil))
......@@ -112,7 +114,9 @@
(storew ndescr result 0 other-pointer-type)
(storew unboxed result code-code-size-slot other-pointer-type)
(storew null-tn result code-entry-points-slot other-pointer-type)
(storew null-tn result code-debug-info-slot other-pointer-type))))
(storew null-tn result code-debug-info-slot other-pointer-type))
(load-symbol-value ndescr *internal-gc-trigger*)
(inst tlt ndescr alloc)))
(define-vop (make-symbol)
(:args (name :scs (descriptor-reg) :to :eval))
......
......@@ -7,7 +7,7 @@
;;; Scott Fahlman (FAHLMAN@CMUC).
;;; **********************************************************************
;;;
;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/rt/array.lisp,v 1.7 1991/08/25 19:06:23 ram Exp $
;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/rt/array.lisp,v 1.8 1991/10/22 16:43:21 wlott Exp $
;;;
;;; This file contains the IBM RT definitions for array operations.
;;;
......@@ -52,6 +52,8 @@
(inst o ndescr type)
(inst sr ndescr 2)
(storew ndescr header 0 vm:other-pointer-type))
(load-symbol-value ndescr *internal-gc-trigger*)
(inst tlt ndescr alloc)
(move result header)))
......
......@@ -1092,6 +1092,8 @@ default-value-5
;; NIL out the last cons.
(storew null-tn dst -1 vm:list-pointer-type))
(load-symbol-value ndescr *internal-gc-trigger*)
(inst tlt ndescr alloc)
(emit-label done))))
......
......@@ -189,16 +189,19 @@
Alloc-tn is a register to hold the heap pointer, and it can be any register
since raw heap pointers look like fixnums (dual-word aligned objects). The
body is placed inside PSEUDO-ATOMIC, and presumably initializes the object."
`(pseudo-atomic (,header-tn)
(load-symbol-value ,alloc-tn *allocation-pointer*)
;; Take free pointer and make descriptor pointer.
;; Just add in three low-tag bits since alloc ptr is dual-word aligned.
(inst cal ,result-tn ,alloc-tn other-pointer-type)
(inst cal ,alloc-tn ,alloc-tn (pad-data-block ,size))
(store-symbol-value ,alloc-tn *allocation-pointer*)
(inst li ,header-tn (logior (ash (1- ,size) type-bits) ,type-code))
(storew ,header-tn ,result-tn 0 other-pointer-type)
,@body))
`(progn
(pseudo-atomic (,header-tn)
(load-symbol-value ,alloc-tn *allocation-pointer*)
;; Take free pointer and make descriptor pointer.
;; Just add in three low-tag bits since alloc ptr is dual-word aligned.
(inst cal ,result-tn ,alloc-tn other-pointer-type)
(inst cal ,alloc-tn ,alloc-tn (pad-data-block ,size))
(store-symbol-value ,alloc-tn *allocation-pointer*)
(inst li ,header-tn (logior (ash (1- ,size) type-bits) ,type-code))
(storew ,header-tn ,result-tn 0 other-pointer-type)
,@body)
(load-symbol-value ,header-tn *internal-gc-trigger*)
(inst tlt ,alloc-tn ,header-tn)))
......
......@@ -7,7 +7,7 @@
;;; Scott Fahlman (FAHLMAN@CMUC).
;;; **********************************************************************
;;;
;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/rt/move.lisp,v 1.3 1991/05/09 16:30:06 ram Exp $
;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/rt/move.lisp,v 1.4 1991/10/22 16:42:18 wlott Exp $
;;;
;;; This file contains the IBM RT VM definition of operand loading/saving and the
;;; Move VOP.
......@@ -303,6 +303,8 @@
(store-symbol-value alloc *allocation-pointer*)
(storew temp y 0 other-pointer-type)
(storew x y bignum-digits-offset other-pointer-type))
(load-symbol-value temp *internal-gc-trigger*)
(inst tlt temp alloc)
(inst b done)))))
;;;
(define-move-vop move-from-unsigned :move
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment