raspberrypi.nothing

;; -*- mode: scheme -*-

;; Copyright (C) 2012-2015 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
;;
;; This file is part of pi-nothing.
;;
;; pi-nothing is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published
;; by the Free Software Foundation, either version 3 of the License,
;; or (at your option) any later version.
;;
;; pi-nothing is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with pi-nothing. If not, see <http://www.gnu.org/licenses/>.
;;
;;---------------------------------------------------------------------------
;; NOTE: The procedure (font0-bitmap), containing font data, is NOT
;; covered by the GPL, and is instead covered by the Bitstream Vera
;; Fonts Copyright license, which is available in the file
;; font0license.txt.
;;---------------------------------------------------------------------------

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Interrupt table

;; TODO: Limitation on the linker means this routine has to be early
;; in the image, so that the offset to
;; sys:exception-handler-undefined-instruction etc isn't too large to
;; fit in an instruction. See the label-linker instance in
;; `indirect-immediate` in mach-arm7.rkt. A more flexible linker would
;; be able to put the needed value in the data quasisegment, like the
;; non-label branch does.
(define (configure-interrupt-table)
  (let ((mutable vec 0))
    (while (<u vec 8)
      (! (<< vec 2) #xe59ff018) ;; LDR PC, [PC, #24]
      (set! vec (+ vec 1))))
  (! #x20 interrupt:reset)
  (! #x24 sys:exception-handler-undefined-instruction)
  (! sys:interrupt-vector-undefined-instruction interrupt:undefined-instruction)
  (! #x28 sys:exception-handler-swi)
  (! sys:interrupt-vector-swi interrupt:swi)
  (! #x2c sys:exception-handler-prefetch-abort)
  (! sys:interrupt-vector-prefetch-abort interrupt:prefetch-abort)
  (! #x30 sys:exception-handler-data-abort)
  (! sys:interrupt-vector-data-abort interrupt:data-abort)
  (! #x34 interrupt:unused)
  (! #x38 sys:exception-handler-irq)
  (! sys:interrupt-vector-irq interrupt:irq)
  (! #x3c sys:exception-handler-fiq)
  (! sys:interrupt-vector-fiq interrupt:fiq))

(define (cpu-enable-interrupts)
  (sys:set-cpsr (binand (sys:get-cpsr) #xffffff3f))) ;; clear I and F bits

(define (cpu-disable-interrupts)
  (sys:set-cpsr (binor (sys:get-cpsr) #xc0))) ;; set I and F bits

(define (interrupt:reset)
  (error %error-unexpected-interrupt:reset)
  0)

(define (interrupt:undefined-instruction)
  (error %error-unexpected-interrupt:undefined-instruction)
  0) ;; either 0 or 4 depending on whether to skip the insn or retry it

(define (interrupt:swi)
  (error %error-unexpected-interrupt:swi)
  0) ;; will return immediately after the SWI

(define (interrupt:prefetch-abort)
  (error %error-unexpected-interrupt:prefetch-abort)
  0) ;; either 0 or 4 depending on whether to skip the insn or retry it

(define (interrupt:data-abort)
  (error %error-unexpected-interrupt:data-abort)
  0) ;; either 4 or 8 depending on whether to skip the insn or retry it

(define (interrupt:unused)
  (error %error-unexpected-interrupt:unused)
  0)

(define (irq-start-cycle-counter)
  (data #"\0\0\0\0"))

(define (interrupt:irq dummy cycle-counter)
  (! (irq-start-cycle-counter) cycle-counter)
  (sys:set-spsr (binor (sys:get-spsr) #xc0)) ;; disable interrupts when we return from this handler.
  ;; ^ we do this because we don't know which interrupt caused us
  ;; here, so we can't clear the condition and will loop forever.
  ;; We leave the clearing of the condition to user code.
  4) ;; not zero! otherwise we end up skipping an instruction

(define (interrupt:fiq)
  (error %error-unexpected-interrupt:fiq)
  4) ;; not zero! otherwise we end up skipping an instruction

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(const %error-division-by-zero				#x00000002)
(const %error-no-error					#x00000007)

(const %error-bad-mailbox-channel			#x00000010)
(const %error-bad-mailbox-pointer			#x00000011)
(const %error-unexpected-mailbox-message		#x00000012)

(const %error-framebuffer-mode-set-failed		#x00000020)

(const %error-unexpected-interrupt:reset			#x00000030)
(const %error-unexpected-interrupt:undefined-instruction	#x00000031)
(const %error-unexpected-interrupt:swi				#x00000032)
(const %error-unexpected-interrupt:prefetch-abort		#x00000033)
(const %error-unexpected-interrupt:data-abort			#x00000034)
(const %error-unexpected-interrupt:unused			#x00000035)
(const %error-unexpected-interrupt:irq				#x00000036)
(const %error-unexpected-interrupt:fiq				#x00000037)

(const %error-devicetree-bad-node-type			#x00000040)

(const %error-dma-no-free-channels			#x00000050)
(const %error-dma-channel-double-free			#x00000051)

(define (error code)
  (pulse-bits-forever code))

(define (error/argument code arg)
  (while (= 0 0)
    (pulse-bits code)
    (pulse-bits arg)
    (long-delay)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (division-by-zero a b)
  (error %error-division-by-zero))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (delay-countdown v)
  (let ((mutable n v))
    (while (>u n 0)
      (set! n (- n 1)))))

(define (short-delay)
  (delay-countdown #x2000000))

(define (long-delay)
  (delay-countdown #x6000000))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(const %gpio-base #x20200000)
(const %gpio-function-select-base #x0000) ;; GPIO pins 0-9; subsequent pins at adjacent regs
(const %gpio-pin-output-set-base #x001c) ;; GPIO pins 0-31; 32-53 in adjacent reg
(const %gpio-pin-output-clear-base #x0028) ;; GPIO pins 0-31; 32-53 in adjacent reg
(const %gpio-pull-up/down #x0094)
(const %gpio-pull-up/down-clock-base #x0098) ;; GPIO pins 0-31; 32-53 in adjacent reg

(const %gpio-pin-control-mask 7) ;; 3 bits
(const %gpio-pin-control-input 0) ;; pin is an input
(const %gpio-pin-control-output 1) ;; pin is an output
(const %gpio-pin-control-alternate-function-base 4) ;; add alt fun num to get funs 0-5

(const %gpio-pull-neither 0)
(const %gpio-pull-down 1)
(const %gpio-pull-up 2)

(define (gpio-function-select! pin function)
  (let ((reg (+ %gpio-base %gpio-function-select-base (/ pin 10)))
	(ofs (* (% pin 10) 3)))
    (let ((old (? reg)))
      (! reg (binor (binand old (binnot (<< %gpio-pin-control-mask ofs)))
		    (<< (binand function %gpio-pin-control-mask) ofs))))))

(define (gpio-set-pin! pin state)
  (! (+ %gpio-base
	(if (<> state 0) %gpio-pin-output-set-base %gpio-pin-output-clear-base)
	(>>u pin 5)) ;; 32 pins per reg
     (<< 1 (binand pin 31))))

;; pins0 and pins1 are bitmasks with a bit set for each pin to modify
;; e.g. pins0 should have (1 << 0) set to modify setting for pin 0
;; pins0 covers pins 0-31, and pins1 covers pins 32-53
;; value 0 = disable both pull-up and pull-down
;; value 1 = enable pull down
;; value 2 = enable pull up
(define (gpio-pull-control! pins0 pins1 value)
  (! (+ %gpio-base %gpio-pull-up/down) value)
  (delay-cycles 150)
  (when (<> pins0 0) (! (+ %gpio-base %gpio-pull-up/down-clock-base 0) pins0))
  (when (<> pins1 0) (! (+ %gpio-base %gpio-pull-up/down-clock-base 4) pins1))
  (delay-cycles 150)
  (! (+ %gpio-base %gpio-pull-up/down) 0)
  (when (<> pins0 0) (! (+ %gpio-base %gpio-pull-up/down-clock-base 0) 0))
  (when (<> pins1 0) (! (+ %gpio-base %gpio-pull-up/down-clock-base 4) 0)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (enable-led)
  (gpio-function-select! 16 %gpio-pin-control-output))

(define (set-led! state)
  (gpio-set-pin! 16 (if (<> state 0) 0 1)))

(define (pulse-bits bitfield)
  (if (<> bitfield 0)
      (let ((bit (binand bitfield 1)))
	(pulse-bits (>>u bitfield 1))
	(set-led! 1)
	(if (<> bit 0) (long-delay) (short-delay))
	(set-led! 0)
	(short-delay))
      (begin (set-led! 0)
	     (long-delay))))

(define (pulse-bits-forever bitfield)
  (while (= 0 0) (pulse-bits bitfield)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(const $alloc-pointer-addr #x00200000) ;; Heap starts at 2MB - i.e. above the stack

(define (init-alloc!)
  (! $alloc-pointer-addr (+ $alloc-pointer-addr 16))) ;; can't use 4, is not 16-aligned

(define (*save-alloc-state*)
  (? $alloc-pointer-addr))

(define (*restore-alloc-state* saved-state)
  (! $alloc-pointer-addr saved-state))

(define (round-up-to-4 x) (binand #xfffffffc (+ x 3)))
(define (round-up-to-16 x) (binand #xfffffff0 (+ x 15)))

(define (alloc-align! bits)
  (let ((mask (- (<< 1 bits) 1)))
    (let ((aligned-pointer (binand (binnot mask) (+ (? $alloc-pointer-addr) mask))))
      (! $alloc-pointer-addr aligned-pointer))))

(define (alloc! size)
  ;; always returns a 16-byte aligned pointer
  (let ((rounded-size (round-up-to-16 size))
	(result (? $alloc-pointer-addr)))
    (! $alloc-pointer-addr (+ result rounded-size))
    result))

(define (copy-bytes! target source count)
  (when (>u count 0)
    (!byte target (?byte source))
    (copy-bytes! (+ target 1) (+ source 1) (- count 1))))

(define (maxu a b)
  (if (>u a b) a b))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(const %mailbox-base #x2000b880)

(const %mailbox-reg-read #x00)
(const %mailbox-reg-peek #x10)
(const %mailbox-reg-sender #x14)
(const %mailbox-reg-status #x18)
(const %mailbox-reg-config #x1c)
(const %mailbox-reg-write #x20)

(const %channel-power-management 0)
(const %channel-framebuffer 1)
(const %channel-virtual-uart 2)
(const %channel-vchiq 3)
(const %channel-leds 4)
(const %channel-buttons 5)
(const %channel-touchscreen 6)
;; 7 unused?
(const %channel-properties-arm->vc 8)
(const %channel-properties-vc->arm 9)

(define (mailbox-barrier)
  ;; TODO: what kinds of memory barriers are needed here and in
  ;; mailbox-recv? See http://elinux.org/RPi_Framebuffer.
  (sys:clean-and-invalidate-data-cache)
  0)

(define (mailbox-status)
  (mailbox-barrier)
  (? (+ %mailbox-base %mailbox-reg-status)))

(define (mailbox-send! mailbox-channel message-pointer)
  (when (>=u mailbox-channel 16) (error %error-bad-mailbox-channel))
  (when (<> (binand message-pointer 15) 0) (error %error-bad-mailbox-pointer))
  (while (<> (binand (mailbox-status) (<< 1 31)) 0))
  (! (+ %mailbox-base %mailbox-reg-write)
     (binor mailbox-channel message-pointer))
  (mailbox-barrier))

(define (mailbox-recv mailbox-channel)
  (when (>=u mailbox-channel 16) (error %error-bad-mailbox-channel))
  (while (<> (binand (mailbox-status) (<< 1 30)) 0))
  (mailbox-barrier)
  (let ((pointer-and-channel (? (+ %mailbox-base %mailbox-reg-read))))
    (when (<> (binand pointer-and-channel 15) mailbox-channel)
      (error %error-unexpected-mailbox-message))
    (binand pointer-and-channel #xfffffff0)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Mailbox property interface
;; https://github.com/raspberrypi/firmware/wiki/Mailbox-property-interface

;; Property buffer must be a multiple of 32 bits, i.e. a whole number of words.
;; Each tag needs to have enough internal sub-buffer space for its reply.

(struct property-buffer-header ((size word) ;; in bytes; includes this header
				(opcode word)
				;; Sequence of tags/values follows,
				;; terminated by %property-tag-end and
				;; padding to 4-byte alignment.
				))

(const %property-buffer-op-request #x00000000)
(const %property-buffer-op-response-ok #x80000000)
(const %property-buffer-op-response-error #x80000001) ;; "error parsing request buffer"

(struct property-buffer-tag ((id word)
			     (buffer-size word) ;; in bytes; EXCLUDES this header
			     (value-length word) ;; MSB 0=req, 1=resp; 31 bits value length in bytes
			     ;; Value buffer follows, buffer-size bytes.
			     ))

(const %property-tag-end #x00000000)
(const %property-tag-get-arm-memory #x00010005)
(const %property-tag-get-vc-memory #x00010006)
(const %property-tag-get-clock-rate #x00030002)
(const %property-tag-get-physical-display-size #x00040003)
(const %property-tag-get-dma-channels #x00060001)

(define (mailbox-property-get tag request-buffer request-buffer-size response-buffer-size)
  (let ((*saved* (*save-alloc-state*))
        (request/response-buffer-size (maxu request-buffer-size response-buffer-size)))
    (let ((buflen (round-up-to-4 (+ sizeof-property-buffer-header
				    sizeof-property-buffer-tag
                                    request/response-buffer-size
				    4)))) ;; for end tag
      (let ((buf (alloc! buflen)))
	(let ((tag-start (+ buf sizeof-property-buffer-header))
	      (value-start (+ buf sizeof-property-buffer-header sizeof-property-buffer-tag)))
	  (! (+ buf property-buffer-header-size) buflen)
	  (! (+ buf property-buffer-header-opcode) %property-buffer-op-request)
	  (! (+ tag-start property-buffer-tag-id) tag)
	  (! (+ tag-start property-buffer-tag-buffer-size) request/response-buffer-size)
	  (! (+ tag-start property-buffer-tag-value-length) 0)
          (copy-bytes! value-start request-buffer request-buffer-size)
	  (! (+ value-start request/response-buffer-size) %property-tag-end)
	  (mailbox-send! %channel-properties-arm->vc buf)
	  (let ((reply (mailbox-recv %channel-properties-arm->vc)))
	    ;; The reply seems to be the same as the buffer pointer we gave.
	    (when (<> reply buf)
	      (puts (data #"(Weird, mailbox-property-get reply \0"))
	      (putx reply)
	      (puts (data #" isn't buf \0"))
	      (putx buf)
	      (puts (data #")\n\0"))))
	  (*restore-alloc-state* *saved*)
	  value-start))))) ;; N.B. only valid until the next `alloc!`!

(struct property-memory-info ((base word)
			      (size word))) ;; in bytes

(define (get-*-memory tag)
  (? (+ (mailbox-property-get tag 0 0 sizeof-property-memory-info)
	property-memory-info-size)))

(define (get-arm-memory) (get-*-memory %property-tag-get-arm-memory))
(define (get-vc-memory) (get-*-memory %property-tag-get-vc-memory))

(struct property-display-dimensions ((width word)
                                     (height word)))

(define (get-physical-display-size)
  (mailbox-property-get %property-tag-get-physical-display-size 0 0 sizeof-property-display-dimensions))

(define (get-dma-channel-availability-mask)
  (binand (? (mailbox-property-get %property-tag-get-dma-channels 0 0 4))
	  #x0000ffff))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Clocks

(const %clock-RESERVED 0)
(const %clock-emmc 1)
(const %clock-uart 2)
(const %clock-arm 3)
(const %clock-core 4)
(const %clock-v3d 5)
(const %clock-h264 6)
(const %clock-isp 7)
(const %clock-sdram 8)
(const %clock-pixel 9)
(const %clock-pwm 10)

(define (get-clock-rate clock-id)
  (let ((*saved* (*save-alloc-state*)))
    (let ((clock-id-buffer (alloc! 4)))
      (! clock-id-buffer clock-id)
      (let ((reply-buffer (mailbox-property-get %property-tag-get-clock-rate clock-id-buffer 4 8)))
        (*restore-alloc-state* *saved*)
        (? (+ reply-buffer 4))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(struct framebuffer-description ((width word)
				 (height word)
				 (virtual-width word)
				 (virtual-height word)
				 (pitch word) ;; set by GPU
				 (depth word) ;; bits per pixel
				 (x-offset word)
				 (y-offset word)
				 (pointer word) ;; set by GPU
				 (size word))) ;; set by GPU

(define (framebuffer-pointer fbinfo) (? (+ fbinfo framebuffer-description-pointer)))
(define (framebuffer-stride fbinfo) (? (+ fbinfo framebuffer-description-pitch)))
(define (framebuffer-pixel-width fbinfo) (>>u (? (+ fbinfo framebuffer-description-depth)) 3))

(define (pointer->gpu-pointer v)
  (binor #x40000000 v))

(define (gpu-pointer->pointer v)
  (binand #x3fffffff v))

(define (initialize-framebuffer)
  (let ((dimensions (get-physical-display-size)))
    (let ((W (? (+ dimensions property-display-dimensions-width)))
          (H (? (+ dimensions property-display-dimensions-height)))
          ;; ^ Must read from `dimensions` before performing the next `alloc!`.
          (fbinfo (alloc! sizeof-framebuffer-description))
          ;; (W 1920) (H 1080)
          ;; (W 1024) (H 768)
          ;; (W 640) (H 480)
          ;; (W 320) (H 240)
          )
      (! (+ fbinfo framebuffer-description-width) W)
      (! (+ fbinfo framebuffer-description-height) H)
      (! (+ fbinfo framebuffer-description-virtual-width) W)
      (! (+ fbinfo framebuffer-description-virtual-height) H)
      (! (+ fbinfo framebuffer-description-pitch) 0)
      (! (+ fbinfo framebuffer-description-depth) 32)
      (! (+ fbinfo framebuffer-description-x-offset) 0)
      (! (+ fbinfo framebuffer-description-y-offset) 0)
      (! (+ fbinfo framebuffer-description-pointer) 0)
      (! (+ fbinfo framebuffer-description-size) 0)
      (mailbox-send! %channel-framebuffer (pointer->gpu-pointer fbinfo))
      (let ((result (mailbox-recv %channel-framebuffer)))
        (when (<> result 0) (error/argument %error-framebuffer-mode-set-failed result))
        (! (+ fbinfo framebuffer-description-pointer)
           (gpu-pointer->pointer (? (+ fbinfo framebuffer-description-pointer))))
        fbinfo))))

;; TODO: Use the mailbox property interface to set the cursor sprite?
;; https://github.com/raspberrypi/firmware/wiki/Mailbox-property-interface

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; DMA

;; Registers for talking to the DMA units
(struct dma ((control/status word)
	     (control-block-address word)
	     (transfer-information word)
	     (source-address word)
	     (destination-address word)
	     (transfer-len word)
	     (stride word)
	     (next-control-block word)
	     (debug word)))

;; Control blocks, basically a bunch of parameters in RAM. Pointers to
;; control blocks are sent to the DMA hardware via the "dma" struct
;; above.
(struct dma-control-block ((transfer-information word)
			   (source-address word)
			   (destination-address word)
			   (transfer-len word)
			   (stride word)
			   (next-control-block word)
			   (reserved0 word)
			   (reserved1 word)))

(const dma0 #x20007000) ;; DMA channel 0 registers. Subsequent
			;; channels (for DMA0 through DMA14 (not 15))
			;; start at intervals of #x100, i.e.
			;; #x20007100 for DMA1, etc. DMA15 does exist,
			;; but at #x20E05000. (See the BCM2835
			;; peripherals PDF.)

(const dma-int-status #x20007fe0) ;; All DMA channels interrupt status
(const dma-enable #x20007ff0) ;; All DMA channels enable register

;; DMA control/status register
(const DMA_ACTIVE				#x00000001)
(const DMA_END					#x00000002)
(const DMA_INT					#x00000004)
(const DMA_DREQ					#x00000008)
(const DMA_PAUSED				#x00000010)
(const DMA_DREQ_STOPS_DMA			#x00000020)
(const DMA_WAITING_FOR_OUTSTANDING_WRITES	#x00000040)
(const DMA_ERROR				#x00000100)
(const DMA_PRIORITY_MASK			#x000F0000) ;; priorities 0-15
(const DMA_PANIC_PRIORITY_MASK			#x00F00000) ;; priorities 0-15
(const DMA_WAIT_FOR_OUTSTANDING_WRITES		#x10000000)
(const DMA_DISDEBUG				#x20000000)
(const DMA_ABORT				#x40000000)
(const DMA_RESET				#x80000000)

;; DMA transfer information
(const DMA_INTEN				#x00000001)
(const DMA_TDMODE				#x00000002) ;; 2D mode
;;						#x00000004 ?
(const DMA_WAIT_RESP				#x00000008)
(const DMA_DEST_INC				#x00000010)
(const DMA_DEST_WIDTH				#x00000020)
(const DMA_DEST_DREQ				#x00000040)
(const DMA_DEST_IGNORE				#x000080)
(const DMA_SRC_INC				#x0000100)
(const DMA_SRC_WIDTH				#x0000200)
(const DMA_SRC_DREQ				#x0000400)
(const DMA_SRC_IGNORE				#x0000800)
(const DMA_BURST_LENGTH_MASK			#x0000F000) ;; burst length 1-16 (!!)
(const DMA_PERMAP_MASK				#x001F0000) ;; peripheral mapping; 0=unpaced
(const DMA_WAITS_MASK				#x03E00000) ;; extra wait cycles, 0-31
(const DMA_NO_WIDE_BURSTS			#x04000000)

;; In 2D mode, split field specifies X and Y dimensions separately
(const DMA_XLENGTH	#x0000FFFF)
(const DMA_YLENGTH	#x3FFF0000)
(const DMA_YLENGTH_SHIFT 16)

;; In 2D mode, source and destination strides specified separately
(const DMA_S_STRIDE	#x0000FFFF)
(const DMA_D_STRIDE	#xFFFF0000)
(const DMA_D_STRIDE_SHIFT 16)

;; DMA debug fields
(const DMA_READ_LAST_NOT_SET_ERROR	#x00000001)
(const DMA_FIFO_ERROR			#x00000002)
(const DMA_READ_ERROR			#x00000004)
(const DMA_OUTSTANDING_WRITES		#x000000F0)
(const DMA_ID				#x0000FF00)
(const DMA_STATE			#x01FF0000)
(const DMA_VERSION			#x0E000000)
(const DMA_LITE				#x10000000)

(struct dma-state ((lite-channels word)
		   (free-full-channel-mask word)
		   (free-full-channel-count word)
		   (free-lite-channel-mask word)
		   (free-lite-channel-count word)))

(define (initialize-dma)
  (let ((state (alloc! sizeof-dma-state))
	(initial-availability (get-dma-channel-availability-mask)))
    (! (+ state dma-state-lite-channels) 0)
    (! (+ state dma-state-free-full-channel-mask) 0)
    (! (+ state dma-state-free-full-channel-count) 0)
    (! (+ state dma-state-free-lite-channel-mask) 0)
    (! (+ state dma-state-free-lite-channel-count) 0)
    (let ((mutable n 0))
      (while (<u n 14) ;; TODO: handle channel 15 properly
	(let ((mask (<< 1 n)))
	  (when (<> (binand initial-availability mask) 0)
	    (when (<> (binand (? (+ dma0 (* #x100 n) dma-debug)) DMA_LITE) 0)
	      (! (+ state dma-state-lite-channels)
		 (binor (? (+ state dma-state-lite-channels)) mask)))
	    (free-dma-channel state n)))
	(set! n (+ n 1))))
    (! dma-enable (binor (? dma-enable) initial-availability)) ;; actually enables the DMA channels
    state))

(define (free-dma-channel dma channel)
  (let ((mask (<< 1 channel)))
    (let ((lite? (if (<> (binand (? (+ dma dma-state-lite-channels)) mask) 0) 1 0)))
      (let ((free-mask-offset (if (<> lite? 0)
				  dma-state-free-lite-channel-mask
				  dma-state-free-full-channel-mask))
	    (free-count-offset (if (<> lite? 0)
				   dma-state-free-lite-channel-count
				   dma-state-free-full-channel-count)))
	(let ((free (? (+ dma free-mask-offset))))
	  (when (<> (binand free mask) 0) (error %error-dma-channel-double-free))
	  (! (+ dma free-mask-offset) (binor free mask))
	  (! (+ dma free-count-offset) (+ (? (+ dma free-count-offset)) 1)))))))

(define (free-dma-channels dma channels count)
  (when (>u count 0)
    (free-dma-channel dma (? channels))
    (free-dma-channels dma (+ channels 4) (- count 1))))

(define (allocate-dma-channel dma lite?)
  (if (<> lite? 0)
      (allocate-dma-channel1 dma
			     dma-state-free-lite-channel-mask
			     dma-state-free-lite-channel-count)
      (allocate-dma-channel1 dma
			     dma-state-free-full-channel-mask
			     dma-state-free-full-channel-count)))

(define (allocate-dma-channel1 dma free-mask-offset free-count-offset)
  (let ((old-count (? (+ dma free-count-offset))))
    (when (= old-count 0) (error %error-dma-no-free-channels))
    (! (+ dma free-count-offset) (- old-count 1)))
  (allocate-dma-channel2 dma free-mask-offset (? (+ dma free-mask-offset)) 0))

(define (allocate-dma-channel2 dma free-mask-offset free n)
  ;; Caller has already ensured that *some* channel is free, hence no termination check here
  (let ((mask (<< 1 n)))
    (if (= (binand free mask) 0)
	(allocate-dma-channel2 dma free-mask-offset free (+ n 1))
	(begin
	  (! (+ dma free-mask-offset) (binand free (binnot mask)))
	  n))))

(define (allocate-dma-channels dma lite? channels count)
  (when (>u count 0)
    (! channels (allocate-dma-channel dma lite?))
    (allocate-dma-channels dma lite? (+ channels 4) (- count 1))))

(define (start-dma channel control-block)
  ;; TODO: handle channel 15
  (let ((base (+ dma0 (* #x100 channel))))
    (sys:clean-data-cache)
    (sys:data-sync-barrier)
    (! (+ base dma-control-block-address) (pointer->gpu-pointer control-block))
    (! (+ base dma-control/status) DMA_ACTIVE)))

(define (wait-for-dma-completion channel)
  ;; TODO: handle channel 15
  (let ((base (+ dma0 (* #x100 channel))))
    (sys:clean-data-cache)
    (sys:data-sync-barrier)
    (while (<> (binand (? (+ base dma-control/status)) DMA_ACTIVE) 0))
    (! (+ base dma-control/status) (binor DMA_END DMA_INT)))) ;; clear flags

(define (fill-control-block control-block
			    mode
			    source
			    target
			    width ;; bytes
			    height
			    source-width ;; bytes
			    target-width) ;; bytes
  (! (+ control-block dma-control-block-transfer-information) mode)
  (! (+ control-block dma-control-block-source-address) (pointer->gpu-pointer source))
  (! (+ control-block dma-control-block-destination-address) (pointer->gpu-pointer target))
  (! (+ control-block dma-control-block-transfer-len)
     (binor (binand (<< (- height 1) DMA_YLENGTH_SHIFT) DMA_YLENGTH)
	    (binand width DMA_XLENGTH)))
  (! (+ control-block dma-control-block-stride)
     (binor (binand (<< (- target-width width) DMA_D_STRIDE_SHIFT) DMA_D_STRIDE)
	    (binand (- source-width width) DMA_S_STRIDE)))
  (! (+ control-block dma-control-block-next-control-block) 0)
  (! (+ control-block dma-control-block-reserved0) 0)
  (! (+ control-block dma-control-block-reserved1) 0))

(define (synchronous-2d-transfer dma
				 fill?
				 source
				 target
				 width ;; bytes
				 height
				 source-width ;; bytes
				 target-width) ;; bytes
  (let ((*saved* (*save-alloc-state*)))
    (alloc-align! 5) ;; 5-bit alignment = 32-byte boundary
    (let ((slices (if (<u width 16)
		      1 ;; don't bother slicing narrow transfers
		      (? (+ dma dma-state-free-full-channel-count)))))
      (let ((cbs (alloc! (* 8 4 slices)))
	    ;; ^ make sure to allocate the control blocks first, since
	    ;; they need the 32-byte alignment.
	    (channels (alloc! (* 4 slices)))
	    (slicewidth (<< (/ (>>u width 2) slices) 2))) ;; slices should be whole pixels/words wide
	(allocate-dma-channels dma 0 channels slices)
	;; (putxs channels slices)
	;; (newline)
	(let ((mutable n 0))
	  (while (<u n (- slices 1))
	    (fill-control-block (+ cbs (* 8 4 n))
				(binor DMA_TDMODE
				       DMA_DEST_INC
				       DMA_DEST_WIDTH
				       (if (<> fill? 0) 0 DMA_SRC_INC)
				       DMA_SRC_WIDTH)
				(if (<> fill? 0)
				    source
				    (+ source (* n slicewidth)))
				(+ target (* n slicewidth))
				slicewidth
				height
				(if (<> fill? 0) slicewidth source-width)
				target-width)
	    (start-dma (? (+ channels (<< n 2))) (+ cbs (* 8 4 n)))
	    (set! n (+ n 1))))
	(let ((n (- slices 1)))
	  (fill-control-block (+ cbs (* 8 4 n))
			      (binor DMA_TDMODE
				     DMA_DEST_INC
				     DMA_DEST_WIDTH
				     (if (<> fill? 0) 0 DMA_SRC_INC)
				     DMA_SRC_WIDTH)
			      (if (<> fill? 0)
				  source
				  (+ source (* n slicewidth)))
			      (+ target (* n slicewidth))
			      (- width (* n slicewidth))
			      height
			      (if (<> fill? 0) slicewidth source-width)
			      target-width)
	  (start-dma (? (+ channels (<< n 2))) (+ cbs (* 8 4 n))))
	(let ((mutable n 0))
	  (while (<u n slices)
	    (wait-for-dma-completion (? (+ channels (<< n 2))))
	    (set! n (+ n 1))))
	(free-dma-channels dma channels slices)))
    (*restore-alloc-state* *saved*)))

(define (synchronous-2d-move dma
			     source
			     target
			     width ;; bytes
			     height
			     source-width ;; bytes
			     target-width) ;; bytes
  (synchronous-2d-transfer dma
			   0
			   source
			   target
			   width
			   height
			   source-width
			   target-width))

(define (synchronous-2d-fill dma
			     value target width height target-stride)
  (let ((*saved* (*save-alloc-state*)))
    (let ((source-block (alloc! 16)))
      (! source-block value)
      (! (+ source-block 4) value)
      (! (+ source-block 8) value)
      (! (+ source-block 12) value)
      (synchronous-2d-transfer dma
			       1
			       source-block
			       target
			       width
			       height
			       -1 ;; not used
			       target-stride))
    (*restore-alloc-state* *saved*)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(struct console ((fbinfo word)
		 (dma word)
		 (x word)
		 (y word)
		 (width word)
		 (height word)))

(define (make-console fbinfo dma)
  (let ((c (alloc! sizeof-console)))
    (! (+ c console-fbinfo) fbinfo)
    (! (+ c console-dma) dma)
    (! (+ c console-x) 0)
    (! (+ c console-y) 0)
    (! (+ c console-width) (>>u (? (+ fbinfo framebuffer-description-width)) %char-width-shift))
    (! (+ c console-height) (>>u (? (+ fbinfo framebuffer-description-height)) %char-height-shift))
    c))

(define (console-putc con ch)
  (putc ch)
  (when (= ch 13)
    (! (+ con console-x) 0)
    (return 0))
  (when (= ch 10)
    (putc 13)
    (! (+ con console-x) 0)
    (! (+ con console-y) (+ (? (+ con console-y)) 1))
    (scroll-if-required con)
    (return 0))
  (blit-char (? (+ con console-fbinfo))
	     (<< (? (+ con console-x)) %char-width-shift)
	     (<< (? (+ con console-y)) %char-height-shift)
	     ch
	     #x00ffffff
	     #x000000ff)
  (! (+ con console-x) (+ (? (+ con console-x)) 1))
  (when (= (? (+ con console-x)) (? (+ con console-width)))
    (console-putc con 10)))

(define (scroll-if-required con)
  (let ((height (? (+ con console-height))))
    (when (= (? (+ con console-y)) height)
      (let ((fbinfo (? (+ con console-fbinfo))))
	(let ((target (framebuffer-pointer fbinfo))
	      (offset (* (framebuffer-stride fbinfo) (<< 1 %char-height-shift)))
	      (limit (* (framebuffer-stride fbinfo) (<< 1 %char-height-shift) (- height 1))))
	  (synchronous-2d-move (? (+ con console-dma))
			       (+ target offset)
			       target
			       (framebuffer-stride fbinfo)
			       (* (- height 1) (<< 1 %char-height-shift))
			       (framebuffer-stride fbinfo)
			       (framebuffer-stride fbinfo))
	  (synchronous-2d-fill (? (+ con console-dma))
			       0
	  		       (+ target limit)
	  		       (framebuffer-stride fbinfo)
	  		       (<< 1 %char-height-shift)
	  		       (framebuffer-stride fbinfo))
	  ))
      (! (+ con console-y) (- height 1)))))

(define (console-puts con p)
  (let ((ch (?byte p)))
    (when (<> ch 0)
      (console-putc con ch)
      (console-puts con (+ p 1)))))

(define (console-newline con)
  (console-putc con 10))

(define (console-putn* con i)
  (if (<> i 0)
      (begin (console-putn* con (/ i 10))
	     (console-putc con (+ (% i 10) 48)))
      0))

(define (console-putn con i)
  (if (<> i 0)
      (console-putn* con i)
      (console-putc con 48)))

(define (console-putx con n)
  (let ((mutable shift 28))
    (while (>=s shift 0)
      (let ((digit (binand 15 (>>u n shift))))
	(console-putc con (+ digit (if (>=u digit 10)
				       55 ;; 65 - 10
				       48)))
	(set! shift (- shift 4))))))

(define (console-putxdigit con n)
  (let ((digit (binand 15 n)))
    (console-putc con (+ digit (if (>=u digit 10) 55 48)))))

(define (console-putx-block con bs len)
  (let ((mutable n 0))
    (while (<u n len)
      (let ((b (?byte (+ bs n))))
	(console-putxdigit con (>>u b 4))
	(console-putxdigit con b))
      (set! n (+ n 1)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(const ATAG_NONE	#x00000000)
(const ATAG_CORE	#x54410001)
(const ATAG_MEM		#x54410002)
(const ATAG_VIDEOTEXT	#x54410003)
(const ATAG_RAMDISK	#x54410004)
(const ATAG_INITRD2	#x54420005) ;; yes, really, not #x54410005. Presumably that was INITRD1?
(const ATAG_SERIAL	#x54410006)
(const ATAG_REVISION	#x54410007)
(const ATAG_VIDEOLFB	#x54410008)
(const ATAG_CMDLINE	#x54410009)

(define (dump-atag-word con base field-number description-str)
  (console-putc con 32)
  (console-putc con 32)
  (console-putx con (? (+ base (<< (+ field-number 2) 2))))
  (console-putc con 32)
  (console-puts con description-str)
  (console-newline con))

(define (dump-atag-core con base)
  (dump-atag-word con base 0 (data #"flags\0"))
  (dump-atag-word con base 1 (data #"pagesize\0"))
  (dump-atag-word con base 2 (data #"rootdev\0")))

(define (dump-atag-mem con base)
  (dump-atag-word con base 0 (data #"size\0"))
  (dump-atag-word con base 1 (data #"start\0")))

(define (dump-atag-cmdline con base)
  (console-putc con 32)
  (console-putc con 32)
  (console-puts con (+ base 8))
  (console-newline con))

(define (dump-atags con base)
  (let ((size (? base))
	(tag (? (+ base 4))))
    (console-puts con (data #"ATAG #x\0"))
    (console-putx con tag)
    (console-puts con (data #" size \0"))
    (console-putn con size)
    (console-newline con)
    (when (= tag ATAG_CORE) (dump-atag-core con base))
    (when (= tag ATAG_MEM) (dump-atag-mem con base))
    (when (= tag ATAG_CMDLINE) (dump-atag-cmdline con base))
    (when (<> tag ATAG_NONE)
      (dump-atags con (+ base (<< size 2))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; While the RPi has an SP804, it's not quite AMBA-compatible, and the
;; BCM2835 peripheral documentation recommends to use the "System
;; Timer" instead. That's what this is.
;;  - free-running counter runs at 1 MHz
;;  - memory barriers as usual required whenever we're switching between peripherals
;;     - apparently sys:data-mem-barrier ?
;;  - compare0 and compare2 are used by the GPU.
;;  - compare1 and compare3 are free for use by the CPU.

(struct system-timer ((control/status word)
		      (counter-low word)
		      (counter-high word)
		      (compare0 word)
		      (compare1 word)
		      (compare2 word)
		      (compare3 word)))

(const system-timer-base #x20003000)

(define (current-timer-value)
  (sys:data-mem-barrier)
  (? (+ system-timer-base system-timer-counter-low)))

;; Clear previous interrupt, if any
(define (clear-fired-alarm)
  (sys:data-mem-barrier)
  (! (+ system-timer-base system-timer-control/status) (<< 1 3))) ;; use timer ch 3

;; TODO: Use "Clocks" mailbox property interface to read the base
;; clock value dynamically. We're assuming it's 1 MHz here.
(define (set-alarm relative-microseconds)
  (set-alarm-absolute (+ (current-timer-value) relative-microseconds)))

(define (set-alarm-absolute absolute-microseconds)
  (clear-fired-alarm)
  (! (+ system-timer-base system-timer-compare3) absolute-microseconds)
  absolute-microseconds)

(define (check-alarm)
  (if (<> (binand (? (+ system-timer-base system-timer-control/status)) (<< 1 3)) 0)
      (begin (clear-fired-alarm) 1)
      0))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Likewise, the RPi seems to have an unusual interrupt controller.

(struct interrupt-controller ((basic-pending word)
			      (pending1 word)
			      (pending2 word)
			      (fiq-control word)
			      (enable1 word)
			      (enable2 word)
			      (basic-enable word)
			      (disable1 word)
			      (disable2 word)
			      (basic-disable word)))

;; The BCM2835 peripheral docs give only some of these values; the
;; Xinu people at http://xinu.mscs.mu.edu/BCM2835_Interrupt_Controller
;; fill in some of the blanks.
(const IRQ_SYSTEM_TIMER_COMPARE0 0) ;; GPU ONLY
(const IRQ_SYSTEM_TIMER_COMPARE1 1) ;; OK for CPU
(const IRQ_SYSTEM_TIMER_COMPARE2 2) ;; GPU ONLY
(const IRQ_SYSTEM_TIMER_COMPARE3 3) ;; OK for CPU
(const IRQ_USB 9)
(const IRQ_PCM_AUDIO 55)
(const IRQ_UART 57)
(const IRQ_SDHC 62)

(const interrupt-controller-base #x2000b200)

(define (configure-interrupt-controller)
  (! (+ interrupt-controller-base interrupt-controller-enable1)
     (binor (<< 1 IRQ_SYSTEM_TIMER_COMPARE3)))
  (! (+ interrupt-controller-base interrupt-controller-enable2)
     (binor (<< 1 (- IRQ_UART 32)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(struct boot-param-header ((magic word)
			   (totalsize word)
			   (off_dt_struct word)
			   (off_dt_strings word)
			   (off_mem_rsvmap word)
			   (version word)
			   (last_comp_version word)
			   ;; Version 2 fields:
			   (boot_cpuid_phys word)
			   ;; Version 3 fields:
			   (size_dt_strings word)
			   ;; Version 17 fields:
			   (size_dt_struct word)))

(const OF_DT_HEADER	#xD00DFEED)
(const OF_DT_BEGIN_NODE #x00000001)
(const OF_DT_END_NODE	#x00000002)
(const OF_DT_PROP	#x00000003)
(const OF_DT_END	#x00000009)

(define (byte-swap v)
  (binor (>>u v 24)
	 (binand (>>u v 8) #xff00)
	 (binand (<< v 8) #xff0000)
	 (<< v 24)))

(define (?be addr)
  (byte-swap (? addr)))

(define (print-indent con amount)
  (let ((mutable n 0))
    (while (<u n amount)
      (console-putc con 32)
      (set! n (+ n 1)))))

(define (strlen p)
  (let ((mutable p p)
	(mutable count 0)
	(mutable ch (?byte p)))
    (while (<> ch 0)
      (set! count (+ count 1))
      (set! p (+ p 1))
      (set! ch (?byte p)))
    count))

(define (strcmp p q)
  (let ((pbyte (?byte p)))
    (let ((diff (- pbyte (?byte q))))
      (cond ((<> diff 0) diff)
            ((= pbyte 0) 0)
            (else (strcmp (+ p 1) (+ q 1)))))))

(define (round-up-to-4-bytes n)
  (binand #xfffffffc (+ n 3)))

(define (dump-dt-properties con p strings-base indent)
  (if (= (devicetree-property? p) 0)
      p ;; return address of potential children (or end of node)
      (begin
	(print-indent con indent)
	(console-puts con (+ strings-base (devicetree-property-name-offset p)))
	(console-puts con (data #" size \0"))
	(console-putn con (devicetree-property-size p))
	(console-putc con 32)
	(console-putx-block con (devicetree-property-value p) (devicetree-property-size p))
	(console-newline con)
	(dump-dt-properties con (devicetree-property-next p) strings-base indent))))

(define (dump-dt-node con p strings-base indent)
  (print-indent con indent)
  (console-putc con 34)
  (console-puts con (devicetree-node-name p))
  (console-putc con 34)
  (console-newline con)
  (let ((mutable child (dump-dt-properties con
					   (devicetree-node-first-property p)
					   strings-base
					   (+ indent 2))))
    (while (<> (devicetree-node? child) 0)
      (set! child (dump-dt-node con child strings-base (+ indent 2))))
    (+ child 4) ;; skip the OF_DT_END_NODE marker.
    ))

(define (dump-block-be con p word-count)
  (console-putx con p)
  (console-putc con 58)
  (let ((mutable n 0))
    (while (<u n word-count)
      (console-putc con 32)
      (console-putx con (?be (+ p (<< n 2))))
      (let ((column (binand n 3)))
	(set! n (+ n 1))
	(when (= column 3)
	  (console-newline con)
	  (console-putx con (+ p (<< n 2)))
	  (console-putc con 58))))))

(define (dump-dt-reserved-memorymap con p)
  (let ((addr-lo (?be p))
	(addr-hi (?be (+ p 4)))
	(size-lo (?be (+ p 8)))
	(size-hi (?be (+ p 12))))
    (when (lognot (logand (= size-lo 0) (= size-hi 0)))
      (console-putx con addr-hi)
      (console-putx con addr-lo)
      (console-putc con 32)
      (console-putx con size-hi)
      (console-putx con size-lo)
      (console-newline con)
      (dump-dt-reserved-memorymap con (+ p 16)))))

(define (dump-devicetree con base)
  (when (= (?be (+ base boot-param-header-magic)) OF_DT_HEADER)
    (let ((totalsize (?be (+ base boot-param-header-totalsize)))
	  (strings-base (+ base (?be (+ base boot-param-header-off_dt_strings))))
	  (memory-map-base (+ base (?be (+ base boot-param-header-off_mem_rsvmap))))
	  (version (?be (+ base boot-param-header-version))))
      (console-puts con (data #"Devicetree version \0"))
      (console-putn con version)
      (console-newline con)
      (when (>=u version 16) ;; earlier versions have full paths
			     ;; instead of node leaf names - we don't
			     ;; support the older format
	;; (dump-block-be con struct-base 64 #;(>>u totalsize 2))
	(dump-dt-reserved-memorymap con memory-map-base)
	(let ((chosen (devicetree-find-child (devicetree-root-node base) (data #"chosen\0"))))
	  (when (<> chosen 0)
	    (let ((bootargs (devicetree-find-property base chosen (data #"bootargs\0"))))
	      (when (<> bootargs 0)
		;; NUL-terminated string
		(console-puts con (devicetree-property-value bootargs))
		(console-newline con)))))
	(dump-dt-node con (devicetree-root-node base) strings-base 2)
	;; (console-puts con (data #"Done printing devicetree.\n\0"))
	))))

(define (devicetree-root-node base)
  (+ base (?be (+ base boot-param-header-off_dt_struct))))

(define (devicetree-property? p) (if (= (?be p) OF_DT_PROP) 1 0))
(define (devicetree-property-size p) (?be (+ p 4)))
(define (devicetree-property-name-offset p) (?be (+ p 8)))
(define (devicetree-property-value p) (+ p 12))
(define (devicetree-property-next p) (+ (devicetree-property-value p)
					(round-up-to-4-bytes (devicetree-property-size p))))

(define (devicetree-end? p) (if (= (?be p) OF_DT_END_NODE) 1 0))

(define (devicetree-node? p) (if (= (?be p) OF_DT_BEGIN_NODE) 1 0))
(define (devicetree-node-name p) (+ p 4))

(define (devicetree-node-first-property nodep)
  (when (<> (?be nodep) OF_DT_BEGIN_NODE) (error %error-devicetree-bad-node-type))
  (let ((node-name (+ nodep 4)))
    (+ node-name (round-up-to-4-bytes (+ (strlen node-name) 1)))))

(define (devicetree-node-first-child nodep)
  (let ((mutable p (devicetree-node-first-property nodep)))
    (while (<> (devicetree-property? p) 0) (set! p (devicetree-property-next p)))
    p))

(define (devicetree-node-next nodep)
  (let ((mutable p (devicetree-node-first-child nodep)))
    (while (<> (devicetree-node? p) 0) (set! p (devicetree-node-next p)))
    (+ p 4))) ;; skip the OF_DT_END_NODE marker.

(define (devicetree-find-property base nodep propname)
  (devicetree-find-property1 (+ base (?be (+ base boot-param-header-off_dt_strings)))
			     (devicetree-node-first-property nodep)
			     propname))

(define (devicetree-find-property1 strings-base p propname)
  (cond
   ((= (devicetree-property? p) 0) 0)
   ((= (strcmp (+ strings-base (devicetree-property-name-offset p)) propname) 0) p)
   (else (devicetree-find-property1 strings-base (devicetree-property-next p) propname))))

(define (devicetree-find-child nodep childname)
  (devicetree-find-child1 (devicetree-node-first-child nodep) childname))

(define (devicetree-find-child1 p childname)
  (cond
   ((= (devicetree-node? p) 0) 0)
   ((= (strcmp (devicetree-node-name p) childname) 0) p)
   (else (devicetree-find-child1 (devicetree-node-next p) childname))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (enable-caches)
  (sys:invalidate-unified-cache)
  (sys:invalidate-tlb)
  ;;                                      .     Instruction caches (bit 12)
  ;;                                       .    Branch prediction (bit 11)
  ;;                                         .  Data caches (bit 2)
  (sys:set-sctlr (binor (sys:get-sctlr) #x1804)))

;; Drastically simplified.
(define (store-page-table-entry! pagetable-base virtaddr physaddr flags)
  (let ((entry-num (>>u virtaddr 20)))
    (! (+ pagetable-base (<< entry-num 2))
       (binor (<< (>>u physaddr 20) 20)
	      flags
	      2))))

(define (configure-mmu-identity-mapping)
  ;; Let's arbitrarily (!) place our root page table at #x4000. Qemu
  ;; loads versatilepb images to #x10000, and Raspberry Pi images load
  ;; to #x8000, so we have just enough room for our 16k page table at
  ;; #x4000 on a Raspberry Pi.
  (let ((pagetable-base #x4000))
    (let ((mutable addr 0))
      (while (<u addr #x40000000)
	(let ((flags (if (<> (binand addr #x20000000) 0)
			 #x00000000    ;; nothing, i.e. not cacheable
			 #x0000000c))) ;; C and B, i.e. cacheable
	  (store-page-table-entry! pagetable-base addr addr flags)
	  (store-page-table-entry! pagetable-base (+ addr #x40000000) (+ addr #x40000000) flags)
	  (store-page-table-entry! pagetable-base (+ addr #x80000000) (+ addr #x80000000) flags)
	  (store-page-table-entry! pagetable-base (+ addr #xC0000000) (+ addr #xC0000000) flags))
	(set! addr (+ addr #x100000))))
    (sys:set-mmu-domains #xffffffff) ;; All Master mode, no checks
    (sys:set-ttbr0 pagetable-base)
    (sys:set-ttbr1 pagetable-base)
    (sys:set-ttbcr 0)
    ;; N.B. Instruction cache must be disabled at the moment MMU is enabled!
    (sys:set-sctlr (binor (sys:get-sctlr) 1))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; UART

(struct uart ((dr word)
	      (rsr-ecr word)
	      (reserved1 byte 16)
	      (fr word)
	      (reserved2 byte 4)
	      (lpr word)
	      (ibrd word)
	      (fbrd word)
	      (lcr-h word)
	      (cr word)
	      (ifls word)
	      (imsc word)
	      (raw-interrupt-status word) ;; a.k.a. RIS
	      (masked-interrupt-status word) ;; a.k.a. MIS
	      (icr word)
	      (dmacr word)))

(const uart0 #x20201000)
(const uart-flag-tx-busy #x08)
(const uart-flag-rx-fifo-empty #x10)
(const uart-flag-tx-fifo-full #x20)

(const uart-lcr-h-stick-parity-select #x80)
(const uart-lcr-h-data-bits-mask #x60)
(const   uart-lcr-h-8-data-bits #x60)
(const   uart-lcr-h-7-data-bits #x40)
(const   uart-lcr-h-6-data-bits #x20)
(const   uart-lcr-h-5-data-bits #x00)
(const uart-lcr-h-fifo-enable #x10)
(const uart-lcr-h-2-stop-bits #x08) ;; absent -> 1 stop bit
(const uart-lcr-h-even-parity #x04) ;; absent -> odd, if enabled at all
(const uart-lcr-h-parity-enable #x02)
(const uart-lcr-h-break #x01) ;; set to force TX low

(define (configure-uart)
  ;; Based on the teachings of
  ;;  - https://github.com/xinu-os/xinu/blob/master/device/uart-pl011/uartHwInit.c
  ;;  - https://github.com/dwelch67/raspberrypi/blob/master/uartx01/uartx01.c

  ;; First, disable the UART entirely.
  (! (+ uart0 uart-cr) 0)

  ;; Next, ensure that GPIO pins 14 and 15 are configured right.
  ;;  - They need to have "alternate function 0" selected
  ;;  - They need to have pull-up/pull-down disabled
  (gpio-function-select! 14 (+ %gpio-pin-control-alternate-function-base 0))
  (gpio-function-select! 15 (+ %gpio-pin-control-alternate-function-base 0))
  (gpio-pull-control! (binor (<< 1 14)
			     (<< 1 15))
		      0
		      %gpio-pull-neither)

  ;; Now wait for the UART to stop being busy, in case it is
  (while (<> (binand (? (+ uart0 uart-fr)) uart-flag-tx-busy) 0))

  ;; Flush the tx FIFO by marking it as disabled
  (! (+ uart0 uart-lcr-h) (binand (? (+ uart0 uart-lcr-h)) (binnot uart-lcr-h-fifo-enable)))

  ;; Disable UART interrupts
  (! (+ uart0 uart-imsc) 0)

  ;; Clear any pending interrupts that might be there
  (! (+ uart0 uart-icr) #x7f2) ;; clear them all except the "disabled, write as zero" ones

  ;; Set the baud rate divisors, integer and fractional. Read the base clock value via the mailbox.
  (let ((uart-clock-base (get-clock-rate %clock-uart)) ;; On Raspberry pi 1, default 3000000 = 3MHz
        (baud-rate 115200))
    ;; actual divisor D = 3000000.0 / (16 * baudrate) = roughly 1.627604 for 115200 baud
    ;; integer divisor = trunc(D) = 1 for 115200 baud
    ;; fractional divisor = trunc(((D - trunc(D)) * 64) + 0.5) = 40, for 115200
    (let ((D<<128 (/ (<< uart-clock-base 3) baud-rate)))
      (! (+ uart0 uart-ibrd) (>>u D<<128 7))
      (! (+ uart0 uart-fbrd) (binand 63 (>>u (+ D<<128 1) 1)))))

  ;; Set 8N1, and (following xinu) leave the FIFOs off.
  (! (+ uart0 uart-lcr-h) uart-lcr-h-8-data-bits)

  ;; Enable the UART.
  (! (+ uart0 uart-cr) #x301) ;; RXE | TXE | UARTEN

  ;; Enable the UART's interrupt.
  (uart-enable-interrupt))

;; Tells the UART to signal an interrupt. Still need to enable
;; interrupts at the VIC and at the CPU.
(define (uart-enable-interrupt)
  (let ((old (? (+ uart0 uart-imsc))))
    (puts (data #"UART-IMSC: \0")) (putx old) (newline)
    (! (+ uart0 uart-imsc) (binor old (<< 1 4))))) ;; RXIM

(define (uart-interrupt-status)
  (? (+ uart0 uart-masked-interrupt-status)))

(define (putc ch)
  (while (<> (binand (? (+ uart0 uart-fr)) uart-flag-tx-fifo-full) 0))
  (! (+ uart0 uart-dr) ch))

(define (uart-char-waiting?)
  (if (<> (binand (? (+ uart0 uart-fr)) uart-flag-rx-fifo-empty) 0) 0 1))

(define (poll-for-char)
  (if (<> (uart-char-waiting?) 0)
      (? (+ uart0 uart-dr))
      -1))

(define (getc)
  (let ((mutable ch -1))
    (while (= ch -1)
      (set! ch (poll-for-char)))
    ch))

(define (puts p)
  (let ((ch (?byte p)))
    (when (<> ch 0)
      (putc ch)
      (puts (+ p 1)))))

(define (putn* i)
  (if (<> i 0)
      (begin (putn* (/ i 10))
	     (putc (+ (% i 10) 48)))
      0))

(define (putn i)
  (if (<> i 0)
      (putn* i)
      (putc 48)))

(define (putx n)
  (let ((mutable shift 28))
    (while (>=s shift 0)
      (let ((digit (binand 15 (>>u n shift))))
	(putc (+ digit (if (>=u digit 10)
			   55 ;; 65 - 10
			   48)))
	(set! shift (- shift 4))))))

(define (putxs ns count)
  (when (>u count 0)
    (putc 32)
    (putx (? ns))
    (putxs (+ ns 4) (- count 1))))

(define (newline)
  (putc 13)
  (putc 10))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ARM1176JZF-S specific performance monitor

(define (configure-performance-monitor)
  (sys:set-rpi-performance-monitor-control
   (binor (sys:get-rpi-performance-monitor-control)
	  (<< 1 2) ;; reset cycle counter to 0
	  (<< 1 0) ;; enable all counters
	  )))

(define (delay-cycles n)
  (let ((start (sys:get-rpi-cycle-counter)))
    (while (<u (- (sys:get-rpi-cycle-counter) start) n))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (print-banner con)
  (console-puts con
		(data #"Welcome to MINOS for Raspberry Pi\n"
		      #"Copyright (C) 2012-2018 Tony Garnock-Jones <tonyg@leastfixedpoint.com>\n\0")))

(define (print-memory-info con)
  (console-puts con (data #"ARM memory \0"))
  (console-putn con (get-arm-memory))
  (console-puts con (data #" bytes; VC memory \0"))
  (console-putn con (get-vc-memory))
  (console-puts con (data #" bytes\n\0")))

(define (print-dma-info con dma)
  (console-puts con (data #"DMA full channels: \0"))
  (console-putx con (? (+ dma dma-state-free-full-channel-mask)))
  (console-newline con)
  (console-puts con (data #"DMA lite channels: \0"))
  (console-putx con (? (+ dma dma-state-free-lite-channel-mask)))
  (console-newline con))

(define (print-irq-latency con delta)
  (console-puts con (data #"IRQ latency \0"))
  (console-putn con delta)
  (console-puts con (data #" cycles; \0")))

(const %tick-interval 1000000)

(define (main always-zero machine-type atags-base)
  (enable-led)
  (configure-interrupt-table)
  (configure-mmu-identity-mapping)
  (enable-caches) ;; After MMU enable, to make sure Icache is disabled when enabling MMU
  (init-alloc!)
  (configure-interrupt-controller)
  (configure-performance-monitor)
  ;; Must configure UART after setting up the performance monitor,
  ;; because it uses the cycle counter to accurately pause during GPIO
  ;; pull-up/pull-down configuration.
  (configure-uart)
  (let ((fbinfo (initialize-framebuffer))
	(dma (initialize-dma)))
    (let ((con (make-console fbinfo dma)))

      (print-banner con)
      (print-memory-info con)
      (print-dma-info con dma)

      (console-puts con (data #"Machine type \0"))
      (console-putn con machine-type)
      (console-newline con)

      (when (= (? (+ atags-base 4)) ATAG_CORE)
	(dump-atags con atags-base))

      (dump-devicetree con atags-base)

      ;; Without this, incomplete rendering of the dumped devicetree
      ;; (or whatever the console last printed)!
      (sys:clean-data-cache)

      #;(let ((mutable n 0)
	    (fill-width 128)
	    (fill-height 128)
	    (fill-x-distance 128)
	    (fill-y-distance 128))
	(while (= 0 0)
	  (let ((start (current-timer-value)))
	    (synchronous-2d-fill dma
				 (let ((m (binand n 255)))
				   (binor m
					  (<< m 8)
					  (<< m 16)))
				 (framebuffer-pointer fbinfo)
				 (<< fill-width 2)
				 fill-height
				 (framebuffer-stride fbinfo))
	    (let ((stop (current-timer-value)))
	      (when (= (% n 1000) 0)
		(putn (- stop start))
		(putc 32)
		(putn (/ 1000000 (- stop start)))
		(putc 45))))

	  (let ((start (current-timer-value)))
	    (let ((colour (let ((m (binand n 255))) (binor m (<< m 8) (<< m 16))))
		  (stride (framebuffer-stride fbinfo)))
	      (let ((mutable target (framebuffer-pointer fbinfo))
		    (mutable y (* fill-y-distance stride))
		    (mutable x (<< fill-x-distance 2))
		    (x-limit (<< (+ fill-x-distance fill-width) 2)))
		(while (<u y (* (+ fill-y-distance fill-height) stride))
		  (while (<u x x-limit)
		    (! (+ target y x) colour)
		    (set! x (+ x 4)))
		  (set! x (<< fill-x-distance 2))
		  (set! y (+ y stride)))))
	    (let ((stop (current-timer-value)))
	      (when (= (% n 1000) 0)
		(putn (- stop start))
		(putc 32)
		(putn (/ 1000000 (- stop start)))
		(newline))))
	  (set! n (+ n 1))))

      (let ((mutable deadline (set-alarm %tick-interval)))
	(while (= 0 0)
	  (cpu-enable-interrupts)
	  ;; TODO: Properly handle missed timer deadlines and clock
	  ;; rollover. Currently, if we're busy while a deadline
	  ;; expires, there's risk of setting the next deadline for a
	  ;; time that has already passed. In that case, the interrupt
	  ;; will never fire, since timer matching is done by counter
	  ;; equality, not counter-less-than.
	  (sys:wait-for-interrupt)
	  (let ((stop (sys:get-rpi-cycle-counter))
		(awoke-at-time (current-timer-value))
		(start (? (irq-start-cycle-counter))))
	    ;; (console-putx con (? (+ interrupt-controller-base interrupt-controller-basic-pending)))
	    ;; (console-putc con 32)
	    ;; (console-putx con (? (+ interrupt-controller-base interrupt-controller-pending1)))
	    ;; (console-putc con 32)
	    ;; (console-putx con (? (+ interrupt-controller-base interrupt-controller-pending2)))
	    ;; (console-putc con 32)
	    (when (<> (uart-interrupt-status) 0)
	      (! (+ uart0 uart-icr) (<< 1 4))
	      (while (<> (uart-char-waiting?) 0)
		(let ((ch (getc)))
		  (console-puts con (data #"You typed: \0"))
		  (console-putc con ch)
		  (let ((errs (>>u ch 8)))
		    (when (<> errs 0)
		      (console-puts con (data #" and there were errors: \0"))
		      (console-putx con errs)))
		  (console-newline con))))
	    (when (<> (check-alarm) 0)
	      (print-irq-latency con (- stop start))
	      (console-puts con (data #"The time is \0"))
	      (console-putn con awoke-at-time)
	      (console-puts con (data #"; next deadline \0"))
	      (set! deadline (set-alarm-absolute (+ deadline %tick-interval)))
	      (console-putn con deadline)
	      (console-newline con)))
	  )))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(const %char-width-shift 3)
(const %char-height-shift 4)

(define (blit-char fbinfo x y ch color bgcolor)
  (let ((stride (framebuffer-stride fbinfo))
	(pixwidth (framebuffer-pixel-width fbinfo)))
    (let ((mutable p (+ (font0-bitmap) (<< ch %char-height-shift)))
	  (mutable target-leftmost (+ (framebuffer-pointer fbinfo)
				(* y stride)
				(* x pixwidth))))
      (let ((limit (+ p (<< 1 %char-height-shift))))
	(while (<u p limit)
	  (let ((mutable target target-leftmost)
		(mutable pixel 0)
		(row (?byte p)))
	    (while (<u pixel (<< 1 %char-width-shift))
	      (! target (if (<> (binand row (<< 1 pixel)) 0) color bgcolor))
	      (set! pixel (+ pixel 1))
	      (set! target (+ target pixwidth)))
	  (set! p (+ p 1))
	  (set! target-leftmost (+ target-leftmost stride))))))))

(define (font0-bitmap)
  ;; Monospace Default font, from
  ;; http://www.cl.cam.ac.uk/freshers/raspberrypi/tutorials/os/downloads.html:
  ;; "These fonts are the simplest ones available. They use a 1 to
  ;; represent a white pixel, a 0 to represent a black pixel, and
  ;; having representations for the first 128 ASCII characters. The
  ;; use 16 bytes per character, arranged such that each byte is one
  ;; complete row, going left to right with higher bits, going top to
  ;; bottom with later bytes."
  ;;
  ;; NOTE that this font data is covered by the license in
  ;; font0license.txt, not by the GPL.
  ;;
  (data #"\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\b\b\b\b\b\b\0\b\b\0\0\0\0\0\0\0\24\24\24\24\0\0\0\0\0\0\0\0\0\0\0HHh\376$$\177\24\22\22\0\0\0\0\0\0\0\20|\222\22\34p\220\222|\20\20\0\0\0\0\0\6\t\tF8f\220\220`\0\0\0\0\0\0\08\4\4\f\222\262\242F\274\0\0\0\0\0\0\0\b\b\b\b\0\0\0\0\0\0\0\0\0\0000\20\20\b\b\b\b\b\b\20\20 \0\0\0\0\f\b\b\20\20\20\20\20\20\b\b\f\0\0\0\0\0\0\20\222|8\326\20\0\0\0\0\0\0\0\0\0\0\0\b\b\b\177\b\b\b\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\30\30\b\4\0\0\0\0\0\0\0\0\0\0\34\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\30\30\0\0\0\0\0\0\0@  \20\20\30\b\b\4\4\2\0\0\0\0\08D\202\202\222\202\202D8\0\0\0\0\0\0\0\34\20\20\20\20\20\20\20|\0\0\0\0\0\0\0|\302\200\200@0\30\4\376\0\0\0\0\0\0\0|\202\200\3008\300\200\302|\0\0\0\0\0\0\0`PXHDB\376@@\0\0\0\0\0\0\0~\2\2>\300\200\200\302<\0\0\0\0\0\0\0x\204\2z\306\202\202\304x\0\0\0\0\0\0\0\376@@  \20\30\b\4\0\0\0\0\0\0\0|\202\202\202|\202\202\206|\0\0\0\0\0\0\0<F\202\202\306\274\200B<\0\0\0\0\0\0\0\0\0\30\30\0\0\0\30\30\0\0\0\0\0\0\0\0\0\30\30\0\0\0\30\30\b\4\0\0\0\0\0\0\0\200p\16\16p\200\0\0\0\0\0\0\0\0\0\0\0\376\0\0\376\0\0\0\0\0\0\0\0\0\0\0\2\34\340\340\34\2\0\0\0\0\0\0\0\0\34\" \20\b\b\0\b\b\0\0\0\0\0\0\0x\314\204\342\222\222\222\342\4\fx\0\0\0\0\0\20(((DD|\306\202\0\0\0\0\0\0\0~\202\202\202~\202\202\202~\0\0\0\0\0\0\0x\204\2\2\2\2\2\204x\0\0\0\0\0\0\0>B\202\202\202\202\202B>\0\0\0\0\0\0\0\376\2\2\2\376\2\2\2\376\0\0\0\0\0\0\0\376\2\2\2\376\2\2\2\2\0\0\0\0\0\0\0x\204\2\2\302\202\202\204x\0\0\0\0\0\0\0\202\202\202\202\376\202\202\202\202\0\0\0\0\0\0\0>\b\b\b\b\b\b\b>\0\0\0\0\0\0\08      \"\34\0\0\0\0\0\0\0B\"\22\n\16\22\"\"B\0\0\0\0\0\0\0\2\2\2\2\2\2\2\2\376\0\0\0\0\0\0\0\306\306\252\252\252\222\202\202\202\0\0\0\0\0\0\0\206\206\212\212\222\242\242\302\302\0\0\0\0\0\0\08D\202\202\202\202\202D8\0\0\0\0\0\0\0~\302\202\202\302~\2\2\2\0\0\0\0\0\0\08D\202\202\202\202\202Dx`@\0\0\0\0\0~\302\202\202~B\202\202\2\0\0\0\0\0\0\0|\206\2\6|\300\200\302}\0\0\0\0\0\0\0\177\b\b\b\b\b\b\b\b\0\0\0\0\0\0\0\202\202\202\202\202\202\202\202|\0\0\0\0\0\0\0\202\306DDD(((\20\0\0\0\0\0\0\0\201\201\201ZZZfff\0\0\0\0\0\0\0\306D(8\20(lD\202\0\0\0\0\0\0\0A\"\24\24\b\b\b\b\b\0\0\0\0\0\0\0\376\300` \20\b\f\6\376\0\0\0\0\08\b\b\b\b\b\b\b\b\b\b8\0\0\0\0\0\0\2\4\4\b\b\30\20\20  @\0\0\0\34\20\20\20\20\20\20\20\20\20\20\34\0\0\0\0\0\0\b\24\"c\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\177\0\0\0\b\20\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\08D@|Bb\\\0\0\0\0\0\2\2\2\2>fBBBf>\0\0\0\0\0\0\0\0\08D\2\2\2D8\0\0\0\0\0@@@@|fBBBf|\0\0\0\0\0\0\0\0\0<fB~\2F<\0\0\0\0\0000\b\b\b>\b\b\b\b\b\b\0\0\0\0\0\0\0\0\0|fBBBf\\@D8\0\0\2\2\2\2:FBBBBB\0\0\0\0\0\b\0\0\0\16\b\b\b\b\b>\0\0\0\0\0\20\0\0\0\34\20\20\20\20\20\20\20\20\16\0\0\2\2\2\2\"\22\n\16\22\"B\0\0\0\0\0\16\b\b\b\b\b\b\b\b\bp\0\0\0\0\0\0\0\0\0\376\222\222\222\222\222\222\0\0\0\0\0\0\0\0\0:FBBBBB\0\0\0\0\0\0\0\0\0<fBBBf<\0\0\0\0\0\0\0\0\0>fBBBf>\2\2\2\0\0\0\0\0\0|fBBBf\\@@@\0\0\0\0\0\0<L\4\4\4\4\4\0\0\0\0\0\0\0\0\0<B\2<@B<\0\0\0\0\0\0\0\b\b~\b\b\b\b\bp\0\0\0\0\0\0\0\0\0BBBBBb\\\0\0\0\0\0\0\0\0\0Bf$$<\30\30\0\0\0\0\0\0\0\0\0\201\201ZZZ$$\0\0\0\0\0\0\0\0\0f$\30\30\30$f\0\0\0\0\0\0\0\0\0BD$$(\30\20\20\b\f\0\0\0\0\0\0~@ \30\4\2~\0\0\0\0\08\b\b\b\b\6\b\b\b\b\b0\0\0\0\0\b\b\b\b\b\b\b\b\b\b\b\b\b\0\0\0\16\b\b\b\b0\b\b\b\b\b\6\0\0\0\0\0\0\0\0\0\0\234b\0\0\0\0\0\0\0\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377"))