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