197 lines
3.4 KiB
Forth
197 lines
3.4 KiB
Forth
\
|
|
\ Fcode payload for QEMU CG3 graphics card
|
|
\
|
|
\ This is the Forth source for an Fcode payload to initialise
|
|
\ the QEMU CG3 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
|
|
" debug-type" (find-xt) value debug-type-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
|
|
;
|
|
|
|
: debug-type debug-type-xt execute ;
|
|
|
|
\
|
|
\ Registers
|
|
\
|
|
|
|
h# 400000 constant cg3-off-dac
|
|
h# 20 constant /cg3-off-dac
|
|
|
|
h# 800000 constant cg3-off-fb
|
|
h# c0000 constant /cg3-off-fb
|
|
|
|
: >cg3-reg-spec ( offset size -- encoded-reg )
|
|
>r 0 my-address d+ my-space encode-phys r> encode-int encode+
|
|
;
|
|
|
|
: cg3-reg
|
|
\ A real cg3 rom appears to just map the entire region with a
|
|
\ single entry
|
|
h# 0 h# 1000000 >cg3-reg-spec
|
|
" 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 cg3-dac
|
|
-1 value fb-addr
|
|
|
|
: dac! ( data reg# -- )
|
|
cg3-dac + c!
|
|
;
|
|
|
|
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
|
|
cg3-off-dac /cg3-off-dac do-map-in to cg3-dac
|
|
;
|
|
|
|
: fb-map
|
|
cg3-off-fb h# c0000 do-map-in to fb-addr
|
|
;
|
|
|
|
: map-regs
|
|
dac-map fb-map
|
|
;
|
|
|
|
\
|
|
\ Installation
|
|
\
|
|
|
|
" cgthree" device-name
|
|
" display" device-type
|
|
" SUNW,501-1415" model
|
|
|
|
: qemu-cg3-driver-install ( -- )
|
|
cg3-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
|
|
|
|
frame-buffer-adr encode-int " address" property
|
|
|
|
openbios-video-width openbios-video-height over char-width / over char-height /
|
|
fb8-install
|
|
then
|
|
;
|
|
|
|
: qemu-cg3-driver-init
|
|
|
|
cg3-reg
|
|
|
|
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
|
|
|
|
\ Monitor sense. Some searching suggests that this is
|
|
\ 5 for 1024x768 and 7 for 1152x900
|
|
openbios-video-width h# 480 = if
|
|
h# 7
|
|
else
|
|
h# 5
|
|
then
|
|
encode-int " monitor-sense" property
|
|
|
|
" SUNW" encode-string " manufacturer" property
|
|
" ISO8859-1" encode-string " character-set" property
|
|
h# c encode-int " cursorshift" property
|
|
|
|
['] qemu-cg3-driver-install is-install
|
|
;
|
|
|
|
qemu-cg3-driver-init
|
|
|
|
end0
|