qemu/roms/openbios/drivers/tcx.fs

   1 \
   2 \ Fcode payload for QEMU TCX graphics card
   3 \
   4 \ This is the Forth source for an Fcode payload to initialise
   5 \ the QEMU TCX graphics card.
   6 \
   7 \ (C) Copyright 2013 Mark Cave-Ayland
   8 \
   9
  10 fcode-version3
  11
  12 \
  13 \ Instead of using fixed values for the framebuffer address and the width
  14 \ and height, grab the ones passed in by QEMU/generated by OpenBIOS
  15 \
  16
  17 : (find-xt)   \ ( str len -- xt | -1 )
  18   $find if
  19     exit
  20   else
  21     2drop
  22     -1
  23   then
  24 ;
  25
  26 : (is-openbios)  \ ( -- true | false )
  27   " openbios-video-width" (find-xt) -1 <> if
  28     -1
  29   else
  30     0
  31   then
  32 ;
  33
  34 " openbios-video-width" (find-xt) cell+ value openbios-video-width-xt
  35 " openbios-video-height" (find-xt) cell+ value openbios-video-height-xt
  36 " depth-bits" (find-xt) cell+ value depth-bits-xt
  37 " line-bytes" (find-xt) cell+ value line-bytes-xt
  38
  39 : openbios-video-width
  40   (is-openbios) if
  41     openbios-video-width-xt @
  42   else
  43     h# 400
  44   then
  45 ;
  46
  47 : openbios-video-height
  48   (is-openbios) if
  49     openbios-video-height-xt @
  50   else
  51     h# 300
  52   then
  53 ;
  54
  55 : depth-bits
  56   (is-openbios) if
  57     depth-bits-xt @
  58   else
  59     h# 8
  60   then
  61 ;
  62
  63 : line-bytes
  64   (is-openbios) if
  65     line-bytes-xt @
  66   else
  67     h# 400
  68   then
  69 ;
  70
  71 \
  72 \ Registers
  73 \
  74
  75 h# 0 constant tcx-off-rom
  76 h# 10000 constant /tcx-off-rom
  77
  78 h# 200000 constant tcx-off-cmap
  79 h# 4000 constant /tcx-off-cmap-24
  80 h# 4 constant /tcx-off-cmap-8
  81
  82 h# 240000 constant tcx-off-dhc
  83 h# 4000 constant /tcx-off-dhc-24
  84 h# 4 constant /tcx-off-dhc-8
  85
  86 h# 280000 constant tcx-off-alt
  87 h# 8000 constant /tcx-off-alt-24
  88 h# 1 constant /tcx-off-alt-8
  89
  90 h# 301000 constant tcx-off-thc-24
  91 h# 300000 constant tcx-off-thc-8
  92 h# 1000 constant /tcx-off-thc-24
  93 h# 81c constant /tcx-off-thc-8
  94
  95 h# 701000 constant tcx-off-tec
  96 h# 1000 constant /tcx-off-tec
  97
  98 h# 800000 constant tcx-off-dfb8
  99 h# 100000 constant /tcx-off-dfb8
 100
 101 h# 2000000 constant tcx-off-dfb24
 102 h# 400000 constant /tcx-off-dfb24-24
 103 h# 1 constant /tcx-off-dfb24-8
 104
 105 h# 4000000 constant tcx-off-stip
 106 h# 800000 constant /tcx-off-stip
 107
 108 h# 6000000 constant tcx-off-blit
 109 h# 800000 constant /tcx-off-blit
 110
 111 h# a000000 constant tcx-off-rdfb32
 112 h# 400000 constant /tcx-off-rdfb32-24
 113 h# 1 constant /tcx-off-rdfb32-8
 114
 115 h# c000000 constant tcx-off-rstip
 116 h# 800000 constant /tcx-off-rstip-24
 117 h# 1 constant /tcx-off-rstip-8
 118
 119 h# e000000 constant tcx-off-rblit
 120 h# 800000 constant /tcx-off-rblit-24
 121 h# 1 constant /tcx-off-rblit-8
 122
 123 : >tcx-reg-spec ( offset size -- encoded-reg )
 124   >r 0 my-address d+ my-space encode-phys r> encode-int encode+
 125 ;
 126
 127 : tcx-8bit-reg
 128   \ WARNING: order is important (at least to Solaris)
 129   tcx-off-dfb8 /tcx-off-dfb8 >tcx-reg-spec
 130   tcx-off-dfb24 /tcx-off-dfb24-8 >tcx-reg-spec encode+
 131   tcx-off-stip /tcx-off-stip >tcx-reg-spec encode+
 132   tcx-off-blit /tcx-off-blit >tcx-reg-spec encode+
 133   tcx-off-rdfb32 /tcx-off-rdfb32-8 >tcx-reg-spec encode+
 134   tcx-off-rstip /tcx-off-rstip-8 >tcx-reg-spec encode+
 135   tcx-off-rblit /tcx-off-rblit-8 >tcx-reg-spec encode+
 136   tcx-off-tec /tcx-off-tec >tcx-reg-spec encode+
 137   tcx-off-cmap /tcx-off-cmap-8 >tcx-reg-spec encode+
 138   tcx-off-thc-8 /tcx-off-thc-8 >tcx-reg-spec encode+
 139   tcx-off-rom /tcx-off-rom >tcx-reg-spec encode+
 140   tcx-off-dhc /tcx-off-dhc-8 >tcx-reg-spec encode+
 141   tcx-off-alt /tcx-off-alt-8 >tcx-reg-spec encode+
 142   " reg" property
 143 ;
 144
 145 : tcx-24bit-reg
 146   \ WARNING: order is important (at least to Solaris)
 147   tcx-off-dfb8 /tcx-off-dfb8 >tcx-reg-spec
 148   tcx-off-dfb24 /tcx-off-dfb24-24 >tcx-reg-spec encode+
 149   tcx-off-stip /tcx-off-stip >tcx-reg-spec encode+
 150   tcx-off-blit /tcx-off-blit >tcx-reg-spec encode+
 151   tcx-off-rdfb32 /tcx-off-rdfb32-24 >tcx-reg-spec encode+
 152   tcx-off-rstip /tcx-off-rstip-24 >tcx-reg-spec encode+
 153   tcx-off-rblit /tcx-off-rblit-24 >tcx-reg-spec encode+
 154   tcx-off-tec /tcx-off-tec >tcx-reg-spec encode+
 155   tcx-off-cmap /tcx-off-cmap-24 >tcx-reg-spec encode+
 156   tcx-off-thc-24 /tcx-off-thc-24 >tcx-reg-spec encode+
 157   tcx-off-rom /tcx-off-rom >tcx-reg-spec encode+
 158   tcx-off-dhc /tcx-off-dhc-24 >tcx-reg-spec encode+
 159   tcx-off-alt /tcx-off-alt-24 >tcx-reg-spec encode+
 160   " reg" property
 161 ;
 162
 163 : do-map-in ( offset size -- virt )
 164   >r my-space r> " map-in" $call-parent
 165 ;
 166
 167 : do-map-out ( virt size )
 168   " map-out" $call-parent
 169 ;
 170
 171 \
 172 \ DAC
 173 \
 174
 175 -1 value tcx-dac
 176 -1 value /tcx-dac
 177 -1 value fb-addr
 178
 179 : dac! ( data reg# -- )
 180   >r dup 2dup bljoin r> tcx-dac + l!
 181 ;
 182
 183 external
 184
 185 : color!  ( r g b c# -- )
 186   0 dac!       ( r g b )
 187   swap rot     ( b g r )
 188   4 dac!       ( b g )
 189   4 dac!       ( b )
 190   4 dac!       (  )
 191 ;
 192
 193 headerless
 194
 195 \
 196 \ Mapping
 197 \
 198
 199 : dac-map
 200   tcx-off-cmap /tcx-dac do-map-in to tcx-dac
 201 ;
 202
 203 : fb-map
 204   tcx-off-dfb8 h# c0000 do-map-in to fb-addr
 205 ;
 206
 207 : map-regs
 208   dac-map fb-map
 209 ;
 210
 211 \
 212 \ Installation
 213 \
 214
 215 " SUNW,tcx" device-name
 216 " display" device-type
 217
 218 : qemu-tcx-driver-install ( -- )
 219   tcx-dac -1 = if
 220     map-regs
 221
 222     \ Initial pallette taken from Sun's "Writing FCode Programs"
 223     h# ff h# ff h# ff h# 0  color!    \ Background white
 224     h# 0  h# 0  h# 0  h# ff color!    \ Foreground black
 225     h# 64 h# 41 h# b4 h# 1  color!    \ SUN-blue logo
 226
 227     fb-addr to frame-buffer-adr
 228     default-font set-font
 229
 230     \ Sun TCX adapters don't have an address property, but it is useful for
 231     \ OpenBIOS developers. Unfortunately NetBSD SPARC32 has a bug that causes
 232     \ it to fail initialising TCX if the address property is present; so work
 233     \ around this by adding an underscore prefix
 234     frame-buffer-adr encode-int " _address" property
 235
 236     openbios-video-width openbios-video-height over char-width / over char-height /
 237     fb8-install
 238   then
 239 ;
 240
 241 : qemu-tcx-driver-init
 242
 243   \ Handle differences between 8-bit/24-bit mode
 244   depth-bits 8 = if
 245     tcx-8bit-reg
 246     /tcx-off-cmap-8 to /tcx-dac
 247     " true" encode-string " tcx-8-bit" property
 248   else
 249     tcx-24bit-reg
 250     /tcx-off-cmap-24 to /tcx-dac
 251
 252     \ Even with a 24-bit enabled TCX card, the control plane is
 253     \ used in 8-bit mode. So force the video subsystem into 8-bit
 254     \ mode before initialisation.
 255     8 depth-bits-xt !
 256     openbios-video-width line-bytes-xt !
 257   then
 258
 259   h# 1d encode-int " vbporch" property
 260   h# a0 encode-int " hbporch" property
 261   h# 06 encode-int " vsync" property
 262   h# 88 encode-int " hsync" property
 263   h# 03 encode-int " vfporch" property
 264   h# 18 encode-int " hfporch" property
 265   h# 03dfd240 encode-int " pixfreq" property
 266   h# 3c encode-int " vfreq" property
 267
 268   openbios-video-height encode-int " height" property
 269   openbios-video-width encode-int " width" property
 270   line-bytes encode-int " linebytes" property
 271
 272   h# 39 encode-int 0 encode-int encode+ " intr" property
 273   5 encode-int " interrupts" property
 274
 275   ['] qemu-tcx-driver-install is-install
 276 ;
 277
 278 qemu-tcx-driver-init
 279
 280 end0