cgen/intrinsics.scm

   1 ; intrinsics support generator support routines.
   2 ;
   3 ; This entire file is deeply littered with mep-specific logic. You have
   4 ; been warned.
   5 ;
   6 ; Copyright (C) 2000, 2001, 2002, 2003, 2009 Red Hat, Inc.
   7 ; This file is part of CGEN.
   8
   9 ; Specify which application.
  10 (set! APPLICATION 'INTRINSICS)
  11
  12 (debug-enable 'backtrace)
  13
  14 ; String containing copyright text.
  15 (define CURRENT-COPYRIGHT #f)
  16
  17 ; String containing text defining the package we're generating code for.
  18 (define CURRENT-PACKAGE #f)
  19
  20 ; Initialize the options.
  21 (define (option-init!)
  22   (set! CURRENT-COPYRIGHT copyright-fsf)
  23   (set! CURRENT-PACKAGE package-gnu-simulators)
  24   *UNSPECIFIED*
  25   )
  26
  27 (define (intrinsics-analyze!)
  28   (arch-analyze-insns! CURRENT-ARCH
  29                        #t  ; include aliases
  30                        #t) ; do analyze the semantics
  31   )
  32
  33 ;; Shortcuts for commonly-used functions.
  34 (define sa string-append)
  35 (define (st x) (stringize x " "))
  36
  37 ;; HELPER FUNCTIONS
  38 ;; ----------------
  39
  40 ;; True if FN returns the same value for FIRST and SECOND.
  41 (define (same? fn first second)
  42   (equal? (fn first) (fn second)))
  43
  44 ;; True if predicate FN holds for both FIRST and SECOND.
  45 (define (both? fn first second)
  46   (and (fn first) (fn second)))
  47
  48 ;; True if FN holds for every element of LIST.
  49 (define (for-all? fn list)
  50   (let loop ((list list))
  51     (or (null? list)
  52         (and (fn (car list))
  53              (loop (cdr list))))))
  54
  55 ;; True if FN holds for one element of LIST.
  56 (define (exists? fn list)
  57   (let loop ((list list))
  58     (and (pair? list)
  59          (or (fn (car list))
  60              (loop (cdr list))))))
  61
  62 ;; True if LIST1 and LIST2 are the same length and (FN X Y) holds for
  63 ;; each (X Y) in the zipped list.
  64 (define (for-all-pairs? fn list1 list2)
  65   (let loop ((list1 list1) (list2 list2))
  66     (or (both? null? list1 list2)
  67         (and (both? pair? list1 list2)
  68              (fn (car list1) (car list2))
  69              (loop (cdr list1) (cdr list2))))))
  70
  71 ;; Use (SETTER ELEM INDEX) to assign some number INDEX to each element
  72 ;; ELEM of LIST.  BASE is the index of the first element; other elements
  73 ;; are numbered incrementally.  Return the first unused index value.
  74 (define (number-list setter list base)
  75   (let loop ((list list) (index base))
  76     (if (null? list)
  77         index
  78         (begin
  79           (setter (car list) index)
  80           (loop (cdr list) (+ index 1))))))
  81
  82 ;; Apply FN to every list of arguments in ARGS.
  83 (define (apply-list fn args)
  84   (for-each (lambda (list) (apply fn list)) args))
  85
  86 ;; Sort list ELEMS with partial order FN, where (FN X Y) is true iff X "<=" Y.
  87 (define (sort-partial elems fn)
  88   (if (null? elems)
  89       elems
  90       (let ((sorted (list (car elems))))
  91         (for-each
  92          (lambda (elem)
  93            (let loop ((pos sorted))
  94              (if (fn elem (car pos))
  95                  (begin
  96                    (set-cdr! pos (cons (car pos) (cdr pos)))
  97                    (set-car! pos elem))
  98                  (if (null? (cdr pos))
  99                      (set-cdr! pos (list elem))
 100                      (loop (cdr pos))))))
 101          (cdr elems))
 102         sorted)))
 103
 104 ;; Generate preprocessor macro names, suitable for use as bitmasks.
 105 (define (bitmask-name prefix name)
 106   (string-upcase (sa prefix "_" (gen-c-symbol name))))
 107
 108 ;; Return an inclusive OR of every bitmask member in NAMES.
 109 (define (bitmask prefix names)
 110   (if (null? names)
 111       "0"
 112       (stringize (map (lambda (x) (bitmask-name prefix x)) names) "|")))
 113
 114 ;; Assign values to every bitmask in NAMES.
 115 (define (define-bitmasks prefix names)
 116   (number-list
 117    (lambda (name index)
 118      (string-write "#define " (bitmask-name prefix name)
 119                    " " (st (logsll 1 index)) "\n"))
 120    names 0)
 121   (string-write "\n"))
 122
 123 ;; Convert ISA symbol ISA into a target-frobbed string
 124 (define (convert-isa isa)
 125   (target:frob-isa-name (symbol->string isa)))
 126
 127 ;; PRETTY-PRINTER SUPPORT
 128 ;; ----------------------
 129
 130 ;; How many spaces to indent the next line.
 131 (define indentation 0)
 132
 133 ;; End the current line and indent the new one.
 134 (define (line-break)
 135   (string-write "\n" (make-string indentation #\space)))
 136
 137 ;; Helper functions, useful as arguments to WRITE-LIST.
 138 (define (comma-break)
 139   (string-write ", "))
 140
 141 (define (comma-line-break)
 142   (string-write ",")
 143   (line-break))
 144
 145 ;; Execute BODY so that every call to LINE-BREAK will indent by
 146 ;; INDENT more spaces than it does now.
 147 (defmacro write-with-indent (indent . body)
 148   `(begin
 149      (set! indentation (+ indentation ,indent))
 150      ,(cons 'begin body)
 151      (set! indentation (- indentation ,indent))))
 152
 153 ;; Write PREFIX, then execute BODY so that every call to LINE-BREAK
 154 ;; will indent to the end of the prefix.  Write SUFFIX afterwards.
 155 ;;
 156 ;; This function should only be called at the start of a new line.
 157 (defmacro write-construct (prefix suffix . body)
 158   `(begin
 159      (string-write ,prefix)
 160      (write-with-indent (string-length ,prefix) ,(cons 'begin body))
 161      (string-write ,suffix)))
 162
 163 ;; Write out each element of LIST individually using WRITE.  Use (BREAK)
 164 ;; to separate the elements.
 165 (define (write-list break list write)
 166   (if (pair? list)
 167       (begin
 168         (write (car list))
 169         (for-each (lambda (x) (break) (write x)) (cdr list)))))
 170
 171 ;; Like WRITE-LIST, but write DUMMY if the list is empty.
 172 (define (write-nonempty-list break list write dummy)
 173   (if (null? list)
 174       (string-write dummy)
 175       (write-list break list write)))
 176
 177 ;; MACROS
 178 ;; ------
 179
 180 ;; little macro for making assoc tables with nice names
 181 (defmacro deftable (basename)
 182   (let* ((table (symbol-append basename '-table))
 183          (initializer (symbol-append 'init- basename '!))
 184          (keys (symbol-append basename '-keys))
 185          (getter (symbol-append 'get- basename))
 186          (setter (symbol-append 'set- basename '!)))
 187     `(begin
 188        (define ,table '())
 189        (define (,initializer) (set! ,table '()))
 190        (define (,keys) (map car ,table))
 191        (define (,getter k)
 192          (let ((pair (assoc k ,table)))
 193            (if pair (cdr pair) pair)))
 194        (define (,setter k v)
 195          (let ((pair (assoc k ,table)))
 196            (if pair
 197                (set-cdr! pair v)
 198                (set! ,table (cons (cons k v) ,table))))))))
 199
 200 ;; Make a very simple structure interface.  NAME is the structure's name
 201 ;; and FIELDS is a list of its fields.
 202 ;;
 203 ;;    (make-struct foo (f1 f2 f3 ...))
 204 ;;
 205 ;; defines the following functions:
 206 ;;
 207 ;;    (foo:make f1 f2 f3 ...)
 208 ;;        Create a new object with the given values for fields F1, F2, F3...
 209 ;;
 210 ;;    (foo:f1 object)
 211 ;;        Return the value of OBJECT's F1 field, or #f if OBJECT itself is #f.
 212 ;;
 213 ;;    (foo:set-f1! object value)
 214 ;;        Set OBJECT's F1 field to VALUE.
 215 ;;
 216 ;; ... and likewise for the other fields.  Each structure is represented
 217 ;; as a vector of its elements.
 218 (defmacro make-struct (name fields)
 219   (let ((commands (list `(define ,(symbol-append name ':make)
 220                            (lambda ,fields ,(cons 'vector fields))))))
 221     (number-list
 222      (lambda (field index)
 223        (let* ((setname (symbol-append name ':set- field '!))
 224               (getname (symbol-append name ': field))
 225               (setter `(define (,setname x val) (vector-set! x ,index val)))
 226               (getter `(define (,getname x) (and x (vector-ref x ,index)))))
 227          (set! commands (cons setter (cons getter commands)))))
 228      fields
 229      0)
 230     (cons 'begin commands)))
 231
 232
 233 ;; MEP-SPECIFIC DETAILS
 234 ;; --------------------
 235
 236 ;; Predicates for recognizing coprocessor register set hardware names.
 237 ;; HW is the hardware name: a symbol, or #:unbound in some cases.
 238 ;;
 239 ;; At the moment, we do this by looking at the hardware's name as a
 240 ;; string; it would be more graceful to handle this with an attribute.
 241 ;;
 242 ;; Older MeP .cpu files call the coprocessor register sets h-cr,
 243 ;; h-cr64, and h-ccr.  Newer versions of a2cgen suffix the hardware
 244 ;; names for the coprocessor's registers with the name of the
 245 ;; coprocessor, and the me_module number.  So, for example, if
 246 ;; me_module 3 has an rhcop coprocessor, its register sets will be
 247 ;; called h-cr64-rhcop-3, h-cr-rhcop-3, and h-ccr-rhcop-3.
 248
 249 ;; Return a predicate that recognizes hardware names that start with
 250 ;; PREFIX.  PREFIX is a string, like "h-cr"; the returned predicate
 251 ;; will return true if its argument is the symbol whose name is
 252 ;; PREFIX, (e.g. 'h-cr), or any symbol whose name begins with PREFIX
 253 ;; followed by a hyphen (e.g. 'h-cr-rhcop-1).
 254 (define (suffixed-hardware-recognizer prefix)
 255   ;; Precompute some stuff.
 256   (let* ((no-hyphen-sym (string->symbol prefix))
 257          (hyphenated (string-append prefix "-"))
 258          (hyphenated-len (string-length hyphenated)))
 259     (lambda (obj)
 260       (or (eq? obj no-hyphen-sym)
 261           (and (symbol? obj)
 262                (let ((name (symbol->string obj)))
 263                  (and (>= (string-length name) hyphenated-len)
 264                       (string=? (substring name 0 hyphenated-len)
 265                                 hyphenated))))))))
 266
 267 (define is-h-cr64?    (suffixed-hardware-recognizer "h-cr64"))
 268 (define is-h-cr?      (suffixed-hardware-recognizer "h-cr"))
 269 (define is-h-ccr?     (suffixed-hardware-recognizer "h-ccr"))
 270
 271 ;; Return the gcc rtl mode that should be used for operand OP.
 272 ;; Return #f to use the default, target-independent choice.
 273 (define (target:guess-mode op)
 274   (cond
 275    ((equal? (md-operand:cdata op) 'FMAX_INT) "SI")
 276    ((equal? (md-operand:cdata op) 'FMAX_FLOAT) "SF")
 277    ((is-h-cr64? (md-operand:hw op)) "DI")
 278    ((is-h-cr? (md-operand:hw op)) "SI")
 279    ((not (memory? (md-operand:type op))) "SI")
 280    (else #f)))
 281
 282 ;; Return the list of arguments for an intrinsic function.  ARGUMENTS is
 283 ;; a list of the operands found in the instruction's syntax string, in the
 284 ;; order they appear.  OUTPUT-OPERANDS is a list of all the instruction's
 285 ;; output operands (no particular order).  Both lists contain md-operands.
 286 ;;
 287 ;; Normally ARGUMENTS itself is the correct return value, but we
 288 ;; need a couple of MeP-specific hacks:
 289 ;;
 290 ;;   - Instructions that write to r0 do not make r0 a syntactic
 291 ;;   operand.  Instead, they embed "\\$0" in the syntax string.
 292 ;;   Cope with this by adding $0 to the beginning of the list
 293 ;;   if written.
 294 ;;
 295 ;;   - $spr and $tpr can appear in the syntax string but are
 296 ;;   not supposed to be treated as arguments to the intrinsic.
 297 (define (target:frob-arguments arguments output-operands)
 298   (set! arguments (find (lambda (op)
 299                           (not (member (md-operand:name op) '(tpr spr))))
 300                         arguments))
 301   (let ((r0-writes (find (lambda (op)
 302                            (equal? (md-operand:fixed-register op) 0))
 303                          output-operands)))
 304     (if (pair? r0-writes)
 305         (set! arguments (cons (car r0-writes) arguments))))
 306   arguments)
 307
 308 ;; Convert the given cgen ISA name into its gcc equivalent.
 309 ;; cgen names such as 'ext_core<X>' and 'ext_cop<X>_YY' become 'ext<X>'.
 310 (define (target:frob-isa-name isa)
 311   (cond
 312    ((equal? "ext_cop" (string-take 7 isa))
 313     (sa "ext" (string-drop 7 (string-drop -3 isa))))
 314
 315    ((equal? "ext_core" (string-take 8 isa))
 316     (sa "ext" (string-drop 8 isa)))
 317
 318    (else isa)))
 319
 320 ;; Apply FN once for each ISA.  The first argument to FN is a user-readable
 321 ;; string that describes the ISA.  The second argument is the ISA name
 322 ;; returned by frob-isa-name.
 323 (define (target:for-each-isa! fn)
 324   (for-each (lambda (entry)
 325               (apply fn (car entry) (sa "ext" (st (cadr entry))) '()))
 326             (cdr (attr-values (current-attr-lookup 'CONFIG)))))
 327
 328 ;; Return the number of the first register belonging to the given
 329 ;; hardware element.
 330 (define (target:base-reg hw)
 331   (cond
 332    ((eq? hw 'h-gpr) 0)             ; core registers
 333    ((eq? hw 'h-csr) 16)            ; control registers
 334    ((is-h-cr? hw) 48)              ; 32-bit coprocessor registers
 335    ((is-h-cr64? hw) 48)            ; 64-bit coprocessor registers (same)
 336    ((is-h-ccr? hw) 80)             ; coprocessor control registers
 337    (else 0)))
 338
 339 ;; Return the constraint string for register operand OP.
 340 (define (target:reg-constraint op)
 341   (case (md-operand:fixed-register op)
 342     ((0) "z")
 343     ((23) "h") ;; hi
 344     ((24) "l") ;; lo
 345     (else
 346      (cond
 347       ;; "tiny" registers, in the range 0..7
 348       ((equal? (md-operand:ifield op) 'f-rn3) "t")
 349
 350       (else
 351        (let ((hw (md-operand:hw op)))
 352          (cond
 353           ((eq? hw 'h-gpr) "r")    ; core registers
 354           ((eq? hw 'h-csr) "c")    ; control registers
 355           ((or (is-h-cr64? hw)     ; 32-bit coprocessor registers
 356                (is-h-cr? hw))      ; 64-bit coprocessor registers
 357            (if (equal? (md-operand:length op) 4) "em" "x"))
 358           ((is-h-ccr? hw) "y")     ; coprocessor control registers
 359           (else "r"))))))))
 360
 361 ;; The first hard register available to the intrinsics generator.
 362 (define target:first-unused-register 113)
 363
 364 ;; The instructions mapped to a particular intrinsic can be subdivided
 365 ;; into groups, each representing a particular form of code generation.
 366 ;; In the MeP case, we have one group for __vliw functions and one group
 367 ;; for normal functions.
 368 (define target:groups '(normal vliw))
 369
 370 ;; True if INSN belongs to GROUP, where GROUP is a member of TARGET:GROUPS.
 371 (define (target:belongs-to-group? insn group)
 372   (case (obj-attr-value (md-insn:cgen-insn insn) 'SLOT)
 373     ((NONE)
 374      (let ((slots (obj-attr-value (md-insn:cgen-insn insn) 'SLOTS)))
 375        (cond ((not slots) (equal? group 'normal))
 376              ((memq 'CORE slots) #t)
 377              ((memq 'C3 slots) (equal? group 'normal))
 378              (else (equal? group 'vliw)))))
 379     ((C3) (equal? group 'normal))
 380     ((V1 V3) (equal? group 'vliw))))
 381
 382 ;; Convert an intrinsic's cgen name into the name of its builtin function.
 383 (define (target:builtin-name name)
 384   (string-append "mep_" (gen-c-symbol name)))
 385
 386 ;; Helper functions for getting the values of certain mep-specific gcc
 387 ;; attributes.  In each case INSN is a cgen instruction (not an md-insn).
 388 (define (/may-trap-attribute insn)
 389   (if (obj-has-attr? insn 'MAY_TRAP) "yes" "no"))
 390
 391 (define (/slot-attribute insn)
 392   (if (exists? (lambda (isa)
 393                  (or (equal? isa 'mep)
 394                      (equal? (string-take 8 (st isa)) "ext_core")))
 395                (obj-attr-value insn 'ISA))
 396       "core"
 397       "cop"))
 398
 399 (define (/latency-attribute insn)
 400   (if (obj-attr-value insn 'LATENCY)
 401       (st (obj-attr-value insn 'LATENCY))
 402       "0"))
 403
 404 (define (/length-attribute insn)
 405   (st (/ (insn-length insn) 8)))
 406
 407 (define (/stall-attribute insn)
 408   (string-downcase (st (obj-attr-value insn 'STALL))))
 409
 410 (define (/slots-attribute insn)
 411   (let ((slots (obj-attr-value insn 'SLOTS)))
 412     (if slots
 413         (string-downcase (gen-c-symbol (st slots)))
 414         "core")))
 415
 416 ;; Return the define_insn attributes for INSN as a list of (NAME . VALUE)
 417 ;; pairs.
 418 (define (target:attributes insn)
 419   (let ((cgen-insn (md-insn:cgen-insn insn)))
 420     (list (cons 'may_trap (/may-trap-attribute cgen-insn))
 421           (cons 'latency (/latency-attribute cgen-insn))
 422           (cons 'length (/length-attribute cgen-insn))
 423           (cons 'slot (/slot-attribute cgen-insn))
 424           (cons 'slots (/slots-attribute cgen-insn))
 425           (if (eq? (obj-attr-value cgen-insn 'STALL) 'SHIFTI)
 426               (cons 'shiftop "operand2")
 427               (cons 'stall (/stall-attribute cgen-insn))))))
 428
 429 ;; Define target-specific fields of cgen_insn.  In the MeP case, we want
 430 ;; to record how long the intruction is.
 431 (define (target:declare-fields)
 432   (sa "\n"
 433       "  /* The length of the instruction, in bytes.  */\n"
 434       "  int length;\n"))
 435
 436 ;; Initialize the fields described above.
 437 (define (target:initialize-fields insn)
 438   (comma-line-break)
 439   (string-write (/length-attribute (md-insn:cgen-insn insn))))
 440
 441 ;; Use WELL-KNOWN-INTRINSIC to define the names of builtins that
 442 ;; gcc might treat specially.
 443 (define (target:add-well-known-intrinsics)
 444   (apply-list (lambda args
 445                 (apply well-known-intrinsic args)
 446                 (apply well-known-intrinsic (sa (car args) "3") (cdr args))
 447                 (apply well-known-intrinsic (sa (car args) "i") (cdr args))
 448                 (apply well-known-intrinsic (sa (car args) "i3") (cdr args)))
 449               `(("cadd" plus)
 450                 ("csub" minus)
 451                 ("cand" and)
 452                 ("cor" ior)
 453                 ("cnor" nor)
 454                 ("cxor" xor)
 455                 ("csll" ashift)
 456                 ("csrl" lshiftrt)
 457                 ("csra" ashiftrt)))
 458
 459   (apply-list well-known-intrinsic
 460               `(("cmov")
 461                 ("cpmov")
 462                 ("cmovi" set)
 463                 ("cmov1")
 464                 ("cmov2")
 465                 ("cmovc1")
 466                 ("cmovc2")
 467                 ("cmovh1")
 468                 ("cmovh2")
 469                 ("cneg" neg)
 470                 ("cmula0")
 471                 ("xmula0")
 472                 ("cextuh")
 473                 ("cextub")
 474                 ("cexth")
 475                 ("cextb")
 476                 ("fmovs")
 477                 ("fadds" plus "TARGET_FMAX")
 478                 ("fsubs" minus "TARGET_FMAX")
 479                 ("fmuls" mult "TARGET_FMAX")
 480                 ("fdivs" div "TARGET_FMAX")
 481                 ("fsqrts" sqrt "TARGET_FMAX")
 482                 ("fabss" abs "TARGET_FMAX")
 483                 ("fnegs" neg "TARGET_FMAX")
 484                 ("ftruncws" fix "TARGET_FMAX")
 485                 ("fcvtsw" float "TARGET_FMAX")
 486                 ("fcmpus" unordered "TARGET_FMAX")
 487                 ("fcmpues" uneq "TARGET_FMAX")
 488                 ("fcmpuls" unlt "TARGET_FMAX")
 489                 ("fcmpules" unle "TARGET_FMAX")
 490                 ("fcmpes" eq "TARGET_FMAX")
 491                 ("fcmplis" lt "TARGET_FMAX")
 492                 ("fcmpleis" le "TARGET_FMAX"))))
 493
 494 ;; INTRINSIC OPERANDS
 495 ;; ------------------
 496 ;;
 497 ;; Each intrinsic operand is represented by a unique MD-OPERAND.
 498 ;; These objects refer back to normal cgen operands but add the extra
 499 ;; information needed for intrinsics support.  Each MD-OPERAND belongs
 500 ;; to exactly one MD-INSN.
 501 ;;
 502 ;;    OP is the cgen operand
 503 ;;
 504 ;;    IFIELD-VALUE is the constant value that the instruction assigns
 505 ;;    to the operand's field, or #f if the field isn't constant.
 506 ;;
 507 ;;    ARG-INDEX is the position of this operand in the intrinsic's
 508 ;;    argument list, or #f if the operand is not an argument.
 509 ;;
 510 ;;    READ-INDEX is the match_operand number assigned to this operand
 511 ;;    when it appears in a right-hand context.  The value is #f if we
 512 ;;    never generate such a match_operand, either because the operand
 513 ;;    is a strict lvalue or because ARG-INDEX is #f.
 514 ;;
 515 ;;    WRITE-INDEX is like READ-INDEX but is used for left-hand contexts.
 516 ;;
 517 ;;    MODE is the operand's gcc mode (SI, etc.).
 518 (make-struct md-operand (op ifield-value arg-index
 519                          read-index write-index mode))
 520
 521 ;; Helper functions to extract commonly-used fields from the
 522 ;; underlying cgen operand.
 523 (define (md-operand:name op) (op:sem-name (md-operand:op op)))
 524 (define (md-operand:type op) (op:type (md-operand:op op)))
 525 (define (md-operand:register? op) (register? (md-operand:type op)))
 526 (define (md-operand:index op) (op:index (md-operand:op op)))
 527 (define (md-operand:length op) (op:length (md-operand:op op)))
 528 (define (md-operand:hw op) (op:hw-name (md-operand:op op)))
 529 (define (md-operand:ifield op)
 530   (let ((ifield (op-ifield (md-operand:op op))))
 531     (and ifield (obj:name ifield))))
 532
 533 ;; Functions to access well-known operand attributes.
 534 (define (md-operand:cdata op) (obj-attr-value (md-operand:op op) 'CDATA))
 535 (define (md-operand:alignment op) (obj-attr-value (md-operand:op op) 'ALIGN))
 536 (define (md-operand:sem-only? op) (obj-has-attr? (md-operand:op op) 'SEM-ONLY))
 537
 538 ;; Return true if operand OP represents the program counter.
 539 (define (md-operand:pc? op)
 540   (or (equal? (md-operand:name op) 'pc)
 541       (pc? (md-operand:type op))))
 542
 543 ;; Return true if operand OP must be mapped to a label.  This is only
 544 ;; ever true of argument operands.
 545 (define (md-operand:label? op)
 546   (and (class-instance? <hw-immediate> (md-operand:type op))
 547        (equal? (md-operand:cdata op) 'LABEL)))
 548
 549 ;; Return true if OP is an immediate operand.
 550 (define (md-operand:immediate? op)
 551   (class-instance? <hw-immediate> (md-operand:type op)))
 552
 553 ;; Return true if operand OP is an index into a register file.  gcc will
 554 ;; convert them into REG rtxes.
 555 (define (md-operand:regnum? op)
 556   (equal? (md-operand:cdata op) 'REGNUM))
 557
 558 ;; If operand OP is a fixed hard register, return the number GCC assigns
 559 ;; to it, otherwise return #f.
 560 (define (md-operand:fixed-register op)
 561   (and (not (md-operand:pc? op))
 562        (md-operand:register? op)
 563        (let ((constant (if (hw-index-constant? (md-operand:index op))
 564                            (hw-index-constant-value (md-operand:index op))
 565                            (md-operand:ifield-value op))))
 566          (and constant
 567               (+ constant (target:base-reg (md-operand:hw op)))))))
 568
 569 ;; SPECIFIC TO 32-BIT TARGETS
 570 ;; Guess the gcc rtl mode for operand OP.  First see whether it uses
 571 ;; a known hardware element, then try the CDATA attribute.
 572 (define (md-operand:guess-mode op)
 573   (or (target:guess-mode op)
 574       (case (md-operand:cdata op)
 575         ((SHORT USHORT) "HI")
 576         ((CHAR UCHAR) "QI")
 577         (else "SI"))))
 578
 579 ;; Return true if operand OP is a signed immediate.
 580 (define (md-operand:signed? op)
 581   (equal? (md-operand:hw op) 'h-sint))
 582
 583 ;; If OP accepts only CONST_INTs, return the lowest value it accepts.
 584 (define (md-operand:lower-bound op)
 585   (if (md-operand:signed? op)
 586       (- (logsll 1 (+ (md-operand:alignment op)
 587                       (md-operand:length op)
 588                       -2)))
 589       0))
 590
 591 ;; Likewise the highest value + 1.
 592 (define (md-operand:upper-bound op)
 593   (logsll 1 (+ (md-operand:alignment op)
 594                (md-operand:length op)
 595                (if (md-operand:signed? op) -2 -1))))
 596
 597 ;; Return the name of an immediate predicate for operand OP, assuming
 598 ;; that OP should accept only CONST_INTs.  We define these predicates
 599 ;; in the gcc include file.
 600 (define (md-operand:immediate-predicate op)
 601   (gen-c-symbol (sa "cgen_" (st (md-operand:hw op)) "_"
 602                     (st (md-operand:length op))
 603                     "a" (st (md-operand:alignment op))
 604                     "_immediate")))
 605
 606 ;; Return the match_operand predicate for operand OP.
 607 (define (md-operand:predicate op lvalue?)
 608   (cond
 609    ((memory? (md-operand:type op)) "memory_operand")
 610    ((md-operand:label? op) "immediate_operand")
 611    ((md-operand:immediate? op) (md-operand:immediate-predicate op))
 612    (lvalue? "nonimmediate_operand")
 613    (else "general_operand")))
 614
 615
 616 ;; Return the gcc rtx for non-argument operand OP.
 617 (define (md-operand:fixed-rtx op)
 618   (cond
 619    ((memory? (md-operand:type op))
 620     (sa "(mem:" (md-operand:mode op) " (scratch:SI))"))
 621
 622    ((md-operand:fixed-register op)
 623     (sa "(reg:" (md-operand:mode op) " "
 624         (st (md-operand:fixed-register op)) ")"))
 625
 626    (else
 627     (error (sa "bad intrinsic operand \"" (st (md-operand:name op))
 628                "\": need constant or ifield indexed register, got "
 629                (st (hw-index:type (md-operand:index op))))))))
 630
 631 ;; Return the constraint string for operand OP.  LVALUE? is true if the
 632 ;; operand is appearing in a left-hand context.  For read-write operands,
 633 ;; the rvalue operand should have a numerical constraint giving the
 634 ;; number of the lvalue.
 635 (define (md-operand:constraint lvalue? op)
 636   (cond
 637    ((and (not lvalue?) (md-operand:write-index op))
 638     (st (md-operand:write-index op)))
 639    ((md-operand:immediate? op) "")
 640    (else (target:reg-constraint op))))
 641
 642 ;; Return the rtl pattern for operand OP.  CONTEXT is LHS if the operand
 643 ;; is being used as an lvalue, RHS if it is being used as an rvalue in the
 644 ;; first set of a pattern and RHS-COPY if it is being used as an rvalue
 645 ;; in subsequent sets.
 646 (define (md-operand:to-string context op)
 647   (cond
 648    ((md-operand:pc? op) "(pc)")
 649    (else
 650     (let* ((lvalue? (equal? context 'lhs))
 651            (index (if lvalue?
 652                       (md-operand:write-index op)
 653                       (md-operand:read-index op))))
 654       (cond
 655        ((not index) (md-operand:fixed-rtx op))
 656        ((equal? context 'rhs-copy) (sa "(match_dup " (st index) ")"))
 657        (else
 658         (sa "(match_operand:"
 659             (md-operand:mode op) " " (st index) " \""
 660             (md-operand:predicate op lvalue?) "\" \"" (if lvalue? "=" "")
 661             (md-operand:constraint lvalue? op) "\")")))))))
 662
 663
 664 ;; GCC INSTRUCTION PATTERNS
 665 ;; ------------------------
 666 ;;
 667 ;; If we need to generate a define_insn pattern for a particular cgen
 668 ;; instruction, we will create a unique MD-INSN for it.  Each MD-INSN
 669 ;; is associated with a (shared) INTRINSIC object.
 670 ;;
 671 ;;    MD-NAME is the name of the define_insn pattern
 672 ;;
 673 ;;    INDEX is a unique number given to this instruction.  Instructions
 674 ;;    are numbered according to their position in the .md output file,
 675 ;;    the first instruction having index 0.
 676 ;;
 677 ;;    INTRINSIC is the intrinsic object to which this instruction belongs.
 678 ;;
 679 ;;    CGEN-INSN is the underlying cgen insn.
 680 ;;
 681 ;;    SYNTAX is the output of syntax-break-out with cgen operands
 682 ;;    converted to md-operands.
 683 ;;
 684 ;;    ARGUMENTS is a list of the operands that act as formal arguments
 685 ;;    to the intrinsic function.  Usually this is the same as SYNTAX
 686 ;;    with strings removed, but there can be target-specific reasons
 687 ;;    for using a different argument list.
 688 ;;
 689 ;;    INPUTS is a list of the operands that appear in a right-hand
 690 ;;    context within the define_insn pattern.  If a member of this
 691 ;;    list is also in ARGUMENTS, it will have a valid READ-INDEX.
 692 ;;
 693 ;;    OUTPUTS is like INPUTS except that it lists the operands that
 694 ;;    appear in a left-hand context.  Argument operands in this list
 695 ;;    will have a valid WRITE-INDEX.
 696 ;;
 697 ;;    OPERANDS is a concatenation of OUTPUTS and INPUTS.
 698 ;;
 699 ;;    CPTYPE is the type to use for coprocessor operands (like V4HI)
 700 ;;
 701 ;;    CRET? is set if the first argument is returned rather than passed.
 702
 703 (make-struct md-insn (md-name index intrinsic cgen-insn syntax arguments
 704                       inputs outputs operands cptype cret?))
 705
 706 ;; Return the name of the underlying cgen insn, mostly used for
 707 ;; error reporting.
 708 (define (md-insn:cgen-name insn) (obj:name (md-insn:cgen-insn insn)))
 709
 710 ;; Return true if INSN is inherently volatile, meaning that it has
 711 ;; important effects that are not described by its gcc rtx pattern.
 712 ;; This is true for any instruction with the VOLATILE attribute,
 713 ;; any instruction without output operands (including those with
 714 ;; no semantics at all) and any instruction that reads from or
 715 ;; writes to a REGNUM operand.
 716 (define (md-insn:volatile? insn)
 717   (or (null? (md-insn:outputs insn))
 718       (exists? md-operand:regnum? (md-insn:operands insn))
 719       (obj-has-attr? (md-insn:cgen-insn insn) 'VOLATILE)))
 720
 721 ;; Return the list of ISAs that implement INSN.  Ignore those that
 722 ;; were excluded on the command line.
 723 (define (md-insn:isas insn)
 724   (map convert-isa
 725        (find (lambda (isa) (member isa intrinsics-isas))
 726              (obj-attr-value (md-insn:cgen-insn insn) 'ISA))))
 727
 728 ;; The full list of instruction groups.  As well target-specific groups,
 729 ;; this includes "known-code", meaning that the instruction uses a specific
 730 ;; rtl code instead of an unspec.
 731 (define md-insn-groups (cons 'known-code target:groups))
 732
 733 ;; Return the list of groups to which INSN belongs.
 734 (define (md-insn:groups insn)
 735   (let ((target-groups (find (lambda (group)
 736                                (target:belongs-to-group? insn group))
 737                              target:groups)))
 738     (if (intrinsic:unspec-version (md-insn:intrinsic insn))
 739         (cons 'known-code target-groups)
 740         target-groups)))
 741
 742 ;; Partial ordering of syntax elements.  Return true if ELEM1 and ELEM2
 743 ;; are compatible and ELEM2's range is a superset of ELEM1's.  The rules
 744 ;; are that:
 745 ;;
 746 ;;    - Identical syntax strings are compatible.
 747 ;;
 748 ;;    - Immediate operands are compatible if the range of one is contained
 749 ;;    within the range of the other.
 750 ;;
 751 ;;    - Other types of operand are compatible if they use the same
 752 ;;    hardware element and have the same length.
 753 (define (syntax<=? elem1 elem2)
 754   (or (and (both? vector? elem1 elem2)
 755            (if (both? md-operand:immediate? elem1 elem2)
 756                (and (>= (md-operand:alignment elem1)
 757                         (md-operand:alignment elem2))
 758                     (>= (md-operand:lower-bound elem1)
 759                         (md-operand:lower-bound elem2))
 760                     (<= (md-operand:upper-bound elem1)
 761                         (md-operand:upper-bound elem2)))
 762                (and (same? md-operand:hw elem1 elem2)
 763                     (same? md-operand:length elem1 elem2))))
 764       (and (both? string? elem1 elem2)
 765            (string=? elem1 elem2))))
 766
 767 ;; Helper functions for comparing lists of operands or lists of syntax
 768 ;; pieces using the above ordering.
 769 (define (md-insn:operands<=? insn1 insn2)
 770   (for-all-pairs? syntax<=?
 771                   (md-insn:operands insn1)
 772                   (md-insn:operands insn2)))
 773
 774 (define (md-insn:syntax<=? insn1 insn2)
 775   (for-all-pairs? syntax<=?
 776                   (md-insn:syntax insn1)
 777                   (md-insn:syntax insn2)))
 778
 779
 780 ;; INTRINSICS
 781 ;; ----------
 782 ;;
 783 ;; Intrinsics have two names, the one that appears in the cgen file
 784 ;; and the one that is given to the builtin function.  The former is
 785 ;; its "cgen name" and is only relevant during the analysis phase.
 786 ;;
 787 ;;    NAME is the name of the intrinsic's builtin function.  It is
 788 ;;    generated from the cgen name by TARGET:BUILTIN-NAME.
 789 ;;
 790 ;;    INDEX is the index of this intrinsic in the global INTRINSICS list.
 791 ;;
 792 ;;    UNSPEC is the unspec number to use for the right hand side of the
 793 ;;    first SET pattern.  Add 2 for each subsequent output (so that real
 794 ;;    and shadow registers can use different unspec numbers).
 795 ;;
 796 ;;    HOOK is the gcc-hook object associated with this intrinsic,
 797 ;;    or #f if none.
 798 ;;
 799 ;;    ISAS maps ISA names to the most general implementation of the
 800 ;;    intrinsic for that ISA.  Used for error checking.
 801 (make-struct intrinsic (name index unspec hook isas))
 802
 803 ;; Short-cut functions
 804 (define (intrinsic:unspec-version intrinsic)
 805   (gcc-hook:unspec-version (intrinsic:hook intrinsic)))
 806
 807 ;; Return the maximum of HIGHEST and the length of insn property PROPERTY
 808 ;; for any implementation of INSTRINSIC.  PROPERTY can the something
 809 ;; like MD-INSN:INPUTS or MD-INSN:OUTPUTS.
 810 (define (intrinsic:max highest property intrinsic)
 811   (for-each
 812    (lambda (isa)
 813      (set! highest (max highest (length (apply property (cdr isa) '())))))
 814    (intrinsic:isas intrinsic))
 815   highest)
 816
 817 ;; GLOBAL VARIABLES
 818 ;; ----------------
 819
 820 ;; Maps cgen intrinsic names to intrinsic objects.
 821 (deftable intrinsic)
 822
 823 ;; The list of all intrinsics.  After the analysis phase, this list
 824 ;; is in index order.
 825 (define intrinsics '())
 826
 827 ;; The list of all instructions, in the order they appear in the .md file.
 828 ;; When two instructions are compatible, but one is more general than
 829 ;; the other, the more general one will come after the less general one.
 830 (define md-insns '())
 831
 832 ;; Maps fixed hard registers onto shadow global registers.
 833 (define shadow-registers '())
 834
 835 ;; Create an intrinsic with the given cgen name and gcc hook.  Add it to
 836 ;; INTRINSICS and INTRINSIC-TABLE.
 837 (define (add-intrinsic name hook)
 838   (let ((intrinsic (intrinsic:make (target:builtin-name name) #f #f hook '())))
 839     (set! intrinsics (cons intrinsic intrinsics))
 840     (set-intrinsic! name intrinsic)
 841     intrinsic))
 842
 843 ;; Return a shadow version of hard register REG.
 844 (define (get-shadow reg)
 845   (or (assoc-ref shadow-registers reg)
 846       (let ((retval (+ target:first-unused-register
 847                        (length shadow-registers))))
 848         (set! shadow-registers
 849               (append! shadow-registers (list (cons reg retval))))
 850         retval)))
 851
 852 ;; WELL-KNOWN INTRINSICS
 853 ;; ---------------------
 854
 855 ;; gcc might have a special use for certain intrinsics.  Such intrinsics
 856 ;; have a GCC-HOOK structure attached.
 857 ;;
 858 ;;    RTL-CODE is an rtl code that can be used in the define_insn
 859 ;;    pattern instead of usual unspec or unspec_volatile.  Usually
 860 ;;    the field is an arithmetic or logic code, but it can also be:
 861 ;;
 862 ;;        - 'set': the intrinsic implements a move of some sort.
 863 ;;        - 'nor': represented in gcc as (and (not X) (not Y)).
 864 ;;        - #f: use unspecs as normal.
 865 ;;
 866 ;;    CONDITION is a condition that must be true for the RTL-CODE
 867 ;;    version of the instruction to be available.
 868 ;;
 869 ;;    UNSPEC-VERSION is a version of the same intrinsic that has no
 870 ;;    gcc-hook structure.  It is sometimes useful to have two versions
 871 ;;    of the same instrinsic, one with a specific rtl-code and one
 872 ;;    with a general unspec.  The former will allow more optimisations
 873 ;;    while the latter will act more like an inline asm statement.
 874 (make-struct gcc-hook (rtl-code condition unspec-version))
 875
 876 ;; Declare a well-known intrinsic with the given cgen name and
 877 ;; gcc-hook fields.
 878 (define (well-known-intrinsic name . args)
 879   (let* ((rtl-code (and (> (length args) 0) (car args)))
 880          (condition (and (> (length args) 1) (cadr args)))
 881          (unspec-version (and rtl-code (add-intrinsic name #f))))
 882     (add-intrinsic name (gcc-hook:make rtl-code condition unspec-version))))
 883
 884 (target:add-well-known-intrinsics)
 885
 886
 887 ;; ANALYSIS PHASE
 888 ;; --------------
 889
 890 ;; The next available unspec number.
 891 (define next-unspec 1000)
 892
 893 ;; Given cgen instruction INSN, return the cgen name of its intrinsic.
 894 (define (intrinsic-name insn)
 895   (let ((name (obj-attr-value insn 'INTRINSIC)))
 896     (if (equal? name "") (symbol->string (obj:name insn)) name)))
 897
 898 ;; Look up an intrinsic by its cgen name.  Create a new intrinsic
 899 ;; if the name hasn't been used yet.
 900 (define (find-intrinsic name)
 901   (or (get-intrinsic name)
 902       (add-intrinsic name #f)))
 903
 904 ;; If instruction INSN assigns to a constant value to OP's field,
 905 ;; record it in IFIELD-VALUE.
 906 (define (check-ifield-value op insn)
 907   (let* ((name (md-operand:ifield op))
 908          (ifield (and name (object-assq name (insn-iflds insn)))))
 909     (if (and ifield (ifld-constant? ifield))
 910         (md-operand:set-ifield-value! op (ifld-get-value ifield)))))
 911
 912 ;; Create an md-insn from the given cgen instruction and add it to MD-INSNS.
 913 (define (add-md-insn insn intrinsic md-prefix)
 914   (let* ((sfmt (insn-sfmt insn))
 915          (operands '())
 916
 917          ;; Create a new md-operand for OP.
 918          (new-operand (lambda (op)
 919                         (let ((created (md-operand:make op #f #f #f #f #f)))
 920                           (set! operands (cons created operands))
 921                           (check-ifield-value created insn)
 922                           created)))
 923
 924          ;; Find an md-operand for OP, create a new one if we
 925          ;; haven't seen it before.
 926          (make-operand (lambda (op)
 927                          (let loop ((entry operands))
 928                            (if (null? entry)
 929                                (new-operand op)
 930                                (if (equal? (op:sem-name op)
 931                                            (md-operand:name (car entry)))
 932                                    (car entry)
 933                                    (loop (cdr entry)))))))
 934
 935          ;; A partial order on md-operands.  Sort them by their position
 936          ;; in the argument list, putting non-argument operands last.
 937          ;;
 938          ;; This ordering is needed when non-commutative intrinsics
 939          ;; use a specific gcc rtl code.  For example, if we have
 940          ;; an intrinsic:
 941          ;;
 942          ;;      sub (op0, op1, op2)
 943          ;;
 944          ;; which is known to do subtraction, we might use the MINUS
 945          ;; rtl code in the define_insn pattern.  op1 must then be
 946          ;; the first input operand and op2 must be the second:
 947          ;;
 948          ;;      (set op0 (minus op1 op2))
 949          (op<= (lambda (x y)
 950                  (let ((xpos (md-operand:arg-index x))
 951                        (ypos (md-operand:arg-index y)))
 952                    (or (not ypos) (and xpos (<= xpos ypos))))))
 953
 954          ;; Create a version of the broken-out syntax in which
 955          ;; each cgen operand is replaced by an md-operand.
 956          (syntax (map (lambda (x)
 957                         (if (operand? x) (make-operand x) x))
 958                       (syntax-break-out (insn-syntax insn)
 959                                         (obj-isa-list insn))))
 960
 961          ;; All relevant outputs.
 962          (outputs (find (lambda (op)
 963                           (or (md-operand:pc? op)
 964                               (md-operand:fixed-register op)
 965                               (not (md-operand:sem-only? op))))
 966                         (map make-operand (sfmt-out-ops sfmt))))
 967
 968          ;; The arguments to the intrinsic function, represented as
 969          ;; a list of operands.  Usually this is taken directly from
 970          ;; the assembler syntax, but allow machine-specific hacks
 971          ;; to modify the list.
 972          (arguments (target:frob-arguments (find vector? syntax) outputs))
 973
 974          ;; The operands that we know to be inputs.  For tidiness' sake,
 975          ;; remove (pc), which was no real meaning inside an unspec or
 976          ;; unspec_volatile.
 977          (inputs (find (lambda (op)
 978                          (and (not (md-operand:pc? op))
 979                               (or (md-operand:fixed-register op)
 980                                   (not (md-operand:sem-only? op)))))
 981                        (map make-operand (sfmt-in-ops sfmt))))
 982
 983          ;; If an argument has not been classified as an input
 984          ;; or an output, treat it as an input.  This helps us to
 985          ;; deal with insns whose semantics have not been given.
 986          (quiet-inputs (find (lambda (op)
 987                                (and (not (memq op inputs))
 988                                     (not (memq op outputs))))
 989                              arguments))
 990
 991          ;; Allow an intrinsic to specify a type for coprocessor
 992          ;; operands, as they tend to be insn-specific vector types.
 993          (cptype (obj-attr-value insn 'CPTYPE))
 994
 995          (cret? (equal? (obj-attr-value insn 'CRET) 'FIRST))
 996          )
 997
 998     ;; Number each argument operand according to its position in the list.
 999     (number-list md-operand:set-arg-index! arguments 0)
1000
1001     ;; Sort the inputs and outputs as described above.
1002     (set! inputs (sort-partial (append inputs quiet-inputs) op<=))
1003     (set! outputs (sort-partial outputs op<=))
1004
1005     ;; Assign match_operand numbers to each argument.  Outputs should
1006     ;; have lower numbers than inputs.
1007     (number-list md-operand:set-read-index!
1008                  (find md-operand:arg-index inputs)
1009                  (number-list md-operand:set-write-index!
1010                               (find md-operand:arg-index outputs)
1011                               0))
1012
1013     ;; Assign a mode to each operand.  If we have an output operand,
1014     ;; use its mode for all immediate operands.  This is mainly for
1015     ;; intrinsics which use rtl codes like 'plus': the source operands
1016     ;; are then expected to have the same mode as the destination.
1017     (for-each (lambda (op)
1018                 (if (and (pair? outputs) (md-operand:immediate? op))
1019                     (md-operand:set-mode! op (md-operand:mode (car outputs)))
1020                     (md-operand:set-mode! op (md-operand:guess-mode op))))
1021               (append outputs inputs))
1022
1023     (set! md-insns
1024           (cons (md-insn:make (sa md-prefix (gen-c-symbol (obj:name insn)))
1025                               #f intrinsic insn syntax
1026                               arguments inputs outputs
1027                               (append outputs inputs) cptype cret?)
1028                 md-insns))))
1029
1030 ;; Make INSN available when generating code for ISA, updating INSN's
1031 ;; intrinsic structure accordingly.  Insns are passed to this function
1032 ;; in .md file order.
1033 (define (add-intrinsic-for-isa insn isa)
1034   (let* ((intrinsic (md-insn:intrinsic insn))
1035          (entry (assoc isa (intrinsic:isas intrinsic))))
1036     (if (not entry)
1037         ;; We haven't yet seen an implementation of this intrinsic for ISA.
1038         (intrinsic:set-isas! intrinsic
1039                              (cons (cons isa insn)
1040                                    (intrinsic:isas intrinsic)))
1041
1042         ;; The intrinsic has already been implemented for ISA.
1043         ;; Check whether INSN is at least as general as the bellwether
1044         ;; implementation.  If it isn't, report an error, otherwise
1045         ;; use INSN as the new bellwether.
1046         (let ((bellwether (cdr entry)))
1047
1048 ;; This is temporarily disabled as some IVC2 intrinsics *do* have the
1049 ;; same actual signature and operands, but different bit encodings
1050 ;; depending on the slot.  This different syntax makes them not match.
1051
1052 ;;        (if (not (md-insn:syntax<=? bellwether insn))
1053 ;;            (error (sa "instructions \"" (md-insn:cgen-name insn)
1054 ;;                       "\" and \"" (md-insn:cgen-name bellwether)
1055 ;;                       "\" are both mapped to intrinsic \""
1056 ;;                       (intrinsic:name intrinsic)
1057 ;;                       "\" but do not have a compatible syntax")))
1058
1059 ;;        (if (not (md-insn:operands<=? bellwether insn))
1060 ;;            (error (sa "instructions \"" (md-insn:cgen-name insn)
1061 ;;                       "\" and \"" (md-insn:cgen-name bellwether)
1062 ;;                       "\" are both mapped to intrinsic \""
1063 ;;                       (intrinsic:name intrinsic)
1064 ;;                       "\" but do not have compatible semantics")))
1065
1066           (set-cdr! entry insn)))))
1067
1068 ;; Return true if the given insn should be included in the output files.
1069 (define (need-insn? insn)
1070   (not (member (insn-mnemonic insn) '("--unused--" "--reserved--" "--syscall--"))))
1071
1072 ;; Set up global variables, if we haven't already.
1073 (define (analyze-intrinsics!)
1074   (if (null? md-insns)
1075       (begin
1076         (message "Analyzing intrinsics...\n")
1077
1078         ;; Set up the global lists.
1079         (for-each
1080          (lambda (insn)
1081            (if (need-insn? insn)
1082                (let ((intrinsic (find-intrinsic (intrinsic-name insn))))
1083                  (add-md-insn insn intrinsic "cgen_intrinsic_")
1084                  (if (intrinsic:unspec-version intrinsic)
1085                      (add-md-insn insn (intrinsic:unspec-version intrinsic)
1086                                   "cgen_intrinsic_unspec_")))))
1087          (current-insn-list))
1088
1089         (set! md-insns (sort-partial md-insns md-insn:syntax<=?))
1090
1091         ;; Tell each object what position it has in its respective list.
1092         (number-list md-insn:set-index! md-insns 0)
1093         (number-list intrinsic:set-index! intrinsics 0)
1094
1095         ;; Check whether the mapping of instructions to intrinsics is OK.
1096         (for-each
1097          (lambda (insn)
1098            (for-each
1099             (lambda (isa) (add-intrinsic-for-isa insn isa))
1100             (md-insn:isas insn)))
1101          md-insns)
1102
1103         ;; Assign unspec numbers to each intrinsic.
1104         (for-each
1105          (lambda (intrinsic)
1106            (intrinsic:set-unspec! intrinsic next-unspec)
1107            (set! next-unspec
1108                  (+ next-unspec
1109                     (* 2 (intrinsic:max 1 md-insn:outputs intrinsic)))))
1110          intrinsics))))
1111
1112
1113 ;; ITERATION FUNCTIONS
1114 ;; -------------------
1115
1116 (define (for-each-md-insn fn)
1117   (for-each fn md-insns))
1118
1119 (define (for-each-argument fn)
1120   (for-each-md-insn
1121    (lambda (insn)
1122      (for-each (lambda (op) (fn insn op))
1123                (md-insn:arguments insn)))))
1124
1125 ;; .MD GENERATOR
1126 ;; -------------
1127
1128 ;; Write the output template for INSN's define_insn.
1129 ;; ??? Still MeP-specific.
1130 (define (write-syntax insn)
1131   (let ((in-mnemonic? #t))
1132     (for-each
1133      (lambda (part)
1134        (cond
1135         ((vector? part)
1136          (let* ((name (md-operand:name part))
1137                 (pos (lambda () (st (or (md-operand:read-index part)
1138                                         (md-operand:write-index part))))))
1139            (cond
1140             ((equal? name 'tpr) (string-write "$tp"))
1141             ((equal? name 'spr) (string-write "$sp"))
1142             ((equal? name 'csrn) (string-write "%" (pos)))
1143             ((md-operand:label? part) (string-write "%l" (pos)))
1144             (else (string-write "%" (pos))))))
1145
1146         ((and in-mnemonic? (equal? " " part))
1147          (set! in-mnemonic? #f)
1148          (string-write "\\\\t"))
1149
1150         (else (string-write part))))
1151      (md-insn:syntax insn))))
1152
1153 ;; Write the inputs to INSN, wrapped in an unspec, unspec_volatile,
1154 ;; or intrinsic-specific rtl code.  MODE is the mode should go after
1155 ;; the wrapper's rtl-code, such as "" or ":SI".  UNSPEC is the unspec
1156 ;; number to use, if an unspec is needed, and CONTEXT is as for
1157 ;; MD-OPERAND:TO-STRING.
1158 (define (write-inputs context insn mode unspec)
1159   (let* ((code (gcc-hook:rtl-code (intrinsic:hook (md-insn:intrinsic insn))))
1160          (inputs (map (lambda (op)
1161                         (md-operand:to-string context op))
1162                       (md-insn:inputs insn))))
1163     (if (not code)
1164         (begin
1165           (string-write (if (md-insn:volatile? insn)
1166                             "(unspec_volatile"
1167                             "(unspec")
1168                         mode " [")
1169           (write-with-indent 2
1170             (line-break)
1171             (if (null? inputs)
1172                 (string-write "(const_int 0)")
1173                 (write-list line-break inputs string-write)))
1174           (line-break)
1175           (string-write "] " (st unspec) ")"))
1176         (cond
1177          ((equal? code 'set)
1178           (string-write (car inputs)))
1179
1180          ((equal? code 'nor)
1181           (write-construct (sa "(and" mode " ") ")"
1182             (write-list line-break inputs
1183                         (lambda (op)
1184                           (string-write "(not" mode " " op ")")))))
1185
1186          (else
1187           (write-construct (sa "(" (st code) mode " ") ")"
1188             (write-list line-break inputs string-write)))))))
1189
1190 ;; Write a "(set ...)" pattern for the given output.  CONTEXT is RHS
1191 ;; for the first output and RHS-COPY for the rest.  UNSPEC is an unspec
1192 ;; number to use for this output.
1193 (define (write-to-one-output context insn output unspec)
1194   (write-construct "(set " ")"
1195     (string-write (md-operand:to-string 'lhs output))
1196     (line-break)
1197     (let ((branch-labels (and (md-operand:pc? output)
1198                               (find md-operand:label?
1199                                     (md-insn:inputs insn)))))
1200       (if (pair? branch-labels)
1201           (write-construct "(if_then_else " ")"
1202             (write-construct "(eq " ")"
1203               (write-inputs context insn "" unspec)
1204               (line-break)
1205               (string-write "(const_int 0)"))
1206             (line-break)
1207             (string-write "(match_dup "
1208                           (st (md-operand:read-index (car branch-labels)))
1209                           ")")
1210             (line-break)
1211             (string-write "(pc)"))
1212           (let ((mode (md-operand:mode output)))
1213             (write-inputs context insn (sa ":" mode) unspec)))))
1214   ;; If this instruction is used for expanding intrinsics, and if the
1215   ;; output is a fixed register that is not mapped to an intrinsic
1216   ;; argument, treat the instruction as setting a global register.
1217   ;; This isn't necessary for volatile instructions since gcc will
1218   ;; not try to second-guess what they do.
1219   (if (and (not (intrinsic:unspec-version (md-insn:intrinsic insn)))
1220            (not (md-insn:volatile? insn))
1221            (not (md-operand:write-index output))
1222            (md-operand:fixed-register output))
1223       (let ((reg (get-shadow (md-operand:fixed-register output))))
1224         (line-break)
1225         (write-construct "(set " ")"
1226           (string-write "(reg:SI " (st reg) ")")
1227           (line-break)
1228           (write-inputs 'rhs-copy insn ":SI" (+ unspec 1))))))
1229
1230
1231 ;; Write a define_insn for INSN.
1232 (define (write-insn insn)
1233   (string-write "\n\n(define_insn \"" (md-insn:md-name insn) "\"\n")
1234   (write-construct "  [" "]"
1235     (let ((outputs (md-insn:outputs insn))
1236           (unspec (intrinsic:unspec (md-insn:intrinsic insn))))
1237       (if (null? outputs)
1238           (write-inputs 'rhs insn "" unspec)
1239           (begin
1240             (write-to-one-output 'rhs insn (car outputs) unspec)
1241             (number-list
1242              (lambda (output index)
1243                (line-break)
1244                (write-to-one-output 'rhs-copy insn output
1245                                     (+ unspec (* 2 index))))
1246              (cdr outputs) 1)))))
1247   (line-break)
1248
1249   ;; C predicate.
1250   (string-write "  \"CGEN_ENABLE_INSN_P (" (st (md-insn:index insn)) ")")
1251   (let ((hook (intrinsic:hook (md-insn:intrinsic insn))))
1252     (if (gcc-hook:condition hook)
1253         (string-write " && (" (gcc-hook:condition hook) ")")))
1254   (string-write "\"\n")
1255
1256   ;; assembly syntax
1257   (string-write "  \"")
1258   (write-syntax insn)
1259   (string-write "\"\n")
1260
1261   ;; attributes
1262   (write-construct "  [" "]"
1263     (write-list line-break (target:attributes insn)
1264                 (lambda (attribute)
1265                   (string-write "(set_attr \"" (car attribute)
1266                                 "\" \"" (cdr attribute) "\")"))))
1267   (string-write ")\n"))
1268
1269 (define (insns.md)
1270   (string-write
1271    "\n\n"
1272    ";; DO NOT EDIT: This file is automatically generated by CGEN.\n"
1273    ";; Any changes you make will be discarded when it is next regenerated.\n"
1274    "\n\n")
1275   (analyze-intrinsics!)
1276   (message "Generating .md file...\n")
1277
1278   (init-immediate-predicate!)
1279   (for-each-argument note-immediates)
1280
1281   ;; Define the immediate predicates.
1282   (for-each
1283    (lambda (entry)
1284      (let* ((op (cdr entry))
1285             (align-mask (- (md-operand:alignment op) 1)))
1286        (string-write
1287         "(define_predicate \""
1288         (car entry) "\"\n"
1289         "  (and (match_code \"const_int\")\n"
1290         "        (match_test \"(INTVAL (op) & " (st align-mask) ") == 0\n"
1291         "                   && INTVAL (op) >= " (st (md-operand:lower-bound op)) "\n"
1292         "                   && INTVAL (op) < " (st (md-operand:upper-bound op)) "\")))\n"
1293         "\n")))
1294    immediate-predicate-table)
1295
1296   (for-each-md-insn write-insn)
1297   (string-write "\n")
1298   "")
1299
1300
1301 ;; GCC SOURCE CODE GENERATOR
1302 ;; -------------------------
1303
1304 ;; Maps the names of immediate predicates to an example of an operand
1305 ;; which needs it.
1306 (deftable immediate-predicate)
1307
1308 ;; If OP is an immediate predicate, make sure that it has an entry
1309 ;; in IMMEDIATE-PREDICATES.
1310 (define (note-immediates insn op)
1311   (if (and (md-operand:immediate? op)
1312            (not (md-operand:label? op)))
1313       (let ((name (md-operand:immediate-predicate op)))
1314         (if (not (get-immediate-predicate name))
1315             (set-immediate-predicate! name op)))))
1316
1317 (define (enum-type op cptype)
1318   (cond
1319    ((is-h-cr64? (md-operand:hw op))
1320     (case cptype
1321       ((V8QI) "cgen_regnum_operand_type_V8QI")
1322       ((V4HI) "cgen_regnum_operand_type_V4HI")
1323       ((V2SI) "cgen_regnum_operand_type_V2SI")
1324       ((V8UQI) "cgen_regnum_operand_type_V8UQI")
1325       ((V4UHI) "cgen_regnum_operand_type_V4UHI")
1326       ((V2USI) "cgen_regnum_operand_type_V2USI")
1327       ((VECT) "cgen_regnum_operand_type_VECTOR")
1328       ((CP_DATA_BUS_INT) "cgen_regnum_operand_type_CP_DATA_BUS_INT")
1329       (else "cgen_regnum_operand_type_DI")))
1330    ((is-h-cr?   (md-operand:hw op))
1331     "cgen_regnum_operand_type_SI")
1332    (else
1333     (case (md-operand:cdata op)
1334       ((POINTER)         "cgen_regnum_operand_type_POINTER")
1335       ((LABEL)           "cgen_regnum_operand_type_LABEL")
1336       ((LONG)            "cgen_regnum_operand_type_LONG")
1337       ((ULONG)           "cgen_regnum_operand_type_ULONG")
1338       ((SHORT)           "cgen_regnum_operand_type_SHORT")
1339       ((USHORT)          "cgen_regnum_operand_type_USHORT")
1340       ((CHAR)            "cgen_regnum_operand_type_CHAR")
1341       ((UCHAR)           "cgen_regnum_operand_type_UCHAR")
1342       (else              "cgen_regnum_operand_type_DEFAULT")))))
1343
1344 ;; Write out the cgen_insn initialiser for INSN.
1345 (define (write-cgen-insn insn)
1346   (write-construct "  { " " }"
1347     (string-write (st (intrinsic:index (md-insn:intrinsic insn))))
1348
1349     (comma-line-break)
1350     (string-write (bitmask "ISA" (md-insn:isas insn)))
1351
1352     (comma-line-break)
1353     (string-write (bitmask "GROUP" (md-insn:groups insn)))
1354
1355     (comma-line-break)
1356     (string-write "CODE_FOR_" (md-insn:md-name insn))
1357
1358     (comma-line-break)
1359     (string-write (st (length (md-insn:arguments insn))))
1360
1361     (comma-line-break)
1362     (string-write (if (md-insn:cret? insn) "1" "0"))
1363
1364     (comma-line-break)
1365     (write-construct "{ " " }"
1366       (write-nonempty-list
1367         comma-break
1368         (find md-operand:arg-index (md-insn:operands insn))
1369         (lambda (op) (string-write (st (md-operand:arg-index op))))
1370         "0"))
1371
1372    (comma-line-break)
1373    (write-construct "{ " " }"
1374      (write-nonempty-list
1375         comma-break
1376         (md-insn:arguments insn)
1377         (lambda (op)
1378           (if (md-operand:regnum? op)
1379               (string-write
1380                "{ " (st (md-operand:upper-bound op))
1381                ", " (st (target:base-reg (md-operand:hw op))))
1382               (string-write "{ 0, 0"))
1383           (string-write ", " (enum-type op (md-insn:cptype insn))
1384                         ", " (if (and (not (equal? (md-operand:cdata op) 'REGNUM))
1385                                       (md-operand:write-index op))
1386                                  "1" "0")
1387                         " }"))
1388         "{ 0, 0, cgen_regnum_operand_type_DEFAULT, 0}"))
1389
1390     (target:initialize-fields insn)))
1391
1392 (define (intrinsics.h) ; i.e., mep-intrin.h
1393   (string-write
1394    "\n\n"
1395    "/* DO NOT EDIT: This file is automatically generated by CGEN.\n"
1396    "   Any changes you make will be discarded when it is next regenerated. */\n"
1397    "\n")
1398   (analyze-intrinsics!)
1399   (message "Generating gcc include file...\n")
1400   (init-immediate-predicate!)
1401   (for-each-argument note-immediates)
1402
1403   (string-write "#ifdef WANT_GCC_DECLARATIONS\n")
1404
1405   ;; Declare the range of shadow registers
1406   (string-write "#define FIRST_SHADOW_REGISTER "
1407                 (st target:first-unused-register) "\n")
1408   (string-write "#define LAST_SHADOW_REGISTER "
1409                 (st (+ target:first-unused-register
1410                        (length shadow-registers)
1411                        -1)) "\n")
1412   (string-write "#define FIXED_SHADOW_REGISTERS \\\n  ")
1413   (write-list comma-break
1414               shadow-registers
1415               (lambda (entry) (string-write "1")))
1416   (string-write "\n")
1417   (string-write "#define CALL_USED_SHADOW_REGISTERS FIXED_SHADOW_REGISTERS\n")
1418   (string-write "#define SHADOW_REG_ALLOC_ORDER \\\n  ")
1419   (write-list comma-break
1420               shadow-registers
1421               (lambda (entry) (string-write (st (cdr entry)))))
1422   (string-write "\n")
1423   (string-write "#define SHADOW_REGISTER_NAMES \\\n  ")
1424   (write-list comma-break
1425               shadow-registers
1426               (lambda (entry)
1427                 (string-write "\"$shadow" (st (car entry)) "\"")))
1428   (string-write "\n\n")
1429
1430   ;; Declare the index values for well-known intrinsics.
1431   (string-write "\n\n#ifndef __MEP__\n")
1432   (string-write "enum {\n")
1433   (write-list comma-line-break
1434               (find intrinsic:hook intrinsics)
1435               (lambda (intrinsic)
1436                 (string-write "  " (intrinsic:name intrinsic)
1437                               " = " (st (intrinsic:index intrinsic)))))
1438   (string-write "\n};\n")
1439   (string-write "#endif /* ! defined (__MEP__) */\n")
1440
1441   ;; Define the structure used to describe intrinsic insns.
1442   (string-write
1443    "\n\n"
1444    "enum cgen_regnum_operand_type {\n"
1445    "  cgen_regnum_operand_type_POINTER,         /* long *          */\n"
1446    "  cgen_regnum_operand_type_LABEL,           /* void *          */\n"
1447    "  cgen_regnum_operand_type_LONG,            /* long            */\n"
1448    "  cgen_regnum_operand_type_ULONG,           /* unsigned long   */\n"
1449    "  cgen_regnum_operand_type_SHORT,           /* short           */\n"
1450    "  cgen_regnum_operand_type_USHORT,          /* unsigned short  */\n"
1451    "  cgen_regnum_operand_type_CHAR,            /* char            */\n"
1452    "  cgen_regnum_operand_type_UCHAR,           /* unsigned char   */\n"
1453    "  cgen_regnum_operand_type_SI,           /* __cop long      */\n"
1454    "  cgen_regnum_operand_type_DI,           /* __cop long long */\n"
1455    "  cgen_regnum_operand_type_CP_DATA_BUS_INT, /* cp_data_bus_int */\n"
1456    "  cgen_regnum_operand_type_VECTOR,          /* opaque vector type */\n"
1457    "  cgen_regnum_operand_type_V8QI,            /* V8QI vector type */\n"
1458    "  cgen_regnum_operand_type_V4HI,            /* V4HI vector type */\n"
1459    "  cgen_regnum_operand_type_V2SI,            /* V2SI vector type */\n"
1460    "  cgen_regnum_operand_type_V8UQI,           /* V8UQI vector type */\n"
1461    "  cgen_regnum_operand_type_V4UHI,           /* V4UHI vector type */\n"
1462    "  cgen_regnum_operand_type_V2USI,           /* V2USI vector type */\n"
1463    "  cgen_regnum_operand_type_DEFAULT = cgen_regnum_operand_type_LONG\n"
1464    "};\n"
1465    "\n"
1466    "struct cgen_regnum_operand {\n"
1467    "  /* The number of addressable registers, 0 for non-regnum operands.  */\n"
1468    "  unsigned char count;\n"
1469    "\n"
1470    "  /* The first register.  */\n"
1471    "  unsigned char base;\n"
1472    "\n"
1473    "  /* The type of the operand.  */\n"
1474    "  enum cgen_regnum_operand_type type;\n"
1475    "\n"
1476    "  /* Is it passed by reference?  */\n"
1477    "  int reference_p;\n"
1478    "};\n\n"
1479    "struct cgen_insn {\n"
1480    "  /* An index into cgen_intrinsics[].  */\n"
1481    "  unsigned int intrinsic;\n"
1482    "\n"
1483    "  /* A bitmask of the ISAs which include this instruction.  */\n"
1484    "  unsigned int isas;\n"
1485    "\n"
1486    "  /* A bitmask of the target-specific groups to which this instruction\n"
1487    "     belongs.  */\n"
1488    "  unsigned int groups;\n"
1489    "\n"
1490    "  /* The insn_code for this instruction.  */\n"
1491    "  int icode;\n"
1492    "\n"
1493    "  /* The number of arguments to the intrinsic function.  */\n"
1494    "  unsigned int num_args;\n"
1495    "\n"
1496    "  /* If true, the first argument is the return value.  */\n"
1497    "  unsigned int cret_p;\n"
1498    "\n"
1499    "  /* Maps operand numbers to argument numbers.  */\n"
1500    "  unsigned int op_mapping[10];\n"
1501    "\n"
1502    "  /* Array of regnum properties, indexed by argument number.  */\n"
1503    "  struct cgen_regnum_operand regnums[10];\n"
1504    (target:declare-fields)
1505    "};\n")
1506
1507   ;; Declare the arrays that we define later.
1508   (string-write
1509    "\n"
1510    "extern const struct cgen_insn cgen_insns[];\n"
1511    "extern const char *const cgen_intrinsics[];\n")
1512
1513   ;; Macro used by the .md file.
1514   (string-write
1515    "\n"
1516    "/* Is the instruction described by cgen_insns[INDEX] enabled?  */\n"
1517    "#define CGEN_ENABLE_INSN_P(INDEX) \\\n"
1518    "  ((CGEN_CURRENT_ISAS & cgen_insns[INDEX].isas) != 0 \\\n"
1519    "   && (CGEN_CURRENT_GROUP & cgen_insns[INDEX].groups) != 0)\n\n")
1520
1521   (define-bitmasks "ISA"
1522     (remove-duplicates (sort (map convert-isa intrinsics-isas) string<?)))
1523
1524   (define-bitmasks "GROUP" md-insn-groups)
1525
1526   (string-write "#endif\n")
1527
1528   (string-write "#ifdef WANT_GCC_DEFINITIONS\n")
1529
1530   ;; Create an array describing the range and alignment of immediate
1531   ;; predicates.
1532   (string-write
1533    "struct cgen_immediate_predicate {\n"
1534    "  insn_operand_predicate_fn predicate;\n"
1535    "  int lower, upper, align;\n"
1536    "};\n\n"
1537    "const struct cgen_immediate_predicate cgen_immediate_predicates[] = {\n")
1538
1539   (write-list comma-line-break immediate-predicate-table
1540               (lambda (entry)
1541                 (let ((op (cdr entry)))
1542                   (string-write
1543                    "  { " (car entry)
1544                    ", " (st (md-operand:lower-bound op))
1545                    ", " (st (md-operand:upper-bound op))
1546                    ", " (st (md-operand:alignment op)) " }"))))
1547
1548   (string-write "\n};\n\n")
1549
1550   ;; Create an array containing the names of all the available intrinsinics.
1551   (string-write "const char *const cgen_intrinsics[] = {\n")
1552   (write-list comma-line-break intrinsics
1553               (lambda (intrinsic)
1554                 (string-write "  \"" (intrinsic:name intrinsic) "\"")))
1555   (string-write "\n};\n\n")
1556
1557   ;; Create an array describing each .md file instruction.
1558   (string-write "const struct cgen_insn cgen_insns[] = {\n")
1559   (write-list comma-line-break md-insns write-cgen-insn)
1560   (string-write "\n};\n")
1561
1562   (string-write "#endif\n"))
1563
1564
1565 ;; PROTOTYPE GENERATOR
1566 ;; -------------------
1567
1568 (define (runtime-type op cptype retval)
1569   (sa (case (md-operand:cdata op)
1570         ((POINTER) "long *")
1571         ((LABEL) "void *")
1572         ((LONG) "long")
1573         ((ULONG) "unsigned long")
1574         ((SHORT) "short")
1575         ((USHORT) "unsigned short")
1576         ((CHAR) "char")
1577         ((UCHAR) "unsigned char")
1578         ((CP_DATA_BUS_INT)
1579          ;;(logit 0 "op " (md-operand:cdata op) " cptype " cptype "\n")
1580          (case cptype
1581            ((V2SI) "cp_v2si")
1582            ((V4HI) "cp_v4hi")
1583            ((V8QI) "cp_v8qi")
1584            ((V2USI) "cp_v2usi")
1585            ((V4UHI) "cp_v4uhi")
1586            ((V8UQI) "cp_v8uqi")
1587            ((VECT) "cp_vector")
1588             (else "cp_data_bus_int")))
1589         (else "long"))
1590       (if (and (not (equal? (md-operand:cdata op) 'REGNUM))
1591                (md-operand:write-index op)
1592                (not retval))
1593           "*" "")))
1594
1595 (define (intrinsic-protos.h) ; i.e., intrinsics.h
1596   (string-write
1597    "\n\n"
1598    "/* DO NOT EDIT: This file is automatically generated by CGEN.\n"
1599    "   Any changes you make will be discarded when it is next regenerated.\n"
1600    "*/\n\n"
1601    "/* GCC defines these internally, as follows... \n";
1602    "#if __MEP_CONFIG_CP_DATA_BUS_WIDTH == 64\n"
1603    "  typedef long long cp_data_bus_int;\n"
1604    "#else\n"
1605    "  typedef long cp_data_bus_int;\n"
1606    "#endif\n"
1607    "typedef          char  cp_v8qi  __attribute__((vector_size(8)));\n"
1608    "typedef unsigned char  cp_v8uqi __attribute__((vector_size(8)));\n"
1609    "typedef          short cp_v4hi  __attribute__((vector_size(8)));\n"
1610    "typedef unsigned short cp_v4uhi __attribute__((vector_size(8)));\n"
1611    "typedef          int   cp_v2si  __attribute__((vector_size(8)));\n"
1612    "typedef unsigned int   cp_v2usi __attribute__((vector_size(8)));\n"
1613    "*/\n\n")
1614   (analyze-intrinsics!)
1615   (message "Generating prototype file...\n")
1616   (target:for-each-isa!
1617    (lambda (name isa)
1618      (string-write "\n// " name "\n")
1619      (for-each
1620       (lambda (intrinsic)
1621         (let ((entry (assoc isa (intrinsic:isas intrinsic))))
1622           (if entry
1623               (let* ((insn (cdr entry))
1624                      (arguments (md-insn:arguments insn))
1625                      (retval (if (md-insn:cret? insn)
1626                                  (runtime-type (car arguments) (md-insn:cptype insn) #t)
1627                                  "void"))
1628                      (proto (sa retval " " (intrinsic:name intrinsic)
1629                                 " (" (stringize (map (lambda (arg)
1630                                                        (runtime-type arg
1631                                                                      (md-insn:cptype insn) #f))
1632                                                        (if (md-insn:cret? insn)
1633                                                            (cdr arguments)
1634                                                            arguments)
1635                                                        )
1636                                                 ", ")
1637                                 ");"))
1638                      (proto-len (string-length proto))
1639                      (attrs '()))
1640
1641                 (if (md-insn:volatile? insn)
1642                     (set! attrs (cons "volatile" attrs)))
1643
1644                 (string-write proto)
1645                 (if (pair? attrs)
1646                     (string-write (make-string (max 1 (- 40 proto-len))
1647                                                #\space)
1648                                   "// " (stringize attrs " ")))
1649                 (string-write "\n")))))
1650       intrinsics)))
1651   "")
1652
1653
1654 ;; The rest of this file has not been converted to use the INTRINSICS
1655 ;; attribute.  The code isn't used at the moment anyway.
1656
1657 (define (intrinsic-testsuite.c)
1658   (map-intrinsics!)
1659   (for-each (maybe-do-all declare-intrinsic-test) intrinsic-insns)
1660   (string-write "\n")
1661   "")
1662
1663 (define (test-val is-retval? op vbase)
1664   (let ((mode (op:mode op))
1665         (cdata (obj-attr-value op 'CDATA)))
1666     (cond
1667      ((equal? cdata 'REGNUM) "7")
1668      ((equal? cdata 'LABEL) "&&lab")
1669      ((treat-op-as-immediate? op)
1670       (let* ((field (fetch-ifield-for-op-in-current-insn op))
1671              (align-bits (case (obj:name field)
1672                            ((f-8s8a2 f-12s4a2 f-17s16a2 f-24s5a2n f-24u5a2n f-7u9a2 f-8s24a2) 1)
1673                            ((f-7u9a4 f-8s24a4 f-24u8a4n) 2)
1674                            ((f-8s24a8) 3)
1675                            (else 0)))
1676              (val (ash (send field 'max-value) align-bits)))
1677         (string-append "0x" (number->string val 16))))
1678      (else (let* ((expr-suffix (if is-retval? ""
1679                                    (if (get-gcc-write-index op) "" " + 1")))
1680                   (val
1681                    (case cdata
1682                      ((POINTER) "p")
1683                      ((LONG) "l")
1684                      ((ULONG) "ul")
1685                      ((SHORT) "s")
1686                      ((USHORT) "us")
1687                      ((CHAR) "c")
1688                      ((UCHAR) "uc")
1689                      ((CP_DATA_BUS_INT) "cpdbi")
1690                      (else "l"))))
1691              (sa vbase val expr-suffix))))))
1692
1693 (define (declare-intrinsic-test name insn others)
1694   (set! curr-insn insn)
1695   (scan-syntax insn)
1696   (scan-read-write insn)
1697
1698   (let* ((mnem (insn-mnemonic insn))
1699          (syntax (insn-syntax insn))
1700          (first #t)
1701          (comma-not-first (lambda () (if first (begin (set! first #f) "") ", ")))
1702          (vars '("x" "y" "z" "t" "w"))
1703          (operands syntactic-operands))
1704
1705     (cond ((equal? mnem "--unused--") '())
1706           ((equal? mnem "--reserved--") '())
1707           (else
1708            (begin
1709              (string-write (target:builtin-name (intrinsic-name insn)) " (")
1710              (for-each (lambda (operand)
1711                          (string-write (sa (comma-not-first)
1712                                            (test-val #f operand (car vars))
1713                                            ))
1714                          (set! vars (cdr vars))) operands)
1715              (string-write ");\n")))
1716           )))