| \ |
| \ 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 |