cgen/gas-test.scm

   1 ; CPU description file generator for the GNU assembler testsuite.
   2 ; Copyright (C) 2000, 2001, 2009 Red Hat, Inc.
   3 ; This file is part of CGEN.
   4 ; See file COPYING.CGEN for details.
   5
   6 ; This is invoked to build allinsn.exp and a script to run to
   7 ; generate allinsn.s and allinsn.d.
   8
   9 ; Specify which application.
  10 (set! APPLICATION 'GAS-TEST)
  11 \f
  12 ; Called before/after the .cpu file has been read.
  13
  14 (define (gas-test-init!) (opcodes-init!))
  15 (define (gas-test-finish!) (opcodes-finish!))
  16
  17 ; Called after .cpu file has been read and global error checks are done.
  18 ; We use the `tmp' member to record the syntax split up into its components.
  19
  20 (define (gas-test-analyze!)
  21   (opcodes-analyze!)
  22   (map (lambda (insn)
  23          (elm-xset! insn 'tmp (syntax-break-out (insn-syntax insn))))
  24        (non-multi-insns (current-insn-list)))
  25   *UNSPECIFIED*
  26 )
  27 \f
  28 ; Methods to compute test data.
  29 ; The result is a list of strings to be inserted in the assembler
  30 ; in the operand's position.
  31
  32 ; For a general assembler operand, just turn the value into a string.
  33
  34 (method-make!
  35  <hw-asm> 'test-data
  36  (lambda (self ops)
  37    (map (lambda (op)
  38           (cond ((null? op) "")
  39                 ((number? op) (number->string op))
  40                 (else (error "unsupported assembler operand" op))))
  41         ops))
  42 )
  43
  44 ; For a keyword operand, choose the appropriate keyword.
  45 ; OPS is a list of values, e.g. from an ifield.
  46
  47 (method-make!
  48  <keyword> 'test-data
  49  (lambda (self ops)
  50    (let* ((test-cases (elm-get self 'values))
  51           (prefix (elm-get self 'name-prefix))
  52           (find-kw (lambda (val)
  53                      (find-first (lambda (kw) (= (cadr kw) val)) test-cases))))
  54      (map (lambda (n)
  55             ;; If an ifield has, e.g., 2 bits (values 0,1,2,3) and the keyword
  56             ;; only has two values, e.g. (foo 0) (bar 1), then we can get
  57             ;; invalid requests, i.e. for ifield values of 2 and 3.
  58             ;; It's not clear what to do here, but it seems like this is an
  59             ;; error in the description file.
  60             ;; So it seems like we should flag an error for invalid requests.
  61             ;; OTOH, we're just generating testcases.  So instead we just
  62             ;; flag a warning and cope by returning the first keyword in the
  63             ;; list.
  64             (let ((kw (find-kw n)))
  65               (if (not kw)
  66                   (begin
  67                     (message "WARNING: Invalid test data request for keyword "
  68                              (obj:name self)
  69                              ": "
  70                              n
  71                              ".\n"
  72                              "         Compensating by picking a different value.\n")
  73                     (set! kw (car test-cases))))
  74               (string-append
  75                (if (and (not (string=? prefix ""))
  76                         (eq? (string-ref prefix 0) #\$))
  77                    "\\" "")
  78                prefix
  79                (->string (car kw)))))
  80           ops)))
  81 )
  82
  83 (method-make!
  84  <hw-address> 'test-data
  85  (lambda (self ops)
  86    (let* ((test-cases '("foodata" "4" "footext" "-4"))
  87           (nr-ops (length ops))
  88           (selection (map (lambda (z) (random (length test-cases)))
  89                           (iota nr-ops))))
  90      (map (lambda (n) (list-ref test-cases n)) selection)))
  91 )
  92
  93 (method-make!
  94  <hw-iaddress> 'test-data
  95  (lambda (self ops)
  96    (let* ((test-cases '("footext" "4" "foodata" "-4"))
  97           (nr-ops (length ops))
  98           (selection (map (lambda (z) (random (length test-cases)))
  99                           (iota nr-ops))))
 100      (map (lambda (n) (list-ref test-cases n)) selection)))
 101 )
 102
 103 (method-make-forward! <hw-register> 'indices '(test-data))
 104 (method-make-forward! <hw-immediate> 'values '(test-data))
 105
 106 ; Test data for a field is chosen firstly out of some bit patterns,
 107 ; then randomly.  It is then interpreted based on whether there
 108 ; is a decode method.
 109
 110 (method-make!
 111  <ifield> 'test-data
 112  (lambda (self n)
 113    (let* ((bf-len (ifld-length self))
 114           (field-max (inexact->exact (round (expt 2 bf-len))))
 115           (highbit (quotient field-max 2))
 116           (values (map (lambda (n)
 117                          (case n
 118                            ((0) 0)
 119                            ((1) (- field-max 1))
 120                            ((2) highbit)
 121                            ((3) (- highbit 1))
 122                            ((4) 1)
 123                            (else (random field-max))))
 124                        (iota n)))
 125           (decode (ifld-decode self)))
 126      (if decode
 127          ; FIXME: need to run the decoder.
 128          values
 129          ; no decode method
 130          (case (mode:class (ifld-mode self))
 131            ((INT) (map (lambda (n) (if (>= n highbit) (- n field-max) n))
 132                        values))
 133            ((UINT) values)
 134            (else (error "unsupported mode class"
 135                         (mode:class (ifld-mode self))))))))
 136 )
 137
 138 ;; Return N values for assembler test data, or nil if there are none
 139 ;; (e.g. scalars).
 140 ;; ??? This also returns nil for str-expr and rtx.
 141
 142 (method-make!
 143  <hw-index> 'test-data
 144  (lambda (self n)
 145    (case (hw-index:type self)
 146      ((ifield operand) (send (hw-index:value self) 'test-data n))
 147      ((constant) (make-list n (hw-index:value self)))
 148      ((scalar) (make-list n nil))
 149      ((str-expr rtx) (make-list n nil)) ;; ???
 150      (else (error "invalid hw-index type" (hw-index:type self)))))
 151 )
 152
 153 (method-make!
 154  <operand> 'test-data
 155  (lambda (self n)
 156    (send (op:type self) 'test-data (send (op:index self) 'test-data n)))
 157 )
 158
 159 ; Given an operand, return a set of N test data.
 160 ; e.g. For a keyword operand, return a random subset.
 161 ; For a number, return N numbers.
 162
 163 (define (operand-test-data op n)
 164   (send op 'test-data n)
 165 )
 166
 167 ; Given the broken out assembler syntax string, return the list of operand
 168 ; objects.
 169
 170 (define (extract-operands syntax-list)
 171   (let loop ((result nil) (l syntax-list))
 172     (cond ((null? l) (reverse! result))
 173           ((object? (car l)) (loop (cons (car l) result) (cdr l)))
 174           (else (loop result (cdr l)))))
 175 )
 176
 177 ; Collate a list of operands into a test test.
 178 ; Input is a list of operand lists. Returns a collated set of test
 179 ; inputs. For example:
 180 ; ((r0 r1 r2) (r3 r4 r5) (2 3 8)) => ((r0 r3 2) (r1 r4 3) (r2 r5 8))
 181 ; L is a list of lists.  All elements must have the same length.
 182
 183 (define (/collate-test-set L)
 184   (if (= (length (car L)) 0)
 185       '()
 186       (cons (map car L)
 187             (/collate-test-set (map cdr L))))
 188 )
 189
 190 ; Given a list of operands for an instruction, return the test set
 191 ; (all possible combinations).
 192 ; N is the number of testcases for each operand.
 193 ; The result has N to-the-power (length OP-LIST) elements.
 194
 195 (define (build-test-set op-list n)
 196   (let ((test-data (map (lambda (op) (operand-test-data op n)) op-list))
 197         (len (length op-list)))
 198     (cond ((= len 0) (list (list)))
 199           (else (/collate-test-set test-data))))
 200 )
 201
 202 ; Given an assembler expression and a set of operands build a testcase.
 203 ; TEST-DATA is a list of strings, one element per operand.
 204
 205 (define (build-asm-testcase syntax-list test-data)
 206   (let loop ((result nil) (sl syntax-list) (td test-data))
 207     ;(display (list result sl td "\n"))
 208     (cond ((null? sl)
 209            (string-append "\t"
 210                           (apply string-append (reverse result))
 211                           "\n"))
 212           ((string? (car sl))
 213            (loop (cons (car sl) result) (cdr sl) td))
 214           (else (loop (cons (car td) result) (cdr sl) (cdr td)))))
 215 )
 216
 217 ; Generate the testsuite for INSN.
 218 ; FIXME: make the number of cases an argument to this application.
 219
 220 (define (gen-gas-test insn)
 221   (logit 2 "Generating gas test data for " (obj:name insn) " ...\n")
 222   (string-append
 223    "\t.text\n"
 224    "\t.global " (gen-sym insn) "\n"
 225    (gen-sym insn) ":\n"
 226    (let* ((syntax-list (insn-tmp insn))
 227           (op-list (extract-operands syntax-list))
 228           (test-set (build-test-set op-list 8)))
 229      (string-map (lambda (test-data)
 230                    (build-asm-testcase syntax-list test-data))
 231                  test-set))
 232    )
 233 )
 234
 235 ; Generate the shell script that builds the .d file.
 236 ; .d files contain the objdump result that is used to see whether the
 237 ; testcase passed.
 238 ; We do this by running gas and objdump.
 239 ; Obviously this isn't quite right - bugs in gas or
 240 ; objdump - the things we're testing - will cause an incorrect testsuite to
 241 ; be built and thus the bugs will be missed.  It is *not* intended that this
 242 ; be run immediately before running the testsuite!  Rather, this is run to
 243 ; generate the testsuite which is then inspected for accuracy and checked
 244 ; into CVS.  As bugs in the testsuite are found they are corrected by hand.
 245 ; Or if they're due to bugs in the generator the generator can be rerun and
 246 ; the output diff'd to ensure no errors have crept back in.
 247 ; The point of doing things this way is TO SAVE A HELL OF A LOT OF TYPING!
 248 ; Clearly some hand generated testcases will also be needed, but this
 249 ; provides a good test for each instruction.
 250
 251 (define (cgen-build.sh)
 252   (logit 1 "Generating gas-build.sh ...\n")
 253   (string-append
 254    "\
 255 #/bin/sh
 256 # Generate test result data for " (->string (current-arch-name)) " GAS testing.
 257 # This script is machine generated.
 258 # It is intended to be run in the testsuite source directory.
 259 #
 260 # Syntax: build.sh /path/to/build/gas
 261
 262 if [ $# = 0 ] ; then
 263   if [ ! -x ../gas/as-new ] ; then
 264     echo \"Usage: $0 [/path/to/gas/build]\"
 265   else
 266     BUILD=`pwd`/../gas
 267   fi
 268 else
 269   BUILD=$1
 270 fi
 271
 272 if [ ! -x $BUILD/as-new ] ; then
 273   echo \"$BUILD is not a gas build directory\"
 274   exit 1
 275 fi
 276
 277 # Put results here, so we preserve the existing set for comparison.
 278 rm -rf tmpdir
 279 mkdir tmpdir
 280 cd tmpdir
 281
 282 function gentest {
 283     rm -f a.out
 284     $BUILD/as-new ${1}.s -o a.out
 285     echo \"#as:\" >${1}.d
 286     echo \"#objdump: -dr\" >>${1}.d
 287     echo \"#name: $1\" >>${1}.d
 288     $BUILD/../binutils/objdump -dr a.out | \
 289         sed -e 's/(/\\\\(/g' \
 290             -e 's/)/\\\\)/g' \
 291             -e 's/\\$/\\\\$/g' \
 292             -e 's/\\[/\\\\\\[/g' \
 293             -e 's/\\]/\\\\\\]/g' \
 294             -e 's/[+]/\\\\+/g' \
 295             -e 's/[.]/\\\\./g' \
 296             -e 's/[*]/\\\\*/g' | \
 297         sed -e 's/^.*file format.*$/.*: +file format .*/' \
 298         >>${1}.d
 299     rm -f a.out
 300 }
 301
 302 # Now come all the testcases.
 303 cat > allinsn.s <<EOF
 304  .data
 305 foodata: .word 42
 306  .text
 307 footext:\n"
 308     (string-map (lambda (insn)
 309                   (gen-gas-test insn))
 310                 (non-multi-insns (current-insn-list)))
 311     "EOF\n"
 312     "\n"
 313     "# Finally, generate the .d file.\n"
 314     "gentest allinsn\n"
 315    )
 316 )
 317
 318 ; Generate the dejagnu allinsn.exp file that drives the tests.
 319
 320 (define (cgen-allinsn.exp)
 321   (logit 1 "Generating allinsn.exp ...\n")
 322   (string-append
 323    "\
 324 # " (string-upcase (->string (current-arch-name))) " assembler testsuite. -*- Tcl -*-
 325
 326 if [istarget " (->string (current-arch-name)) "*-*-*] {
 327     run_dump_test \"allinsn\"
 328 }\n"
 329    )
 330 )