module/mescc/mescc.scm

   1 ;;; GNU Mes --- Maxwell Equations of Software
   2 ;;; Copyright © 2016,2017,2018,2019 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
   3 ;;;
   4 ;;; This file is part of GNU Mes.
   5 ;;;
   6 ;;; GNU Mes is free software; you can redistribute it and/or modify it
   7 ;;; under the terms of the GNU General Public License as published by
   8 ;;; the Free Software Foundation; either version 3 of the License, or (at
   9 ;;; your option) any later version.
  10 ;;;
  11 ;;; GNU Mes is distributed in the hope that it will be useful, but
  12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;; GNU General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU General Public License
  17 ;;; along with GNU Mes.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 (define-module (mescc mescc)
  20   #:use-module (srfi srfi-1)
  21   #:use-module (srfi srfi-26)
  22   #:use-module (ice-9 pretty-print)
  23   #:use-module (ice-9 getopt-long)
  24   #:use-module (mes misc)
  25
  26   #:use-module (mescc i386 info)
  27   #:use-module (mescc x86_64 info)
  28   #:use-module (mescc preprocess)
  29   #:use-module (mescc compile)
  30   #:use-module (mescc M1)
  31   #:export (mescc:preprocess
  32             mescc:get-host
  33             mescc:compile
  34             mescc:assemble
  35             mescc:link))
  36
  37 (define GUILE-with-output-to-file with-output-to-file)
  38 (define (with-output-to-file file-name thunk)
  39   (if (equal? file-name "-") (thunk)
  40       (GUILE-with-output-to-file file-name thunk)))
  41
  42 (define (mescc:preprocess options)
  43   (let* ((pretty-print/write (string->symbol (option-ref options 'write (if guile? "pretty-print" "write"))))
  44          (pretty-print/write (if (eq? pretty-print/write 'pretty-print) pretty-print write))
  45          (files (option-ref options '() '("a.c")))
  46          (input-file-name (car files))
  47          (input-base (basename input-file-name))
  48          (ast-file-name (cond ((and (option-ref options 'preprocess #f)
  49                                     (option-ref options 'output #f)))
  50                               (else (replace-suffix input-base ".E"))))
  51          (dir (dirname input-file-name))
  52          (defines (reverse (filter-map (multi-opt 'define) options)))
  53          (includes (reverse (filter-map (multi-opt 'include) options)))
  54          (includes (cons dir includes))
  55          (prefix (option-ref options 'prefix ""))
  56          (machine (option-ref options 'machine "32"))
  57          (arch (arch-get options))
  58          (defines (cons (arch-get-define options) defines)))
  59     (with-output-to-file ast-file-name
  60       (lambda _ (for-each (cut c->ast prefix defines includes arch pretty-print/write <>) files)))))
  61
  62 (define (c->ast prefix defines includes arch write file-name)
  63   (with-input-from-file file-name
  64     (cut write (c99-input->ast #:prefix prefix #:defines defines #:includes includes #:arch arch))))
  65
  66 (define (mescc:compile options)
  67   (let* ((files (option-ref options '() '("a.c")))
  68          (input-file-name (car files))
  69          (input-base (basename input-file-name))
  70          (M1-file-name (cond ((and (option-ref options 'compile #f)
  71                                    (option-ref options 'output #f)))
  72                              (else (replace-suffix input-base ".s"))))
  73          (infos (map (cut file->info options <>) files))
  74          (verbose? (option-ref options 'verbose #f))
  75          (align? (option-ref options 'align #f)))
  76     (when verbose?
  77       (stderr "dumping: ~a\n" M1-file-name))
  78     (with-output-to-file M1-file-name
  79       (cut infos->M1 M1-file-name infos #:align? align?))
  80     M1-file-name))
  81
  82 (define (file->info options file-name)
  83   (cond ((.c? file-name) (c->info options file-name))
  84         ((.E? file-name) (E->info options file-name))))
  85
  86 (define (c->info options file-name)
  87   (let* ((defines (reverse (filter-map (multi-opt 'define) options)))
  88          (includes (reverse (filter-map (multi-opt 'include) options)))
  89          (dir (dirname file-name))
  90          (includes (cons dir includes))
  91          (prefix (option-ref options 'prefix ""))
  92          (defines (cons (arch-get-define options) defines))
  93          (arch (arch-get options)))
  94     (with-input-from-file file-name
  95       (cut c99-input->info (arch-get-info options) #:prefix prefix #:defines defines #:includes includes #:arch arch))))
  96
  97 (define (E->info options file-name)
  98   (let ((ast (with-input-from-file file-name read)))
  99     (c99-ast->info (arch-get-info options) ast)))
 100
 101 (define (mescc:assemble options)
 102   (let* ((files (option-ref options '() '("a.c")))
 103          (input-file-name (car files))
 104          (input-base (basename input-file-name))
 105          (hex2-file-name (cond ((and (option-ref options 'assemble #f)
 106                                      (option-ref options 'output #f)))
 107                                (else (replace-suffix input-base ".o"))))
 108          (s-files (filter .s? files))
 109          (hex2-files  M1->hex2 ) ;; FIXME
 110          (source-files (filter (disjoin .c? .E?) files))
 111          (infos (map (cut file->info options <>) source-files)))
 112     (if (and (pair? s-files) (pair? infos))
 113         (error "mixing source and object not supported:" source-files s-files))
 114     (when (pair? s-files)
 115       (M1->hex2 options s-files))
 116     (when (pair? infos)
 117       (infos->hex2 options hex2-file-name infos))
 118     hex2-file-name))
 119
 120 (define (mescc:link options)
 121   (let* ((files (option-ref options '() '("a.c")))
 122          (source-files (filter (disjoin .c? .E?) files))
 123          (s-files (filter .s? files))
 124          (o-files (filter .o? files))
 125          (input-file-name (car files))
 126          (hex2-file-name (if (or (string-suffix? ".hex2" input-file-name)
 127                                  (string-suffix? ".o" input-file-name)) input-file-name
 128                                  (replace-suffix input-file-name ".o")))
 129          (infos (map (cut file->info options <>) source-files))
 130          (s-files (filter .s? files))
 131          (hex2-files (filter .o? files))
 132          (hex2-files (if (null? s-files) hex2-files
 133                          (append hex2-files (list (M1->hex2 options s-files)))))
 134          (hex2-files (if (null? infos) hex2-files
 135                          (append hex2-files
 136                                  (list (infos->hex2 options hex2-file-name infos)))))
 137          (default-libraries (if (or (option-ref options 'nodefaultlibs #f)
 138                                     (option-ref options 'nostdlib #f)) '()
 139                                     '("c")))
 140          (libraries (filter-map (multi-opt 'library) options))
 141          (libraries (delete-duplicates (append libraries default-libraries)))
 142          (hex2-libraries (map (cut find-library options ".a" <>) libraries))
 143          (hex2-files (append hex2-files hex2-libraries))
 144          (s-files (append s-files (map (cut find-library options ".s" <>)  libraries)))
 145          (debug-info? (option-ref options 'debug-info #f))
 146          (s-files (cons (replace-suffix input-file-name ".s") s-files))
 147          (elf-footer (and debug-info?
 148                           (or (M1->blood-elf options s-files)
 149                               (exit 1)))))
 150     (or (hex2->elf options hex2-files #:elf-footer elf-footer)
 151         (exit 1))))
 152
 153 (define (infos->hex2 options hex2-file-name infos)
 154   (let* ((input-file-name (car (option-ref options '() '("a.c"))))
 155          (M1-file-name (replace-suffix hex2-file-name ".s"))
 156          (options (acons 'compile #t options)) ; ugh
 157          (options (acons 'output hex2-file-name options))
 158          (verbose? (option-ref options 'verbose #f))
 159          (align? (option-ref options 'align #f)))
 160     (when verbose?
 161       (stderr "dumping: ~a\n" M1-file-name))
 162     (with-output-to-file M1-file-name
 163       (cut infos->M1 M1-file-name infos #:align? align?))
 164     (or (M1->hex2 options (list M1-file-name))
 165         (exit 1))))
 166
 167 (define (M1->hex2 options M1-files)
 168   (let* ((input-file-name (car (option-ref options '() '("a.c"))))
 169          (input-base (basename input-file-name))
 170          (M1-file-name (car M1-files))
 171          (hex2-file-name (cond ((and (option-ref options 'assemble #f)
 172                                      (option-ref options 'output #f)))
 173                                ((option-ref options 'assemble #f)
 174                                 (replace-suffix input-base ".o"))
 175                                (else (replace-suffix M1-file-name ".o"))))
 176          (verbose? (option-ref options 'verbose #f))
 177          (M1 (or (getenv "M1") "M1"))
 178          (command `(,M1
 179                     "--LittleEndian"
 180                     "--architecture" ,(arch-get-architecture options)
 181                     "-f" ,(arch-find options (arch-get-m1-macros options))
 182                     ,@(append-map (cut list "-f" <>) M1-files)
 183                     "-o" ,hex2-file-name)))
 184     (when verbose?
 185       (stderr "~a\n" (string-join command)))
 186     (and (zero? (apply assert-system* command))
 187          hex2-file-name)))
 188
 189 (define* (hex2->elf options hex2-files #:key elf-footer)
 190   (let* ((input-file-name (car (option-ref options '() '("a.c"))))
 191          (elf-file-name (cond ((option-ref options 'output #f))
 192                               (else "a.out")))
 193          (verbose? (option-ref options 'verbose #f))
 194          (hex2 (or (getenv "HEX2") "hex2"))
 195          (base-address (option-ref options 'base-address "0x1000000"))
 196          (machine (arch-get-machine options))
 197          (elf-footer (or elf-footer
 198                          (arch-find options (string-append
 199                                              "elf" machine "-footer-single-main.hex2"))))
 200          (start-files (if (or (option-ref options 'nostartfiles #f)
 201                               (option-ref options 'nostdlib #f)) '()
 202                               `("-f" ,(arch-find options "crt1.o"))))
 203          (command `(,hex2
 204                     "--LittleEndian"
 205                     "--architecture" ,(arch-get-architecture options)
 206                     "--BaseAddress" ,base-address
 207                     "-f" ,(arch-find options (string-append "elf" machine "-header.hex2"))
 208                     ,@start-files
 209                     ,@(append-map (cut list "-f" <>) hex2-files)
 210                     "-f" ,elf-footer
 211                     "--exec_enable"
 212                     "-o" ,elf-file-name)))
 213     (when verbose?
 214       (stderr "~a\n" (string-join command)))
 215     (and (zero? (apply assert-system* command))
 216          elf-file-name)))
 217
 218 (define (M1->blood-elf options M1-files)
 219   (let* ((M1-file-name (car M1-files))
 220          (M1-blood-elf-footer (string-append M1-file-name ".blood-elf"))
 221          (hex2-file-name (replace-suffix M1-file-name ".o"))
 222          (blood-elf-footer (string-append hex2-file-name ".blood-elf"))
 223          (verbose? (option-ref options 'verbose #f))
 224          (blood-elf (or (getenv "BLOOD_ELF") "blood-elf"))
 225          (command `(,blood-elf
 226                       "-f" ,(arch-find options (arch-get-m1-macros options))
 227                       ,@(append-map (cut list "-f" <>) M1-files)
 228                       "-o" ,M1-blood-elf-footer)))
 229     (when verbose?
 230         (format (current-error-port) "~a\n" (string-join command)))
 231     (and (zero? (apply assert-system* command))
 232          (let* ((options (acons 'compile #t options)) ; ugh
 233                 (options (acons 'output blood-elf-footer options)))
 234            (M1->hex2 options (list M1-blood-elf-footer))))))
 235
 236 (define (replace-suffix file-name suffix)
 237   (let* ((parts (string-split file-name #\.))
 238          (base (if (pair? (cdr parts)) (drop-right parts 1)))
 239          (old-suffix (last parts))
 240          (program-prefix (cond ((string-prefix? "arm-mes-" old-suffix) ".arm-mes-")
 241                                ((string-prefix? "x86-mes-" old-suffix) ".x86-mes-")
 242                                ((string-prefix? "x86_64-mes-" old-suffix) ".x86_64-mes-")
 243                                (else "."))))
 244     (if (string-null? suffix)
 245         (if (string-null? program-prefix) (string-join base ".")
 246             (string-append (string-drop program-prefix 1) (string-join base ".")))
 247         (string-append (string-join base ".") program-prefix (string-drop suffix 1)))))
 248
 249 (define (find-library options ext o)
 250   (arch-find options (string-append "lib" o ext)))
 251
 252 (define* (arch-find options file-name)
 253   (let* ((srcdest (or (getenv "srcdest") ""))
 254          (srcdir-lib (string-append srcdest "lib"))
 255          (arch (string-append (arch-get options) "-mes"))
 256          (path (cons* "."
 257                       srcdir-lib
 258                       (prefix-file options "lib")
 259                       (filter-map (multi-opt 'library-dir) options)))
 260          (arch-file-name (string-append arch "/" file-name))
 261          (verbose? (option-ref options 'verbose #f)))
 262     (let ((file (search-path path arch-file-name)))
 263       (when verbose?
 264         (stderr "arch-find=~s\n" arch-file-name)
 265         (stderr "     path=~s\n" path)
 266         (stderr "  => ~s\n" file))
 267       (or file
 268           (error (format #f "mescc: file not found: ~s" arch-file-name))))))
 269
 270 (define (prefix-file options file-name)
 271   (let ((prefix (option-ref options 'prefix "")))
 272     (define (prefix-file o)
 273       (if (string-null? prefix) o (string-append prefix "/" o)))
 274     (prefix-file file-name)))
 275
 276 (define (assert-system* . args)
 277   (let ((status (apply system* args)))
 278     (when (not (zero? status))
 279       (stderr "mescc: failed: ~a\n" (string-join args))
 280       (exit (status:exit-val status)))
 281     status))
 282
 283 (define (arch-get options)
 284   (let* ((machine (option-ref options 'machine #f))
 285          (arch (option-ref options 'arch #f)))
 286     (if machine (cond ((member arch '("x86" "x86_64")) (cond ((equal? machine "32") "x86")
 287                                                              ((equal? machine "64") "x86_64")))
 288                       ((equal? arch "arm") (cond ((equal? machine "32") "arm"))))
 289         arch)))
 290
 291 (define (mescc:get-host options)
 292   (let ((cpu (arch-get options))
 293         (kernel "linux"))
 294     (string-join (list cpu kernel "mes") "-")))
 295
 296 (define (arch-get-info options)
 297   (let ((arch (arch-get options)))
 298     (cond ((equal? arch "arm") (armv4-info))
 299           ((equal? arch "x86") (x86-info))
 300           ((equal? arch "x86_64") (x86_64-info)))))
 301
 302 (define (arch-get-define options)
 303   (let ((arch (arch-get options)))
 304     (cond ((equal? arch "arm") "__arm__=1")
 305           ((equal? arch "x86") "__i386__=1")
 306           ((equal? arch "x86_64") "__x86_64__=1"))))
 307
 308 (define (arch-get-machine options)
 309   (let* ((machine (option-ref options 'machine #f))
 310          (arch (option-ref options 'arch #f)))
 311     (or machine
 312         (if (member arch '("x86_64")) "64"
 313             "32"))))
 314
 315 (define (arch-get-m1-macros options)
 316   (let ((arch (arch-get options)))
 317     (cond ((equal? arch "arm") "arm.M1")
 318           ((equal? arch "x86") "x86.M1")
 319           ((equal? arch "x86_64") "x86_64.M1"))))
 320
 321 (define (arch-get-architecture options)
 322   (let ((arch (arch-get options)))
 323     (cond ((equal? arch "arm") "armv7l")
 324           ((equal? arch "x86") "x86")
 325           ((equal? arch "x86_64") "amd64"))))
 326
 327 (define (multi-opt option-name) (lambda (o) (and (eq? (car o) option-name) (cdr o))))
 328
 329 (define (.c? o) (or (string-suffix? ".c" o)
 330                     (string-suffix? ".M2" o)))
 331 (define (.E? o) (or (string-suffix? ".E" o)
 332                     (string-suffix? ".mes-E" o)
 333                     (string-suffix? ".arm-mes-E" o)
 334                     (string-suffix? ".x86-mes-E" o)
 335                     (string-suffix? ".x86_64-mes-E" o)))
 336 (define (.s? o) (or (string-suffix? ".s" o)
 337                     (string-suffix? ".S" o)
 338                     (string-suffix? ".mes-S" o)
 339                     (string-suffix? ".arm-mes-S" o)
 340                     (string-suffix? ".x86-mes-S" o)
 341                     (string-suffix? ".x86_64-mes-S" o)
 342                     (string-suffix? ".M1" o)))
 343 (define (.o? o) (or (string-suffix? ".o" o)
 344                     (string-suffix? ".mes-o" o)
 345                     (string-suffix? ".arm-mes-o" o)
 346                     (string-suffix? ".x86-mes-o" o)
 347                     (string-suffix? ".x86_64-mes-o" o)
 348                     (string-suffix? ".hex2" o)))