\ cg6 (Lego) frame buffer driver
fcode-version3
hex
" SUNW,cgsix" name
" SUNW,501-xxxx" model
" display" device-type
h# 20.0000 constant dac-offset h# 10 constant /dac
h# 30.0000 constant fhc-offset h# 10 constant /fhc
h# 30.1800 constant thc-offset h# 20 constant /thc
h# 70.0000 constant fbc-offset h# 10 constant /fbc
h# 70.1000 constant tec-offset h# 10 constant /tec
h# 80.0000 constant fb-offset h# 10.0000 constant /frame
: >reg-spec ( offset size -- encoded-reg )
>r 0 my-address d+ my-space encode-phys 0 encode-int encode+ r> encode-int encode+
;
0 0 >reg-spec \ Configuration space registers
dac-offset /dac >reg-spec encode+
fhc-offset /fhc >reg-spec encode+
thc-offset /thc >reg-spec encode+
fbc-offset /fbc >reg-spec encode+
tec-offset /tec >reg-spec encode+
fb-offset /frame >reg-spec encode+
" reg" property
-1 value dac-addr
-1 value fhc-addr
-1 value thc-addr
-1 value fbc-addr
-1 value tec-addr
-1 value fb-addr
: copyright ( -- addr len ) "Copyright (c) 1992 - 1996 Sun Microsystems, Inc. " ;
: do-map-in ( offset size -- )
>r ( offset ) ( R: size ) \ Move size to return stack
0 ( offset 0 ) ( R: size ) \ Convert offset to double number
my-address ( offset 0 phys.lo phys.mid ) ( R: size )
d+ ( phys.lo' phys.mid ) ( R: size )
my-space r> ( phys.lo' phys.mid phys.hi size ) ( R: )
" map-in" $call-parent
;
: do-map-out ( vaddr size -- ) " map-out" $call-parent ;
: dac-map ( -- ) dac-offset /dac do-map-in to dac-addr ;
: dac-unmap ( -- ) dac-addr /dac do-map-out -1 to dac-addr ;
: fhc-map ( -- ) fhc-offset /fhc do-map-in to fhc-addr ;
: fhc-unmap ( -- ) fhc-addr /fhc do-map-out -1 to fhc-addr ;
: thc-map ( -- ) thc-offset /thc do-map-in to thc-addr ;
: thc-unmap ( -- ) thc-addr /thc do-map-out -1 to thc-addr ;
: fbc-map ( -- ) fbc-offset /fbc do-map-in to fbc-addr ;
: fbc-unmap ( -- ) fbc-addr /fbc do-map-out -1 to fbc-addr ;
: tec-map ( -- ) tec-offset /tec do-map-in to tec-addr ;
: tec-unmap ( -- ) tec-addr /tec do-map-out -1 to tec-addr ;
: fb-map ( -- ) fb-offset /frame do-map-in to fb-addr ;
: fb-unmap ( -- ) fb-addr /frame do-map-out -1 to fb-addr ;
: map-regs ( -- ) dac-map fhc-map thc-map fbc-map tec-map ;
: unmap-regs ( -- ) tec-unmap fbc-unmap thc-unmap fhc-unmap dac-unmap ;
\ Brooktree DAC interface section
\ The Brooktree DAC has an internal address register which helps to
\ select the internal register which is to be accessed.
\ First, the address is written to register 0, then the data is written
\ to one of the other registers.
\ Ibis has 3 separate DAC chips which appear as the three least-significant
\ bytes of a longword. All three chips may be simultaneously updated
\ with a single longword write.
: dac! ( data reg# -- ) >r dup 2dup bljoin r> dac-addr + l! ;
: dac-ctl! ( data int.addr reg# -- ) swap 0 dac! dac! ;
\ color! sets an overlay color register.
\ In order to be able to use either the Brooktree 457 or 458 dacs, we
\ set the address once, then store the color 3 times. The chip internally
\ cycles each time the color register is written, selecting in turn the
\ red color, the green color, and the blue color.
\ The chip is used in "RGB mode".
: color! ( r g b c# -- )
0 dac! ( r g b )
swap rot ( b g r )
4 dac! ( b g )
4 dac! ( b )
4 dac! ( )
;
: lego-init-dac ( -- )
40 06 8 dac-ctl! \ Control reg: enable off, overlay off, RGB on
0 05 8 dac-ctl! \ Blinking off
ff 04 8 dac-ctl! \ Read mask set to all ones
ff ff ff 0 color! \ White in overlay background color register
0 0 0 ff color! \ Black in overlay foreground color register
64 41 b4 1 color! \ SUN-blue for logo
;
\ End of Brooktree DAC code
\ Lego Selftest section
: fbc! ( value offset -- ) fbc-addr + l! ;
: fbc@ ( offset -- value ) fbc-addr + l@ ;
: tec! ( value offset -- ) tec-addr + l! ;
: lego-selftest ( -- failed? ) false ;
\ Hardware configuration register section
: fhc! ( value offset -- ) fhc-addr + l! ;
: thc! ( value offset -- ) thc-addr + l! ;
: set-res-params ( hcvd hcvs hchd hchsdvb hchs fhc-conf -- )
0 fhc! 0 thc! 4 thc! 8 thc! c thc! 10 thc!
;
\ Resolution params: hcvd hcvs hchd hchsdvb hchs fhc-conf
: r1024x768 ( -- params ) 2c032c 32c0005 110051 490000 510007 3bb ;
: r1152x900 ( -- params ) 2403a8 10005 15005d 570000 10009 bbb ;
: r1024x1024 ( -- params ) 200426 10005 180054 520000 10009 3bb ;
: r1152x870 ( -- params ) 2c0392 20005 120054 540000 10009 bbb ;
: r1600x1280 ( -- params ) 340534 534009 130045 3d0000 450007 1bbb ;
0 value lego-rez-width
0 value lego-rez-height
0 value sense-code
: set-resolution ( sense-code -- )
case
0 of d# 1152 d# 900 endof
12 of d# 1024 d# 1024 endof
13 of d# 1600 d# 1280 endof
drop d# 1152 d# 900 0
endcase
to lego-rez-height to lego-rez-width
;
8f value thc-misc
: lego-video-on ( -- ) thc-misc 400 or 18 thc! ;
: lego-video-off ( -- ) thc-misc 18 thc! ;
: lego-blink ( -- ) lego-video-off 20 ms lego-video-on ;
: lego-init-hc ( -- )
sense-code case
0 of r1152x900 endof
12 of r1024x1024 endof
13 of r1600x1280 endof
drop r1152x900 0
endcase ( resolution-params )
set-res-params
016b 14 thc! \ THC_HCREFRESH
148f 18 thc! \ THC_HCMISC
lego-video-off \ Turn video on at install time
;
\ End of hardware configuration register section
\ Lego graphics section
: lego-install ( -- )
map-regs fb-map fb-addr to frame-buffer-adr
default-font ( param ... ) set-font
frame-buffer-adr encode-int " address" property
lego-rez-width lego-rez-height over char-width / over char-height /
fb8-install
['] lego-blink to blink-screen
lego-video-on
;
: lego-remove ( -- )
lego-video-off
unmap-regs
fb-unmap -1 to frame-buffer-adr
;
\ End of Lego graphics section
: lego-probe ( -- )
map-regs
sense-code set-resolution
lego-init-dac
lego-init-hc
unmap-regs
lego-rez-width encode-int " width" property
lego-rez-height encode-int " height" property
d# 8 encode-int " depth" property
lego-rez-width encode-int " linebytes" property
['] lego-install is-install
['] lego-remove is-remove
['] lego-selftest is-selftest
;
lego-probe
end0
|
