<commit_before>;;;; Copyright (c) 2011-2016 <NAME> <<EMAIL>>
;;;; This code is licensed under the MIT license.

(defpackage :cold-generator
  (:use :cl :iterate :nibbles)
  (:export #:make-image
           #:allocate
           #:word
           #:array-header
           #:make-value
           #:function-reference
           #:symbol-address
           #:cold-symbol-value
           #:compile-lap-function
           #:set-up-cross-compiler))

(defpackage :cold-generator.x86-64
  (:use :cl :cold-generator)
  (:export #:*undefined-function-thunk*
           #:*closure-trampoline*
           #:*funcallable-instance-trampoline*
           #:create-low-level-interrupt-support))

(defpackage :cold-generator.arm64
  (:use :cl :cold-generator)
  (:export #:*undefined-function-thunk*
           #:*closure-trampoline*
           #:*funcallable-instance-trampoline*))

(in-package :cold-generator)

(defparameter *supervisor-source-files*
  '("supervisor/entry.lisp"
    ("supervisor/x86-64/cpu.lisp" :x86-64)
    ("supervisor/arm64/cpu.lisp" :arm64)
    "supervisor/interrupts.lisp"
    ("supervisor/x86-64/interrupts.lisp" :x86-64)
    ("supervisor/arm64/interrupts.lisp" :arm64)
    ("supervisor/arm64/gic.lisp" :arm64)
    "supervisor/debug.lisp"
    "supervisor/serial.lisp"
    ("supervisor/uart.lisp" :arm64)
    "supervisor/disk.lisp"
    "supervisor/partition.lisp"
    "supervisor/ata.lisp"
    "supervisor/ahci.lisp"
    "supervisor/cdrom.lisp"
    "supervisor/thread.lisp"
    ("supervisor/x86-64/thread.lisp" :x86-64)
    ("supervisor/arm64/thread.lisp" :arm64)
    "supervisor/sync.lisp"
    "supervisor/physical.lisp"
    "supervisor/snapshot.lisp"
    ("supervisor/x86-64/snapshot.lisp" :x86-64)
    ("supervisor/arm64/snapshot.lisp" :arm64)
    "supervisor/store.lisp"
    "supervisor/pager.lisp"
    ("supervisor/x86-64/pager.lisp" :x86-64)
    ("supervisor/arm64/pager.lisp" :arm64)
    "supervisor/time.lisp"
    ("supervisor/x86-64/time.lisp" :x86-64)
    ("supervisor/arm64/time.lisp" :arm64)
    "supervisor/ps2.lisp"
    "supervisor/video.lisp"
    "supervisor/pci.lisp"
    "supervisor/virtio.lisp"
    "supervisor/virtio-pci.lisp"
    "supervisor/virtio-mmio.lisp"
    "supervisor/virtio-block.lisp"
    "supervisor/virtio-input.lisp"
    "supervisor/virtio-gpu.lisp"
    "supervisor/virtualbox.lisp"
    "supervisor/profiler.lisp"
    "supervisor/support.lisp"
    "supervisor/acpi.lisp"
    "supervisor/efi.lisp"
    ("supervisor/x86-64/platform.lisp" :x86-64)
    ("supervisor/arm64/platform.lisp" :arm64)
    "runtime/runtime.lisp"
    ("runtime/runtime-x86-64.lisp" :x86-64)
    ("runtime/runtime-arm64.lisp" :arm64)
    "runtime/allocate.lisp"
    "runtime/cons.lisp"
    "runtime/numbers.lisp"
    ("runtime/float-x86-64.lisp" :x86-64)
    ("runtime/float-arm64.lisp" :arm64)
    "runtime/string.lisp"
    "runtime/array.lisp"
    "runtime/struct.lisp"
    "runtime/symbol.lisp"
    "runtime/function.lisp"
    "supervisor/fdt.lisp"))

(defparameter *source-files*
  '("system/cold-start.lisp"
    "system/data-types.lisp"
    "system/defstruct.lisp"
    "system/cons.lisp"
    "system/sequence.lisp"
    "system/runtime-array.lisp"
    "system/array.lisp"
    "system/printer.lisp"
    "system/stuff.lisp"
    "system/runtime-support.lisp"
    "system/type.lisp"
    "system/setf.lisp"
    "system/cas.lisp"
    "system/string.lisp"
    "system/hash-table.lisp"
    "system/runtime-numbers.lisp"
    ("system/bignum-x86-64.lisp" :x86-64)
    ("system/bignum-arm64.lisp" :arm64)
    "system/numbers.lisp"
    "system/gc.lisp"
    "system/room.lisp"
    "system/reader.lisp"
    "system/character.lisp"
    "system/backquote.lisp"
    "system/format.lisp"
    "system/defmacro.lisp"
    "system/basic-macros.lisp"
    "system/parse.lisp"
    "system/load.lisp"
    "system/time.lisp"
))

(defparameter *special-source-files*
  '(("system/packages.lisp" sys.int::*package-system*)))

(defparameter *warm-source-files*
  '("system/clos/package.lisp"
    "system/clos/macros.lisp"
    "system/clos/single-dispatch-emf-table.lisp"
    "system/clos/boot.lisp"
    "system/clos/closette.lisp"
    "system/clos/method-combination.lisp"
    "system/describe.lisp"
    "system/runtime-misc.lisp"
    "system/condition.lisp"
    "system/restarts.lisp"
    "system/error.lisp"
    "system/coerce.lisp"
    "system/debug.lisp"
    "system/full-eval.lisp"
    "system/fast-eval.lisp"
    "system/eval.lisp"
    "system/stream.lisp"
    "system/ansi-loop.lisp"
    "system/environment.lisp"
    "compiler/package.lisp"
    "compiler/lap.lisp"
    "compiler/lap-x86.lisp"
    "compiler/lap-arm64.lisp"
    "compiler/compiler.lisp"
    "compiler/environment.lisp"
    "compiler/global-environment.lisp"
    "compiler/ast.lisp"
    "compiler/ast-generator.lisp"
    "compiler/pass1.lisp"
    "compiler/constprop.lisp"
    "compiler/simplify.lisp"
    "compiler/lift.lisp"
    "compiler/inline.lisp"
    "compiler/kill-temps.lisp"
    "compiler/keyword-arguments.lisp"
    "compiler/simplify-arguments.lisp"
    "compiler/codegen-x86-64.lisp"
    "compiler/builtins-x86-64/builtins.lisp"
    "compiler/builtins-x86-64/array.lisp"
    "compiler/builtins-x86-64/character.lisp"
    "compiler/builtins-x86-64/cons.lisp"
    "compiler/builtins-x86-64/memory.lisp"
    "compiler/builtins-x86-64/misc.lisp"
    "compiler/builtins-x86-64/numbers.lisp"
    "compiler/builtins-x86-64/objects.lisp"
    "compiler/builtins-x86-64/unwind.lisp"
    "compiler/branch-tension.lisp"
    "compiler/codegen-arm64.lisp"
    "compiler/builtins-arm64/builtins.lisp"
    "compiler/builtins-arm64/cons.lisp"
    "compiler/builtins-arm64/memory.lisp"
    "compiler/builtins-arm64/misc.lisp"
    "compiler/builtins-arm64/numbers.lisp"
    "compiler/builtins-arm64/objects.lisp"
    "compiler/builtins-arm64/unwind.lisp"
    "compiler/lower-environment.lisp"
    "compiler/lower-special-bindings.lisp"
    "compiler/value-aware-lowering.lisp"
    "compiler/simplify-control-flow.lisp"
    "compiler/blexit.lisp"
    "compiler/transforms.lisp"
    "compiler/backend/backend.lisp"
    "compiler/backend/cfg.lisp"
    "compiler/backend/analysis.lisp"
    "compiler/backend/dominance.lisp"
    "compiler/backend/convert-ast.lisp"
    "compiler/backend/multiple-values.lisp"
    "compiler/backend/ssa.lisp"
    "compiler/backend/passes.lisp"
    "compiler/backend/register-allocation.lisp"
    "compiler/backend/x86-64.lisp"
    ("runtime/simd.lisp" :x86-64)
    "system/file-compiler.lisp"
    "system/xp-package.lisp"
    "system/xp.lisp"
    "system/xp-format.lisp"
    "system/xp-printers.lisp"
    "system/profiler.lisp"
    "drivers/network-card.lisp"
    "drivers/virtio-net.lisp"
    ("drivers/rtl8168.lisp" :x86-64)
    "drivers/sound.lisp"
    ("drivers/intel-hda.lisp" :x86-64)
    "net/package.lisp"
    "net/network.lisp"
    "net/ethernet.lisp"
    "net/arp.lisp"
    "net/ip.lisp"
    "net/udp.lisp"
    "net/tcp.lisp"
    "net/dns.lisp"
    "net/network-setup.lisp"
    "file/fs.lisp"
    "file/remote.lisp"
    "config.lisp"
    "ipl.lisp"))

(defparameter *cl-symbol-list-file* "tools/cl-symbols.lisp-expr")
(defparameter *8x8-debug-font* "tools/font8x8")
(defparameter *unifont* "tools/unifont-5.1.20080820.hex")
(defparameter *unicode-data* "tools/UnicodeData.txt")
(defparameter *pci-ids* "tools/pci.ids")

(defun compile-warm-source (&optional force)
  (dolist (file *warm-source-files*)
    (let ((llf-path (merge-pathnames (make-pathname :type "llf" :defaults file))))
      (when (or (not (probe-file llf-path))
                (<= (file-write-date llf-path) (file-write-date file))
                force)
        (format t "~A is out of date will be recompiled.~%" llf-path)
        (sys.c::cross-compile-file file)))))

(defvar *symbol-table*)
(defvar *reverse-symbol-table*)
;; Hash-table mapping function names to function references.
(defvar *fref-table*)
(defvar *struct-table*)
(defvar *unbound-value-address*)
(defvar *undefined-function-address*)
(defvar *closure-trampoline-address*)
(defvar *f-i-trampoline-address*)
(defvar *load-time-evals*)
(defvar *string-dedup-table*)
(defvar *structure-definition-definition*)
(defvar *structure-slot-definition-definition*)
(defvar *image-to-cross-slot-definitions*)

(defvar *function-map*)
(defvar *pending-fixups*)

;;; Memory allocation.

;; Wired area starts at 2M.
(defconstant +wired-area-base+ (* 2 1024 1024))
;; Pinned at 2G.
(defconstant +pinned-area-base+ (* 2 1024 1024 1024))
;; Wired area stops at 2G, below the pinned area.
(defconstant +wired-area-limit+ (* 2 1024 1024 1024))

;; Wired stack area starts at the bottom of the stack area.
(defconstant +wired-stack-area-base+ 0)
;; Not set to 512GB because bootloader is slow & dumb.
(defconstant +wired-stack-area-limit+ (* 2 1024 1024 1024))
;; Leave a gap, for future expansion.
(defconstant +stack-area-base+ (* 512 1024 1024 1024))

;; Past this, the address starts to infringe on the address info bits.
;; Technically, the pinned area doesn't care about bit 44, but be consistent.
(defconstant +area-limit+ (expt 2 44))

(defvar *wired-area-bump*)
(defvar *wired-area-data*)
(defvar *wired-area-store*)
(defvar *pinned-area-bump*)
(defvar *pinned-area-data*)
(defvar *pinned-area-store*)
(defvar *general-area-bump*)
(defvar *general-area-data*)
(defvar *general-area-store*)
(defvar *cons-area-bump*)
(defvar *cons-area-data*)
(defvar *cons-area-store*)

(defstruct stack
  base
  size
  store)

(defvar *stack-list*)
(defvar *stack-area-bump*)

(defvar *store-bump*)

(defvar *default-general-allocation-area* :general)
(defvar *default-cons-allocation-area* :cons)
(defvar *default-pinned-allocation-area* :pinned)

(defun align-up (value boundary)
  (incf value (1- boundary))
  (- value (rem value boundary)))

(defun allocate-1 (size bump-symbol data-symbol data-offset limit tag name)
  (when (>= (+ (symbol-value bump-symbol) size) limit)
    (error "~A area exceeded limit." name))
  (let ((address (symbol-value bump-symbol)))
    (incf (symbol-value bump-symbol) size)
    ;; Keep data vector page aligned, but don't expand it too often.
    ;; Keeping it 2MB aligned is important - WRITE-IMAGE relies on this to
    ;; provide zeros in unallocated parts of the area.
    (let ((dv-size (align-up (symbol-value bump-symbol) #x200000)))
      (when (not (eql (- dv-size data-offset)
                      (length (symbol-value data-symbol))))
        (setf (symbol-value data-symbol) (adjust-array (symbol-value data-symbol)
                                                       (- dv-size data-offset)
                                                       :element-type '(unsigned-byte 8)
                                                       :initial-element 0))))
    (/ (logior address (ash tag sys.int::+address-tag-shift+)) 8)))

(defun allocate (word-count &optional area)
  (when (oddp word-count) (incf word-count))
  (let ((size (* word-count 8)))
    (ecase (or area *default-general-allocation-area*)
      (:wired
       (allocate-1 size '*wired-area-bump* '*wired-area-data* +wired-area-base+ +wired-area-limit+ sys.int::+address-tag-pinned+ "wired"))
      (:pinned
       (allocate-1 size '*pinned-area-bump* '*pinned-area-data* +pinned-area-base+ +area-limit+ sys.int::+address-tag-pinned+ "pinned"))
      (:general
       (allocate-1 size '*general-area-bump* '*general-area-data* 0 +area-limit+ sys.int::+address-tag-general+ "general"))
      (:cons
       (allocate-1 size '*cons-area-bump* '*cons-area-data* 0 +area-limit+ sys.int::+address-tag-cons+ "cons")))))

(defun area-for-address (address)
  (let ((byte-address (* address 8)))
    (case (ldb (byte sys.int::+address-tag-size+
                     sys.int::+address-tag-shift+)
               byte-address)
      (#.sys.int::+address-tag-pinned+
       (cond ((<= +pinned-area-base+ byte-address (1- +area-limit+))
              (values (/ (- (logand byte-address (1- +area-limit+)) +pinned-area-base+) 8)
                      *pinned-area-data*))
             ((<= +wired-area-base+ byte-address (1- +wired-area-limit+))
              (values (/ (- (logand byte-address (1- +area-limit+)) +wired-area-base+) 8)
                      *wired-area-data*))
             (t (error "Unknown address #x~X" address))))
      ;;(#.sys.int::+address-tag-stack+)
      (#.sys.int::+address-tag-general+
       (values (/ (logand byte-address (1- +area-limit+)) 8)
               *general-area-data*))
      (#.sys.int::+address-tag-cons+
       (values (/ (logand byte-address (1- +area-limit+)) 8)
               *cons-area-data*))
      (t (error "Unknown address #x~X" address)))))

(defun create-stack (size)
  ;; Lower guard region.
  (incf *stack-area-bump* #x200000)
  (setf size (align-up size #x1000))
  (let* ((address (logior (ash sys.int::+address-tag-stack+ sys.int::+address-tag-shift+)
                          *stack-area-bump*))
         (info (make-stack :base address :size size)))
    (incf *stack-area-bump* (align-up size #x200000))
    (push info *stack-list*)
    info))

(defvar *word-locks*)

(defun lock-word (address)
  (setf (gethash address *word-locks*) t))

(defun (setf word) (new-value address)
  (when (gethash address *word-locks*)
    (error "Attempted to write locked word at ~X~%" address))
  (multiple-value-bind (offset data-vector)
      (area-for-address address)
    (setf (ub64ref/le data-vector (* offset 8)) new-value)))

(defun word (address)
  (multiple-value-bind (offset data-vector)
      (area-for-address address)
    (ub64ref/le data-vector (* offset 8))))

(defun assemble (code-list &rest args)
  (let ((sys.lap:*function-reference-resolver* #'sys.c::resolve-fref))
    (ecase sys.c::*target-architecture*
      (:x86-64
       (apply #'sys.lap-x86:assemble code-list args))
      (:arm64
       (apply #'mezzano.lap.arm64:assemble code-list args)))))

(defun compile-lap-function (code &key (area *default-pinned-allocation-area*) extra-symbols constant-values (position-independent t) (name 'sys.int::support-function))
  "Compile a list of LAP code as a function. Constants must only be symbols."
  (let ((base-address (if position-independent
                          0
                          *wired-area-bump*)))
    (multiple-value-bind (mc constants fixups symbols gc-info)
        (assemble (list* (list :d64/le 0 0) code) ; 16 byte header.
          :base-address base-address
          :initial-symbols (list* '(nil . :fixup)
                                  '(t . :fixup)
                                  extra-symbols)
          ;; Name & debug info.
          :info (list name nil))
      (declare (ignore symbols))
      (setf mc (adjust-array mc (* (ceiling (length mc) 16) 16) :fill-pointer t))
      (let ((total-size (+ (* (truncate (length mc) 16) 2)
                           (length constants)
                           (ceiling (length gc-info) 8))))
        (when (oddp total-size) (incf total-size))
        (let ((address (allocate total-size area)))
          ;; Copy machine code into the area.
          (dotimes (i (truncate (length mc) 8))<commit_msg>LAP might not return an adjustable array.<commit_after>;;;; Copyright (c) 2011-2016 <NAME> <<EMAIL>>
;;;; This code is licensed under the MIT license.

(defpackage :cold-generator
  (:use :cl :iterate :nibbles)
  (:export #:make-image
           #:allocate
           #:word
           #:array-header
           #:make-value
           #:function-reference
           #:symbol-address
           #:cold-symbol-value
           #:compile-lap-function
           #:set-up-cross-compiler))

(defpackage :cold-generator.x86-64
  (:use :cl :cold-generator)
  (:export #:*undefined-function-thunk*
           #:*closure-trampoline*
           #:*funcallable-instance-trampoline*
           #:create-low-level-interrupt-support))

(defpackage :cold-generator.arm64
  (:use :cl :cold-generator)
  (:export #:*undefined-function-thunk*
           #:*closure-trampoline*
           #:*funcallable-instance-trampoline*))

(in-package :cold-generator)

(defparameter *supervisor-source-files*
  '("supervisor/entry.lisp"
    ("supervisor/x86-64/cpu.lisp" :x86-64)
    ("supervisor/arm64/cpu.lisp" :arm64)
    "supervisor/interrupts.lisp"
    ("supervisor/x86-64/interrupts.lisp" :x86-64)
    ("supervisor/arm64/interrupts.lisp" :arm64)
    ("supervisor/arm64/gic.lisp" :arm64)
    "supervisor/debug.lisp"
    "supervisor/serial.lisp"
    ("supervisor/uart.lisp" :arm64)
    "supervisor/disk.lisp"
    "supervisor/partition.lisp"
    "supervisor/ata.lisp"
    "supervisor/ahci.lisp"
    "supervisor/cdrom.lisp"
    "supervisor/thread.lisp"
    ("supervisor/x86-64/thread.lisp" :x86-64)
    ("supervisor/arm64/thread.lisp" :arm64)
    "supervisor/sync.lisp"
    "supervisor/physical.lisp"
    "supervisor/snapshot.lisp"
    ("supervisor/x86-64/snapshot.lisp" :x86-64)
    ("supervisor/arm64/snapshot.lisp" :arm64)
    "supervisor/store.lisp"
    "supervisor/pager.lisp"
    ("supervisor/x86-64/pager.lisp" :x86-64)
    ("supervisor/arm64/pager.lisp" :arm64)
    "supervisor/time.lisp"
    ("supervisor/x86-64/time.lisp" :x86-64)
    ("supervisor/arm64/time.lisp" :arm64)
    "supervisor/ps2.lisp"
    "supervisor/video.lisp"
    "supervisor/pci.lisp"
    "supervisor/virtio.lisp"
    "supervisor/virtio-pci.lisp"
    "supervisor/virtio-mmio.lisp"
    "supervisor/virtio-block.lisp"
    "supervisor/virtio-input.lisp"
    "supervisor/virtio-gpu.lisp"
    "supervisor/virtualbox.lisp"
    "supervisor/profiler.lisp"
    "supervisor/support.lisp"
    "supervisor/acpi.lisp"
    "supervisor/efi.lisp"
    ("supervisor/x86-64/platform.lisp" :x86-64)
    ("supervisor/arm64/platform.lisp" :arm64)
    "runtime/runtime.lisp"
    ("runtime/runtime-x86-64.lisp" :x86-64)
    ("runtime/runtime-arm64.lisp" :arm64)
    "runtime/allocate.lisp"
    "runtime/cons.lisp"
    "runtime/numbers.lisp"
    ("runtime/float-x86-64.lisp" :x86-64)
    ("runtime/float-arm64.lisp" :arm64)
    "runtime/string.lisp"
    "runtime/array.lisp"
    "runtime/struct.lisp"
    "runtime/symbol.lisp"
    "runtime/function.lisp"
    "supervisor/fdt.lisp"))

(defparameter *source-files*
  '("system/cold-start.lisp"
    "system/data-types.lisp"
    "system/defstruct.lisp"
    "system/cons.lisp"
    "system/sequence.lisp"
    "system/runtime-array.lisp"
    "system/array.lisp"
    "system/printer.lisp"
    "system/stuff.lisp"
    "system/runtime-support.lisp"
    "system/type.lisp"
    "system/setf.lisp"
    "system/cas.lisp"
    "system/string.lisp"
    "system/hash-table.lisp"
    "system/runtime-numbers.lisp"
    ("system/bignum-x86-64.lisp" :x86-64)
    ("system/bignum-arm64.lisp" :arm64)
    "system/numbers.lisp"
    "system/gc.lisp"
    "system/room.lisp"
    "system/reader.lisp"
    "system/character.lisp"
    "system/backquote.lisp"
    "system/format.lisp"
    "system/defmacro.lisp"
    "system/basic-macros.lisp"
    "system/parse.lisp"
    "system/load.lisp"
    "system/time.lisp"
))

(defparameter *special-source-files*
  '(("system/packages.lisp" sys.int::*package-system*)))

(defparameter *warm-source-files*
  '("system/clos/package.lisp"
    "system/clos/macros.lisp"
    "system/clos/single-dispatch-emf-table.lisp"
    "system/clos/boot.lisp"
    "system/clos/closette.lisp"
    "system/clos/method-combination.lisp"
    "system/describe.lisp"
    "system/runtime-misc.lisp"
    "system/condition.lisp"
    "system/restarts.lisp"
    "system/error.lisp"
    "system/coerce.lisp"
    "system/debug.lisp"
    "system/full-eval.lisp"
    "system/fast-eval.lisp"
    "system/eval.lisp"
    "system/stream.lisp"
    "system/ansi-loop.lisp"
    "system/environment.lisp"
    "compiler/package.lisp"
    "compiler/lap.lisp"
    "compiler/lap-x86.lisp"
    "compiler/lap-arm64.lisp"
    "compiler/compiler.lisp"
    "compiler/environment.lisp"
    "compiler/global-environment.lisp"
    "compiler/ast.lisp"
    "compiler/ast-generator.lisp"
    "compiler/pass1.lisp"
    "compiler/constprop.lisp"
    "compiler/simplify.lisp"
    "compiler/lift.lisp"
    "compiler/inline.lisp"
    "compiler/kill-temps.lisp"
    "compiler/keyword-arguments.lisp"
    "compiler/simplify-arguments.lisp"
    "compiler/codegen-x86-64.lisp"
    "compiler/builtins-x86-64/builtins.lisp"
    "compiler/builtins-x86-64/array.lisp"
    "compiler/builtins-x86-64/character.lisp"
    "compiler/builtins-x86-64/cons.lisp"
    "compiler/builtins-x86-64/memory.lisp"
    "compiler/builtins-x86-64/misc.lisp"
    "compiler/builtins-x86-64/numbers.lisp"
    "compiler/builtins-x86-64/objects.lisp"
    "compiler/builtins-x86-64/unwind.lisp"
    "compiler/branch-tension.lisp"
    "compiler/codegen-arm64.lisp"
    "compiler/builtins-arm64/builtins.lisp"
    "compiler/builtins-arm64/cons.lisp"
    "compiler/builtins-arm64/memory.lisp"
    "compiler/builtins-arm64/misc.lisp"
    "compiler/builtins-arm64/numbers.lisp"
    "compiler/builtins-arm64/objects.lisp"
    "compiler/builtins-arm64/unwind.lisp"
    "compiler/lower-environment.lisp"
    "compiler/lower-special-bindings.lisp"
    "compiler/value-aware-lowering.lisp"
    "compiler/simplify-control-flow.lisp"
    "compiler/blexit.lisp"
    "compiler/transforms.lisp"
    "compiler/backend/backend.lisp"
    "compiler/backend/cfg.lisp"
    "compiler/backend/analysis.lisp"
    "compiler/backend/dominance.lisp"
    "compiler/backend/convert-ast.lisp"
    "compiler/backend/multiple-values.lisp"
    "compiler/backend/ssa.lisp"
    "compiler/backend/passes.lisp"
    "compiler/backend/register-allocation.lisp"
    "compiler/backend/x86-64.lisp"
    ("runtime/simd.lisp" :x86-64)
    "system/file-compiler.lisp"
    "system/xp-package.lisp"
    "system/xp.lisp"
    "system/xp-format.lisp"
    "system/xp-printers.lisp"
    "system/profiler.lisp"
    "drivers/network-card.lisp"
    "drivers/virtio-net.lisp"
    ("drivers/rtl8168.lisp" :x86-64)
    "drivers/sound.lisp"
    ("drivers/intel-hda.lisp" :x86-64)
    "net/package.lisp"
    "net/network.lisp"
    "net/ethernet.lisp"
    "net/arp.lisp"
    "net/ip.lisp"
    "net/udp.lisp"
    "net/tcp.lisp"
    "net/dns.lisp"
    "net/network-setup.lisp"
    "file/fs.lisp"
    "file/remote.lisp"
    "config.lisp"
    "ipl.lisp"))

(defparameter *cl-symbol-list-file* "tools/cl-symbols.lisp-expr")
(defparameter *8x8-debug-font* "tools/font8x8")
(defparameter *unifont* "tools/unifont-5.1.20080820.hex")
(defparameter *unicode-data* "tools/UnicodeData.txt")
(defparameter *pci-ids* "tools/pci.ids")

(defun compile-warm-source (&optional force)
  (dolist (file *warm-source-files*)
    (let ((llf-path (merge-pathnames (make-pathname :type "llf" :defaults file))))
      (when (or (not (probe-file llf-path))
                (<= (file-write-date llf-path) (file-write-date file))
                force)
        (format t "~A is out of date will be recompiled.~%" llf-path)
        (sys.c::cross-compile-file file)))))

(defvar *symbol-table*)
(defvar *reverse-symbol-table*)
;; Hash-table mapping function names to function references.
(defvar *fref-table*)
(defvar *struct-table*)
(defvar *unbound-value-address*)
(defvar *undefined-function-address*)
(defvar *closure-trampoline-address*)
(defvar *f-i-trampoline-address*)
(defvar *load-time-evals*)
(defvar *string-dedup-table*)
(defvar *structure-definition-definition*)
(defvar *structure-slot-definition-definition*)
(defvar *image-to-cross-slot-definitions*)

(defvar *function-map*)
(defvar *pending-fixups*)

;;; Memory allocation.

;; Wired area starts at 2M.
(defconstant +wired-area-base+ (* 2 1024 1024))
;; Pinned at 2G.
(defconstant +pinned-area-base+ (* 2 1024 1024 1024))
;; Wired area stops at 2G, below the pinned area.
(defconstant +wired-area-limit+ (* 2 1024 1024 1024))

;; Wired stack area starts at the bottom of the stack area.
(defconstant +wired-stack-area-base+ 0)
;; Not set to 512GB because bootloader is slow & dumb.
(defconstant +wired-stack-area-limit+ (* 2 1024 1024 1024))
;; Leave a gap, for future expansion.
(defconstant +stack-area-base+ (* 512 1024 1024 1024))

;; Past this, the address starts to infringe on the address info bits.
;; Technically, the pinned area doesn't care about bit 44, but be consistent.
(defconstant +area-limit+ (expt 2 44))

(defvar *wired-area-bump*)
(defvar *wired-area-data*)
(defvar *wired-area-store*)
(defvar *pinned-area-bump*)
(defvar *pinned-area-data*)
(defvar *pinned-area-store*)
(defvar *general-area-bump*)
(defvar *general-area-data*)
(defvar *general-area-store*)
(defvar *cons-area-bump*)
(defvar *cons-area-data*)
(defvar *cons-area-store*)

(defstruct stack
  base
  size
  store)

(defvar *stack-list*)
(defvar *stack-area-bump*)

(defvar *store-bump*)

(defvar *default-general-allocation-area* :general)
(defvar *default-cons-allocation-area* :cons)
(defvar *default-pinned-allocation-area* :pinned)

(defun align-up (value boundary)
  (incf value (1- boundary))
  (- value (rem value boundary)))

(defun allocate-1 (size bump-symbol data-symbol data-offset limit tag name)
  (when (>= (+ (symbol-value bump-symbol) size) limit)
    (error "~A area exceeded limit." name))
  (let ((address (symbol-value bump-symbol)))
    (incf (symbol-value bump-symbol) size)
    ;; Keep data vector page aligned, but don't expand it too often.
    ;; Keeping it 2MB aligned is important - WRITE-IMAGE relies on this to
    ;; provide zeros in unallocated parts of the area.
    (let ((dv-size (align-up (symbol-value bump-symbol) #x200000)))
      (when (not (eql (- dv-size data-offset)
                      (length (symbol-value data-symbol))))
        (setf (symbol-value data-symbol) (adjust-array (symbol-value data-symbol)
                                                       (- dv-size data-offset)
                                                       :element-type '(unsigned-byte 8)
                                                       :initial-element 0))))
    (/ (logior address (ash tag sys.int::+address-tag-shift+)) 8)))

(defun allocate (word-count &optional area)
  (when (oddp word-count) (incf word-count))
  (let ((size (* word-count 8)))
    (ecase (or area *default-general-allocation-area*)
      (:wired
       (allocate-1 size '*wired-area-bump* '*wired-area-data* +wired-area-base+ +wired-area-limit+ sys.int::+address-tag-pinned+ "wired"))
      (:pinned
       (allocate-1 size '*pinned-area-bump* '*pinned-area-data* +pinned-area-base+ +area-limit+ sys.int::+address-tag-pinned+ "pinned"))
      (:general
       (allocate-1 size '*general-area-bump* '*general-area-data* 0 +area-limit+ sys.int::+address-tag-general+ "general"))
      (:cons
       (allocate-1 size '*cons-area-bump* '*cons-area-data* 0 +area-limit+ sys.int::+address-tag-cons+ "cons")))))

(defun area-for-address (address)
  (let ((byte-address (* address 8)))
    (case (ldb (byte sys.int::+address-tag-size+
                     sys.int::+address-tag-shift+)
               byte-address)
      (#.sys.int::+address-tag-pinned+
       (cond ((<= +pinned-area-base+ byte-address (1- +area-limit+))
              (values (/ (- (logand byte-address (1- +area-limit+)) +pinned-area-base+) 8)
                      *pinned-area-data*))
             ((<= +wired-area-base+ byte-address (1- +wired-area-limit+))
              (values (/ (- (logand byte-address (1- +area-limit+)) +wired-area-base+) 8)
                      *wired-area-data*))
             (t (error "Unknown address #x~X" address))))
      ;;(#.sys.int::+address-tag-stack+)
      (#.sys.int::+address-tag-general+
       (values (/ (logand byte-address (1- +area-limit+)) 8)
               *general-area-data*))
      (#.sys.int::+address-tag-cons+
       (values (/ (logand byte-address (1- +area-limit+)) 8)
               *cons-area-data*))
      (t (error "Unknown address #x~X" address)))))

(defun create-stack (size)
  ;; Lower guard region.
  (incf *stack-area-bump* #x200000)
  (setf size (align-up size #x1000))
  (let* ((address (logior (ash sys.int::+address-tag-stack+ sys.int::+address-tag-shift+)
                          *stack-area-bump*))
         (info (make-stack :base address :size size)))
    (incf *stack-area-bump* (align-up size #x200000))
    (push info *stack-list*)
    info))

(defvar *word-locks*)

(defun lock-word (address)
  (setf (gethash address *word-locks*) t))

(defun (setf word) (new-value address)
  (when (gethash address *word-locks*)
    (error "Attempted to write locked word at ~X~%" address))
  (multiple-value-bind (offset data-vector)
      (area-for-address address)
    (setf (ub64ref/le data-vector (* offset 8)) new-value)))

(defun word (address)
  (multiple-value-bind (offset data-vector)
      (area-for-address address)
    (ub64ref/le data-vector (* offset 8))))

(defun assemble (code-list &rest args)
  (let ((sys.lap:*function-reference-resolver* #'sys.c::resolve-fref))
    (ecase sys.c::*target-architecture*
      (:x86-64
       (apply #'sys.lap-x86:assemble code-list args))
      (:arm64
       (apply #'mezzano.lap.arm64:assemble code-list args)))))

(defun compile-lap-function (code &key (area *default-pinned-allocation-area*) extra-symbols constant-values (position-independent t) (name 'sys.int::support-function))
  "Compile a list of LAP code as a function. Constants must only be symbols."
  (let ((base-address (if position-independent
                          0
                          *wired-area-bump*)))
    (multiple-value-bind (mc constants fixups symbols gc-info)
        (assemble (list* (list :d64/le 0 0) code) ; 16 byte header.
          :base-address base-address
          :initial-symbols (list* '(nil . :fixup)
                                  '(t . :fixup)
                                  extra-symbols)
          ;; Name & debug info.
          :info (list name nil))
      (declare (ignore symbols))
      (setf mc (let ((array (make-array (* (ceiling (length mc) 16) 16)
                                        :fill-pointer t
                                        :element-type '(unsigned-byte 8))))
                 (replace array mc)))
      (let ((total-size (+ (* (truncate (length mc) 16) 2)
                           (length constants)
                           (ceiling (length gc-info) 8))))
        (when (oddp total-size) (incf total-size))
        (let ((address (allocate total-size area)))
          ;; Copy machine code into the area.
          (dotimes (i (truncate (length mc) 8))
{'fraction_non_alphanumeric': 0.16256596306068602, 'fraction_numerical': 0.025692612137203166, 'mean_word_length': 2.8497968511934992, 'pattern_counts': {'":': 0, '<': 15, '<?xml version=': 0, '>': 11, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 18, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '4500874', 'n_tokens_mistral': 11618, 'n_tokens_neox': 10871, 'n_words': 1928}