diff options
Diffstat (limited to 'qemu/roms/openbios/drivers/tcx.fs')
| -rw-r--r-- | qemu/roms/openbios/drivers/tcx.fs | 280 |
1 files changed, 280 insertions, 0 deletions
diff --git a/qemu/roms/openbios/drivers/tcx.fs b/qemu/roms/openbios/drivers/tcx.fs new file mode 100644 index 000000000..af8991fd0 --- /dev/null +++ b/qemu/roms/openbios/drivers/tcx.fs @@ -0,0 +1,280 @@ +\ +\ Fcode payload for QEMU TCX graphics card +\ +\ This is the Forth source for an Fcode payload to initialise +\ the QEMU TCX graphics card. +\ +\ (C) Copyright 2013 Mark Cave-Ayland +\ + +fcode-version3 + +\ +\ Instead of using fixed values for the framebuffer address and the width +\ and height, grab the ones passed in by QEMU/generated by OpenBIOS +\ + +: (find-xt) \ ( str len -- xt | -1 ) + $find if + exit + else + 2drop + -1 + then +; + +: (is-openbios) \ ( -- true | false ) + " openbios-video-width" (find-xt) -1 <> if + -1 + else + 0 + 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 + (is-openbios) if + openbios-video-width-xt @ + else + h# 400 + then +; + +: openbios-video-height + (is-openbios) if + openbios-video-height-xt @ + else + h# 300 + then +; + +: depth-bits + (is-openbios) if + depth-bits-xt @ + else + h# 8 + then +; + +: line-bytes + (is-openbios) if + line-bytes-xt @ + else + h# 400 + then +; + +\ +\ Registers +\ + +h# 0 constant tcx-off-rom +h# 10000 constant /tcx-off-rom + +h# 200000 constant tcx-off-cmap +h# 4000 constant /tcx-off-cmap-24 +h# 4 constant /tcx-off-cmap-8 + +h# 240000 constant tcx-off-dhc +h# 4000 constant /tcx-off-dhc-24 +h# 4 constant /tcx-off-dhc-8 + +h# 280000 constant tcx-off-alt +h# 8000 constant /tcx-off-alt-24 +h# 1 constant /tcx-off-alt-8 + +h# 301000 constant tcx-off-thc-24 +h# 300000 constant tcx-off-thc-8 +h# 1000 constant /tcx-off-thc-24 +h# 81c constant /tcx-off-thc-8 + +h# 701000 constant tcx-off-tec +h# 1000 constant /tcx-off-tec + +h# 800000 constant tcx-off-dfb8 +h# 100000 constant /tcx-off-dfb8 + +h# 2000000 constant tcx-off-dfb24 +h# 400000 constant /tcx-off-dfb24-24 +h# 1 constant /tcx-off-dfb24-8 + +h# 4000000 constant tcx-off-stip +h# 800000 constant /tcx-off-stip + +h# 6000000 constant tcx-off-blit +h# 800000 constant /tcx-off-blit + +h# a000000 constant tcx-off-rdfb32 +h# 400000 constant /tcx-off-rdfb32-24 +h# 1 constant /tcx-off-rdfb32-8 + +h# c000000 constant tcx-off-rstip +h# 800000 constant /tcx-off-rstip-24 +h# 1 constant /tcx-off-rstip-8 + +h# e000000 constant tcx-off-rblit +h# 800000 constant /tcx-off-rblit-24 +h# 1 constant /tcx-off-rblit-8 + +: >tcx-reg-spec ( offset size -- encoded-reg ) + >r 0 my-address d+ my-space encode-phys r> encode-int encode+ +; + +: tcx-8bit-reg + \ WARNING: order is important (at least to Solaris) + tcx-off-dfb8 /tcx-off-dfb8 >tcx-reg-spec + tcx-off-dfb24 /tcx-off-dfb24-8 >tcx-reg-spec encode+ + tcx-off-stip /tcx-off-stip >tcx-reg-spec encode+ + tcx-off-blit /tcx-off-blit >tcx-reg-spec encode+ + tcx-off-rdfb32 /tcx-off-rdfb32-8 >tcx-reg-spec encode+ + tcx-off-rstip /tcx-off-rstip-8 >tcx-reg-spec encode+ + tcx-off-rblit /tcx-off-rblit-8 >tcx-reg-spec encode+ + tcx-off-tec /tcx-off-tec >tcx-reg-spec encode+ + tcx-off-cmap /tcx-off-cmap-8 >tcx-reg-spec encode+ + tcx-off-thc-8 /tcx-off-thc-8 >tcx-reg-spec encode+ + tcx-off-rom /tcx-off-rom >tcx-reg-spec encode+ + tcx-off-dhc /tcx-off-dhc-8 >tcx-reg-spec encode+ + tcx-off-alt /tcx-off-alt-8 >tcx-reg-spec encode+ + " reg" property +; + +: tcx-24bit-reg + \ WARNING: order is important (at least to Solaris) + tcx-off-dfb8 /tcx-off-dfb8 >tcx-reg-spec + tcx-off-dfb24 /tcx-off-dfb24-24 >tcx-reg-spec encode+ + tcx-off-stip /tcx-off-stip >tcx-reg-spec encode+ + tcx-off-blit /tcx-off-blit >tcx-reg-spec encode+ + tcx-off-rdfb32 /tcx-off-rdfb32-24 >tcx-reg-spec encode+ + tcx-off-rstip /tcx-off-rstip-24 >tcx-reg-spec encode+ + tcx-off-rblit /tcx-off-rblit-24 >tcx-reg-spec encode+ + tcx-off-tec /tcx-off-tec >tcx-reg-spec encode+ + tcx-off-cmap /tcx-off-cmap-24 >tcx-reg-spec encode+ + tcx-off-thc-24 /tcx-off-thc-24 >tcx-reg-spec encode+ + tcx-off-rom /tcx-off-rom >tcx-reg-spec encode+ + tcx-off-dhc /tcx-off-dhc-24 >tcx-reg-spec encode+ + tcx-off-alt /tcx-off-alt-24 >tcx-reg-spec encode+ + " reg" property +; + +: do-map-in ( offset size -- virt ) + >r my-space r> " map-in" $call-parent +; + +: do-map-out ( virt size ) + " map-out" $call-parent +; + +\ +\ DAC +\ + +-1 value tcx-dac +-1 value /tcx-dac +-1 value fb-addr + +: dac! ( data reg# -- ) + >r dup 2dup bljoin r> tcx-dac + l! +; + +external + +: color! ( r g b c# -- ) + 0 dac! ( r g b ) + swap rot ( b g r ) + 4 dac! ( b g ) + 4 dac! ( b ) + 4 dac! ( ) +; + +headerless + +\ +\ Mapping +\ + +: dac-map + tcx-off-cmap /tcx-dac do-map-in to tcx-dac +; + +: fb-map + tcx-off-dfb8 h# c0000 do-map-in to fb-addr +; + +: map-regs + dac-map fb-map +; + +\ +\ Installation +\ + +" SUNW,tcx" device-name +" display" device-type + +: qemu-tcx-driver-install ( -- ) + tcx-dac -1 = if + map-regs + + \ Initial pallette taken from Sun's "Writing FCode Programs" + h# ff h# ff h# ff h# 0 color! \ Background white + h# 0 h# 0 h# 0 h# ff color! \ Foreground black + h# 64 h# 41 h# b4 h# 1 color! \ SUN-blue logo + + fb-addr to frame-buffer-adr + default-font set-font + + \ Sun TCX adapters don't have an address property, but it is useful for + \ OpenBIOS developers. Unfortunately NetBSD SPARC32 has a bug that causes + \ it to fail initialising TCX if the address property is present; so work + \ around this by adding an underscore prefix + frame-buffer-adr encode-int " _address" property + + openbios-video-width openbios-video-height over char-width / over char-height / + fb8-install + then +; + +: qemu-tcx-driver-init + + \ Handle differences between 8-bit/24-bit mode + depth-bits 8 = if + tcx-8bit-reg + /tcx-off-cmap-8 to /tcx-dac + " true" encode-string " tcx-8-bit" property + else + tcx-24bit-reg + /tcx-off-cmap-24 to /tcx-dac + + \ Even with a 24-bit enabled TCX card, the control plane is + \ used in 8-bit mode. So force the video subsystem into 8-bit + \ mode before initialisation. + 8 depth-bits-xt ! + openbios-video-width line-bytes-xt ! + then + + h# 1d encode-int " vbporch" property + h# a0 encode-int " hbporch" property + h# 06 encode-int " vsync" property + h# 88 encode-int " hsync" property + h# 03 encode-int " vfporch" property + h# 18 encode-int " hfporch" property + h# 03dfd240 encode-int " pixfreq" property + h# 3c encode-int " vfreq" property + + openbios-video-height encode-int " height" property + openbios-video-width encode-int " width" property + line-bytes encode-int " linebytes" property + + h# 39 encode-int 0 encode-int encode+ " intr" property + 5 encode-int " interrupts" property + + ['] qemu-tcx-driver-install is-install +; + +qemu-tcx-driver-init + +end0 |