losp/muerte/segments.lisp

   1 ;;;;------------------------------------------------------------------
   2 ;;;;
   3 ;;;;    Copyright (C) 2001, 2003-2005,
   4 ;;;;    Department of Computer Science, University of Tromso, Norway.
   5 ;;;;
   6 ;;;;    For distribution policy, see the accompanying file COPYING.
   7 ;;;;
   8 ;;;; Filename:      segments.lisp
   9 ;;;; Description:
  10 ;;;; Author:        Frode Vatvedt Fjeld <frodef@acm.org>
  11 ;;;; Created at:    Thu May  8 14:25:06 2003
  12 ;;;;
  13 ;;;; $Id: segments.lisp,v 1.19 2007/04/13 22:41:05 ffjeld Exp $
  14 ;;;;
  15 ;;;;------------------------------------------------------------------
  16
  17 (provide :muerte/segments)
  18
  19 (in-package muerte)
  20
  21 (defvar *initial-segment-descriptor-table*)
  22
  23 (defun segment-register (segment-register-name)
  24   "Return the value of an x86 segment register, such as :cs or :ds."
  25   (declare (without-check-stack-limit))
  26   (macrolet ((sreg (reg)
  27                `(with-inline-assembly (:returns :untagged-fixnum-ecx)
  28                   (:xorl :ecx :ecx)
  29                   (:movw ,reg :cx))))
  30     (ecase segment-register-name
  31       (:ss (sreg :ss))
  32       (:cs (sreg :cs))
  33       (:ds (sreg :ds))
  34       (:es (sreg :es))
  35       (:fs (sreg :fs))
  36       (:gs (sreg :gs)))))
  37
  38 (defun (setf segment-register) (value segment-register-name)
  39   "This function indiscriminately sets a segment register,
  40 which is a great way to crash the machine. So know what you're doing."
  41   (declare (without-check-stack-limit))
  42   (check-type value (unsigned-byte 16))
  43   (macrolet ((set-sreg (reg)
  44                `(with-inline-assembly (:returns :nothing)
  45                   (:compile-form (:result-mode :ecx) value)
  46                   (:shrl #.movitz::+movitz-fixnum-shift+ :ecx)
  47                   (:movw :cx ,reg))))
  48     (ecase segment-register-name
  49       (:ss (set-sreg :ss))
  50       (:ds (set-sreg :ds))
  51       (:es (set-sreg :es))
  52       (:fs (set-sreg :fs))
  53       (:gs (set-sreg :gs))
  54       (:cs (without-interrupts
  55              (with-inline-assembly (:returns :nothing)
  56                (:load-lexical (:lexical-binding value) :untagged-fixnum-ecx)
  57                (:declare-label-set jmp-table (jmp-target))
  58                (:pushl :ecx)            ; push selector
  59                (:pushl (:esi (:offset movitz-funobj constant0) 'jmp-table))
  60                (:jmp-segment (:esp))
  61               jmp-target
  62                (:popl :ecx)
  63                (:popl :ecx))))))
  64   value)
  65
  66 (defun %sgdt ()
  67   "Return the location of the GDT, and the limit.
  68 Error if the GDT location is not zero modulo 4."
  69   (declare (without-check-stack-limit))
  70   (eval-when (:compile-toplevel)
  71     (assert (= 4 movitz:+movitz-fixnum-factor+)))
  72   (without-interrupts
  73     (with-inline-assembly (:returns :multiple-values)
  74       (:std)
  75       (:pushl 0)
  76       (:pushl 0)
  77       (:leal (:esp 2) :ecx)
  78       (:sgdt (:ecx))
  79       (:popl :ebx)
  80       (:shrl #.(cl:- 16 movitz::+movitz-fixnum-shift+) :ebx)
  81       (:andl -4 :ebx)
  82       (:popl :eax)
  83       (:andl -4 :eax)
  84       (:cld)
  85       (:movl 2 :ecx)
  86       (:stc))))
  87
  88 (defun %lgdt (base-location limit)
  89   "Set the GDT according to base-location and limit.
  90 This is the setter corresponding to the sgdt getter."
  91   (declare (without-check-stack-limit))
  92   (eval-when (:compile-toplevel)
  93     (assert (= 4 movitz:+movitz-fixnum-factor+)))
  94   (check-type base-location fixnum)
  95   (check-type limit positive-fixnum)
  96   (without-interrupts
  97     (with-inline-assembly (:returns :eax)
  98       (:compile-form (:result-mode :push) base-location)
  99       (:compile-form (:result-mode :push) limit)
 100       (:shll #.(cl:- 16 movitz:+movitz-fixnum-shift+) (:esp))
 101       (:leal (:esp 2) :ecx)
 102       (:lgdt (:ecx))
 103       (:popl :eax)
 104       (:popl :eax))))
 105
 106 ;;;
 107
 108 (defun control-register (name)
 109   (macrolet ((creg (reg)
 110                `(with-inline-assembly (:returns :untagged-fixnum-ecx)
 111                   (:movcr ,reg :ecx))))
 112     (ecase name
 113       (:cr0 (creg :cr0))
 114       (:cr2 (creg :cr2))
 115       (:cr3 (creg :cr3))
 116       (:cr4 (creg :cr4)))))
 117
 118 (defun control-register-lo12 (name)
 119   "Return the low 12 bits of an x86 control register, such as :cr0 or :cr1."
 120   (macrolet ((creg (reg)
 121                `(with-inline-assembly (:returns :untagged-fixnum-ecx)
 122                   (:movcr ,reg :ecx)
 123                   (:andl #xfff :ecx))))
 124     (ecase name
 125       (:cr0 (creg :cr0))
 126       (:cr2 (creg :cr2))
 127       (:cr3 (creg :cr3))
 128       (:cr4 (creg :cr4)))))
 129
 130 (defun control-register-hi20 (name)
 131   "Return the high 20 bits of an x86 control register, such as :cr0 or :cr1."
 132   (macrolet ((creg (reg)
 133                `(with-inline-assembly (:returns :ecx)
 134                   (:movcr ,reg :ecx)
 135                   (:andl #xfffff000 :ecx)
 136                   (:shrl #.(cl:- 12 movitz::+movitz-fixnum-shift+) :ecx))))
 137     (ecase name
 138       (:cr0 (creg :cr0))
 139       (:cr2 (creg :cr2))
 140       (:cr3 (creg :cr3))
 141       (:cr4 (creg :cr4)))))
 142
 143 (defun (setf control-register-lo12) (value name)
 144   "Set the low 12 bits of an x86 control register, such as :cr0 or :cr1."
 145   (macrolet ((set-creg (reg)
 146                `(with-inline-assembly (:returns :nothing)
 147                   (:compile-form (:result-mode :eax) value)
 148                   (:movcr ,reg :ecx)
 149                   (:andl ,(cl:* movitz::+movitz-fixnum-factor+ #xfff) :eax)
 150                   (:andl #xfffff000 :ecx)
 151                   (:shrl ,movitz::+movitz-fixnum-shift+ :eax)
 152                   (:orl :eax :ecx)
 153                   (:movcr :ecx ,reg))))
 154     (ecase name
 155       (:cr0 (set-creg :cr0))
 156       (:cr2 (set-creg :cr2))
 157       (:cr3 (set-creg :cr3))
 158       (:cr4 (set-creg :cr4)))
 159     value))
 160
 161 (defun (setf control-register-hi20) (value name)
 162   "Set the high 20 bits of an x86 control register, such as :cr0 or :cr1."
 163   (macrolet ((set-creg (reg)
 164                `(with-inline-assembly (:returns :nothing)
 165                   (:compile-form (:result-mode :eax) value)
 166                   (:movcr ,reg :ecx)
 167                   (:shll ,(- 12 movitz::+movitz-fixnum-shift+) :eax)
 168                   (:andl #xfff :ecx)
 169                   (:andl #xfffff000 :eax)
 170                   (:orl :eax :ecx)
 171                   (:movcr :ecx ,reg))))
 172     (ecase name
 173       (:cr0 (set-creg :cr0))
 174       (:cr2 (set-creg :cr2))
 175       (:cr3 (set-creg :cr3))
 176       (:cr4 (set-creg :cr4)))
 177     value))
 178
 179 ;;
 180
 181 (defun (setf global-segment-descriptor-table) (table)
 182   "Install <table> as the GDT.
 183 NB! you need to ensure that the table object isn't garbage-collected."
 184   (check-type table (vector (unsigned-byte 32)))
 185   (let ((limit (1- (* 4 (length table))))
 186         (base (+ 2 (+ (object-location table)
 187                       (location-physical-offset)))))
 188     (%lgdt base limit)
 189     table))
 190
 191 (defun segment-descriptor-base-location (table selector)
 192   (check-type table (and vector (not simple-vector)))
 193   (eval-when (:compile-toplevel)
 194     (assert (= 4 movitz::+movitz-fixnum-factor+)))
 195   ;; XXX This fails for locations above 2GB.
 196   (let ((offset (+ (logand selector #xfff8)
 197                    (movitz-type-slot-offset 'movitz-basic-vector 'data))))
 198     (logior (ash (memref table (+ 7 offset) :type :unsigned-byte8)
 199                  22)
 200             (ash (memref table (+ 4 offset) :type :unsigned-byte8)
 201                  14)
 202             (ash (memref table (+ 2 offset) :type :unsigned-byte16)
 203                  -2))))
 204
 205 (defun (setf segment-descriptor-base-location) (base-location table selector)
 206   (check-type table (and vector (not simple-vector)))
 207   (eval-when (:compile-toplevel)
 208     (assert (= 4 movitz::+movitz-fixnum-factor+)))
 209   (let ((offset (+ (logand #xfff8 selector)
 210                    (movitz-type-slot-offset 'movitz-basic-vector 'data))))
 211     (setf (memref table (+ 7 offset) :type :unsigned-byte8)
 212       (ldb (byte 8 22) base-location))
 213     (setf (memref table (+ 4 offset) :type :unsigned-byte8)
 214       (ldb (byte 8 14) base-location))
 215     (setf (memref table (+ 2 offset) :type :unsigned-byte16)
 216       (ash (ldb (byte 14 0) base-location) 2))
 217     base-location))
 218
 219 (defun segment-descriptor-limit (table selector)
 220   (check-type table (and vector (not simple-vector)))
 221   (let ((offset (+ (logand #xfff8 selector)
 222                    (movitz-type-slot-offset 'movitz-basic-vector 'data))))
 223     (dpb (memref table (+ 6 offset) :type :unsigned-byte8)
 224          (byte 4 16)
 225          (memref table (+ 0 offset) :type :unsigned-byte16))))
 226
 227 (defun (setf segment-descriptor-limit) (limit table selector)
 228   (check-type table (and vector (not simple-vector)))
 229   (let ((offset (+ (logand #xfff8 selector)
 230                    (movitz-type-slot-offset 'movitz-basic-vector 'data))))
 231     (setf (ldb (byte 4 0) (memref table (+ 6 offset) :type :unsigned-byte8))
 232           (ldb (byte 4 16) limit))
 233     (setf (memref table (+ 0 offset) :type :unsigned-byte16)
 234           (ldb (byte 16 0) limit))
 235     limit))
 236
 237 (defun segment-descriptor-type-s-dpl-p (table selector)
 238   "Access bits 40-47 of the segment descriptor."
 239   (check-type table (and vector (not simple-vector)))
 240   (memref table (+ 5 (logand #xfff8 selector)
 241                    (movitz-type-slot-offset 'movitz-basic-vector 'data))
 242           :type :unsigned-byte8))
 243
 244 (defun (setf segment-descriptor-type-s-dpl-p) (bits table selector)
 245   "Access bits 40-47 of the segment descriptor."
 246   (check-type table (and vector (not simple-vector)))
 247   (setf (memref table (+ 5 (logand #xfff8 selector)
 248                          (movitz-type-slot-offset 'movitz-basic-vector 'data))
 249                 :type :unsigned-byte8)
 250     bits))
 251
 252 (defun segment-descriptor-avl-x-db-g (table selector)
 253   "Access bits 52-55 of the segment descriptor."
 254   (check-type table (and vector (not simple-vector)))
 255   (ldb (byte 4 4)
 256        (memref table (+ 6 (logand #xfff8 selector)
 257                         (movitz-type-slot-offset 'movitz-basic-vector 'data))
 258                :type :unsigned-byte8)))
 259
 260 (defun (setf segment-descriptor-avl-x-db-g) (bits table selector)
 261   "Access bits 52-55 of the segment descriptor."
 262   (check-type table (and vector (not simple-vector)))
 263   (setf (ldb (byte 4 4)
 264              (memref table (+ 6 (logand #xfff8 selector)
 265                               (movitz-type-slot-offset 'movitz-basic-vector 'data))
 266                      :type :unsigned-byte8))
 267     bits))
 268
 269 (defun segment-descriptor (table selector)
 270   "Access entire segment descriptor as a 64-bit integer."
 271   (check-type table (and vector (not simple-vector)))
 272   (let ((offset (+ (logand #xfff8 selector)
 273                    (movitz-type-slot-offset 'movitz-basic-vector 'data))))
 274     (logior (ash (memref table offset :index 1 :type :unsigned-byte32)
 275                  32)
 276             (ash (memref table offset :index 0 :type :unsigned-byte32)
 277                  0))))
 278
 279 (defun (setf segment-descriptor) (value table selector)
 280   "Access entire segment descriptor as a 64-bit integer."
 281   (check-type table (and vector (not simple-vector)))
 282   (let ((offset (+ (logand #xfff8 selector)
 283                    (movitz-type-slot-offset 'movitz-basic-vector 'data))))
 284     (setf (memref table offset :index 1 :type :unsigned-byte32)
 285       (ldb (byte 32 32) value))
 286     (setf (memref table offset :index 0 :type :unsigned-byte32)
 287       (ldb (byte 32 0) value))
 288     value))
 289
 290 (defun dump-global-segment-table (&key table entries nofill)
 291   "Dump contents of the current global (segment) descriptor table into a vector."
 292   (multiple-value-bind (gdt-base gdt-limit)
 293       (%sgdt)
 294     (let* ((gdt-entries (/ (1+ gdt-limit) 8))
 295            (entries (or entries gdt-entries)))
 296       (check-type entries (integer 1 8192))
 297       (let ((table (or table
 298                        (make-array (* 2 entries)
 299                                    :element-type '(unsigned-byte 32)
 300                                    :initial-element 0))))
 301         (check-type table (vector (unsigned-byte 32)))
 302         (unless nofill
 303           (loop for i upfrom 0 below (* 2 gdt-entries)
 304               do (setf (aref table i)
 305                    (memref gdt-base 0 :index i :type :unsigned-byte32 :physicalp t))))
 306         table))))