| \ |
| \ Fcode payload for QEMU VGA graphics card |
| \ |
| \ This is the Forth source for an Fcode payload to initialise |
| \ the QEMU VGA graphics card. |
| \ |
| \ (C) Copyright 2013 Mark Cave-Ayland |
| \ |
| |
| fcode-version3 |
| |
| \ |
| \ Dictionary lookups for words that don't have an FCode |
| \ |
| |
| : (find-xt) \ ( str len -- xt | -1 ) |
| $find if |
| exit |
| else |
| -1 |
| then |
| ; |
| |
| " openbios-video-width" (find-xt) cell+ value openbios-video-width-xt |
| " openbios-video-height" (find-xt) cell+ value openbios-video-height-xt |
| " depth-bits" (find-xt) cell+ value depth-bits-xt |
| " line-bytes" (find-xt) cell+ value line-bytes-xt |
| |
| : openbios-video-width openbios-video-width-xt @ ; |
| : openbios-video-height openbios-video-height-xt @ ; |
| : depth-bits depth-bits-xt @ ; |
| : line-bytes line-bytes-xt @ ; |
| |
| " fb8-fillrect" (find-xt) value fb8-fillrect-xt |
| : fb8-fillrect fb8-fillrect-xt execute ; |
| |
| " fw-cfg-read-file" (find-xt) value fw-cfg-read-file-xt |
| : fw-cfg-read-file fw-cfg-read-file-xt execute ; |
| |
| \ |
| \ IO port words |
| \ |
| |
| " ioc!" (find-xt) value ioc!-xt |
| " iow!" (find-xt) value iow!-xt |
| |
| : ioc! ioc!-xt execute ; |
| : iow! iow!-xt execute ; |
| |
| " le-w!" (find-xt) value le-w!-xt |
| |
| : le-w! le-w!-xt execute ; |
| |
| \ |
| \ PCI |
| \ |
| |
| " pci-bar>pci-addr" (find-xt) value pci-bar>pci-addr-xt |
| : pci-bar>pci-addr pci-bar>pci-addr-xt execute ; |
| |
| h# 10 constant cfg-bar0 \ Framebuffer BAR |
| h# 18 constant cfg-bar2 \ QEMU MMIO ioport BAR |
| -1 value fb-addr |
| -1 value mmio-addr |
| |
| \ |
| \ VGA registers |
| \ |
| |
| h# 3c0 constant vga-addr |
| h# 3c8 constant dac-write-addr |
| h# 3c9 constant dac-data-addr |
| |
| defer vga-ioc! |
| |
| : vga-legacy-ioc! ( val addr ) |
| ioc! |
| ; |
| |
| : vga-mmio-ioc! ( val addr ) |
| h# 3c0 - h# 400 + mmio-addr + c! |
| ; |
| |
| : vga-color! ( r g b index -- ) |
| \ Set the VGA colour registers |
| dac-write-addr vga-ioc! rot |
| 2 >> dac-data-addr vga-ioc! swap |
| 2 >> dac-data-addr vga-ioc! |
| 2 >> dac-data-addr vga-ioc! |
| ; |
| |
| \ |
| \ VBE registers |
| \ |
| |
| h# 0 constant VBE_DISPI_INDEX_ID |
| h# 1 constant VBE_DISPI_INDEX_XRES |
| h# 2 constant VBE_DISPI_INDEX_YRES |
| h# 3 constant VBE_DISPI_INDEX_BPP |
| h# 4 constant VBE_DISPI_INDEX_ENABLE |
| h# 5 constant VBE_DISPI_INDEX_BANK |
| h# 6 constant VBE_DISPI_INDEX_VIRT_WIDTH |
| h# 7 constant VBE_DISPI_INDEX_VIRT_HEIGHT |
| h# 8 constant VBE_DISPI_INDEX_X_OFFSET |
| h# 9 constant VBE_DISPI_INDEX_Y_OFFSET |
| h# a constant VBE_DISPI_INDEX_NB |
| |
| h# 0 constant VBE_DISPI_DISABLED |
| h# 1 constant VBE_DISPI_ENABLED |
| |
| \ |
| \ Bochs VBE register writes |
| \ |
| |
| defer vbe-iow! |
| |
| : vbe-legacy-iow! ( val addr -- ) |
| h# 1ce iow! |
| h# 1d0 iow! |
| ; |
| |
| : vbe-mmio-iow! ( val addr -- ) |
| 1 lshift h# 500 + mmio-addr + cr .s cr le-w! |
| ; |
| |
| \ |
| \ Initialise Bochs VBE mode |
| \ |
| |
| : vbe-init ( -- ) |
| h# 0 vga-addr vga-ioc! \ Enable blanking |
| VBE_DISPI_DISABLED VBE_DISPI_INDEX_ENABLE vbe-iow! |
| h# 0 VBE_DISPI_INDEX_X_OFFSET vbe-iow! |
| h# 0 VBE_DISPI_INDEX_Y_OFFSET vbe-iow! |
| openbios-video-width VBE_DISPI_INDEX_XRES vbe-iow! |
| openbios-video-height VBE_DISPI_INDEX_YRES vbe-iow! |
| depth-bits VBE_DISPI_INDEX_BPP vbe-iow! |
| VBE_DISPI_ENABLED VBE_DISPI_INDEX_ENABLE vbe-iow! |
| h# 0 vga-addr vga-ioc! |
| h# 20 vga-addr vga-ioc! \ Disable blanking |
| ; |
| |
| \ |
| \ PCI BAR mapping |
| \ |
| |
| : map-fb ( -- ) |
| cfg-bar0 pci-bar>pci-addr if \ ( pci-addr.lo pci-addr.mid pci-addr.hi size ) |
| " pci-map-in" $call-parent |
| to fb-addr |
| then |
| ; |
| |
| : map-mmio ( -- ) |
| cfg-bar2 pci-bar>pci-addr if \ ( pci-addr.lo pci-addr.mid pci-addr.hi size ) |
| " pci-map-in" $call-parent |
| to mmio-addr |
| then |
| ; |
| |
| \ |
| \ Legacy IO port or QEMU MMIO accesses |
| \ |
| \ legacy: use standard VGA ioport registers |
| \ MMIO: use QEMU PCI MMIO VGA registers |
| \ |
| \ If building for QEMU, default to MMIO access since it allows |
| \ programming of the VGA card regardless of its position in the |
| \ PCI topology |
| \ |
| |
| [IFDEF] CONFIG_QEMU |
| ['] vga-mmio-ioc! to vga-ioc! |
| ['] vbe-mmio-iow! to vbe-iow! |
| [ELSE] |
| ['] vga-legacy-ioc! to vga-ioc! |
| ['] vbe-legacy-iow! to vbe-iow! |
| [THEN] |
| |
| \ |
| \ Publically visible words |
| \ |
| |
| external |
| |
| [IFDEF] CONFIG_MOL |
| defer mol-color! |
| |
| \ Hook for MOL (see packages/molvideo.c) |
| \ |
| \ Perhaps for neatness this there should be a separate molvga.fs |
| \ but let's leave it here for now. |
| |
| : color! ( r g b index -- ) |
| mol-color! |
| ; |
| |
| [ELSE] |
| |
| \ Standard VGA |
| |
| : color! ( r g b index -- ) |
| vga-color! |
| ; |
| |
| [THEN] |
| |
| : fill-rectangle ( color_ind x y width height -- ) |
| fb8-fillrect |
| ; |
| |
| : dimensions ( -- width height ) |
| openbios-video-width |
| openbios-video-height |
| ; |
| |
| : set-colors ( table start count -- ) |
| 0 do |
| over dup \ ( table start table table ) |
| c@ swap 1+ \ ( table start r table-g ) |
| dup c@ swap 1+ \ ( table start r g table-b ) |
| c@ 3 pick \ ( table start r g b index ) |
| color! \ ( table start ) |
| 1+ |
| swap 3 + swap \ ( table+3 start+1 ) |
| loop |
| ; |
| |
| \ |
| \ Cancel Bochs VBE mode |
| \ |
| |
| : vbe-deinit ( -- ) |
| \ Switching VBE on and off clears the framebuffer |
| VBE_DISPI_DISABLED VBE_DISPI_INDEX_ENABLE vbe-iow! |
| VBE_DISPI_ENABLED VBE_DISPI_INDEX_ENABLE vbe-iow! |
| VBE_DISPI_DISABLED VBE_DISPI_INDEX_ENABLE vbe-iow! |
| ; |
| |
| headerless |
| |
| \ |
| \ Installation |
| \ |
| |
| : qemu-vga-driver-install ( -- ) |
| mmio-addr -1 = if |
| map-mmio vbe-init |
| then |
| fb-addr -1 = if |
| map-fb fb-addr to frame-buffer-adr |
| default-font set-font |
| |
| frame-buffer-adr encode-int " address" property |
| |
| openbios-video-width openbios-video-height over char-width / over char-height / |
| fb8-install |
| then |
| ; |
| |
| : qemu-vga-driver-init |
| openbios-video-width encode-int " width" property |
| openbios-video-height encode-int " height" property |
| depth-bits encode-int " depth" property |
| line-bytes encode-int " linebytes" property |
| |
| \ Is the VGA NDRV driver enabled? (PPC only) |
| " /options" find-package drop s" vga-ndrv?" rot get-package-property not if |
| decode-string 2swap 2drop \ ( addr len ) |
| s" true" drop -rot comp 0= if |
| \ Embed NDRV driver via fw-cfg if it exists |
| " ndrv/qemu_vga.ndrv" fw-cfg-read-file if |
| encode-string " driver,AAPL,MacOS,PowerPC" property |
| then |
| then |
| then |
| |
| ['] qemu-vga-driver-install is-install |
| ; |
| |
| qemu-vga-driver-init |
| |
| end0 |