← Back to branch summary

~pmdj/ubuntu/trusty/qemu/2.9+applesmc+fadtv3

« back to all changes in this revision

Viewing changes to roms/openbios/drivers/tcx.fs

  • Committer: Phil Dennis-Jordan
  • Date: 2017-07-21 08:03:43 UTC
  • mfrom: (1.1.1)
  • Revision ID: phil@philjordan.eu-20170721080343-2yr2vdj7713czahv
New upstream release 2.9.0.

Show diffs side-by-side

added added

removed removed

Lines of Context:
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