losp/los0.lisp

   1 ;;;;------------------ -*- movitz-mode: t -*--------------------------
   2 ;;;;
   3 ;;;;    Copyright (C) 2000-2005,
   4 ;;;;    Department of Computer Science, University of Tromso, Norway
   5 ;;;;
   6 ;;;; Filename:      los0.lisp
   7 ;;;; Description:   Top-level initialization and testing.
   8 ;;;; Author:        Frode Vatvedt Fjeld <frodef@acm.org>
   9 ;;;; Created at:    Fri Dec  1 18:08:32 2000
  10 ;;;; Distribution:  See the accompanying file COPYING.
  11 ;;;;
  12 ;;;; $Id: los0.lisp,v 1.51 2007/04/09 17:30:15 ffjeld Exp $
  13 ;;;;
  14 ;;;;------------------------------------------------------------------
  15
  16 (provide :los0 :load-priority 0)
  17
  18 (require :common-lisp)
  19 (require :x86-pc/all)
  20 (require :x86-pc/io-space)
  21 (require :x86-pc/ne2k)
  22 (require :x86-pc/floppy)
  23 (require :x86-pc/serial)
  24
  25 (require :lib/readline)
  26 (require :lib/toplevel)
  27 ;; (require :lib/net/ip6)
  28 (require :lib/net/ip4)
  29 (require :lib/net/dhcp)
  30 (require :lib/repl)
  31
  32 (require :lib/threading)
  33 (require :lib/scheduler)
  34
  35 (require :lib/graphics)
  36
  37
  38 ;; (require :lice-0.1/all)
  39
  40 (defpackage los0
  41   (:use #:common-lisp
  42         #:muerte
  43         #:muerte.lib
  44         #:muerte.x86-pc
  45         #:repl
  46         #:muerte.readline
  47         #:muerte.toplevel
  48         #:muerte.ethernet
  49 ;;      #:muerte.ip6
  50         #:muerte.ip4
  51         #:muerte.mop
  52         #:muerte.x86-pc.serial
  53         #:threading))
  54
  55 (require :lib/shallow-binding)
  56 (require :los0-gc)                      ; Must come after defpackage.
  57 ;; (require :asteroids)
  58 (require :scratch)
  59
  60 (in-package los0)
  61
  62 ;; (defun load-ansi-tests ()
  63 ;;   (load "../ansi-tests.lisp"))
  64
  65 (defun assess-cpu-frequency ()
  66   "Assess the CPU's frequency in units of 1024 Hz."
  67   (assert (cpu-featurep :tsc) ()
  68     "This function requires a CPU with the time-stamp-counter feature.")
  69   (let ((s0 (loop with x = (rtc-register :second)
  70                 for s0 = (rtc-register :second)
  71                 while (= x s0)
  72                 finally (return s0))))
  73     (multiple-value-bind (c0-lo c0-hi)
  74         (read-time-stamp-counter)
  75       (loop while (= s0 (rtc-register :second)))
  76       (multiple-value-bind (c1-lo c1-hi)
  77           (read-time-stamp-counter)
  78         (+ (ash (- c1-hi c0-hi) 19)
  79            (ash (+ 512 (- c1-lo c0-lo)) -10))))))
  80
  81 (defun report-cpu-frequency ()
  82   (multiple-value-bind (mhz khz)
  83       (truncate (assess-cpu-frequency) 976)
  84     (format t "~&CPU frequency: ~D.~2,'0D MHz.~%" mhz (round khz 10)))
  85   (values))
  86
  87 (defvar *cpu-frequency-mhz*)
  88
  89 (defun init-nano-sleep ()
  90   (setf *cpu-frequency-mhz*
  91     (truncate (assess-cpu-frequency) 976)))
  92
  93 (defun nano-sleep (nano-seconds)
  94   (let* ((t0 (read-time-stamp-counter))
  95          (t1 (+ t0 (truncate (* nano-seconds (%symbol-global-value '*cpu-frequency-mhz*))
  96                              10000))))
  97     (when (< t1 t0)
  98       (loop until (< (read-time-stamp-counter) t0))) ; wait for wrap-around
  99     (loop until (>= (read-time-stamp-counter) t1))))
 100
 101 (defun test-nano-sleep (x)
 102   (time (nano-sleep x)))
 103
 104 ;;;;;
 105
 106 ;;;;;;;;;;;;;;; CL
 107
 108 (defun install-internal-time (&optional (minimum-frequency 100))
 109   "Figure out this CPU's internal-time-unit. Warning: This process takes about 1.5 seconds."
 110   (let ((s0 (loop with x = (rtc-register :second)
 111                 for s0 = (rtc-register :second)
 112                 while (= x s0)
 113                 finally (return s0))))
 114     (multiple-value-bind (c0-lo c0-hi)
 115         (read-time-stamp-counter)
 116       (loop while (= s0 (rtc-register :second)))
 117       (multiple-value-bind (c1-lo c1-hi)
 118           (read-time-stamp-counter)
 119         (let ((res (+ (ash (ldb (byte 22 0) (- c1-hi c0-hi)) 7)
 120                       (ash (- c1-lo c0-lo) -22))))
 121           (cond
 122            ((> res minimum-frequency)
 123             (setf (symbol-function 'get-internal-run-time)
 124               (lambda ()
 125                 (multiple-value-bind (lo hi)
 126                     (read-time-stamp-counter)
 127                   (+ (ash lo -22)
 128                      (ash (ldb (byte 22 0) hi) 7)))))
 129             (setf internal-time-units-per-second res))
 130            (t ;; This is for really slow machines, like bochs..
 131             (let ((res (+ (ash (- c1-hi c0-hi) 13)
 132                           (ash (- c1-lo c0-lo) -16))))
 133               (setf (symbol-function 'get-internal-run-time)
 134                 (lambda ()
 135                   (multiple-value-bind (lo hi)
 136                       (read-time-stamp-counter)
 137                     (+ (ash (ldb (byte 16 0) hi) 13)
 138                        (ash lo -16)))))
 139               (setf internal-time-units-per-second res))))))))
 140   (values))
 141
 142
 143 (defun y-or-n-p (&optional control &rest arguments)
 144   "=> generalized-boolean"
 145   (declare (dynamic-extent arguments))
 146   (when control
 147     (fresh-line *query-io*)
 148     (apply #'format *query-io* control arguments))
 149   (write-string " (y/n) " *query-io*)
 150   (let ((response (contextual-readline *repl-readline-context*)))
 151     (and (> (length response) 0)
 152          (char-equal #\y (char response 0)))))
 153
 154
 155 ;;;;;;;;;;;;;; Top-level commands..
 156
 157 (define-toplevel-command :cls ()
 158   (clear-console *terminal-io*)
 159   (setf (cursor-x *terminal-io*) 0
 160         (cursor-y *terminal-io*) 0)
 161   (values))
 162
 163 (define-toplevel-command :bt (&rest args)
 164   (declare (dynamic-extent args))
 165   (apply #'backtrace (mapcar #'eval args)))
 166
 167 (define-toplevel-command :cpu-reset ()
 168   (when (y-or-n-p "Really reset CPU?")
 169     (muerte.x86-pc.keyboard:cpu-reset))
 170   (values))
 171
 172 (define-toplevel-command :decimal (&optional x-list)
 173   (flet ((do-print (x)
 174            (typecase x
 175              (number
 176               (case *print-base*
 177                 (16 (format t "~&~W = ~D" x x))
 178                 (10 (format t "~&~W = #x~X" x x))
 179                 (t (format t "~&~W = ~D. = #x~X" x x x)))
 180               (when (typep x 'ratio)
 181                 (format t " ~~ ~,3F" x)))
 182              (pointer
 183               (format t "~&~Z = ~W" x x))
 184              (t (fresh-line)
 185                 (write x :radix nil :base (case *print-base* (10 16) (t 10)))))
 186            x))
 187     (if x-list
 188         (do-print (eval x-list))
 189       (dolist (x cl:/ (values-list cl:/))
 190         (do-print x)))))
 191
 192 (define-toplevel-command :z (&optional x-list)
 193   (flet ((do-print (x)
 194            (format t "~&~Z" x)
 195            x))
 196     (if x-list
 197         (do-print (eval x-list))
 198       (dolist (x cl:/ (values-list cl:/))
 199         (do-print x)))))
 200
 201 (defmacro with-paging (options &body body)
 202   (declare (ignore options))
 203   `(block paging
 204      (let ((paging-offset 2))
 205        (handler-bind
 206            ((newline (lambda (condition)
 207                        (declare (ignore condition))
 208                        (when (and paging-offset
 209                                   (>= (incf paging-offset)
 210                                       muerte.x86-pc::*screen-height*))
 211                          (format t "~&more? (y/n/a) ")
 212                          (prog ()
 213                           loop
 214                            (case (muerte.x86-pc.keyboard:poll-char)
 215                              ((#\escape)
 216                               (break "Console pager"))
 217                              ((#\n #\N) ; No more
 218                               (return-from paging (values)))
 219                              ((#\a #\A) ; Quit paging
 220                               (setf paging-offset nil))
 221                              ((#\newline #\x)
 222                               (setf paging-offset
 223                                 (1- muerte.x86-pc::*screen-height*)))
 224                              ((#\y #\Y #\space) ; One more page
 225                               (setf paging-offset 1))
 226                              (t (go loop))))
 227                          (write-char #\return)
 228                          (clear-line *standard-output* 0 (cursor-y *standard-output*))
 229                          ))))
 230          ,@body))))
 231
 232 (define-toplevel-command :more (form)
 233   (with-paging ()
 234     (multiple-value-call #'format t "~@{~&~W~}"
 235                          (eval form))))
 236
 237 (define-toplevel-command :pop ()
 238   (when *debugger-dynamic-context*
 239     (let ((r (find-restart-from-context 'abort *debugger-dynamic-context*)))
 240       (if r
 241           (invoke-restart r)
 242         (warn "No abort restart found."))))
 243   (values))
 244
 245 (define-toplevel-command :trace (&rest args)
 246   (declare (dynamic-extent args))
 247   (cond
 248    ((null args)
 249     (mapcar #'car muerte::*trace-map*))
 250    (t (apply #'do-trace args)
 251       (values))))
 252
 253 (define-toplevel-command :untrace (&rest function-names)
 254   (declare (dynamic-extent function-names))
 255   (cond
 256    ((null function-names)
 257     (do () ((null muerte::*trace-map*))
 258       (do-untrace (caar muerte::*trace-map*))))
 259    (t (map nil #'do-untrace function-names)
 260       (values))))
 261
 262 (defvar *debugger-printing-restarts* nil)
 263
 264 (define-toplevel-command :error ()
 265   (if (not (and (boundp '*debugger-condition*)
 266                 *debugger-condition*))
 267       (fresh-line)
 268     (let ((condition *debugger-condition*)
 269           (*print-safely* t))
 270       (cond
 271        ((consp condition)
 272         (fresh-line)
 273         (write-string (case (car condition)
 274                         ((simple-error error) "Error: ")
 275                         (break "Break: ")
 276                         (t (write (car condition)))))
 277         (if (stringp (cadr condition))
 278             (apply 'format t (cadr condition) (cddr condition))
 279           (write (cdr condition))))
 280        (t (format t "~&Error: ~A" condition)))
 281       (if *debugger-printing-restarts*
 282           (progn (format t "~&[restarts suppressed]")
 283                  (halt-cpu))
 284         (let ((*debugger-printing-restarts* t))
 285           (map-active-restarts (lambda (restart index)
 286                                  (format t "~&~2D: ~A~%" index restart))
 287                                (or *debugger-dynamic-context*
 288                                    (muerte::current-dynamic-context)))))))
 289   (values))
 290
 291 (define-toplevel-command :restart (&optional (r 0) &rest args)
 292   (declare (dynamic-extent args))
 293   (let* ((context (or *debugger-dynamic-context*
 294                       (muerte::current-dynamic-context)))
 295          (restart (typecase r
 296                     (integer
 297                      (find-restart-by-index r context))
 298                     (symbol
 299                      (find-restart-from-context r context)))))
 300     (cond
 301      ((not restart)
 302       (format t "~&There is no restart like that."))
 303      (args
 304       (apply 'invoke-restart restart args))
 305      (t (invoke-restart-interactively restart)))))
 306
 307 (define-toplevel-command :package (package-name)
 308   (let ((p (find-package (string package-name))))
 309     (if (packagep p)
 310         (setf *package* p)
 311       (format t "~&No package named \"~A\"." package-name)))
 312   (values))
 313
 314 (define-toplevel-command :help (&optional (x (or (and (boundp '*debugger-condition*)
 315                                                       *debugger-condition*)
 316                                                  :help)))
 317   (fresh-line)
 318   (cond
 319    ((eq :help x)
 320     (format t "Toplevel commands:")
 321     (maphash (lambda (k v)
 322                (declare (ignore v))
 323                (format t " :~A" k))
 324              *toplevel-commands*))
 325    ((and (keywordp x) (gethash x *toplevel-commands*))
 326     (describe (gethash x *toplevel-commands*)))
 327    (t (describe x)))
 328   (values))
 329
 330 ;;;(muerte.toplevel:define-toplevel-command :bochs-trace (form)
 331 ;;;  (muerte::with-bochs-tracing ()
 332 ;;;    (eval form)))
 333
 334 (muerte.toplevel:define-toplevel-command :mapkey (code-char-form)
 335   (let* ((code-char (eval code-char-form))
 336          (char (etypecase code-char
 337                 (character code-char)
 338                 (integer (code-char code-char)))))
 339     (format t "~&Hit the (single) key you want to map to ~S..." char)
 340     (loop
 341       (loop until (muerte.x86-pc.keyboard::lowlevel-event-p))
 342       (multiple-value-bind (key-code release-p)
 343           (muerte.x86-pc.keyboard::lowlevel-read)
 344         (when (and key-code (not release-p))
 345           (case key-code
 346             (#x1c (format t "~&Will not replace Enter key!"))
 347             (t (format t "~&Setting scan-code ~S to ~S...~%" key-code char)
 348                (setf (aref muerte.x86-pc.keyboard::*scan-codes* key-code) char)))
 349           (return (values)))))))
 350
 351 (defun los0-debugger (condition)
 352   (let ((*debugger-dynamic-context* (muerte::current-dynamic-context))
 353         (*standard-output* *debug-io*)
 354         (*standard-input* *debug-io*)
 355         (*debugger-condition* condition)
 356         (*package* (or (and (packagep *package*) *package*)
 357                        (find-package "LOS0")
 358                        (find-package "USER")
 359                        (find-package "COMMON-LISP")
 360                        (error "Unable to find any package!")))
 361         (*repl-prompt-context* #\d)
 362         #+ignore (*repl-readline-context* (or *repl-readline-context*
 363                                               (make-readline-context :history-size 16))))
 364     (let ((*print-safely* t))
 365       (invoke-toplevel-command :error))
 366     (loop
 367        (with-simple-restart (abort "Abort to command level ~D." (1+ *repl-level*))
 368          (read-eval-print)))))
 369
 370
 371 (defun random (limit)
 372   (etypecase limit
 373     (fixnum
 374      (mod (read-time-stamp-counter) limit))
 375     (muerte::positive-bignum
 376      (let ((x (muerte::copy-bignum limit)))
 377        (dotimes (i (1- (muerte::%bignum-bigits x)))
 378          (setf (memref x 2 :index i :type :unsigned-byte32)
 379            (muerte::read-time-stamp-counter)))
 380        (setf x (muerte::bignum-canonicalize x))
 381        (loop while (>= x limit)
 382            do (setf x (truncate x 2)))
 383        x))))
 384
 385
 386
 387 (defvar *segment-descriptor-table*)
 388
 389 (defun format-segment-table (table &key (start 0) (end (truncate (length table) 2)))
 390   (loop for i from start below end
 391       as selector = (* i 8)
 392       do (format t "~&~3X: base: #x~8,'0X, limit: #x~5,'0X, type-s-dpl-p: ~8,'0b, avl-x-db-g: ~4,'0b~%"
 393                  selector
 394                  (* 4 (segment-descriptor-base-location table selector))
 395                  (segment-descriptor-limit table selector)
 396                  (segment-descriptor-type-s-dpl-p table selector)
 397                  (segment-descriptor-avl-x-db-g table selector)))
 398   (values))
 399
 400
 401 (defun turn-on-irqs ()
 402   ;; listen for timer and keyboard IRQ interrupts
 403   (setf (pic8259-irq-mask) #xfffc)
 404   (with-inline-assembly (:returns :nothing) (:sti)))
 405
 406 (defun genesis ()
 407   ;; (install-shallow-binding)
 408   (setf *debugger-function* #'los0-debugger)
 409   (let ((extended-memsize 0))
 410     ;;  Find out how much extended memory we have
 411     (setf (io-port #x70 :unsigned-byte8) #x18)
 412     (setf extended-memsize (* 256 (io-port #x71 :unsigned-byte8)))
 413     (setf (io-port #x70 :unsigned-byte8) #x17)
 414     (incf extended-memsize (io-port #x71 :unsigned-byte8))
 415     ;; (format t "Extended memory: ~D KB~%" extended-memsize)
 416
 417     (idt-init)
 418
 419     (setf *segment-descriptor-table*    ; Ensure we have a GDT with 16 entries, in static-space.
 420       (setf (global-segment-descriptor-table)
 421         (muerte::dump-global-segment-table :entries 16)))
 422
 423     #+ignore (install-los0-consing :kb-size (* 2 1024))
 424     (let* ((buf (check-the fixnum (%run-time-context-slot nil 'muerte::nursery-space)))
 425            (current (check-the fixnum (memref buf 4)))
 426            (end (check-the fixnum (memref buf 0)))
 427            (free-kb (1- (truncate (- end current 32) 256))))
 428       (cond
 429         ((< free-kb 1)
 430          (warn "Not enough memory to install GC (~D bytes)." (- end buf 16)))
 431         (t (format t "~&Installing los0-GC with ~D KB.~%" free-kb)
 432            (install-los0-consing :kb-size (truncate free-kb 2))))))
 433
 434   #+ignore
 435   (loop
 436      (catch :top-level-repl ; If restarts don't work, you can throw this..
 437        (with-simple-restart (abort "Abort to the top command level.")
 438          (read-eval-print))))
 439
 440 ;  (set-textmode +vga-state-90x30+)
 441   (let ((muerte::*error-no-condition-for-debugger* t))
 442     (clos-bootstrap))
 443
 444   (setf *package* (find-package "LOS0"))
 445
 446   ;; (install-shallow-binding)
 447   (let ((*repl-readline-context* (make-readline-context :history-size 16))
 448         #+ignore (*backtrace-stack-frame-barrier* (stack-frame-uplink (current-stack-frame)))
 449         #+ignore (*error-no-condition-for-debugger* t)
 450         #+ignore (*debugger-function* #'los0-debugger)
 451         #+ignore (*package* *package*))
 452     (with-simple-restart (abort "Skip Los0 boot-up initialization.")
 453       (setf *cpu-features*
 454         (find-cpu-features))
 455       (format t "~&CPU features:~:[ none~;~{ ~A~#[~; and~:;,~]~}~].~%"
 456               *cpu-features* *cpu-features*)
 457       ;; (muerte:asm :int 49)
 458
 459       (when muerte::*multiboot-data*
 460         (set-textmode +vga-state-90x30+))
 461
 462       (cond
 463        ((not (cpu-featurep :tsc))
 464         (warn "This CPU has no time-stamp-counter. Timer-related functions will not work."))
 465        (t (install-internal-time)
 466           (warn "Internal-time will wrap in ~D days."
 467                 (truncate most-positive-fixnum
 468                           (* internal-time-units-per-second 60 60 24)))))
 469       ;; (muerte.toplevel:invoke-toplevel-command :mapkey #\newline)
 470       #+ignore (let ((s (make-instance 'muerte.x86-pc:vga-text-console)))
 471                  (setf *standard-output* s
 472                        *standard-input* s
 473                        *terminal-io* s
 474                        *debug-io* s)))
 475
 476     (setf threading:*segment-descriptor-table-manager*
 477       (make-instance 'threading:segment-descriptor-table-manager))
 478
 479     (muerte.x86-pc.keyboard:setup-kbd)
 480     (muerte.lib::setup-scheduling)
 481    (turn-on-irqs)
 482
 483 ;;;    (ignore-errors
 484 ;;;     (setf (symbol-function 'write-char)
 485 ;;;       (muerte.x86-pc.serial::make-serial-write-char :baudrate 38400))
 486 ;;;     (format t "~&Installed serial-port write-char."))
 487     (let ((* nil) (** nil) (*** nil)
 488           (/ nil) (// nil) (/// nil)
 489           (+ nil) (++ nil) (+++ nil)
 490           (*readline-signal-keypresses* t))
 491       (format t "~&Movitz image Los0 build ~D." *build-number*)
 492       (handler-bind
 493           ((readline-keypress
 494             (lambda (c)
 495               (let ((key (readline-keypress-key c)))
 496                 (when (eq :f12 key)
 497                   (fvf-textmode-screendump)
 498                   (format *query-io* "~&Dumped console contents by TFTP."))))))
 499         (loop
 500           (catch :top-level-repl        ; If restarts don't work, you can throw this..
 501             (with-simple-restart (abort "Abort to the top command level.")
 502               (read-eval-print)))))))
 503
 504   (error "What's up? [~S]" 'hey))
 505
 506 (defun read (&optional input-stream eof-error-p eof-value recursive-p)
 507   (declare (ignore input-stream recursive-p))
 508   (let ((string (muerte.readline:contextual-readline *repl-readline-context*)))
 509     (simple-read-from-string string eof-error-p eof-value)))
 510
 511
 512
 513 (genesis)
 514