Buddy System in Scheme

;; Buddy System in Scheme
;; Author: Maurizio Giordano
;; Install/Run:
;; a) download/install Racket Scheme (5.0 or later)
;; b) run "drracket"
;; c) open this file in drracket
;; d) click "Run" to load the source
;; e) play with the Buddy System API:
;;    i) alloc pages with (alloc_pages order)
;;    ii) free pages with (free_pages page-index order)
;;    iii) display BS config with (draw_memmap_blocks free_area)
;;
 
;; Import racket libraries
(require racket/base)
(require racket/list)
(require racket/vector)
(require 2htdp/image)
 
;; Buddy SYstem Graphic library and globals
(define dx 10)
(define dy 80)
(define delta 4)
(define penwidth 3)
 
(define (page-free)
  (overlay/align "middle" "middle"
           (rectangle dx dy "solid" "white")
           (rectangle (+ dx delta) (+ dy delta) "outline" "black")))
 
(define (page-notfree)
  (overlay/align "middle" "middle"
           (rectangle 10 80 "solid" "pink")
           (rectangle 14 84 "outline" "black")))
 
 
(define (draw_block order index mem)
  (overlay/xy (rectangle (* (expt 2 order) (+ dx delta)) (+ dy delta) "outline" 
                         ;(vector-ref block-colors order)
                         (make-pen (vector-ref block-colors order) 5 "long-dash" "round" "round")
                         ) 
              (- (* index (+ dx delta))) 
              0 mem))
 
(define (draw_memmap mem)
  (if (= 0 (vector-length mem)) 
      #f
      (let loop ((i (vector-length mem)))
        (let ((page (if (= (vector-ref mem (sub1 i)) 0) (page-free) (page-notfree))))
          (if (= i 1) 
              page
              (overlay/xy (loop (sub1 i)) (* (- i 1) (+ dx delta)) 0 page))))))
 
(define (draw_memmap_blocks farea)
  (if (= 0 (vector-length farea)) 
      #f
     (let ((image (draw_memmap mem_map)))
        (let loop ((i (vector-length farea)))
           (cond ((> i 0)
                  (let inloop ((l (vector-ref farea (sub1 i))))
                     (cond ((not (null? l))
                            (set! image (draw_block (sub1 i) (car l) image))
                            (inloop (cdr l)))))
                  (loop (sub1 i)))))
        image)))
 
(define block-colors (vector "red" "orange" "yellow" "green" "blue" "purple" "cyan"))
 
;; Buddy System globals
(define maxorder 5)    ;; max order
(define free_area (make-vector (add1 maxorder) '()))  ;; free_area vector
;; init BS with two free blocks of 32 pages
(vector-set! free_area maxorder (list 0 (expt 2 maxorder)))
;; init memory map with 64 free pages 
(define mem_map (make-vector (* 2 (expt 2 maxorder)) 0))
 
(define (getblock order)
  (let*-values (((first rest) (split-at (vector-ref free_area order) 1))
                ((page) (car first)))
    (values page rest)))
 
;; BS - find the requested block or split larger blocks
(define (rmqueue order)
  (let loop1 ((i order))
    (if (>= i (vector-length free_area)) 
        null                 ; no block could be found
        (if (null? (vector-ref free_area i))
            (loop1 (add1 i))
            (let*-values (((page rest) (getblock i)))
               (vector-set! free_area i rest)
               (let loop2 ((j i))
                  (if (= j order)
                      page
                      (begin (vector-set! free_area (sub1 j) (list (+ page (expt 2 (sub1 j)))))
                             (loop2 (sub1 j))))))))))
 
;; given a block of pages, it finds the "buddy" block
(define (buddy-of page order) 
  (if (= 0 (modulo page (expt 2 (+ order 1))))
      (+ page (expt 2 order))   ;; the buddy block is over the page-block 
      (- page (expt 2 order)))) ;; the buddy block is below the page-block  
 
(define (check_and_clear_pages page order)
  (for ((i (in-range (expt 2 order))))
    (cond ((= 0 (vector-ref mem_map (+ page i)))
        (error "block has some free pages"))))
  (for ((i (in-range (expt 2 order))))
    (vector-set! mem_map (+ page i) 0)))
 
;;
;; BS API
;;
;; (alloc_pages order) -> integer?|null?
;;   order : integer?
;; return: the page index in case of allocation of block of 2^order pages 
;;         otherwise null (empty list) 
 
(define (alloc_pages order)
  (let ((page (rmqueue order)))
    (if (null? page)
        (printf "the block cannot be allocated\n")
        (for ((i (in-range (expt 2 order))))
          (vector-set! mem_map (+ page i) 1)))
    page)) 
 
;; (free_pages page order) -> void?
;;   page  : integer?
;;   order : integer?
;; return: void?
;;   if the deallocation succeded, the block of 2^order pages starting from index "page" 
;;   is freed, otherwise an error is printed 
(define (free_pages page order)
  (check_and_clear_pages page order)       ;; check if pages are allocated and free them
  (let loop ((i order) (1stpage page))     ;; iterate from oder up
    (cond ((< i maxorder) (printf "order=~s\n" i)
           (let ((buddy (buddy-of 1stpage i))  ;; compute the buddy
                 (blocklist (vector-ref free_area i)))  ;; take the list of blocks
             (printf "MEMBER ~s\n" (member buddy blocklist))
             (cond ((member buddy blocklist)
                    (vector-set! free_area i (remove buddy blocklist)) ;; buddy in list remove it
                    (loop (add1 i) (if (> buddy 1stpage) 1stpage buddy)))
                   (else (printf "final block is ~s-~s\n" 1stpage (+ 1stpage (expt 2 i)))
                         (vector-set! free_area i
                           (sort (append (list 1stpage) (vector-ref free_area i)) <=))))))
          (else (printf "final block is ~s-~s\n" 1stpage (+ 1stpage (expt 2 i)))
                (vector-set! free_area i
                      (sort (append (list 1stpage) (vector-ref free_area i)) <=))))))