1 ;;;; allocating simple objects
3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
14 ;;;; Signed and unsigned bignums from word-sized integers. Argument
15 ;;;; and return in the same register. No VOPs, as these are only used
16 ;;;; as out-of-line versions: MOVE-FROM-[UN]SIGNED VOPs handle the
17 ;;;; fixnum cases inline.
19 ;;; #+SB-ASSEMBLING as we don't need VOPS, just the asm routines:
20 ;;; these are out-of-line versions called by VOPs.
24 (let ((tn (symbolicate reg "-TN")))
25 `(define-assembly-routine (,(symbolicate "ALLOC-SIGNED-BIGNUM-IN-" reg)) ()
27 (with-fixed-allocation (,tn bignum-widetag (+ bignum-digits-offset 1))
28 (popw ,tn bignum-digits-offset other-pointer-lowtag))
39 (let ((tn (symbolicate reg "-TN")))
40 `(define-assembly-routine (,(symbolicate "ALLOC-UNSIGNED-BIGNUM-IN-" reg)) ()
42 ;; Sign flag is set by the caller! Note: The inline
43 ;; version always allocates space for two words, but
44 ;; here we minimize garbage.
45 (inst jmp :ns one-word-bignum)
47 (with-fixed-allocation (,tn bignum-widetag (+ bignum-digits-offset 2))
48 (popw ,tn bignum-digits-offset other-pointer-lowtag))
51 (with-fixed-allocation (,tn bignum-widetag (+ bignum-digits-offset 1))
52 (popw ,tn bignum-digits-offset other-pointer-lowtag))
61 ;;; FIXME: This is dead, right? Can it go?
63 (defun frob-allocation-assembly-routine (obj lowtag arg-tn)
64 `(define-assembly-routine (,(intern (format nil "ALLOCATE-~A-TO-~A" obj arg-tn)))
65 ((:temp ,arg-tn descriptor-reg ,(intern (format nil "~A-OFFSET" arg-tn))))
67 (allocation ,arg-tn (pad-data-block ,(intern (format nil "~A-SIZE" obj))))
68 (inst lea ,arg-tn (make-ea :byte :base ,arg-tn :disp ,lowtag)))
72 (macrolet ((frob-cons-routines ()
74 (dolist (tn-offset *dword-regs*
76 (push (frob-allocation-assembly-routine 'cons
78 (intern (aref *dword-register-names* tn-offset)))