281 lines
6.4 KiB
Forth
281 lines
6.4 KiB
Forth
|
\
|
||
|
|
\ 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
|