module/mes/M1.mes

   1 ;;; -*-scheme-*-
   2
   3 ;;; Mes --- Maxwell Equations of Software
   4 ;;; Copyright © 2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
   5 ;;;
   6 ;;; This file is part of Mes.
   7 ;;;
   8 ;;; Mes is free software; you can redistribute it and/or modify it
   9 ;;; under the terms of the GNU General Public License as published by
  10 ;;; the Free Software Foundation; either version 3 of the License, or (at
  11 ;;; your option) any later version.
  12 ;;;
  13 ;;; Mes is distributed in the hope that it will be useful, but
  14 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 ;;; GNU General Public License for more details.
  17 ;;;
  18 ;;; You should have received a copy of the GNU General Public License
  19 ;;; along with Mes.  If not, see <http://www.gnu.org/licenses/>.
  20
  21 ;;; Commentary:
  22
  23 ;;; M1.mes produces stage0' M1 object format
  24
  25 ;;; Code:
  26
  27 (cond-expand
  28  (guile)
  29  (mes
  30   (mes-use-module (srfi srfi-1))
  31   (mes-use-module (srfi srfi-26))
  32   (mes-use-module (mes as))
  33   (mes-use-module (mes elf))
  34   (mes-use-module (mes optargs))
  35   (mes-use-module (mes pmatch))
  36   (mes-use-module (language c99 info))))
  37
  38 (define (logf port string . rest)
  39   (apply format (cons* port string rest))
  40   (force-output port)
  41   #t)
  42
  43 (define (stderr string . rest)
  44   (apply logf (cons* (current-error-port) string rest)))
  45
  46 (define (pke . stuff)
  47   (newline (current-error-port))
  48   (display ";;; " (current-error-port))
  49   (write stuff (current-error-port))
  50   (newline (current-error-port))
  51   (car (last-pair stuff)))
  52
  53 (define (objects->M1 file-name objects)
  54   ((compose (cut object->M1 file-name <>) merge-objects) objects))
  55
  56 (define (object->elf file-name o)
  57   ((compose M1->elf (cut object->M1 file-name <>)) o))
  58
  59 (define (objects->elf file-name objects)
  60   ((compose M1->elf (cut object->M1 file-name <>) merge-objects) objects))
  61
  62 (define (merge-objects objects)
  63   (let loop ((objects (cdr objects)) (object (car objects)))
  64     (if (null? objects) object
  65         (loop (cdr objects)
  66               `((functions . ,(alist-add (assoc-ref object 'functions) (assoc-ref (car objects) 'functions)))
  67                 (globals . ,(alist-add (assoc-ref object 'globals) (assoc-ref (car objects) 'globals))))))))
  68
  69 (define (alist-add a b)
  70   (let* ((b-keys (map car b))
  71          (a (filter (lambda (f) (or (cdr f) (not (member (car f) b-keys)))) a))
  72          (a-keys (map car a)))
  73     (append a (filter (lambda (e) (not (member (car e) a-keys))) b))))
  74
  75 (define (hex2:address o)
  76   (string-append "&" o))
  77
  78 (define (hex2:offset o)
  79   (string-append "%" o))
  80
  81 (define (hex2:offset1 o)
  82   (string-append "!" o))
  83
  84 (define hex? #t)
  85
  86 (define (hex2:immediate o)
  87   (if hex? (string-append "%0x" (dec->hex o))
  88       (string-append "%" (number->string o))))
  89
  90 (define (hex2:immediate1 o)
  91   (if hex? (string-append "!0x" (dec->hex o))
  92       (string-append "!" (number->string o))))
  93
  94 (define* (display-join o #:optional (sep ""))
  95   (let loop ((o o))
  96     (when (pair? o)
  97       (display (car o))
  98       (if (pair? (cdr o))
  99           (display sep))
 100       (loop (cdr o)))))
 101
 102 (define (object->M1 file-name o)
 103   (stderr "dumping M1: object\n")
 104   (let* ((functions (assoc-ref o 'functions))
 105          (function-names (map car functions))
 106          (globals (assoc-ref o 'globals))
 107          (global-names (map car globals))
 108          (strings (filter (lambda (g) (and (pair? g) (eq? (car g) #:string))) global-names)))
 109     (define (string->label o)
 110       (let ((index (list-index (lambda (s) (equal? s o)) strings)))
 111         (if index
 112             (string-append "_string_" file-name "_" (number->string index))
 113             (error "no such string:" o))))
 114     (define (text->M1 o)
 115       (cond
 116        ((char? o) (text->M1 (char->integer o)))
 117        ((string? o) o)
 118        ((symbol? o) (symbol->string o))
 119        ((number? o) (let ((o (if (< o #x80) o (- o #x100))))
 120                       (if hex? (string-append "!0x"
 121                                               (if (and (>= o 0) (< o 16)) "0" "")
 122                                               (number->string o 16))
 123                           (string-append "!" (number->string o)))))
 124        ((and (pair? o) (keyword? (car o)))
 125         (pmatch o
 126           ;; FIXME
 127           ((#:address (#:string ,string)) (hex2:address (string->label `(#:string ,string))))
 128           ((#:address (#:address ,address)) (guard (string? address))
 129            (hex2:address address))
 130           ((#:address (#:address ,global)) (guard (global? global))
 131            (hex2:address (global->string global)))
 132           ((#:address ,function) (guard (function? function))
 133            (hex2:address (function->string function)))
 134           ((#:address ,number) (guard (number? number))
 135            (string-join (map text->M1 (int->bv32 number))))
 136           ((#:string ,string)
 137            (hex2:address (string->label o)))
 138           ((#:address ,address) (guard (string? address)) (hex2:address address))
 139           ((#:address ,global) (guard (global? global))
 140            (hex2:address (global->string global)))
 141           ((#:offset ,offset) (hex2:offset offset))
 142           ((#:offset1 ,offset1) (hex2:offset1 offset1))
 143           ((#:immediate ,immediate) (hex2:immediate immediate))
 144           ((#:immediate1 ,immediate1) (hex2:immediate1 immediate1))
 145           (_ (error "text->M1 no match o" o))))
 146        ((pair? o) (string-join (map text->M1 o)))))
 147     (define (write-function o)
 148       (let ((name (car o))
 149             (text (function:text (cdr o))))
 150         (define (line->M1 o)
 151           (cond ((eq? (car o) #:label)
 152                  (display (string-append ":" (cadr o))))
 153                 ((eq? (car o) #:comment)
 154                  (display "\t\t\t\t\t# ")
 155                  (display (text->M1 (cadr o))))
 156                 ((or (string? (car o)) (symbol? (car o)))
 157                  (display "\t" )
 158                  (display-join (map text->M1 o) " "))
 159                 (else (error "line->M1 invalid line:" o)))
 160           (newline))
 161         (display (string-append "    :" name "\n") (current-error-port))
 162         (display (string-append "\n\n:" name "\n"))
 163         (for-each line->M1 (apply append text))))
 164     (define (write-global o)
 165       (define (labelize o)
 166         (if (not (string? o)) o
 167             (let* ((label o)
 168                    (function? (member label function-names))
 169                    (string-label (string->label label))
 170                    (string? (not (equal? string-label "_string_#f"))))
 171               (cond ((and (pair? o) (global? (cdr o))) (string-append "&" (global->string o)))
 172                     ((and (not string?) (not function?)) (stderr "warning: unresolved label: ~s\n" label))
 173                     (else (string-append "&" label))))))
 174       (define (display-align size)
 175         (let ((alignment (- 4 (modulo size 4))))
 176           (when (> alignment 0)
 177             (display " ")
 178             (display-join (map text->M1 (map (const 0) (iota alignment))) " "))))
 179       (let* ((label (cond
 180                      ((and (pair? (car o)) (eq? (caar o) #:string))
 181                       (string->label (car o)))
 182                      ((global? (cdr o)) (global->string (cdr o)))
 183                      (else (car o))))
 184              (string? (string-prefix? "_string" label))
 185              (foo (if (not (eq? (car (string->list label)) #\_))
 186                       (display (string-append "    :" label "\n") (current-error-port))))
 187              (data ((compose global:value cdr) o))
 188              (data (filter-map labelize data))
 189              (len (length data))
 190              (string-max (or (and=> (getenv "M1_STRING_MAX") string->number) 256))
 191              (string-data (and string? (list-head data (1- (length data))))))
 192         (display (string-append "\n:" label "\n"))
 193         (if (and string-data
 194                  (< len string-max)
 195                  (char? (car data))
 196                  (eq? (last data) #\nul)
 197                  (not (find (cut memq <> '(#\")) string-data))
 198                  (not (any (lambda (ch)
 199                              (or (and (not (memq ch '(#\tab #\newline)))
 200                                       (< (char->integer ch) #x20))
 201                                  (>= (char->integer ch) #x80))) string-data)))
 202             (let ((text string-data))
 203               (display (string-append "\"" (list->string string-data) "\""))
 204               (display-align (1+ (length string-data))))
 205             (let ((text (map text->M1 data)))
 206               (display-join  text " ")
 207               (display-align (length text))))
 208         (newline)))
 209     (display "M1: functions\n" (current-error-port))
 210     (for-each write-function (filter cdr functions))
 211     (when (assoc-ref functions "main")
 212       (display "\n\n:ELF_data\n") ;; FIXME
 213       (display "\n\n:HEX2_data\n"))
 214     (display "M1: globals\n" (current-error-port))
 215     (for-each write-global globals)))