bootblock.lisp

   1 ;;;;------------------------------------------------------------------
   2 ;;;;
   3 ;;;;    Copyright (C) 2001,2000, 2002-2005,
   4 ;;;;    Department of Computer Science, University of Tromso, Norway
   5 ;;;;
   6 ;;;; Filename:      bootblock.lisp
   7 ;;;; Description:   A simple, single-stage, floppy bootloader.
   8 ;;;; Author:        Frode Vatvedt Fjeld <frodef@acm.org>
   9 ;;;; Created at:    Mon Oct  9 20:47:19 2000
  10 ;;;; Distribution:  See the accompanying file COPYING.
  11 ;;;;
  12 ;;;; $Id: bootblock.lisp,v 1.15 2008/02/18 22:30:21 ffjeld Exp $
  13 ;;;;
  14 ;;;;------------------------------------------------------------------
  15
  16 (in-package movitz)
  17
  18 (defvar *bootblock-build-file* #p"bootblock-id.txt")
  19 (defvar *bootblock-build*
  20     ;; make this variable persistent.
  21     (or (ignore-errors
  22          (with-open-file (s *bootblock-build-file* :direction :input)
  23            (with-standard-io-syntax (read s))))
  24         (warn "Unable to read ~S from ~A, resetting to zero."
  25               '*bootblock-build*
  26               *bootblock-build-file*)
  27         0))
  28
  29 (defvar *floppy-size* (* 512 18 2 80))
  30
  31 (defun make-segment-descriptor-byte (&rest descriptor-args)
  32   (list (complex (binary-types::bitfield-compute-numeric-value
  33                   (find-binary-type 'segment-descriptor)
  34                   (apply #'make-segment-descriptor descriptor-args))
  35                  8)))
  36
  37 (defun mkasm16-bios-print ()
  38   "Print something to the terminal.  [es:si] points to the text"
  39   `((:movzxb (:si) :cx)
  40     (:incw :si)
  41     (:movb #xe :ah)
  42     (:movw 7 :bx)
  43     print-loop
  44     (:lodsb)
  45     (:int #x10)
  46     (:loop 'print-loop)
  47     (:ret)))
  48
  49 (defun mkasm16-format-hex ()
  50   "Format a 16-bit word (in DX) into hex string (in DI)"
  51   `((:std)
  52     (:movw 4 :cx)
  53     (:addw :cx :di)
  54     (:decw :di)
  55     format-loop
  56     (:movb :dl :bl)
  57     (:andw #x0f bx)
  58     (:movb ('hex-table bx) :al)
  59     (:stosb)
  60     (:shrw :dx 4)
  61     (:decw :cx)
  62     (:jnz 'format-loop)
  63     (:cld)
  64     (:ret)
  65     hex-table (% format nil "0123456789abcdef")))
  66
  67 (defconstant +SECTOR-SIZE+ 512)
  68 (defconstant +HEAD+ 0)
  69 (defconstant +TRACK+ 1)
  70 (defconstant +NOSEC+ 2)
  71 (defconstant +DADDR+ 4)
  72 (defconstant +DADDRSEG+ 6)
  73 (defconstant +STARTSEC+ 8)
  74
  75 (defconstant +linear-sector+ -4)
  76 (defconstant +destination+ -8)
  77 (defconstant +sectors-per-track+ -12)
  78 (defconstant +stack-frame-size+ 16)
  79
  80 (defconstant +read-buffer+ #x10000)
  81
  82 (defun mkasm16-bios-bootloader (image-size load-address &optional (skip-sectors 0))
  83   (let* ((first-sector (1+ skip-sectors))
  84          (last-sector (+ first-sector (ceiling image-size +sector-size+)))
  85          (read-buffer-segment (floor +read-buffer+ #x10)))
  86     `((:jmp (:pc+ 0))              ; some BIOSes might check for this.
  87       ;;
  88       ;; We are running at address #x7c00.
  89       ;;
  90       (:xorw :ax :ax)
  91       (:movw :ax :ds)
  92       (:movw :ax :es)
  93
  94       (:movw #x9000 :ax)
  95       (:movw :ax :ss)
  96       (:movw #xfffc :bp)
  97       (:leaw (:bp ,(- +stack-frame-size+)) :sp)
  98       (:movw 'welcome :si)              ; Print welcome message)
  99       (:call 'print)
 100
 101       ;;
 102       ;; Enable the A20 gate
 103       ;;
 104       (:call 'empty-8042)
 105       (:movb #xd1 :al)
 106       (:outb :al #x64)
 107
 108       (:call 'empty-8042)
 109       (:movb #xdf :al)
 110       (:outb :al #x60)
 111       (:call 'empty-8042)
 112
 113       ;; Poll the floppy's sectors per track
 114
 115       (:movw 5 (:bp ,+sectors-per-track+))
 116       check-geometry
 117       (:incb (:bp ,+sectors-per-track+))
 118       (:jz 'read-error)
 119       (:movw (:bp ,+sectors-per-track+) :cx )
 120       (:movw #x0201 :ax)
 121       (:xorw :dx :dx)
 122       (:movw ,read-buffer-segment :bx)
 123       (:movw :bx :es)
 124       (:xorw :bx :bx)
 125       (:int #x13)                       ; Call BIOS routine
 126       (:testb :ah :ah)
 127       (:jz 'check-geometry)
 128       (:decb (:bp ,+sectors-per-track+))
 129
 130       ;;
 131       ;; Read sectors into memory
 132       ;;
 133
 134       (:movw ,first-sector (:bp ,+linear-sector+))
 135       (:movl ,load-address (:bp ,+destination+))
 136
 137       read-loop
 138
 139       (:cmpw ,last-sector (:bp ,+linear-sector+))
 140       (:jg 'read-done)
 141
 142       (:movw 'track-start-msg :si) ; Print '(' to screen for each track
 143       (:call 'print)
 144
 145       (:movw (:bp ,+linear-sector+) :ax)
 146       (:movb (:bp ,+sectors-per-track+) :cl)
 147       (:divb :cl :ax)           ; al=quotient, ah=remainder of :ax/:cl
 148
 149       (:movb :ah :cl)                   ; sector - 1
 150       (:movb :al :dh)
 151       (:andb 1 :dh)                     ; head
 152       (:movb :al :ch)
 153       (:shrb 1 :ch)                     ; track
 154       (:xorb :dl :dl)                   ; drive = 0
 155       (:movw (:bp ,+sectors-per-track+) :ax)
 156       (:subb :cl :al)              ; number of sectors (rest of track)
 157       (:incb :cl)
 158       (:addw :ax (:bp ,+linear-sector+))  ; update read pointer
 159       (:movw (:bp ,+linear-sector+) :bx) ; subtract some if it's the last track.
 160       (:subw ,last-sector :bx)
 161       (:jc 'subtract-zero-sectors)
 162       (:subw :bx :ax)
 163       (:jz 'read-done)
 164       subtract-zero-sectors
 165       (:movb 2 :ah)
 166
 167       (:movw ,read-buffer-segment :bx)
 168       (:movw :bx :es)
 169       (:xorw :bx :bx)
 170       (:int #x13)                       ; Call BIOS routine
 171
 172       (:jc 'read-error)
 173       (:movzxb :al :ecx)
 174
 175       ;;
 176       ;; Install GS as 4GB segment
 177       ;; http://www.faqs.org/faqs/assembly-language/x86/general/part2/
 178       ;;
 179       (:cli)
 180       (:lgdt ('gdt-addr))               ; load gdt
 181       (:movcr :cr0 :eax)
 182       (:orb 1 :al)
 183       (:movcr :eax :cr0)
 184       (:jmp (:pc+ 0))
 185       (:movw 16 :bx)
 186       (:movw :bx :gs)
 187       (:andb #xfe :al)
 188       (:movcr :eax :cr0)
 189       (:jmp (:pc+ 0))
 190       (:sti)
 191       ;; Completed install GS as 4GB segment.
 192
 193       ;; Copy data to destination
 194       (:shll ,(+ 9 -2) :ecx)           ; 512/4 = sector-size/word-size
 195       (:movl ,+read-buffer+ :ebx)
 196       (:movl (:bp ,+destination+) :esi)
 197       (:leal (:esi (:ecx 4)) :edx)
 198
 199       (:movl :edx (:bp ,+destination+))
 200
 201       copy-loop
 202       (:decl :ecx)
 203       ((:gs-override) :movl (:ebx (:ecx 4)) :edx)
 204       ((:gs-override) :movl :edx (:esi (:ecx 4)))
 205       (:jnz 'copy-loop)
 206
 207       (:movw 'track-end-msg :si) ; Print ')' to screen after each track
 208       (:call 'print)
 209
 210       (:jmp 'read-loop)
 211
 212       read-done
 213
 214       motor-loop                        ; Wait for floppy motor
 215       (:btw 8 (#x43e))
 216       (:jc 'motor-loop)
 217
 218       (:movw 'entering :si)             ; Print welcome message
 219       (:call 'print)
 220
 221       ;; Read the cursor position into DH (row) and DL (column).
 222       (:movb 3 :ah)
 223       (:movb 0 :bh)
 224       (:int #x10)
 225
 226       (:cli)                            ; Disable interrupts
 227       (:lgdt ('gdt-addr))               ; load gdt
 228
 229       (:xorw :ax :ax)
 230       (:movw :ax :es)                   ; reset es
 231
 232       ;;
 233       ;; Turn off the cursor
 234       ;;
 235
 236 ;;;       (movb #x01 :ah)
 237 ;;;       (movw #x0100 :cx)
 238 ;;;       (int  #x10)
 239
 240
 241       ;;
 242       ;; Load machine status word.  This will enable
 243       ;; protected mode.  The subsequent instruction MUST
 244       ;; reload the code segment register with a selector for
 245       ;; the protected mode code segment descriptor (see
 246       ;; GDT specification).
 247       ;;
 248       (:movw 1 :ax)
 249       (:lmsw :ax)                       ; load word 0 of cr0
 250
 251       ;;
 252       ;; Do a longjump to new-world.  This will cause the CS to
 253       ;; be loaded with the correct descriptor, and the processor
 254       ;; will now run in 32 bit mode.
 255       ;;
 256
 257       (:jmp 8 ('new-world))
 258
 259       ;;
 260       ;; Display error message and hang
 261       ;;
 262       read-error
 263       (:movw 'error :si)                ; Print error message
 264       (:call 'print)
 265       halt-cpu
 266       (:halt)
 267       (:jmp 'halt-cpu)                  ; Infinite loop
 268
 269       ;;
 270       ;; Empty the 8042 Keyboard controller
 271       ;;
 272       empty-8042
 273       (:call 'delay)
 274       (:inb #x64 :al)                   ; 8042 status port
 275       (:testb 1 :al)                 ; if ( no information available )
 276       (:jz 'no-output)                  ;   goto no_output
 277       (:call 'delay)
 278       (:inb #x60 :al)                   ; read it
 279       (:jmp 'empty-8042)
 280       no-output
 281       (:testb 2 :al)                    ; if ( input buffer is full )
 282       (:jnz 'empty-8042)                ;   goto empty_8042
 283       (:ret)
 284
 285       delay
 286       (:xorw :cx :cx)
 287       delay-loop
 288       (:loop 'delay-loop)
 289       (:ret)
 290
 291       print ,@(mkasm16-bios-print)
 292
 293       ;; Data
 294       welcome         (:% :format 8 "Loading Movitz ~D..~%
"
 295                          ,(incf *bootblock-build*))
 296       entering        (:% :format 8 "~%
Enter..")
 297       error           (:% :format 8 "Failed!)")
 298       track-start-msg (:% :format 8 "(")
 299       track-end-msg   (:% :format 8 ")")
 300       sector-msg      (:% :format 8 "-")
 301
 302       (:% :align 16)
 303       gdt
 304       (:% :bytes 16 0)
 305       gdt-addr
 306       (:% :bytes 16 ,(1- (* 3 8)))
 307       (:% :bytes 32 'gdt) ; both the null and pointer to gdt
 308       ;; (% fun (make-segment-descriptor-byte)) ; dummy null descriptor
 309       (:% :fun (make-segment-descriptor-byte :base 0 :limit #xfffff ; 1: code segment
 310                                                      :type 10 :dpl 0
 311                                                      :flags (s p d/b g)))
 312       (:% :fun (make-segment-descriptor-byte :base 0 :limit #xfffff ; 2: data segment
 313                                                      :type 2 :dpl 0
 314                                                      :flags (s p d/b g)))
 315       ;; (% align 4)
 316       new-world
 317       ;; ..must be concatenated onto here.
 318       )))
 319
 320
 321 (defconstant +screen-base+ #xb8000)
 322 (defparameter +message+ "Ok.")
 323 (defparameter +halt-message+ "Halt!")
 324
 325 (defun make-vga-string (string)
 326   (loop for char across string
 327      collect (char-code char)
 328      collect #x07))
 329
 330 (defun mkasm-loader (image-size load-address call-address)
 331   "Make the 32-bit loader."
 332   (assert (<= load-address call-address (+ load-address image-size)) ()
 333     "Call-address #x~X is not in range #x~X to #x~X."
 334     call-address load-address (+ load-address image-size))
 335   `((:movw ,(* 2 8) :ax) ; Load DS, ES and SS with the correct data segment descriptors
 336     (:movw :ax :ds)
 337     (:movw :ax :es)
 338     (:movw :ax :fs)
 339     (:movw :ax :gs)
 340     (:movw :ax :ss)
 341
 342     (:movl #x20000 :esp)
 343 ;;;     (pushl -1)                              ; stack-end-marker
 344
 345     ;; If we are not on a 386, perform WBINVD to flush caches.
 346     ;; (:testl :edi :edi)                       ; clear ZF
 347     (:pushfl)                           ; push original EFLAGS
 348     (:popl :eax)                        ; get original EFLAGS
 349     (:movl :eax :ecx)                   ; save original EFLAGS
 350     (:xorl #x40000 :eax)                ; flip AC bit in EFLAGS
 351     (:pushl :eax)                     ; save new EFLAGS value on stack
 352     (:popfl)                            ; replace current EFLAGS value
 353     (:pushfl)                           ; get new EFLAGS
 354     (:popl :eax)                        ; store new EFLAGS in EAX
 355     (:xorl :ecx :eax)     ; can't toggle AC bit, processor=80386, ZF=1
 356     (:jz 'skip-wbinvd)                  ; jump if 80386 processor
 357     (:wbinvd)
 358     skip-wbinvd
 359
 360     (:movzxb :dl :eax)                  ; cursor column
 361     (:movzxb :dh :ebx)                  ; cursor row
 362
 363     (:imull 160 :ebx :ebx)
 364     (:movl 'i-am-32 :esi)
 365
 366     os-loop
 367     (:leal ((:eax 2) :ebx ,+screen-base+) :edi)
 368     (:xorl :ecx :ecx)
 369     (:movb ,(length +message+) :cl)
 370     ((:repz) :movsw)                    ; print i-am-32
 371
 372     (:movl ,call-address :eax)
 373     (:jmp :eax)                         ; call OS
 374
 375 ;;;     (:movl ,(length +halt-message+) :ecx)
 376 ;;;     (:movl 'halt-msg :esi)
 377 ;;;     (:movl ,(+ +screen-base+ (* 2 80 11) (* 2 35)) :edi)
 378 ;;;     ((:repz) movsw)
 379 ;;;
 380 ;;;     (:movw #x7400 (:edi))
 381 ;;;     eternal
 382 ;;;     (:incb (:edi))
 383 ;;;     (:halt)
 384 ;;;     (:jmp 'eternal)                 ; OS returned?
 385     ;; (% align 2)
 386     i-am-32 (:% :bytes 8 ,@(make-vga-string +message+))
 387 ;;;     halt-msg (% fun ((lambda ()
 388 ;;;                     (loop for char across ,+halt-message+
 389 ;;;                         collect (complex (logior #x4700 (char-code char)) 2)))))
 390     ))
 391
 392 (defun make-bootblock (image-size load-address call-address
 393                        &key (skip-sectors 0) (include-records))
 394   (when *floppy-size*
 395     (let ((floppy-room (- *floppy-size* 512))) ; Size of floppy minus the bootloader.
 396       (if (> image-size floppy-room)
 397           (warn "The image is ~D bytes too big to fit on a ~,2F MB floppy."
 398                 (- image-size floppy-room)
 399                 (/ *floppy-size* (* 1024 1000)))
 400           (format t "~&;; Bootloader has room for ~,1F KB more."
 401                   (/ (- floppy-room image-size) 1024)))))
 402   (multiple-value-bind (bios-loader bb-symtab)
 403       (let ((asm-x86:*position-independent-p* nil)
 404             (asm-x86:*cpu-mode* :16-bit))
 405         (asm:assemble-proglist (mkasm16-bios-bootloader image-size load-address skip-sectors)
 406                                :start-pc #x7c00))
 407     (multiple-value-bind (protected-loader protected-symtab)
 408         (let ((asm-x86:*position-independent-p* nil))
 409           (asm:assemble-proglist (mkasm-loader image-size load-address call-address)
 410                                  :start-pc (cdr (or (assoc 'new-world bb-symtab)
 411                                                     (error "No new-world defined in bios-loader.")))))
 412       (let* ((loader-length (+ (length bios-loader)
 413                                (length protected-loader)))
 414              (bootblock (progn
 415                           (assert (<= loader-length 510) ()
 416                                   "Bootblock size of ~D octets is too big, max is 510!" loader-length)
 417                           (make-array 512 :element-type '(unsigned-byte 8)
 418                                       :fill-pointer loader-length))))
 419         (setf (subseq bootblock 0) bios-loader
 420               (subseq bootblock (length bios-loader)) protected-loader)
 421         (loop until (zerop (mod (fill-pointer bootblock) 4))
 422            do (vector-push 0 bootblock))
 423         (dolist (record include-records)
 424           (let ((*endian* :little-endian))
 425             (with-binary-output-to-vector (stream bootblock)
 426               (write-binary-record record stream))))
 427         (setf (fill-pointer bootblock) 512
 428               (subseq bootblock 510) #(#x55 #xaa)) ; bootblock signature
 429         (format t "~&;; Bootblock size is ~D octets.~%" loader-length)
 430         (format t "~&;; Bootblock build ID: ~D.~%" *bootblock-build*)
 431         (with-open-file (s #p"bootblock-id.txt"
 432                            :direction :output
 433                            :if-exists :supersede)
 434           (with-standard-io-syntax
 435             (write *bootblock-build* :stream s)))
 436         (values bootblock (append bb-symtab protected-symtab))))))
 437