anchor.diff:          (dotimes (i (1- words))
             (setf (sys.int::memref-unsigned-byte-64 freelist (1+ i)) 0))
           ;; Return address.
  -        (return-from %allocate-from-pinned-area freelist)))))
  +        (return freelist)))))
  +
  +(defun %allocate-from-pinned-area-1 (tag data words)
  +  (mezzano.supervisor:without-footholds
  +    (mezzano.supervisor:with-mutex (*allocator-lock*)
  +      (mezzano.supervisor:with-pseudo-atomic
  +        (when *paranoid-allocation*
  +          (verify-freelist sys.int::*pinned-area-freelist* (* 2 1024 1024 1024) sys.int::*pinned-area-bump*))
  +        (let ((address (%allocate-from-freelist-area tag data words 'sys.int::*pinned-area-freelist*)))
  +          (when address
  +            (sys.int::%%assemble-value address sys.int::+tag-object+)))))))
  +
  +(defun %allocate-from-pinned-area (tag data words)
  +  (loop
  +     for i from 0 do
  +       (let ((result (%allocate-from-pinned-area-1 tag data words)))
  +         (when result
  +           (return result)))
  +       (when (> i *maximum-allocation-attempts*)
  +         (error 'storage-condition))
  +       (sys.int::gc)))
  +
  +(defun %allocate-from-wired-area-1 (tag data words)
  +  (mezzano.supervisor::safe-without-interrupts (tag data words)
  +    (mezzano.supervisor:with-symbol-spinlock (*wired-allocator-lock*)
  +      (when *paranoid-allocation*
  +        (verify-freelist sys.int::*wired-area-freelist* (* 2 1024 1024) sys.int::*wired-area-bump*))
  +      (let ((address (%allocate-from-freelist-area tag data words 'sys.int::*wired-area-freelist*)))
  +        (when address
  +          (sys.int::%%assemble-value address sys.int::+tag-object+))))))
  +
  +(defun %allocate-from-wired-area (tag data words)
  +  (loop
  +     for i from 0 do
  +       (let ((result (%allocate-from-wired-area-1 tag data words)))
  +         (when result
  +           (return result)))
  +       (when (> i *maximum-allocation-attempts*)
  +         (error 'storage-condition))
  +       (sys.int::gc)))
  +
  +(defun %cons-in-pinned-area-1 (car cdr)
  +  (mezzano.supervisor:without-footholds
  +    (mezzano.supervisor:with-mutex (*allocator-lock*)
  +      (mezzano.supervisor:with-pseudo-atomic
  +        (when *paranoid-allocation*
  +          (verify-freelist sys.int::*pinned-area-freelist* (* 2 1024 1024 1024) sys.int::*pinned-area-bump*))
  +        (let ((address (%allocate-from-freelist-area sys.int::+object-tag-cons+ 0 4 'sys.int::*pinned-area-freelist*)))
  +          (when address
  +            (let ((val (sys.int::%%assemble-value (+ address 16) sys.int::+tag-cons+)))
  +              (setf (car val) car
  +                    (cdr val) cdr)
  +              val)))))))
  +
  +(defun %cons-in-pinned-area (car cdr)
  +  (loop
  +     for i from 0 do
  +       (let ((result (%cons-in-pinned-area-1 car cdr)))
  +         (when result
  +           (return result)))
  +       (when (> i *maximum-allocation-attempts*)
  +         (error 'storage-condition))
  +       (sys.int::gc)))
  +
  +(defun %cons-in-wired-area-1 (car cdr)
  +  (mezzano.supervisor::safe-without-interrupts (car cdr)
  +    (mezzano.supervisor:with-symbol-spinlock (*wired-allocator-lock*)
  +      (when *paranoid-allocation*
  +        (verify-freelist sys.int::*wired-area-freelist* (* 2 1024 1024) sys.int::*wired-area-bump*))
  +      (let ((address (%allocate-from-freelist-area sys.int::+object-tag-cons+ 0 4 'sys.int::*wired-area-freelist*)))
  +        (when address
  +          (let ((val (sys.int::%%assemble-value (+ address 16) sys.int::+tag-cons+)))
  +            (setf (car val) car
  +                  (cdr val) cdr)
  +            val))))))
  +
  +(defun %cons-in-wired-area (car cdr)
  +  (loop
  +     for i from 0 do
  +       (let ((result (%cons-in-wired-area-1 car cdr)))
  +         (when result
  +           (return result)))
  +       (when (> i *maximum-allocation-attempts*)
  +         (error 'storage-condition))
  +       (sys.int::gc)))
  +
  +(defun %allocate-from-general-area (tag data words)
  +  (let ((gc-count 0))
  +    (tagbody
  +     OUTER-LOOP
  +       (mezzano.supervisor:without-footholds
  +         (mezzano.supervisor:with-mutex (*allocator-lock*)
  +           (tagbody
  +            INNER-LOOP
  +              (return-from %allocate-from-general-area
  +                (mezzano.supervisor:with-pseudo-atomic
  +                  (when (> (+ sys.int::*general-area-bump* (* words 8)) sys.int::*general-area-limit*)
  +                    (go EXPAND-AREA))
  +                  ;; Enough size, allocate here.
  +                  (let ((addr (logior (ash sys.int::+address-tag-general+ sys.int::+address-tag-shift+)
  +                                      sys.int::*general-area-bump*
  +                                      sys.int::*dynamic-mark-bit*)))
  +                    (incf sys.int::*general-area-bump* (* words 8))
  +                    ;; Write array header.
  +                    (set-allocated-object-header addr tag data 0)
  +                    (sys.int::%%assemble-value addr sys.int::+tag-object+))))
  +            EXPAND-AREA
  +              ;; No memory. If there's memory available, then expand the area, otherwise run the GC.
  +              ;; Cannot be done when pseudo-atomic.
  +              ;; Divide granularity by two because this is a semispace area. Need twice as much memory.
  +              (let ((expansion (logand (truncate *general-area-expansion-granularity* 2) (lognot #xFFF))))
  +                (mezzano.supervisor::debug-print-line "Expanding general area by " expansion)
  +                (when (< sys.int::*memory-expansion-remaining* (* expansion 2))
  +                  ;; Not enough memory, abandon ship, do a gc and then attempt the allocation again.
  +                  (go DO-GC))
  +                (decf sys.int::*memory-expansion-remaining* (* expansion 2))
  +                ;; Do new & oldspace allocations seperately, this interacts better with the freelist.
  +                (mezzano.supervisor:allocate-memory-range
  +                 (logior sys.int::*dynamic-mark-bit*
  +                         (ash sys.int::+address-tag-general+
  +                              sys.int::+address-tag-shift+)
  +                         sys.int::*general-area-limit*)
  +                 expansion
  +                 (logior sys.int::+block-map-present+
  +                         sys.int::+block-map-writable+
  +                         sys.int::+block-map-zero-fill+))
  +                (mezzano.supervisor:allocate-memory-range
  +                 (logior (logxor sys.int::*dynamic-mark-bit*
  +                                 (ash 1 sys.int::+address-newspace/oldspace-bit+))
  +                         (ash sys.int::+address-tag-general+
  +                              sys.int::+address-tag-shift+)
  +                         sys.int::*general-area-limit*)
  +                 expansion
  +                 sys.int::+block-map-zero-fill+)
  +                (incf sys.int::*general-area-limit* expansion))
  +              (go INNER-LOOP))))
  +     DO-GC
  +       ;; Must occur outside the locks.
  +       (when (> gc-count *maximum-allocation-attempts*)
  +         (error 'storage-condition))
  +       (incf gc-count)
  +       (sys.int::gc)
  +       (go OUTER-LOOP))))
   
   (defun %allocate-object (tag data size area)
     (when sys.int::*gc-in-progress*
  
positive.code:                                                              (ash (ldb (byte (- 32 sys.int::+object-data-shift+) 0) data) sys.int::+object-data-shift+))
          (sys.int::memref-unsigned-byte-32 address 1) (ldb (byte 32 (- 32 sys.int::+object-data-shift+)) data)))
  
  ;;; FIXME: The pinned/general/cons allocators must somehow initialize their objects with the
  ;;; allocator lock released. taking a pagefault with it taken is bad, as it will cause
  ;;; IRQs to be reenabled. What to do? Make it a mutex? actaully reasonable, but a bit heavy?
  
  ;; Simple first-fit freelist allocator for pinned areas.
  (defun %allocate-from-pinned-area (tag data words freelist-symbol)
    ;; Traverse the freelist.
    (do ((freelist (symbol-value freelist-symbol) (freelist-entry-next freelist))
         (prev nil freelist))
        ((null freelist)
         ;; No memory. Run a GC cycle, try the allocation again, then enlarge the area.
         ;; TODO...
         (mezzano.supervisor:panic "No memory!!!"))
      (let ((size (freelist-entry-size freelist)))
        (when (>= size words)
          ;; This freelist entry is large enough, use it.
  
negative.code:       (incf words))
      (ecase area
        ((nil)
         (%allocate-from-general-area tag data words))
        (:pinned
         (%allocate-from-pinned-area tag data words))
        (:wired
         (%allocate-from-wired-area tag data words)))))
  
  (defun sys.int::cons-in-area (car cdr &optional area)
    (when sys.int::*gc-in-progress*
      (mezzano.supervisor:panic "Allocating during GC!"))
    (ecase area
      ((nil)
       (cons car cdr))
      (:pinned
       (%cons-in-pinned-area car cdr))
      (:wired
       (%cons-in-wired-area car cdr))))
  
  (sys.int::define-lap-function cons ((car cdr))
    ;; Attempt to quickly allocate a cons. Will call SLOW-CONS if things get too hairy.
  