;;; -*- Package: x86 -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the CMU Common Lisp project at
;;; Carnegie Mellon University, and has been placed in the public domain.
;;; If you want to use this code or any part of CMU Common Lisp, please contact
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;;
(ext:file-comment
  "$Header$")
;;;
;;; **********************************************************************
;;;
;;; Stuff to handle allocating simple objects.
;;;
;;; Written by William Lott.
;;;

(in-package :x86)


;;;; From from signed/unsigned

#+assembler ; we don't want a vop for this one.
(define-assembly-routine
    (move-from-signed)
    ((:temp eax dword eax-offset)
     (:temp ebx dword ebx-offset)
     (:temp ecx dword ecx-offset))
  (inst mov ebx eax)
  (inst shl ebx 1)
  (inst jmp :o bignum)
  (inst shl ebx 1)
  (inst jmp :o bignum)
  (inst ret)
  BIGNUM
  (with-fixed-allocation (ebx ecx bignum-type (+ bignum-digits-offset 1))
    (storew eax ebx other-pointer-type bignum-digits-offset)))

#+assembler ; we don't want a vop for this one either.
(define-assembly-routine
    (move-from-unsigned)
    ((:temp eax dword eax-offset)
     (:temp ebx dword ebx-offset)
     (:temp ecx dword ecx-offset))
  (inst mov ebx eax)
  (inst shl ebx 1)
  (inst jmp :c two-word-bignum)
  (inst jmp :s two-word-bignum)
  (inst shl ebx 1)
  (inst jmp :s one-word-bignum)
  (inst ret)
  TWO-WORD-BIGNUM
  (with-fixed-allocation (ebx ecx bignum-type (+ bignum-digits-offset 2))
    (storew eax ebx other-pointer-type bignum-digits-offset))
  (inst ret)
  ONE-WORD-BIGNUM
  (with-fixed-allocation (ebx ecx bignum-type (+ bignum-digits-offset 1))
    (storew eax ebx other-pointer-type bignum-digits-offset)))



;;;; Random allocators.

(define-for-each-primitive-object (obj)
  (let* ((options (primitive-object-options obj))
	 (alloc-trans (getf options :alloc-trans))
	 (alloc-vop (getf options :alloc-vop alloc-trans))
	 (header (primitive-object-header obj))
	 (lowtag (primitive-object-lowtag obj))
	 (size (primitive-object-size obj))
	 (variable-length (primitive-object-variable-length obj)))
    (collect ((args) (init-forms) (null-inits))
      (when (and alloc-vop variable-length)
	(args 'extra-words))
      (dolist (slot (primitive-object-slots obj))
	(let* ((name (slot-name slot))
	       (offset (slot-offset slot)))
	  (ecase (getf (slot-options slot) :init :zero)
	    (:zero)
	    (:null
	     (null-inits `(storew temp result ,offset ,lowtag)))
	    (:unbound
	     (init-forms `(storew unbound-marker result ,offset ,lowtag)))
	    (:arg
	     (args name)
	     (init-forms `(storew ,name result ,offset ,lowtag))))))
      (when (and (null alloc-vop) (args))
	(error "Slots ~S want to be initialized, but there is no alloc vop ~
		defined for ~S."
	       (args) (primitive-object-name obj)))
      (when alloc-vop
	`(define-assembly-routine
	     (,alloc-vop
	      (:cost 35)
	      ,@(when alloc-trans
		  `((:translate ,alloc-trans)))
	      (:policy :fast-safe))
	     (,@(let ((arg-offsets register-arg-offsets))
		  (mapcar #'(lambda (name)
			      (unless arg-offsets
				(error "Too many args in ~S" alloc-vop))
			      `(:arg ,name (descriptor-reg any-reg)
				     ,(pop arg-offsets)))
			  (args)))
		,@(when (or (null-inits) variable-length)
		    '((:temp temp dword-reg ecx-offset)))
		(:temp alloc dword-reg ebx-offset)
		(:res result descriptor-reg eax-offset))
	   (with-allocation (alloc)
	     (inst lea result (make-ea :byte :base alloc :disp ,lowtag))
	     ,@(cond ((and header variable-length)
		      `((move temp extra-words)
			(inst add temp (fixnum (1- ,size)))
			(inst add alloc temp)
			(inst shl temp (- type-bits word-shift))
			(inst or temp ,header)
			(storew temp result 0 ,lowtag)
			(inst add alloc (+ (fixnum 1) lowtag-mask))
			(inst and alloc (lognot lowtag-mask))))
		     (variable-length
		      (error ":REST-P T with no header in ~S?"
			     (primitive-object-name obj)))
		     (header
		      `((inst add alloc (pad-data-block ,size))
			(storew (logior (ash (1- ,size) type-bits) ,header)
				result 0 ,lowtag)))
		     (t
		      `((inst add alloc (pad-data-block ,size)))))
	     ,@(init-forms)
	     ,@(when (null-inits)
		 (if (cdr (null-inits))
		     `((inst mov temp nil-value)
		       ,@(null-inits))
		     `((let ((temp nil-value))
			 ,@(null-inits)))))))))))