losp/ll-testing.lisp

   1 ;;;;------------------------------------------------------------------
   2 ;;;;
   3 ;;;;    Copyright (C) 2005,
   4 ;;;;    Department of Computer Science, University of Tromso, Norway.
   5 ;;;;
   6 ;;;;    For distribution policy, see the accompanying file COPYING.
   7 ;;;;
   8 ;;;; Filename:      ll-testing.lisp
   9 ;;;; Description:   low-level test code.
  10 ;;;; Author:        Frode Vatvedt Fjeld <frodef@acm.org>
  11 ;;;; Created at:    Thu Apr 14 08:18:43 2005
  12 ;;;;
  13 ;;;; $Id: ll-testing.lisp,v 1.12 2005/08/24 07:32:52 ffjeld Exp $
  14 ;;;;
  15 ;;;;------------------------------------------------------------------
  16
  17 (provide :ll-testing)
  18 (in-package muerte)
  19
  20 ;;;(defun dump-global-segment-table (&key table entries nofill)
  21 ;;;  "Dump contents of the current global (segment) descriptor table into a vector."
  22 ;;;  (multiple-value-bind (gdt-base gdt-limit)
  23 ;;;      (%sgdt)
  24 ;;;    (let* ((gdt-entries (/ (1+ gdt-limit) 8))
  25 ;;;        (entries (or entries gdt-entries)))
  26 ;;;      (check-type entries (integer 1 8192))
  27 ;;;      (let ((table (or table
  28 ;;;                    (make-array (* 2 entries)
  29 ;;;                                :element-type '(unsigned-byte 32)
  30 ;;;                                :initial-element 0))))
  31 ;;;     (check-type table (vector (unsigned-byte 32)))
  32 ;;;     (unless nofill
  33 ;;;       (loop for i upfrom 0 below (* 2 gdt-entries)
  34 ;;;           do (setf (aref table i)
  35 ;;;                (memref gdt-base 0 :index i :type :unsigned-byte32 :physicalp t))))
  36 ;;;     table))))
  37
  38
  39
  40 (defmacro control-stack-fs (stack)
  41   `(stack-frame-ref ,stack 0 2))
  42
  43 (defmacro control-stack-esp (stack)
  44   `(stack-frame-ref ,stack 0 1))
  45
  46 (defmacro control-stack-ebp (stack)
  47   `(stack-frame-ref ,stack 0 0))
  48
  49 (defun control-stack-init (&optional (stack (make-array 254 :element-type '(unsigned-byte 32))))
  50   (let ((i (length stack)))
  51     (setf (control-stack-esp stack) i
  52           (control-stack-ebp stack) 0)
  53     stack))
  54
  55 (defun control-stack-push (value stack &optional (type :lisp))
  56   (let ((i (decf (control-stack-esp stack))))
  57     (assert (< 1 i (length stack)))
  58     (setf (stack-frame-ref stack i 0 type) value)))
  59
  60 (defun control-stack-enter-frame (stack &optional function)
  61   (control-stack-push (control-stack-ebp stack) stack)
  62   (setf (control-stack-ebp stack) (control-stack-esp stack))
  63   (when function
  64     (check-type function function)
  65     (control-stack-push function stack))
  66   stack)
  67
  68 (defun stack-stopper (&rest args)
  69   (declare (ignore args))
  70   (declare (without-function-prelude))
  71   (error "Stack stop.")
  72   (format *terminal-io* "~&Stack-stopper halt.")
  73   (loop (halt-cpu)))
  74
  75 (defun alloc-context (segment-descriptor-table)
  76   (let* ((fs-index 8)
  77          (thread (muerte::clone-run-time-context :name 'subthread)))
  78     (setf (segment-descriptor segment-descriptor-table fs-index)
  79       (segment-descriptor segment-descriptor-table (truncate (segment-register :fs) 8)))
  80     (warn "Thread ~S FS base: ~S"
  81           thread
  82           (setf (segment-descriptor-base-location segment-descriptor-table fs-index)
  83             (+ (object-location thread)
  84                (muerte::location-physical-offset))))
  85     (values thread (* 8 fs-index))))
  86
  87 (defun control-stack-bootstrap (stack function &rest args)
  88   (declare (dynamic-extent args))
  89   (check-type function function)
  90   (control-stack-init stack)
  91   (control-stack-push 0 stack)
  92   (control-stack-enter-frame stack #'stack-stopper)
  93   (let ((stack-top (+ (object-location stack) 2 (length stack)))
  94         (stack-bottom (+ (object-location stack) 2)))
  95     (dolist (arg (cddr args))
  96       (control-stack-push arg stack))
  97     (control-stack-push (+ 2 1 (object-location (funobj-code-vector #'stack-stopper)))
  98                         stack)          ; XXX The extra word skips the frame-setup.
  99     (multiple-value-bind (ebp esp)
 100         (control-stack-fixate stack)
 101       (stack-yield stack esp ebp
 102                    :eax (car args)
 103                    :ebx (cadr args)
 104                    :ecx (length args)
 105                    :esi function)))
 106   stack)
 107
 108 ;;;(defun make-thread (&key (name (gensym "thread-")) (function #'invoke-debugger) (args '(nil)))
 109 ;;;  "Make a thread and initialize its stack to apply function to args."
 110 ;;;  (let* ((fs-index 8)                        ; a vacant spot in the global segment descriptor table..
 111 ;;;      (fs (* 8 fs-index))
 112 ;;;      (thread (muerte::clone-run-time-context :name name))
 113 ;;;      (segment-descriptor-table (symbol-value 'muerte.init::*segment-descriptor-table*)))
 114 ;;;    (setf (segment-descriptor segment-descriptor-table fs-index)
 115 ;;;      (segment-descriptor segment-descriptor-table (truncate (segment-register :fs) 8)))
 116 ;;;    (setf (segment-descriptor-base-location segment-descriptor-table fs-index)
 117 ;;;      (+ (object-location thread) (muerte::location-physical-offset)))
 118 ;;;    (let ((cushion nil)
 119 ;;;       (stack (control-stack-init-for-yield (make-array 4094 :element-type '(unsigned-byte 32))
 120 ;;;                                            function args)))
 121 ;;;      (multiple-value-bind (ebp esp)
 122 ;;;       (control-stack-fixate stack)
 123 ;;;     (setf (control-stack-fs stack) fs
 124 ;;;           (control-stack-ebp stack) ebp
 125 ;;;           (control-stack-esp stack) esp))
 126 ;;;      (setf (%run-time-context-slot 'dynamic-env thread) 0
 127 ;;;         (%run-time-context-slot 'stack-vector thread) stack
 128 ;;;         (%run-time-context-slot 'stack-top thread) (+ 2 (object-location stack)
 129 ;;;                                                       (length stack))
 130 ;;;         (%run-time-context-slot 'stack-bottom thread) (+ (object-location stack) 2
 131 ;;;                                                          (or cushion
 132 ;;;                                                              (if (>= (length stack) 200)
 133 ;;;                                                                  100
 134 ;;;                                                                0))))
 135 ;;;      (values thread))))
 136
 137 (defun stack-bootstrapper (&rest ignore)
 138   (declare (ignore ignore))
 139   (let ((frame (current-stack-frame)))
 140     (assert (eql 0 (stack-frame-uplink nil frame)))
 141     (let ((function (stack-frame-ref nil frame 1))
 142           (args (stack-frame-ref nil frame 2)))
 143       (check-type function function)
 144       (check-type args list)
 145       (apply function args)))
 146   (error "Nothing left to do for ~S." (current-run-time-context))
 147   (format *terminal-io* "~&stack-bootstrapper halt.")
 148   (loop (halt-cpu)))
 149
 150 (defun control-stack-init-for-yield (stack function args)
 151   (check-type function function)
 152   (control-stack-init stack)
 153   (control-stack-push args stack)
 154   (control-stack-push function stack)
 155   (control-stack-enter-frame stack #'stack-bootstrapper)
 156   ;; Now pretend stack-bootstrapper called yield. First, the return address
 157   (control-stack-push (+ 2 2 (object-location (funobj-code-vector #'stack-bootstrapper)))
 158                       stack)            ; XXX The extra 2 words skip the frame-setup,
 159                                         ; XXX which happens to be 8 bytes..
 160   (control-stack-enter-frame stack #'yield)
 161   stack)
 162
 163
 164 (defun yield (target-rtc &optional value)
 165   (declare (dynamic-extent values))
 166   (assert (not (eq target-rtc (current-run-time-context))))
 167   (let ((my-stack (%run-time-context-slot 'stack-vector))
 168         (target-stack (%run-time-context-slot 'stack-vector target-rtc)))
 169     (assert (not (eq my-stack target-stack)))
 170     (let ((fs (control-stack-fs target-stack))
 171           (esp (control-stack-esp target-stack))
 172           (ebp (control-stack-ebp target-stack)))
 173       (assert (location-in-object-p target-stack esp))
 174       (assert (location-in-object-p target-stack ebp))
 175       (assert (eq (stack-frame-funobj nil ebp)
 176                   (asm-register :esi)) ()
 177         "Will not yield to a non-yield frame.")
 178       ;; Push eflags for later..
 179       (setf (memref (decf esp) 0) (eflags))
 180       ;; Store EBP and ESP so we can get to them after the switch
 181       (setf (%run-time-context-slot 'scratch1 target-rtc) ebp
 182             (%run-time-context-slot 'scratch2 target-rtc) esp)
 183       ;; Enable someone to yield back here..
 184       (setf (control-stack-fs my-stack) (segment-register :fs)
 185             (control-stack-ebp my-stack) (asm-register :ebp)
 186             (control-stack-esp my-stack) (asm-register :esp))
 187       (with-inline-assembly (:returns :eax)
 188         (:load-lexical (:lexical-binding fs) :untagged-fixnum-ecx)
 189         (:load-lexical (:lexical-binding value) :eax)
 190         (:cli)
 191         (:movw :cx :fs)
 192         (:locally (:movl (:edi (:edi-offset scratch1)) :ebp))
 193         (:locally (:movl (:edi (:edi-offset scratch2)) :esp))
 194         (:popfl)))))
 195
 196 (defun stack-yield (stack esp ebp &key eax ebx ecx edx esi eflags (dynamic-env 0) cushion)
 197   "Activate stack for the current run-time-context, and load the indicated CPU state.
 198 EIP is loaded from ESI's code-vector."
 199   (assert (not (eq stack (%run-time-context-slot 'stack-vector))))
 200   (assert (location-in-object-p stack esp))
 201   (assert (location-in-object-p stack ebp))
 202   (assert (or (= 0 dynamic-env) (location-in-object-p stack dynamic-env)))
 203   (let ((stack-top (+ (object-location stack) 2 (length stack)))
 204         (stack-bottom (+ (object-location stack) 2
 205                          (or cushion
 206                              (if (>= (length stack) 200)
 207                                  100
 208                                0)))))
 209     (with-inline-assembly (:returns :non-local-exit)
 210       (:clc)
 211       (:pushfl)
 212       (:popl :ebx)
 213       (:compile-form (:result-mode :eax) eflags)
 214       (:cmpl :edi :eax)
 215       (:je 'no-eflags-provided)
 216       (:movl :eax :ebx)
 217      no-eflags-provided
 218       (:locally (:movl :ebx (:edi (:edi-offset raw-scratch0)))) ; Keep eflags in raw-scratch0
 219       (:cli)                            ; Disable interrupts for a little while
 220       (:compile-form (:result-mode :eax) stack)
 221       (:locally (:movl :eax (:edi (:edi-offset stack-vector))))
 222       (:compile-form (:result-mode :eax) dynamic-env)
 223       (:locally (:movl :eax (:edi (:edi-offset dynamic-env))))
 224       (:compile-two-forms (:eax :ebx) stack-top stack-bottom)
 225       (:locally (:movl :eax (:edi (:edi-offset stack-top))))
 226       (:locally (:movl :ebx (:edi (:edi-offset stack-bottom))))
 227
 228       (:compile-two-forms (:eax :ebx) esp ebp)
 229       (:locally (:movl :eax (:edi (:edi-offset scratch1))))
 230       (:locally (:movl :ebx (:edi (:edi-offset scratch2))))
 231
 232       (:compile-form (:result-mode :untagged-fixnum-ecx) ecx)
 233       (:compile-two-forms (:eax :ebx) eax ebx)
 234       (:compile-two-forms (:edx :esi) edx esi)
 235       (:locally (:movl (:edi (:edi-offset scratch1)) :esp))
 236       (:locally (:movl (:edi (:edi-offset scratch2)) :ebp))
 237       (:locally (:pushl (:edi (:edi-offset raw-scratch0)))) ; reset eflags
 238       (:popfl)
 239       (:jmp (:esi (:offset movitz-funobj code-vector))))))
 240
 241
 242