cgen/operand.scm

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