;;; -*- Mode:LISP; Package:LISP-INTERNALS; Readtable:CL; Base:10 -*-
;;;
;;;; Stack Groups
;;;

(defstruct (stack-group (:conc-name sg-)
			(:constructor %make-stack-group
				      (name
					special-pdl special-pdl-ptr special-pdl-limit
					extraneous-pdl extraneous-pdl-ptr extraneous-pdl-limit))
			(:copier   nil))
  name
  special-pdl
  special-pdl-ptr
  special-pdl-limit
  extraneous-pdl
  extraneous-pdl-ptr
  extraneous-pdl-limit
  control-pdl)


(defun make-stack-group (name &key (special-pdl-size 1000.)
			           (extraneous-pdl-size 1000.))
  (let ((spdl ;(array:make-vector (1+ special-pdl-size))
	      (array:make-1d-array (1+ special-pdl-size)
				   array:art-special-pdl
				   gr:*special-pdl-area*))
	(epdl (array:make-1d-array (1+ extraneous-pdl-size)
				   array:art-extraneous-pdl
				   gr:*special-pdl-area*)))	;maybe should be different area, maybe not
    (let ((sg (%make-stack-group
		name
		spdl
		(cons:make-pointer vinc:$$dtp-unboxed-locative
				   (hw:24+ 2 spdl))
		(cons:make-pointer vinc:$$dtp-unboxed-locative
				   (hw:32+ special-pdl-size spdl))
		epdl
		(cons:make-pointer vinc:$$dtp-unboxed-locative
				   (hw:24+ 2 epdl))
		(cons:make-pointer vinc:$$dtp-unboxed-locative
				   (hw:32+ extraneous-pdl-size epdl)))))
      (array:svset spdl 0 sg)
      (array:svset epdl 0 sg)
      sg)))


;this stuff has been moved to k-sys:k;boot-stack-groups
;(defun boot-stack-groups ()
;  ;; this should not be neccessary, these initial areas
;  ;; should have constant area numbers
;  (setq gr::*special-pdl-area*
;	(area-data:make-area 5.
;			     (region-bits:encode-region-bits
;			       region-bits:$$region-fixed
;			       region-bits:$$region-new-space
;			       region-bits:$$region-space-unboxed
;			       region-bits:$$region-read-write
;			       region-bits:$$scavenge-enabled
;			       region-bits:$$region-internal-memory
;			       0.
;			       )
;			     1.))
;  (let ((initial-sg (make-stack-group "Initial Stack Group")))
;    (setq gr:*special-pdl-ptr* (sg-special-pdl-ptr initial-sg))
;    (setq gr:*special-pdl-limit* (sg-special-pdl-limit initial-sg))
;    (setq gr:*stack-pointer* (sg-extraneous-pdl-ptr initial-sg))
;    (setq gr:*stack-limit*   (sg-extraneous-pdl-limit initial-sg))
;;   (setq gr:*current-stack-group* initial-sg)
;    nil
;    ))