cgen/operand.scm

   1 ; Operands
   2 ; Copyright (C) 2000, 2001, 2005, 2009, 2010 Red Hat, Inc.
   3 ; This file is part of CGEN.
   4 ; See file COPYING.CGEN for details.
   5
   6 ; Operands map a set of values (registers, whatever) to an instruction field
   7 ; or other indexing mechanism.  Operands are also how the semantic code refers
   8 ; to hardware elements.
   9
  10 ; The `<operand>' class.
  11 ;
  12 ; ??? Need a new lighterweight version for instances in semantics.
  13 ; This should only contain the static elements from the description file.
  14 ;
  15 ; ??? Derived operands don't use all the current class members.  Perhaps
  16 ; split <operand> into two.
  17
  18 (define <operand>
  19   (class-make '<operand>
  20               '(<source-ident>)
  21               '(
  22                 ; Name as used in semantic code.
  23                 ; Generally this is the same as NAME.  It is changed by the
  24                 ; `operand:' rtx function.  One reason is to set a "pretty"
  25                 ; name in tracing output (most useful in memory operands).
  26                 ; A more important reason is to help match semantic operands
  27                 ; with function unit input/output arguments.
  28                 sem-name
  29
  30                 ; Pretty name as used in tracing code.
  31                 ; Generally this is the same as the hardware element's name.
  32                 pretty-sem-name
  33
  34                 ; Semantic name of hardware element refered to by this operand.
  35                 hw-name
  36
  37                 ; Hardware type of operand, a subclass of <hardware-base>.
  38                 ; This is computed lazily from HW-NAME as many hardware
  39                 ; elements can have the same semantic name.  Applications
  40                 ; that require a unique hardware element to be refered to are
  41                 ; required to ensure duplicates are discarded (usually done
  42                 ; by keeping the appropriate machs).
  43                 ; All h/w elements with the same semantic name are required
  44                 ; to be the same kind (register, immediate, etc.).
  45                 ; FIXME: Rename to hw.
  46                 (type . #f)
  47
  48                 ; Name of mode, as specified in description file.
  49                 ; This needn't be the actual mode, as WI will get coerced
  50                 ; to the actual word int mode.
  51                 mode-name
  52
  53                 ; The mode TYPE is being referenced in.
  54                 ; This is also looked up lazily for the same reasons as TYPE.
  55                 (mode . #f)
  56
  57                 ; Selector.
  58                 ; A number or #f used to select a variant of the hardware
  59                 ; element.  An example is ASI's on sparc.
  60                 ; ??? I really need to be better at picking names.
  61                 (selector . #f)
  62
  63                 ; Index into type, class <hw-index>.
  64                 ; For example in the case of an array of registers
  65                 ; it can be an instruction field or in the case of a memory
  66                 ; reference it can be a register operand (or general rtx).
  67                 ; ??? At present <hw-index> is a facade over the real index
  68                 ; type.  Not sure what the best way to do this is.
  69                 (index . #f)
  70
  71                 ; Code to run when the operand is read or #f meaning pass
  72                 ; the request on to the hardware object.
  73                 (getter . #f)
  74
  75                 ; Code to run when the operand is written or #f meaning pass
  76                 ; the request on to the hardware object.
  77                 (setter . #f)
  78
  79                 ; Associative list of (symbol . "handler") entries.
  80                 ; Each entry maps an operation to its handler (which is up to
  81                 ; the application but is generally a function name).
  82                 (handlers . ())
  83
  84                 ; Ordinal number of the operand in an insn's semantic
  85                 ; description.  There is no relation between the number and
  86                 ; where in the semantics the operand appears.  An operand that
  87                 ; is both read and written are given separate ordinal numbers
  88                 ; (inputs are treated separately from outputs).
  89                 (num . -1)
  90
  91                 ; Boolean indicating if the operand is conditionally
  92                 ; referenced.  #f means the operand is always referenced by
  93                 ; the instruction.
  94                 (cond? . #f)
  95
  96                 ; whether (and by how much) this instance of the operand is
  97                 ; delayed.
  98                 (delayed . #f)
  99                 )
 100               nil)
 101 )
 102
 103 ; The default make! assigns the default h/w selector.
 104
 105 (method-make!
 106  <operand> 'make!
 107  (lambda (self location name comment attrs
 108                hw-name mode-name index handlers getter setter)
 109    (elm-set! self 'location location)
 110    (elm-set! self 'name name)
 111    (elm-set! self 'sem-name name)
 112    (elm-set! self 'pretty-sem-name hw-name)
 113    (elm-set! self 'comment comment)
 114    (elm-set! self 'attrs attrs)
 115    (elm-set! self 'hw-name hw-name)
 116    (elm-set! self 'mode-name mode-name)
 117    (elm-set! self 'selector hw-selector-default)
 118    (elm-set! self 'index index)
 119    (elm-set! self 'handlers handlers)
 120    (elm-set! self 'getter getter)
 121    (elm-set! self 'setter setter)
 122    self)
 123 )
 124
 125 ; FIXME: The prefix field- doesn't seem right.  Indices needn't be
 126 ; ifields, though for operands defined in .cpu files they usually are.
 127 (method-make-forward! <operand> 'index '(field-start field-length))
 128
 129 ; Accessor fns
 130
 131 (define op:sem-name (elm-make-getter <operand> 'sem-name))
 132 (define op:set-sem-name! (elm-make-setter <operand> 'sem-name))
 133 (define op:set-pretty-sem-name! (elm-make-setter <operand> 'pretty-sem-name))
 134 (define op:hw-name (elm-make-getter <operand> 'hw-name))
 135 (define op:mode-name (elm-make-getter <operand> 'mode-name))
 136 (define op:selector (elm-make-getter <operand> 'selector))
 137 ; FIXME: op:index should be named op:hwindex.
 138 (define op:index (elm-make-getter <operand> 'index))
 139 (define op:handlers (elm-make-getter <operand> 'handlers))
 140 (define op:getter (elm-make-getter <operand> 'getter))
 141 (define op:setter (elm-make-getter <operand> 'setter))
 142 (define op:num (elm-make-getter <operand> 'num))
 143 (define op:set-num! (elm-make-setter <operand> 'num))
 144 (define op:cond? (elm-make-getter <operand> 'cond?))
 145 (define op:set-cond?! (elm-make-setter <operand> 'cond?))
 146 (define op:delay (elm-make-getter <operand> 'delayed))
 147 (define op:set-delay! (elm-make-setter <operand> 'delayed))
 148
 149 ; Compute the hardware type lazily.
 150 ; FIXME: op:type should be named op:hwtype or some such.
 151
 152 (define op:type
 153   (let ((getter (elm-make-getter <operand> 'type)))
 154     (lambda (op)
 155       (let ((type (getter op)))
 156         (if type
 157             type
 158             (let* ((hw-name (op:hw-name op))
 159                    (hw-objs (current-hw-sem-lookup hw-name)))
 160               (if (!= (length hw-objs) 1)
 161                   (error "cannot resolve h/w reference" hw-name))
 162               ((elm-make-setter <operand> 'type) op (car hw-objs))
 163               (car hw-objs))))))
 164 )
 165
 166 ; Compute the operand's mode lazily (depends on hardware type which is
 167 ; computed lazily).
 168
 169 (define op:mode
 170   (let ((getter (elm-make-getter <operand> 'mode)))
 171     (lambda (op)
 172       (let ((mode (getter op)))
 173         (if mode
 174             mode
 175             (let ((mode-name (op:mode-name op))
 176                   (type (op:type op)))
 177               (let ((mode (if (eq? mode-name 'DFLT)
 178                               (hw-default-mode type)
 179                               (mode:lookup mode-name))))
 180                 ((elm-make-setter <operand> 'mode) op mode)
 181                 mode))))))
 182 )
 183
 184 (method-make! <operand> 'get-mode (lambda (self) (op:mode self)))
 185
 186 ; FIXME: wip
 187 ; Result is the <ifield> object or #f if there is none.
 188
 189 (define (op-ifield op)
 190   (logit 4 "  op-ifield op= " (obj:name op)
 191          ", indx= " (obj:name (op:index op)) "\n")
 192   (let ((indx (op:index op)))
 193     (if indx
 194         (let ((maybe-ifld (hw-index:value (op:index op))))
 195           (logit 4 "  ifld=" (obj:name maybe-ifld) "\n")
 196           (cond ((ifield? maybe-ifld) maybe-ifld)
 197                 ((derived-ifield? maybe-ifld) maybe-ifld)
 198                 ((ifield? indx) indx)
 199                 ((derived-ifield? indx) indx)
 200                 (else #f)))
 201         #f))
 202 )
 203
 204 ; Return mode to use for index or #f if scalar.
 205 ; This can't use method-make-forward! as we need to call op:type to
 206 ; resolve the hardware reference.
 207
 208 (method-make!
 209  <operand> 'get-index-mode
 210  (lambda (self) (send (op:type self) 'get-index-mode))
 211 )
 212
 213 ; Return the operand's enum.
 214
 215 (define (op-enum op)
 216   (string-upcase (string-append "@ARCH@_OPERAND_" (gen-sym op)))
 217 )
 218
 219 ; Return a boolean indicating if X is an operand.
 220
 221 (define (operand? x) (class-instance? <operand> x))
 222
 223 ; Default gen-pretty-name method.
 224 ; Return a C string of the name intended for users.
 225 ;
 226 ; FIXME: The current implementation is a quick hack.  Parallel execution
 227 ; support can create operands with long names.  e.g. h-memory-add-WI-src2-slo16
 228 ; The eventual way this will be handled is to record with each operand the
 229 ; entry number (or some such) in the operand instance table so that for
 230 ; registers we can compute the register's name.
 231
 232 (method-make!
 233  <operand> 'gen-pretty-name
 234  (lambda (self mode)
 235    (let* ((name (->string (if (elm-bound? self 'pretty-sem-name)
 236                               (elm-get self 'pretty-sem-name)
 237                               (if (elm-bound? self 'sem-name)
 238                                   (elm-get self 'sem-name)
 239                                   (obj:name self)))))
 240           (pname (cond ((string=? "h-memory" (string-take 8 name)) "memory")
 241                        ((string=? "h-" (string-take 2 name)) (string-drop 2 name))
 242                        (else name))))
 243      (string-append "\"" pname "\"")))
 244 )
 245 \f
 246 ; Mode support.
 247
 248 ; Create a copy of operand OP in mode NEW-MODE-NAME.
 249 ; NOTE: Even if the mode isn't changing this creates a copy.
 250 ; If OP has been subclassed the result must contain the complete class
 251 ; (e.g. the behaviour of `object-copy').
 252 ; NEW-MODE-NAME must be a valid numeric mode.
 253
 254 (define (op:new-mode op new-mode-name)
 255   (let ((result (object-copy op)))
 256     ; (logit 1 "op:new-mode op=" (op:sem-name op)
 257     ;   " class=" (object-class-name op)
 258     ;   " hw-name=" (op:hw-name op)
 259     ;   " mode=" (op:mode op)
 260     ;   " newmode=" new-mode-name)
 261 ;    (if (or (eq? new-mode-name 'DFLT)
 262 ;           (eq? new-mode-name 'VOID) ; temporary: for upward compatibility
 263 ;           (mode:eq? new-mode-name (op:mode op)))
 264 ;       ; Mode isn't changing.
 265 ;       result
 266     (if #t ;; FIXME
 267         ; See if new mode is supported by the hardware.
 268         (if (hw-mode-ok? (op:type op) new-mode-name (op:index op))
 269             (let ((new-mode (mode:lookup new-mode-name)))
 270               (if (not new-mode)
 271                   (error "op:new-mode: internal error, bad mode"
 272                          new-mode-name))
 273               (elm-xset! result 'mode-name new-mode-name)
 274               (elm-xset! result 'mode new-mode)
 275               result)
 276             (parse-error (make-obj-context op "op:new-mode")
 277                          (string-append "invalid mode for operand `"
 278                                         (->string (obj:name op))
 279                                         "'")
 280                          new-mode-name))))
 281 )
 282
 283 ; Return #t if operand OP references its h/w element in its natural mode.
 284
 285 (define (op-natural-mode? op)
 286   (or (eq? (op:mode-name op) 'DFLT)
 287       (mode-compatible? 'samesize (op:mode op) (hw-default-mode (op:type op))))
 288 )
 289 \f
 290 ; Ifield support.
 291
 292 ; Return list of ifields used by OP.
 293
 294 (define (op-iflds-used op)
 295   (if (derived-operand? op)
 296       (collect op-iflds-used (derived-args op))
 297       ; else
 298       (let ((indx (op:index op)))
 299         (if (and (eq? (hw-index:type indx) 'ifield)
 300                  (not (= (ifld-length (hw-index:value indx)) 0)))
 301             (ifld-needed-iflds (hw-index:value indx))
 302             nil)))
 303 )
 304 \f
 305 ; The `hw-index' class.
 306 ; [Was named `index' but that conflicts with the C library function and caused
 307 ; problems when using Hobbit.  And `index' is too generic a name anyway.]
 308 ;
 309 ; An operand combines a hardware object with its index.
 310 ; e.g. in an array of registers an operand serves to combine the register bank
 311 ; with the instruction field that chooses which one.
 312 ; Hardware elements are accessed via other means as well besides instruction
 313 ; fields so we need a way to designate something as being an index.
 314 ; The `hw-index' class does that.  It serves as a facade to the underlying
 315 ; details.
 316 ; ??? Not sure whether this is the best way to handle this or not.
 317 ;
 318 ; NAME is the name of the index or 'anonymous.
 319 ; This is used, for example, to give a name to the simulator extraction
 320 ; structure member.
 321 ; TYPE is a symbol that indicates what VALUE is.
 322 ; scalar: the hardware object is a scalar, no index is required
 323 ;         [MODE and VALUE are #f to denote "undefined" in this case]
 324 ; constant: a (non-negative) integer (FIXME: rename to const)
 325 ; enum: an enum value stored as (enum-name . (enum-lookup-val enum-name)),
 326 ;       i.e. (name value . enum-obj)
 327 ; str-expr: a C expression as a string
 328 ; rtx: an rtx to be expanded
 329 ; ifield: an <ifield> object
 330 ; derived-ifield: a <derived-ifield> object ???
 331 ; operand: an <operand> object
 332 ; ??? A useful simplification may be to always record the value as an rtx
 333 ; [which may require extensions to rtl so is deferred].
 334 ; ??? We could use runtime type identification, but doing things this way
 335 ; adds more structure.
 336 ;
 337 ; MODE is the mode of VALUE, as a <mode> object.
 338 ; If DFLT, mode must be obtained from VALUE.
 339 ; DFLT is only allowable for rtx and operand types.
 340
 341 (define <hw-index> (class-make '<hw-index> nil '(name type mode value) nil))
 342
 343 ; Accessors.
 344 ; Use obj:name for `name'.
 345 (define hw-index:type (elm-make-getter <hw-index> 'type))
 346 (define hw-index:mode (elm-make-getter <hw-index> 'mode))
 347 (define hw-index:value (elm-make-getter <hw-index> 'value))
 348
 349 ; Allow the mode to be specified by its name.
 350 (method-make!
 351  <hw-index> 'make!
 352  (lambda (self name type mode value)
 353    (elm-set! self 'name name)
 354    (elm-set! self 'type type)
 355    (elm-set! self 'mode (mode-maybe-lookup mode))
 356    (elm-set! self 'value value)
 357    self)
 358 )
 359
 360 ; get-name handler
 361 (method-make!
 362  <hw-index> 'get-name
 363  (lambda (self)
 364    (elm-get self 'name))
 365 )
 366
 367 ; get-atlist handler
 368 (method-make!
 369  <hw-index> 'get-atlist
 370  (lambda (self)
 371    (case (hw-index:type self)
 372      ((ifield) (obj-atlist (hw-index:value self)))
 373      (else atlist-empty)))
 374 )
 375
 376 ; ??? Until other things settle.
 377 (method-make!
 378  <hw-index> 'field-start
 379  (lambda (self)
 380    (if (eq? (hw-index:type self) 'ifield)
 381        (send (hw-index:value self) 'field-start)
 382        0))
 383 )
 384 (method-make!
 385  <hw-index> 'field-length
 386  (lambda (self)
 387    (if (eq? (hw-index:type self) 'ifield)
 388        (send (hw-index:value self) 'field-length)
 389        0))
 390 )
 391
 392 ;; Return #t if index is a constant.
 393
 394 (define (hw-index-constant? hw-index)
 395   (memq (hw-index:type hw-index) '(constant enum))
 396 )
 397
 398 ;; Given that (hw-index-constant? hw-index) is true, return the value.
 399
 400 (define (hw-index-constant-value hw-index)
 401   (case (hw-index:type hw-index)
 402     ((constant) (hw-index:value hw-index))
 403     ((enum) (hw-index-enum-value hw-index))
 404     (else (error "invalid constant hw-index" hw-index)))
 405 )
 406
 407 ;; Make an enum <hw-index> given the enum's name.
 408
 409 (define (make-enum-hw-index name enum-name)
 410   (make <hw-index> name 'enum UINT
 411         (cons enum-name (enum-lookup-val enum-name)))
 412 )
 413
 414 ;; Given an enum <hw-index>, return the enum's name.
 415
 416 (define (hw-index-enum-name hw-index)
 417   (car (hw-index:value hw-index))
 418 )
 419
 420 ;; Given an enum <hw-index>, return the enum's value.
 421
 422 (define (hw-index-enum-value hw-index)
 423   (cadr (hw-index:value hw-index))
 424 )
 425
 426 ;; Given an enum <hw-index>, return the enum's object.
 427
 428 (define (hw-index-enum-obj hw-index)
 429   (cddr (hw-index:value hw-index))
 430 )
 431
 432 ; There only ever needs to be one of these objects, so create one.
 433
 434 (define hw-index-scalar
 435   ; We can't use `make' here as the make! method calls mode:lookup which
 436   ; (a) doesn't exist if we're compiled with Hobbit and mode.scm isn't
 437   ; and (b) will fail anyway since #f isn't a valid mode.
 438   (let ((scalar-index (new <hw-index>)))
 439     (elm-xset! scalar-index 'name 'hw-index-scalar)
 440     (elm-xset! scalar-index 'type 'scalar)
 441     (elm-xset! scalar-index 'mode #f)
 442     (elm-xset! scalar-index 'value #f)
 443     (lambda () scalar-index))
 444 )
 445
 446 ; Placeholder for indices of "anyof" operands.
 447 ; There only needs to be one of these, so we create one and always use that.
 448
 449 (define hw-index-anyof
 450   ; We can't use `make' here as the make! method calls mode:lookup which
 451   ; (a) doesn't exist if we're compiled with Hobbit and mode.scm isn't
 452   ; and (b) will fail anyway since #f isn't a valid mode.
 453   (let ((anyof-index (new <hw-index>)))
 454     (elm-xset! anyof-index 'name 'hw-index-anyof)
 455     (elm-xset! anyof-index 'type 'scalar)
 456     (elm-xset! anyof-index 'mode #f)
 457     (elm-xset! anyof-index 'value #f)
 458     (lambda () anyof-index))
 459 )
 460
 461 (define hw-index-derived
 462   ; We can't use `make' here as the make! method calls mode:lookup which
 463   ; (a) doesn't exist if we're compiled with Hobbit and mode.scm isn't
 464   ; and (b) will fail anyway since #f isn't a valid mode.
 465   (let ((derived-index (new <hw-index>)))
 466     (elm-xset! derived-index 'name 'hw-index-derived)
 467     (elm-xset! derived-index 'type 'scalar)
 468     (elm-xset! derived-index 'mode #f)
 469     (elm-xset! derived-index 'value #f)
 470     (lambda () derived-index))
 471 )
 472 \f
 473 ; Hardware selector support.
 474 ;
 475 ; A hardware "selector" is like an index except is along an atypical axis
 476 ; and thus is rarely used.  It exists to support things like ASI's on Sparc.
 477
 478 ; What to pass to indicate "default selector".
 479 ; (??? value is temporary choice to be revisited).
 480 (define hw-selector-default '(symbol NONE))
 481
 482 (define (hw-selector-default? sel) (equal? sel hw-selector-default))
 483 \f
 484 ; Hardware support.
 485
 486 ; Return list of hardware elements refered to in OP-LIST
 487 ; with no duplicates.
 488
 489 (define (op-nub-hw op-list)
 490   ; Build a list of hw elements.
 491   (let ((hw-list (map (lambda (op)
 492                         (if (hw-ref? op) ; FIXME: hw-ref? is undefined
 493                             op
 494                             (op:type op)))
 495                       op-list)))
 496     ; Now build an alist of (name . obj) elements, take the nub, then the cdr.
 497     ; ??? These lists tend to be small so sorting first is probably overkill.
 498     (map cdr
 499          (alist-nub (alist-sort (map (lambda (hw) (cons (obj:name hw) hw))
 500                                      hw-list)))))
 501 )
 502 \f
 503 ; Parsing support.
 504
 505 ; Utility of /operand-parse-[gs]etter to build the expected syntax,
 506 ; for use in error messages.
 507
 508 (define (/operand-g/setter-syntax rank setter?)
 509   (string-append "("
 510                  (string-drop1
 511                   (numbers->string (iota rank) " index"))
 512                  (if setter?
 513                      (if (>= rank 1)
 514                          " newval"
 515                          "newval")
 516                      "")
 517                  ") (expression)")
 518 )
 519
 520 ; Parse a getter spec.
 521 ; The syntax is (([index-names]) (... code ...)).
 522 ; Omit `index-names' for scalar objects.
 523 ; {rank} is the required number of elements in {index-names}.
 524
 525 (define (/operand-parse-getter context getter rank)
 526   (if (null? getter)
 527       #f ; use default
 528       (let ()
 529         (if (or (not (list? getter))
 530                 (!= (length getter) 2)
 531                 (not (and (list? (car getter))
 532                           (= (length (car getter)) rank))))
 533             (parse-error context
 534                          (string-append "invalid getter, should be "
 535                                         (/operand-g/setter-syntax rank #f))
 536                          getter))
 537         (if (not (rtx? (cadr getter)))
 538             (parse-error context "invalid rtx expression" getter))
 539         getter))
 540 )
 541
 542 ; Parse a setter spec.
 543 ; The syntax is (([index-names] newval) (... code ...)).
 544 ; Omit `index-names' for scalar objects.
 545 ; {rank} is the required number of elements in {index-names}.
 546
 547 (define (/operand-parse-setter context setter rank)
 548   (if (null? setter)
 549       #f ; use default
 550       (let ()
 551         (if (or (not (list? setter))
 552                 (!= (length setter) 2)
 553                 (not (and (list? (car setter))
 554                           (= (+ 1 (length (car setter)) rank)))))
 555             (parse-error context
 556                          (string-append "invalid setter, should be "
 557                                         (/operand-g/setter-syntax rank #t))
 558                          setter))
 559         (if (not (rtx? (cadr setter)))
 560             (parse-error context "invalid rtx expression" setter))
 561         setter))
 562 )
 563
 564 ; Parse an operand definition.
 565 ; This is the main routine for building an operand object from a
 566 ; description in the .cpu file.
 567 ; All arguments are in raw (non-evaluated) form.
 568 ; The result is the parsed object or #f if object isn't for selected mach(s).
 569 ; ??? This only takes insn fields as the index.  May need another proc (or an
 570 ; enhancement of this one) that takes other kinds of indices.
 571
 572 (define (/operand-parse context name comment attrs hw mode index handlers getter setter)
 573   (logit 2 "Processing operand " name " ...\n")
 574
 575   ;; Pick out name first to augment the error context.
 576   (let* ((name (parse-name context name))
 577          (context (context-append-name context name))
 578          (atlist-obj (atlist-parse context attrs "cgen_operand"))
 579          (isa-name-list (atlist-attr-value atlist-obj 'ISA #f)))
 580
 581     ;; Verify all specified ISAs are valid.
 582     (if (not (all-true? (map current-isa-lookup isa-name-list)))
 583         (parse-error context "unknown isa in isa list" isa-name-list))
 584
 585     (if (keep-atlist? atlist-obj #f)
 586
 587         (let ((hw-objs (current-hw-sem-lookup hw))
 588               (mode-obj (parse-mode-name context mode))
 589               (index-val (cond ((integer? index)
 590                                 index)
 591                                ((and (symbol? index) (enum-lookup-val index))
 592                                 => (lambda (x) x))
 593                                ((and (symbol? index) (current-ifld-lookup index isa-name-list))
 594                                 => (lambda (x) x))
 595                                (else
 596                                 (if (symbol? index)
 597                                     (parse-error context "unknown enum or ifield" index)
 598                                     (parse-error context "invalid operand index" index))))))
 599
 600           (if (not mode-obj)
 601               (parse-error context "unknown mode" mode))
 602           ;; Disallow some obviously invalid numeric indices.
 603           (if (and (number? index-val)
 604                    (or (not (integer? index-val))
 605                        (< index-val 0)))
 606               (parse-error context "invalid integer index" index))
 607           ;; If an enum is used, it must be non-negative.
 608           (if (and (pair? index-val)
 609                    (< (car index-val) 0))
 610               (parse-error context "negative enum value" index))
 611           ;; NOTE: Don't validate HW until we know whether this operand
 612           ;; will be kept or not.  If not, HW may have been discarded too.
 613           (if (null? hw-objs)
 614               (parse-error context "unknown hardware element" hw))
 615
 616           ;; At this point INDEX-VAL is either an integer, (value . enum-obj),
 617           ;; or an <ifield> object.
 618           ;; Since we can't look up the hardware element at this time
 619           ;; [well, actually we should be able to with a bit of work],
 620           ;; we determine scalarness from an index of f-nil.
 621           (let ((hw-index
 622                   (cond ((integer? index-val)
 623                          (make <hw-index> (symbol-append 'i- name)
 624                                ;; FIXME: constant -> const
 625                                'constant UINT index-val))
 626                         ((pair? index-val) ;; enum?
 627                          (make <hw-index> (symbol-append 'i- name)
 628                                'enum UINT (cons index index-val)))
 629                         ((ifld-nil? index-val)
 630                          (hw-index-scalar))
 631                         (else
 632                          (make <hw-index> (symbol-append 'i- name)
 633                                'ifield UINT index-val)))))
 634             (make <operand>
 635               (context-location context)
 636               name
 637               (parse-comment context comment)
 638               ;; Copy FLD's attributes so one needn't duplicate attrs like
 639               ;; PCREL-ADDR, etc.  An operand inherits the attributes of
 640               ;; its field.  They are overridable of course, which is why we use
 641               ;; `atlist-append' here.
 642               (if (ifield? index-val)
 643                   (atlist-append atlist-obj (obj-atlist index-val))
 644                   atlist-obj)
 645               hw ;; note that this is the hw's name, not an object
 646               mode ;; ditto, this is a name, not an object
 647               hw-index
 648               (parse-handlers context '(parse print) handlers)
 649               (/operand-parse-getter context getter (if scalar? 0 1))
 650               (/operand-parse-setter context setter (if scalar? 0 1))
 651               )))
 652
 653         (begin
 654           (logit 2 "Ignoring " name ".\n")
 655           #f)))
 656 )
 657
 658 ; Read an operand description.
 659 ; This is the main routine for analyzing operands in the .cpu file.
 660 ; CONTEXT is a <context> object for error messages.
 661 ; ARG-LIST is an associative list of field name and field value.
 662 ; /operand-parse is invoked to create the <operand> object.
 663
 664 (define (/operand-read context . arg-list)
 665   (let (
 666         (name nil)
 667         (comment nil)
 668         (attrs nil)
 669         (type nil)
 670         (mode 'DFLT)     ; use default mode of TYPE
 671         (index nil)
 672         (handlers nil)
 673         (getter nil)
 674         (setter nil)
 675         )
 676
 677     (let loop ((arg-list arg-list))
 678       (if (null? arg-list)
 679           nil
 680           (let ((arg (car arg-list))
 681                 (elm-name (caar arg-list)))
 682             (case elm-name
 683               ((name) (set! name (cadr arg)))
 684               ((comment) (set! comment (cadr arg)))
 685               ((attrs) (set! attrs (cdr arg)))
 686               ((type) (set! type (cadr arg)))
 687               ((mode) (set! mode (cadr arg)))
 688               ((index) (set! index (cadr arg)))
 689               ((handlers) (set! handlers (cdr arg)))
 690               ((getter) (set! getter (cdr arg)))
 691               ((setter) (set! setter (cdr arg)))
 692               (else (parse-error context "invalid operand arg" arg)))
 693             (loop (cdr arg-list)))))
 694
 695     ; Now that we've identified the elements, build the object.
 696     (/operand-parse context name comment attrs type mode index handlers
 697                     getter setter))
 698 )
 699
 700 ; Define an operand object, name/value pair list version.
 701
 702 (define define-operand
 703   (lambda arg-list
 704     (let ((op (apply /operand-read (cons (make-current-context "define-operand")
 705                                          arg-list))))
 706       (if op
 707           (current-op-add! op))
 708       op))
 709 )
 710
 711 ; Define an operand object, all arguments specified.
 712
 713 (define (define-full-operand name comment attrs type mode index handlers getter setter)
 714   (let ((op (/operand-parse (make-current-context "define-full-operand")
 715                             name comment attrs
 716                             type mode index handlers getter setter)))
 717     (if op
 718         (current-op-add! op))
 719     op)
 720 )
 721 \f
 722 ; Derived operands.
 723 ;
 724 ; Derived operands are used to implement operands more complex than just
 725 ; the mapping of an instruction field to a register bank.  Their present
 726 ; raison d'etre is to create a new axis on which to implement the complex
 727 ; addressing modes of the i386 and m68k.  The brute force way of describing
 728 ; these instruction sets would be to have one `dni' per addressing mode
 729 ; per instruction.  What's needed is to abstract away the various addressing
 730 ; modes within something like operands.
 731 ;
 732 ; ??? While internally we end up with the "brute force" approach, in and of
 733 ; itself that's ok because it's an internal implementation issue.
 734 ; See <multi-insn>.
 735 ;
 736 ; ??? Another way to go is to have one dni per addressing mode.  That seems
 737 ; less clean though as one dni would be any of add, sub, and, or, xor, etc.
 738 ;
 739 ; ??? Some addressing modes have side-effects (e.g. pre-dec, etc. like insns).
 740 ; This can be represented, but if two operands have side-effects special
 741 ; trickery may be required to get the order of side-effects right.  Need to
 742 ; avoid any "trickery" at all.
 743 ;
 744 ; ??? Not yet handled are modelling parameters.
 745 ; ??? Not yet handled are the handlers,getter,setter spec of normal operands.
 746 ;
 747 ; ??? Division of class members b/w <operand> and <derived-operand> is wip.
 748 ; ??? As is potential introduction of other classes to properly organize
 749 ; things.
 750
 751 (define <derived-operand>
 752   (class-make '<derived-operand>
 753               '(<operand>)
 754               '(
 755                 ; Args (list of <operands> objects).
 756                 args
 757
 758                 ; Syntax string.
 759                 syntax
 760
 761                 ; Base ifield, common to all choices.
 762                 ; ??? experiment
 763                 base-ifield
 764
 765                 ; <derived-ifield> object.
 766                 encoding
 767
 768                 ; Assertions of any ifield values or #f if none.
 769                 (ifield-assertion . #f)
 770                 )
 771               '())
 772 )
 773
 774 ;; <derived-operand> constructor.
 775 ;; MODE is a <mode> object.
 776
 777 (method-make!
 778  <derived-operand> 'make!
 779  (lambda (self name comment attrs mode
 780                args syntax base-ifield encoding ifield-assertion
 781                getter setter)
 782    (elm-set! self 'name name)
 783    (elm-set! self 'comment comment)
 784    (elm-set! self 'attrs attrs)
 785    (elm-set! self 'sem-name name)
 786    (elm-set! self 'pretty-sem-name #f) ;; FIXME
 787    (elm-set! self 'hw-name #f) ;; FIXME
 788    (elm-set! self 'mode mode)
 789    (elm-set! self 'mode-name (obj:name mode))
 790    (elm-set! self 'getter getter)
 791    (elm-set! self 'setter setter)
 792    ;; These are the additional fields in <derived-operand>.
 793    (elm-set! self 'args args)
 794    (elm-set! self 'syntax syntax)
 795    (elm-set! self 'base-ifield base-ifield)
 796    (elm-set! self 'encoding encoding)
 797    (elm-set! self 'ifield-assertion ifield-assertion)
 798    self)
 799 )
 800
 801 (define (derived-operand? x) (class-instance? <derived-operand> x))
 802
 803 (define-getters <derived-operand> derived
 804   (args syntax base-ifield encoding ifield-assertion)
 805 )
 806
 807 ; "anyof" operands are subclassed from derived operands.
 808 ; They typically handle multiple addressing modes of CISC architectures.
 809
 810 (define <anyof-operand>
 811   (class-make '<anyof-operand>
 812               '(<operand>)
 813               '(
 814                 ; Base ifield, common to all choices.
 815                 ; FIXME: wip
 816                 base-ifield
 817
 818                 ; List of <derived-operand> objects.
 819                 ; ??? Maybe allow <operand>'s too?
 820                 choices
 821                 )
 822               '())
 823 )
 824
 825 (define (anyof-operand? x) (class-instance? <anyof-operand> x))
 826
 827 (method-make!
 828  <anyof-operand> 'make!
 829  (lambda (self name comment attrs mode-name base-ifield choices)
 830    (elm-set! self 'name name)
 831    (elm-set! self 'comment comment)
 832    (elm-set! self 'attrs attrs)
 833    (elm-set! self 'sem-name name)
 834    (elm-set! self 'pretty-sem-name #f) ;; FIXME
 835    (elm-set! self 'hw-name #f) ;; FIXME
 836    (elm-set! self 'mode-name mode-name)
 837    (elm-set! self 'base-ifield base-ifield)
 838    (elm-set! self 'choices choices)
 839    ; Set index to a special marker value.
 840    (elm-set! self 'index (hw-index-anyof))
 841    self)
 842 )
 843
 844 (define-getters <anyof-operand> anyof (choices))
 845 \f
 846 ; Derived/Anyof parsing support.
 847
 848 ; Subroutine of /derived-operand-parse to parse the encoding.
 849 ; The result is a <derived-ifield> object.
 850 ; The {owner} member still needs to be set!
 851
 852 (define (/derived-parse-encoding context isa-name-list operand-name encoding)
 853   (if (or (null? encoding)
 854           (not (list? encoding)))
 855       (parse-error context "encoding not a list" encoding))
 856   (if (not (eq? (car encoding) '+))
 857       (parse-error context "encoding must begin with `+'" encoding))
 858
 859   ; ??? Calling /parse-insn-format is a quick hack.
 860   ; It's an internal routine of some other file.
 861   (let ((iflds (/parse-insn-format context #f isa-name-list encoding)))
 862     (make <derived-ifield>
 863           operand-name
 864           'derived-ifield ; (string-append "<derived-ifield> for " operand-name)
 865           atlist-empty
 866           #f ; owner
 867           iflds ; subfields
 868           ))
 869 )
 870
 871 ;; Subroutine of /derived-operand-parse to parse the ifield assertion.
 872 ;; The ifield assertion is either () or a (restricted) RTL expression
 873 ;; asserting something about the ifield values of the containing insn.
 874 ;; The result is #f if the assertion is (), or the canonical rtl.
 875
 876 (define (/derived-parse-ifield-assertion context isa-name-list ifield-assertion)
 877   (if (null? ifield-assertion)
 878       #f
 879       (rtx-canonicalize context 'INT isa-name-list nil ifield-assertion))
 880 )
 881
 882 ; Parse a derived operand definition.
 883 ; This is the main routine for building a derived operand object from a
 884 ; description in the .cpu file.
 885 ; All arguments are in raw (non-evaluated) form.
 886 ; The result is the parsed object or #f if object isn't for selected mach(s).
 887 ;
 888 ; ??? Currently no support for handlers(,???) found in normal operands.
 889 ; Later, when necessary.
 890
 891 (define (/derived-operand-parse context name comment attrs mode
 892                                 args syntax
 893                                 base-ifield encoding ifield-assertion
 894                                 getter setter)
 895   (logit 2 "Processing derived operand " name " ...\n")
 896
 897   ;; Pick out name first to augment the error context.
 898   (let* ((name (parse-name context name))
 899          (context (context-append-name context name))
 900          (atlist-obj (atlist-parse context attrs "cgen_operand"))
 901          (isa-name-list (atlist-attr-value atlist-obj 'ISA #f)))
 902
 903     ;; Verify all specified ISAs are valid.
 904     (if (not (all-true? (map current-isa-lookup isa-name-list)))
 905         (parse-error context "unknown isa in isa list" isa-name-list))
 906
 907     (if (keep-atlist? atlist-obj #f)
 908
 909         (let* ((mode-obj (parse-mode-name context mode))
 910                (parsed-encoding (/derived-parse-encoding context isa-name-list
 911                                                          name encoding)))
 912
 913           (if (not mode-obj)
 914               (parse-error context "unknown mode" mode))
 915
 916           (let ((result
 917                  (make <derived-operand>
 918                        name
 919                        (parse-comment context comment)
 920                        atlist-obj
 921                        mode-obj
 922                        (map (lambda (a)
 923                               (if (not (symbol? a))
 924                                   (parse-error context "arg not a symbol" a))
 925                               (let ((op (current-op-lookup a isa-name-list)))
 926                                 (if (not op)
 927                                     (parse-error context "not an operand" a))
 928                                 op))
 929                             args)
 930                        syntax
 931                        base-ifield ; FIXME: validate
 932                        parsed-encoding
 933                        (/derived-parse-ifield-assertion context isa-name-list
 934                                                         ifield-assertion)
 935                        (if (null? getter)
 936                            #f
 937                            (/operand-parse-getter
 938                             context
 939                             (list args
 940                                   (rtx-canonicalize context mode
 941                                                     isa-name-list nil
 942                                                     getter))
 943                             (length args)))
 944                        (if (null? setter)
 945                            #f
 946                            (/operand-parse-setter
 947                             context
 948                             (list (append args '(newval))
 949                                   (rtx-canonicalize context 'VOID
 950                                                     isa-name-list
 951                                                     (list (list 'newval mode #f))
 952                                                     setter))
 953                             (length args)))
 954                        )))
 955             (elm-set! result 'hw-name (obj:name (hardware-for-mode mode-obj)))
 956             ;(elm-set! result 'hw-name (obj:name parsed-encoding))
 957             ;(elm-set! result 'hw-name base-ifield)
 958             (elm-set! result 'index parsed-encoding)
 959             ; (elm-set! result 'index (hw-index-derived)) ; A temporary dummy
 960             (logit 2 "  new derived-operand; name= " name
 961                    ", hw-name= " (op:hw-name result)
 962                    ", index=" (obj:name parsed-encoding) "\n")
 963             (derived-ifield-set-owner! parsed-encoding result)
 964             result))
 965
 966         (begin
 967           (logit 2 "Ignoring " name ".\n")
 968           #f)))
 969 )
 970
 971 ; Read a derived operand description.
 972 ; This is the main routine for analyzing derived operands in the .cpu file.
 973 ; CONTEXT is a <context> object for error messages.
 974 ; ARG-LIST is an associative list of field name and field value.
 975 ; /derived-operand-parse is invoked to create the <derived-operand> object.
 976
 977 (define (/derived-operand-read context . arg-list)
 978   (let (
 979         (name nil)
 980         (comment nil)
 981         (attrs nil)
 982         (mode 'DFLT)     ; use default mode of TYPE
 983         (args nil)
 984         (syntax nil)
 985         (base-ifield nil)
 986         (encoding nil)
 987         (ifield-assertion nil)
 988         (getter nil)
 989         (setter nil)
 990         )
 991
 992     (let loop ((arg-list arg-list))
 993       (if (null? arg-list)
 994           nil
 995           (let ((arg (car arg-list))
 996                 (elm-name (caar arg-list)))
 997             (case elm-name
 998               ((name) (set! name (cadr arg)))
 999               ((comment) (set! comment (cadr arg)))
1000               ((attrs) (set! attrs (cdr arg)))
1001               ((mode) (set! mode (cadr arg)))
1002               ((args) (set! args (cadr arg)))
1003               ((syntax) (set! syntax (cadr arg)))
1004               ((base-ifield) (set! base-ifield (cadr arg)))
1005               ((encoding) (set! encoding (cadr arg)))
1006               ((ifield-assertion) (set! ifield-assertion (cadr arg)))
1007               ((getter) (set! getter (cadr arg)))
1008               ((setter) (set! setter (cadr arg)))
1009               (else (parse-error context "invalid derived-operand arg" arg)))
1010             (loop (cdr arg-list)))))
1011
1012     ; Now that we've identified the elements, build the object.
1013     (/derived-operand-parse context name comment attrs mode args
1014                             syntax base-ifield encoding ifield-assertion
1015                             getter setter))
1016 )
1017
1018 ; Define a derived operand object, name/value pair list version.
1019
1020 (define define-derived-operand
1021   (lambda arg-list
1022     (let ((op (apply /derived-operand-read
1023                      (cons (make-current-context "define-derived-operand")
1024                            arg-list))))
1025       (if op
1026           (current-op-add! op))
1027       op))
1028 )
1029
1030 ; Define a derived operand object, all arguments specified.
1031 ; ??? Not supported (yet).
1032 ;
1033 ;(define (define-full-derived-operand name comment attrs mode ...)
1034 ;  (let ((op (/derived-operand-parse (make-current-context "define-full-derived-operand")
1035 ;                                   name comment attrs
1036 ;                                   mode ...)))
1037 ;    (if op
1038 ;       (current-op-add! op))
1039 ;    op)
1040 ;)
1041
1042 ; Parse an "anyof" choice, which is a derived-operand name.
1043 ; The result is {choice} unchanged.
1044
1045 (define (/anyof-parse-choice context choice isa-name-list)
1046   (if (not (symbol? choice))
1047       (parse-error context "anyof choice not a symbol" choice))
1048   (let ((op (current-op-lookup choice isa-name-list)))
1049     (if (not (derived-operand? op))
1050         (parse-error context "anyof choice not a derived-operand" choice))
1051     op)
1052 )
1053
1054 ; Parse an "anyof" derived operand.
1055 ; This is the main routine for building a derived operand object from a
1056 ; description in the .cpu file.
1057 ; All arguments are in raw (non-evaluated) form.
1058 ; The result is the parsed object or #f if object isn't for selected mach(s).
1059 ;
1060 ; ??? Currently no support for handlers(,???) found in normal operands.
1061 ; Later, when necessary.
1062
1063 (define (/anyof-operand-parse context name comment attrs mode
1064                               base-ifield choices)
1065   (logit 2 "Processing anyof operand " name " ...\n")
1066
1067   ;; Pick out name first to augment the error context.
1068   (let* ((name (parse-name context name))
1069          (context (context-append-name context name))
1070          (atlist-obj (atlist-parse context attrs "cgen_operand")))
1071
1072     (if (keep-atlist? atlist-obj #f)
1073
1074         (let ((mode-obj (parse-mode-name context mode))
1075               (isa-name-list (atlist-attr-value atlist-obj 'ISA #f)))
1076           (if (not mode-obj)
1077               (parse-error context "unknown mode" mode))
1078
1079           (make <anyof-operand>
1080                 name
1081                 (parse-comment context comment)
1082                 atlist-obj
1083                 mode
1084                 base-ifield
1085                 (map (lambda (c)
1086                        (/anyof-parse-choice context c isa-name-list))
1087                      choices)))
1088
1089         (begin
1090           (logit 2 "Ignoring " name ".\n")
1091           #f)))
1092 )
1093
1094 ; Read an anyof operand description.
1095 ; This is the main routine for analyzing anyof operands in the .cpu file.
1096 ; CONTEXT is a <context> object for error messages.
1097 ; ARG-LIST is an associative list of field name and field value.
1098 ; /anyof-operand-parse is invoked to create the <anyof-operand> object.
1099
1100 (define (/anyof-operand-read context . arg-list)
1101   (let (
1102         (name nil)
1103         (comment nil)
1104         (attrs nil)
1105         (mode 'DFLT)     ; use default mode of TYPE
1106         (base-ifield nil)
1107         (choices nil)
1108         )
1109
1110     (let loop ((arg-list arg-list))
1111       (if (null? arg-list)
1112           nil
1113           (let ((arg (car arg-list))
1114                 (elm-name (caar arg-list)))
1115             (case elm-name
1116               ((name) (set! name (cadr arg)))
1117               ((comment) (set! comment (cadr arg)))
1118               ((attrs) (set! attrs (cdr arg)))
1119               ((mode) (set! mode (cadr arg)))
1120               ((base-ifield) (set! base-ifield (cadr arg)))
1121               ((choices) (set! choices (cdr arg)))
1122               (else (parse-error context "invalid anyof-operand arg" arg)))
1123             (loop (cdr arg-list)))))
1124
1125     ; Now that we've identified the elements, build the object.
1126     (/anyof-operand-parse context name comment attrs mode base-ifield choices))
1127 )
1128
1129 ; Define an anyof operand object, name/value pair list version.
1130
1131 (define define-anyof-operand
1132   (lambda arg-list
1133     (let ((op (apply /anyof-operand-read
1134                      (cons (make-current-context "define-anyof-operand")
1135                            arg-list))))
1136       (if op
1137           (current-op-add! op))
1138       op))
1139 )
1140 \f
1141 ; Utilities to flatten out the <anyof-operand> derivation heirarchy.
1142
1143 ; Utility class used when instantiating insns with derived operands.
1144 ; This collects together in one place all the appropriate data of an
1145 ; instantiated "anyof" operand.
1146
1147 (define <anyof-instance>
1148   (class-make '<anyof-instance>
1149               '(<derived-operand>)
1150               '(
1151                 ; <anyof-operand> object we were instantiated from.
1152                 parent
1153                 )
1154               nil)
1155 )
1156
1157 (method-make-make! <anyof-instance>
1158                    '(name comment attrs mode
1159                           args syntax base-ifield encoding ifield-assertion
1160                           getter setter parent)
1161 )
1162
1163 (define-getters <anyof-instance> anyof-instance (parent))
1164
1165 (define (anyof-instance? x) (class-instance? <anyof-instance> x))
1166
1167 ; Return initial list of known ifield values in {anyof-instance}.
1168
1169 (define (/anyof-initial-known anyof-instance)
1170   (assert (derived-operand? anyof-instance))
1171   (let ((encoding (derived-encoding anyof-instance)))
1172     (assert (derived-ifield? encoding))
1173     (ifld-known-values (derived-ifield-subfields encoding)))
1174 )
1175
1176 ; Return true if {anyof-instance} satisfies its ifield assertions.
1177 ; {known-values} is the {known} argument to rtx-solve.
1178
1179 (define (anyof-satisfies-assertions? anyof-instance known-values)
1180   (assert (derived-operand? anyof-instance))
1181   (let ((assertion (derived-ifield-assertion anyof-instance)))
1182     (if assertion
1183         (rtx-solve (make-obj-context anyof-instance #f)
1184                    anyof-instance ; owner
1185                    assertion
1186                    known-values)
1187         #t))
1188 )
1189
1190 ; Subroutine of /anyof-merge-subchoices.
1191 ; Merge syntaxes of VALUE-NAMES/VALUES into SYNTAX.
1192 ;
1193 ; Example:
1194 ; If SYNTAX is "$a+$b", and VALUE-NAMES is (b), and VALUES is
1195 ; ("$c+$d"-object), then return "$a+$c+$d".
1196
1197 (define (/anyof-syntax anyof-instance)
1198   (elm-get anyof-instance 'syntax)
1199 )
1200
1201 (define (/anyof-name anyof-instance)
1202   (elm-get anyof-instance 'name)
1203 )
1204
1205 ; CONTAINER is the <anyof-operand> containing SYNTAX.
1206
1207 (define (/anyof-merge-syntax syntax value-names values container)
1208   (let* ((isa-name-list (obj-isa-list container))
1209          (syntax-elements (syntax-break-out syntax isa-name-list)))
1210     (syntax-make (map (lambda (e)
1211                         (if (anyof-operand? e)
1212                             (let* ((name (obj:name e))
1213                                    (indx (element-lookup-index name value-names 0)))
1214                               (if (not indx)
1215                                 (error "Name " name " not one of " values)
1216                                 )
1217                               (/anyof-syntax (list-ref values indx)))
1218                             e))
1219                       syntax-elements)))
1220 )
1221
1222 ; Subroutine of /anyof-merge-subchoices.
1223 ; Merge syntaxes of {value-names}/{values} into <derived-ifield> {encoding}.
1224 ; The result is a new <derived-ifield> object with subfields matching
1225 ; {value-names} replaced with {values}.
1226 ; {container} is the containing <anyof-operand>.
1227 ;
1228 ; Example:
1229 ; If {encoding} is (a-ifield-object b-anyof-ifield-object), and {value-names}
1230 ; is (b), and {values} is (c-choice-of-b-object), then return
1231 ; (a-ifield-object c-choice-of-b-ifield-object).
1232
1233 (define (/anyof-merge-encoding container encoding value-names values)
1234   (assert (derived-ifield? encoding))
1235   (let ((subfields (derived-ifield-subfields encoding))
1236         (result (object-copy encoding)))
1237     ; Delete all the elements that are being replaced with ifields from
1238     ; {values} and add the new ifields.
1239     (derived-ifield-set-subfields! result
1240                                    (append
1241                                     (find (lambda (f)
1242                                             (not (memq (obj:name f) value-names)))
1243                                           subfields)
1244                                     (map derived-encoding values)))
1245     result)
1246 )
1247
1248 ; Subroutine of /anyof-merge-subchoices.
1249 ; Merge semantics of VALUE-NAMES/VALUES into GETTER.
1250 ;
1251 ; Example:
1252 ; If GETTER is (mem QI foo), and VALUE-NAMES is (foo), and VALUES is
1253 ; ((add a b)-object), then return (mem QI (add a b)).
1254
1255 (define (/anyof-merge-getter getter value-names values)
1256   ; ??? This implementation is a quick hack, intended to evolve or be replaced.
1257   (cond ((not getter)
1258          #f)
1259         (else
1260          (map (lambda (e)
1261                 (cond ((symbol? e)
1262                        (let ((indx (element-lookup-index e value-names 0)))
1263                          (if indx
1264                              (op:getter (list-ref values indx))
1265                              e)))
1266                       ((pair? e) ; pair? -> cheap non-null-list?
1267                        (/anyof-merge-getter e value-names values))
1268                       (else
1269                        e)))
1270               getter)))
1271 )
1272
1273 ; Subroutine of /anyof-merge-subchoices.
1274 ; Merge semantics of VALUE-NAMES/VALUES into SETTER.
1275 ;
1276 ; Example:
1277 ; If SETTER is (set (mem QI foo) newval), and VALUE-NAMES is (foo),
1278 ; and VALUES is ((add a b)-object), then return
1279 ; (set (mem QI (add a b)) newval).
1280 ;
1281 ; ??? `newval' in this context is a reserved word.
1282
1283 (define (/anyof-merge-setter setter value-names values)
1284   ; ??? This implementation is a quick hack, intended to evolve or be replaced.
1285   (cond ((not setter)
1286          #f)
1287         ((rtx-single-set? setter)
1288          (let ((src (rtx-set-src setter))
1289                (dest (rtx-set-dest setter))
1290                (mode (rtx-mode setter))
1291                (options (rtx-options setter))
1292                (name (rtx-name setter)))
1293            (if (rtx-kind 'mem dest)
1294                (set! dest
1295                      (rtx-change-address dest
1296                                          (/anyof-merge-getter
1297                                           (rtx-mem-addr dest)
1298                                           value-names values))))
1299            (set! src (/anyof-merge-getter src value-names values))
1300            (rtx-make name options mode dest src)))
1301         (else
1302          (error "/anyof-merge-setter: unsupported form" (car setter))))
1303 )
1304
1305 ; Subroutine of -sub-insn-make!.
1306 ; Merge semantics of VALUE-NAMES/VALUES into SEMANTICS.
1307 ; Defined here and not in insn.scm to keep it with the getter/setter mergers.
1308 ;
1309 ; Example:
1310 ; If SEMANTICS is (mem QI foo), and VALUE-NAMES is (foo), and VALUES is
1311 ; ((add a b)-object), then return (mem QI (add a b)).
1312
1313 (define (anyof-merge-semantics semantics value-names values)
1314   ; ??? This implementation is a quick hack, intended to evolve or be replaced.
1315   (let ((result
1316          (cond ((not semantics)
1317                 #f)
1318                (else
1319                 (map (lambda (e)
1320                        (cond ((symbol? e)
1321                               (let ((indx (element-lookup-index e value-names 0)))
1322                                 (if indx
1323                                     (/anyof-name (list-ref values indx))
1324                                     ; (op:sem-name (list-ref values indx))
1325                                     e)))
1326                              ((pair? e) ; pair? -> cheap non-null-list?
1327                               (anyof-merge-semantics e value-names values))
1328                              (else
1329                               e)))
1330                      semantics)))))
1331     (logit 4 "  merged semantics: [" semantics "] -> [" result "]\n")
1332     result)
1333 )
1334
1335 ; Subroutine of /anyof-merge-subchoices.
1336 ; Merge assertion of VALUE-NAMES/VALUES into ASSERTION.
1337 ;
1338 ; Example:
1339 ; If ASSERTION is (ne f-base-reg 5), and VALUE-NAMES is
1340 ; (foo), and VALUES is ((ne f-mod 0)), then return
1341 ; (andif (ne f-base-reg 5) (ne f-mod 0)).
1342 ;
1343 ; FIXME: Perform simplification pass, based on combined set of known
1344 ; ifield values.
1345
1346 (define (/anyof-merge-ifield-assertion assertion value-names values)
1347   (let ((assertions (find identity
1348                           (cons assertion
1349                                 (map derived-ifield-assertion values)))))
1350     (if (null? assertions)
1351         #f
1352         (rtx-combine 'andif assertions)))
1353 )
1354
1355 ; Subroutine of /anyof-all-subchoices.
1356 ; Return a copy of <derived-operand> CHOICE with NEW-ARGS from ANYOF-ARGS
1357 ; merged in.  This is for when a derived operand is itself composed of
1358 ; anyof operands.
1359 ; ANYOF-ARGS is a list of <anyof-operand>'s to be replaced in CHOICE.
1360 ; NEW-ARGS is a corresponding list of values (<derived-operands>'s) of each
1361 ; element in ANYOF-ARGS.
1362 ; CONTAINER is the <anyof-operand> containing CHOICE.
1363
1364 (define (/anyof-merge-subchoices container choice anyof-args new-args)
1365   (assert (all-true? (map anyof-operand? anyof-args)))
1366   (assert (all-true? (map derived-operand? new-args)))
1367
1368   (let* ((arg-names (map obj:name anyof-args))
1369          (encoding (/anyof-merge-encoding container (derived-encoding choice)
1370                                           arg-names new-args))
1371          (result
1372           (make <anyof-instance>
1373                 (apply symbol-append
1374                        (cons (obj:name choice)
1375                              (map (lambda (anyof)
1376                                     (symbol-append '- (obj:name anyof)))
1377                                   new-args)))
1378                 (obj:comment choice)
1379                 (obj-atlist choice)
1380                 (op:mode choice)
1381                 (derived-args choice)
1382                 (/anyof-merge-syntax (derived-syntax choice)
1383                                      arg-names new-args
1384                                      container)
1385                 (derived-base-ifield choice)
1386                 encoding
1387                 (/anyof-merge-ifield-assertion (derived-ifield-assertion choice)
1388                                                anyof-args new-args)
1389                 (/anyof-merge-getter (op:getter choice)
1390                                      arg-names new-args)
1391                 (/anyof-merge-setter (op:setter choice)
1392                                      arg-names new-args)
1393                 container)))
1394
1395     (elm-set! result 'index encoding)
1396     ; Creating the link from {encoding} to {result}.
1397     (derived-ifield-set-owner! encoding result)
1398     result)
1399 )
1400
1401 ; Subroutine of /anyof-all-choices-1.
1402 ; Return a list of all possible subchoices of <derived-operand> ANYOF-CHOICE,
1403 ; known to use <anyof-operand>'s itself.
1404 ; CONTAINER is the containing <anyof-operand>.
1405
1406 (define (/anyof-all-subchoices container anyof-choice)
1407   ; Split args into anyof and non-anyof elements.
1408   (let* ((args (derived-args anyof-choice))
1409          (anyof-args (find anyof-operand? args)))
1410
1411     (assert (not (null? anyof-args)))
1412
1413     ; Iterate over all combinations.
1414     ; {todo} is a list with one element for each anyof argument.
1415     ; Each element is in turn a list of all <derived-operand> choices for the
1416     ; <anyof-operand>.  The result we want is every possible combination.
1417     ; Example:
1418     ; If {todo} is ((1 2 3) (a) (B C)) the result we want is
1419     ; ((1 a B) (1 a C) (2 a B) (2 a C) (3 a B) (3 a C)).
1420     ;
1421     ; Note that some of these values may be derived from nested
1422     ; <anyof-operand>'s which is why we recursively call /anyof-all-choices-1.
1423     ; ??? /anyof-all-choices-1 should cache the results.
1424
1425     (let* ((todo (map /anyof-all-choices-1 anyof-args))
1426            (lengths (map length todo))
1427            (total (apply * lengths))
1428            (result nil))
1429
1430       ; ??? One might prefer a `do' loop here, but every time I see one I
1431       ; have to spend too long remembering its syntax.
1432       (let loop ((i 0))
1433         (if (< i total)
1434             (let* ((indices (split-value lengths i))
1435                    (new-args (map list-ref todo indices)))
1436               ;(display "new-args: " (current-error-port))
1437               ;(display (map obj:name new-args) (current-error-port))
1438               ;(newline (current-error-port))
1439               (set! result
1440                     (cons (/anyof-merge-subchoices container
1441                                                    anyof-choice
1442                                                    anyof-args
1443                                                    new-args)
1444                           result))
1445               (loop (+ i 1)))))
1446
1447       result))
1448 )
1449
1450 ; Return an <anyof-instance> object from <derived-operand> {derop}, which is a
1451 ; choice of {anyof-operand}.
1452
1453 (define (/anyof-instance-from-derived anyof-operand derop)
1454   (let* ((encoding (object-copy (derived-encoding derop)))
1455          (result
1456           (make <anyof-instance>
1457                 (obj:name derop)
1458                 (obj:comment derop)
1459                 (obj-atlist derop)
1460                 (op:mode derop)
1461                 (derived-args derop)
1462                 (derived-syntax derop)
1463                 (derived-base-ifield derop)
1464                 encoding
1465                 (derived-ifield-assertion derop)
1466                 (op:getter derop)
1467                 (op:setter derop)
1468                 anyof-operand)))
1469     ; Creating the link from {encoding} to {result}.
1470     (derived-ifield-set-owner! encoding result)
1471     result)
1472 )
1473
1474 ; Return list of <anyof-instance> objects, one for each possible variant of
1475 ; ANYOF-OPERAND.
1476 ;
1477 ; One could move this up into the cpu description file using pmacros.
1478 ; However, that's not the right way to go.  How we currently implement
1479 ; the notion of derived operands is separate from the notion of having them
1480 ; in the description language.  pmacros are not "in" the language (to the
1481 ; extent that the cpu description file reader "sees" them), they live
1482 ; above it.  And the right way to do this is with something "in" the language.
1483 ; Derived operands are the first cut at it.  They'll evolve or be replaced
1484 ; (and it's the implementation of them that will evolve first).
1485
1486 (define (/anyof-all-choices-1 anyof-operand)
1487   (assert (anyof-operand? anyof-operand))
1488
1489   (let ((result nil))
1490
1491     ; For each choice, scan the operands for further derived operands.
1492     ; If found, replace the choice with the list of its subchoices.
1493     ; If not found, create an <anyof-instance> object for it.  This is
1494     ; basically just a copy of the object, but {anyof-operand} is recorded
1495     ; with it so that we can later resolve `follows' specs.
1496
1497     (let loop ((choices (anyof-choices anyof-operand)))
1498       (if (not (null? choices))
1499           (let* ((this (car choices))
1500                  (args (derived-args this)))
1501
1502             (if (any-true? (map anyof-operand? args))
1503
1504                 ; This operand has "anyof" operands so we need to turn this
1505                 ; choice into a list of all possible subchoices.
1506                 (let ((subchoices (/anyof-all-subchoices anyof-operand this)))
1507                   (set! result
1508                         (append subchoices result)))
1509
1510                 ; No <anyof-operand> arguments.
1511                 (set! result
1512                       (cons (/anyof-instance-from-derived anyof-operand this)
1513                             result)))
1514
1515             (loop (cdr choices)))))
1516
1517     (assert (all-true? (map anyof-instance? result)))
1518     result)
1519 )
1520
1521 ; Cover fn of /anyof-all-choices-1.
1522 ; Return list of <anyof-instance> objects, one for each possible variant of
1523 ; ANYOF-OPERAND.
1524 ; We want to delete choices that fail their ifield assertions, but since
1525 ; /anyof-all-choices-1 can recursively call itself, assertion checking is
1526 ; defered until it returns.
1527
1528 (define (anyof-all-choices anyof-operand)
1529   (let ((all-choices (/anyof-all-choices-1 anyof-operand)))
1530
1531     ; Delete ones that fail their ifield assertions.
1532     ; Sometimes there isn't enough information yet to completely do this.
1533     ; When that happens it is the caller's responsibility to deal with it.
1534     ; However, it is our responsibility to assert as much as we can.
1535     (find (lambda (op)
1536             (anyof-satisfies-assertions? op
1537                                          (/anyof-initial-known op)))
1538           all-choices))
1539 )
1540 \f
1541 ; Operand utilities.
1542
1543 ; Look up operand NAME in the operand table.
1544 ; This proc isolates the strategy we use to record operand objects.
1545
1546 ; Look up an operand via SEM-NAME.
1547
1548 (define (op:lookup-sem-name op-list sem-name)
1549   (let loop ((op-list op-list))
1550     (cond ((null? op-list) #f)
1551           ((eq? sem-name (op:sem-name (car op-list))) (car op-list))
1552           (else (loop (cdr op-list)))))
1553 )
1554
1555 ; Given an operand, return the starting bit number.
1556 ; Note that the field isn't necessarily contiguous.
1557
1558 (define (op:start operand) (send operand 'field-start))
1559
1560 ; Given an operand, return the total length in bits.
1561 ; Note that the field isn't necessarily contiguous.
1562
1563 (define (op:length operand) (send operand 'field-length))
1564
1565 ; Return a sorted list of operand lists.
1566 ; Each element in the inner list is an operand with the same name, but for
1567 ; whatever reason were defined separately.
1568 ; The outer list is sorted by name.
1569
1570 (define (op-sort op-list)
1571   ; We assume there is at least one operand.
1572   (if (null? op-list)
1573       (error "op-sort: no operands!"))
1574   ; First sort by name.
1575   (let ((sorted-ops (alpha-sort-obj-list op-list)))
1576     (let loop ((result nil)
1577                ; Current set of operands with same name.
1578                (this-elm (list (car sorted-ops)))
1579                (ops (cdr sorted-ops))
1580                )
1581       (if (null? ops)
1582           ; Reverse things to keep them in file order (minimizes random
1583           ; changes in generated files).
1584           (reverse! (cons (reverse! this-elm) result))
1585           ; Not done.  Check for new set.
1586           (if (eq? (obj:name (car ops)) (obj:name (car this-elm)))
1587               (loop result (cons (car ops) this-elm) (cdr ops))
1588               (loop (cons (reverse! this-elm) result) (list (car ops))
1589                     (cdr ops))))))
1590 )
1591
1592 ; FIXME: Not used anymore but leave in for now.
1593 ; Objects used in assembler syntax ($0, $1, ...).
1594 ;
1595 ;(define <syntax-operand>
1596 ;  (class-make '<syntax-operand> nil '(number value) nil))
1597 ;(method-make-make! <syntax-operand> '(number))
1598 ;
1599 ;(define $0 (make <syntax-operand> 0))
1600 ;(define $1 (make <syntax-operand> 1))
1601 ;(define $2 (make <syntax-operand> 2))
1602 ;(define $3 (make <syntax-operand> 3))
1603 \f
1604 ;; PC support.
1605 ;; This is a subclass of <operand>, used to give the simulator a place to
1606 ;; hang a couple of methods.
1607 ;; At the moment we only support one pc, a reasonable place to stop for now.
1608
1609 (define <pc> (class-make '<pc> '(<operand>) nil nil))
1610
1611 (method-make!
1612  <pc> 'make!
1613  (lambda (self)
1614    (send-next self '<pc> 'make!
1615               (builtin-location) 'pc "program counter"
1616               (atlist-parse (make-prefix-context "make! of pc")
1617                             '(SEM-ONLY) "cgen_operand")
1618               'h-pc ;; FIXME: keep name h-pc hardwired?
1619               'DFLT
1620               ;;(hw-index-scalar) ;; FIXME: change to this
1621               (make <hw-index> 'anonymous
1622                     'ifield 'UINT (current-ifld-lookup 'f-nil))
1623               nil ;; handlers
1624               #f #f) ;; getter setter
1625    self)
1626 )
1627
1628 ; Return a boolean indicating if operand op is the pc.
1629 ; This must not call op:type.  op:type will try to resolve a hardware
1630 ; element that may be multiply specified, and this is used in contexts
1631 ; where that's not possible.
1632
1633 (define (pc? op) (class-instance? <pc> op))
1634 \f
1635 ; Called before/after loading the .cpu file to initialize/finalize.
1636
1637 ; Builtins.
1638 ; The pc operand used in rtl expressions.
1639 (define pc nil)
1640
1641 ; Called before reading a .cpu file in.
1642
1643 (define (operand-init!)
1644   (reader-add-command! 'define-operand
1645                        "\
1646 Define an operand, name/value pair list version.
1647 "
1648                        nil 'arg-list define-operand)
1649   (reader-add-command! 'define-full-operand
1650                        "\
1651 Define an operand, all arguments specified.
1652 "
1653                        nil '(name comment attrs hw-type mode hw-index handlers getter setter)
1654                        define-full-operand)
1655
1656   (reader-add-command! 'define-derived-operand
1657                        "\
1658 Define a derived operand, name/value pair list version.
1659 "
1660                        nil 'arg-list define-derived-operand)
1661
1662   (reader-add-command! 'define-anyof-operand
1663                        "\
1664 Define an anyof operand, name/value pair list version.
1665 "
1666                        nil 'arg-list define-anyof-operand)
1667
1668   *UNSPECIFIED*
1669 )
1670
1671 ; Install builtin operands.
1672
1673 (define (operand-builtin!)
1674   ; Standard operand attributes.
1675   ; ??? Some of these can be combined into one.
1676
1677   (define-attr '(for operand) '(type boolean) '(name NEGATIVE)
1678     '(comment "value is negative"))
1679
1680   ; Operand plays a part in RELAXABLE/RELAXED insns.
1681   (define-attr '(for operand) '(type boolean) '(name RELAX)
1682     '(comment "operand is the relax participant"))
1683
1684   ; ??? Might be able to make SEM-ONLY go away (or machine compute it)
1685   ; by scanning which operands are refered to by the insn syntax strings.
1686   (define-attr '(for operand) '(type boolean) '(name SEM-ONLY)
1687     '(comment "operand is for semantic use only"))
1688
1689   ; Also (defined elsewhere): PCREL-ADDR ABS-ADDR.
1690
1691   (set! pc (make <pc>))
1692   (obj-cons-attr! pc (all-isas-attr))
1693   (current-op-add! pc)
1694
1695   *UNSPECIFIED*
1696 )
1697
1698 ; Called after a .cpu file has been read in.
1699
1700 (define (operand-finish!)
1701   *UNSPECIFIED*
1702 )