cgen/rtl-c.scm

   1 ; RTL->C translation support.
   2 ; Copyright (C) 2000, 2005, 2009, 2010 Red Hat, Inc.
   3 ; This file is part of CGEN.
   4 ; See file COPYING.CGEN for details.
   5
   6 ; Generating C from RTL
   7 ; ---------------------
   8 ; The main way to generate C code from an RTL expression is:
   9 ;
  10 ; (rtl-c-parsed mode isa-name-list nil '(func mode ...))
  11 ;
  12 ; E.g.
  13 ; (rtl-c-parsed SI (all) nil '(add () SI (const () SI 1) (const () SI 2)))
  14 ; -->
  15 ; "ADDSI (1, 2)"
  16 ;
  17 ; The expression is in source form and must be already canonicalized (with
  18 ; rtx-canonicalize).  There is also rtl-c for the occasions where the rtl
  19 ; isn't already canonicalized.
  20 ;
  21 ; The `set' rtx needs to be handled a little carefully.
  22 ; Both the dest and src are processed first, and then code to perform the
  23 ; assignment is computed.  However, the dest may require more than a simple
  24 ; C assignment.  Therefore set dests are converted to the specified object
  25 ; (e.g. a hardware operand) and then a message is sent to this object to
  26 ; perform the actual code generation.
  27 ;
  28 ; All interesting operands (e.g. regs, mem) are `operand' objects.
  29 ; The following messages must be supported by operand objects.
  30 ; - get-mode      - return mode of operand
  31 ; - cxmake-get    - return <c-expr> object containing operand's value
  32 ; - gen-set-quiet - return string of C code to set operand's value (no tracing)
  33 ; - gen-set-trace - return string of C code to set operand's value
  34 ;
  35 ; Instruction fields are refered to by name.
  36 ; Instruction ifields must have these methods:
  37 ; - get-mode
  38 ; - cxmake-get
  39 ;
  40 ; Conventions used in this file:
  41 ; - see rtl.scm
  42 \f
  43 ; The <c-expr> object.
  44 ; This is a fully translated expression (i.e. C code).
  45
  46 (define <c-expr>
  47   (class-make '<c-expr> nil
  48               '(
  49                 ; The mode of C-CODE.
  50                 mode
  51                 ; The translated C code.
  52                 c-code
  53                 ; The source expression, for debugging.
  54                 expr
  55                 ; Attributes of the expression.
  56                 atlist
  57                 ; List of temporaries required to compute the expression.
  58                 ; ??? wip.  These would be combined as the expression is
  59                 ; built up.  Then in sets and other statements, the temporaries
  60                 ; would be declared.
  61                 ;(tmps . nil)
  62                 )
  63               nil)
  64 )
  65
  66 (method-make!
  67  <c-expr> 'make!
  68  (lambda (self mode c-code atlist)
  69    ; FIXME: Extend COS to allow specifying member predicates.
  70    (assert (mode? mode))
  71    (assert (string? c-code))
  72    ;(assert (atlist? atlist)) ; FIXME: What should this be?
  73    (elm-set! self 'mode mode)
  74    (elm-set! self 'c-code c-code)
  75    (elm-set! self 'atlist atlist)
  76    self)
  77 )
  78
  79 ; Accessor fns
  80
  81 (define cx:mode (elm-make-getter <c-expr> 'mode))
  82 (define cx:c-code (elm-make-getter <c-expr> 'c-code))
  83 (define cx:expr (elm-make-getter <c-expr> 'expr))
  84 (define cx:atlist (elm-make-getter <c-expr> 'atlist))
  85 ;(define cx:tmps (elm-make-getter <c-expr> 'tmps))
  86
  87 ; Any object with attributes requires the get-atlist method.
  88
  89 (method-make! <c-expr> 'get-atlist (lambda (self) (elm-get self 'atlist)))
  90
  91 ; Respond to 'get-mode messages.
  92
  93 (method-make! <c-expr> 'get-mode (lambda (self) (elm-get self 'mode)))
  94
  95 ; Respond to 'get-name messages for rtx-dump.
  96
  97 (method-make!
  98  <c-expr> 'get-name
  99  (lambda (self)
 100    (string-append "(" (obj:str-name (elm-get self 'mode)) ") "
 101                   (cx:c self)))
 102 )
 103
 104 ; Return C code to perform an assignment.
 105 ; NEWVAL is a <c-expr> object of the value to be assigned to SELF.
 106
 107 (method-make! <c-expr> 'gen-set-quiet
 108               (lambda (self estate mode indx selector newval)
 109                 (string-append "  " (cx:c self) " = " (cx:c newval) ";\n"))
 110 )
 111
 112 (method-make! <c-expr> 'gen-set-trace
 113               (lambda (self estate mode indx selector newval)
 114                 (string-append "  " (cx:c self) " = " (cx:c newval) ";\n"))
 115 )
 116
 117 ; Return the C code of CX.
 118 ; ??? This used to handle lazy evaluation of the expression.
 119 ; Maybe it will again, so it's left in, as a cover fn to cx:c-code.
 120
 121 (define (cx:c cx)
 122   (cx:c-code cx)
 123 )
 124
 125 ; Main routine to create a <c-expr> node object.
 126 ; MODE is either the mode's symbol (e.g. 'QI) or a <mode> object.
 127 ; CODE is a string of C code.
 128
 129 (define (cx:make mode code)
 130   (make <c-expr> (mode-maybe-lookup mode) code nil)
 131 )
 132
 133 ; Make copy of CX in new mode MODE.
 134 ; MODE must be a <mode> object.
 135
 136 (define (cx-new-mode mode cx)
 137   (make <c-expr> mode (cx:c cx) (cx:atlist cx))
 138 )
 139
 140 ; Same as cx:make except with attributes.
 141
 142 (define (cx:make-with-atlist mode code atlist)
 143   (make <c-expr> (mode-maybe-lookup mode) code atlist)
 144 )
 145
 146 ; Return a boolean indicated if X is a <c-expr> object.
 147
 148 (define (c-expr? x) (class-instance? <c-expr> x))
 149 \f
 150 ; RTX environment support.
 151
 152 (method-make!
 153  <rtx-temp> 'cxmake-get
 154  (lambda (self estate mode indx selector)
 155    (cx:make mode (rtx-temp-value self)))
 156 )
 157
 158 (method-make!
 159  <rtx-temp> 'gen-set-quiet
 160  (lambda (self estate mode indx selector src)
 161    (string-append "  " (rtx-temp-value self) " = " (cx:c src) ";\n"))
 162 )
 163
 164 (method-make!
 165  <rtx-temp> 'gen-set-trace
 166  (lambda (self estate mode indx selector src)
 167    (string-append "  " (rtx-temp-value self) " = " (cx:c src) ";\n"))
 168 )
 169
 170 (define (gen-temp-defs estate env)
 171   (string-map (lambda (temp)
 172                 (let ((temp-obj (cdr temp)))
 173                   (string-append "  " (mode:c-type (rtx-temp-mode temp-obj))
 174                                  " " (rtx-temp-value temp-obj) ";\n")))
 175               env)
 176 )
 177 \f
 178 ; Top level routines to handle rtl->c translation.
 179
 180 ; rtl->c configuration parameters
 181
 182 ; #t -> emit calls to rtl cover fns, otherwise emit plain C where possible.
 183 (define /rtl-c-rtl-cover-fns? #f)
 184
 185 ; Called before emitting code to configure the generator.
 186 ; ??? I think this can go away now (since cover-fn specification is also
 187 ; done at each call to rtl-c).
 188
 189 (define (rtl-c-config! . args)
 190   (set! /rtl-c-rtl-cover-fns? #f)
 191   (let loop ((args args))
 192     (if (null? args)
 193         #f ; done
 194         (begin
 195           (case (car args)
 196             ((#:rtl-cover-fns?)
 197              (set! /rtl-c-rtl-cover-fns? (cadr args)))
 198             (else (error "rtl-c-config: unknown option:" (car args))))
 199           (loop (cddr args)))))
 200   *UNSPECIFIED*
 201 )
 202
 203 ; Subclass of <eval-state> to record additional things needed for rtl->c.
 204
 205 (define <rtl-c-eval-state>
 206   (class-make '<rtl-c-eval-state> '(<eval-state>)
 207               '(
 208                 ; #t -> emit calls to rtl cover fns.
 209                 (rtl-cover-fns? . #f)
 210
 211                 ; name of output language, "c" or "c++"
 212                 (output-language . "c")
 213
 214                 ; #t if generating code for a macro.
 215                 ; Each newline is then preceeded with '\\'.
 216                 (macro? . #f)
 217
 218                 ; Boolean indicating if evaluation is for an instruction.
 219                 ; It's not always possible to look at OWNER, e.g. when we're
 220                 ; processing semantic fragments.
 221                 (for-insn? . #f)
 222
 223                 ; #f -> reference ifield values using FLD macro.
 224                 ; #t -> use C variables.
 225                 ; ??? This is only needed to get correct ifield references
 226                 ; in opcodes, decoder, and semantics.  Maybe a better way to
 227                 ; go would be to specify the caller's name so there'd be just
 228                 ; one of these, rather than an increasing number.  However,
 229                 ; for now either way is the same.
 230                 ; An alternative is to specify a callback to try first.
 231                 (ifield-var? . #f)
 232                 )
 233               nil)
 234 )
 235
 236 ; FIXME: involves upcasting.
 237 (define-getters <rtl-c-eval-state> estate
 238   (rtl-cover-fns? output-language macro? for-insn? ifield-var?)
 239 )
 240
 241 ; Return booleans indicating if output language is C/C++.
 242
 243 (define (estate-output-language-c? estate)
 244   (string=? (estate-output-language estate) "c")
 245 )
 246 (define (estate-output-language-c++? estate)
 247   (string=? (estate-output-language estate) "c++")
 248 )
 249
 250 (method-make!
 251  <rtl-c-eval-state> 'vmake!
 252  (lambda (self args)
 253    ; Initialize parent class first.
 254    (let loop ((args (send-next self '<rtl-c-eval-state> 'vmake! args))
 255               (unrecognized nil))
 256      (if (null? args)
 257          (reverse! unrecognized) ; ??? Could invoke method to initialize here.
 258          (begin
 259            (case (car args)
 260              ((#:rtl-cover-fns?)
 261               (elm-set! self 'rtl-cover-fns? (cadr args)))
 262              ((#:output-language)
 263               (elm-set! self 'output-language (cadr args)))
 264              ((#:macro?)
 265               (elm-set! self 'macro? (cadr args)))
 266              ((#:for-insn?)
 267               (elm-set! self 'for-insn? (cadr args)))
 268              ((#:ifield-var?)
 269               (elm-set! self 'ifield-var? (cadr args)))
 270              (else
 271               ; Build in reverse order, as we reverse it back when we're done.
 272               (set! unrecognized
 273                     (cons (cadr args) (cons (car args) unrecognized)))))
 274            (loop (cddr args) unrecognized)))))
 275 )
 276
 277 ;; Build an estate for use in generating C.
 278 ;; OVERRIDES is a #:keyword/value list of parameters to apply last.
 279
 280 (define (estate-make-for-rtl-c overrides)
 281   (apply vmake
 282          (append!
 283           (list
 284            <rtl-c-eval-state>
 285            #:expr-fn (lambda (rtx-obj expr mode estate)
 286                        (rtl-c-generator rtx-obj))
 287            #:rtl-cover-fns? /rtl-c-rtl-cover-fns?)
 288           overrides))
 289 )
 290
 291 ; Translate RTL expression EXPR to C.
 292 ; ESTATE is the current rtx evaluation state.
 293 ; MODE is a <mode> object.
 294
 295 (define (rtl-c-with-estate estate mode expr)
 296   (cx:c (rtl-c-get estate mode (rtx-eval-with-estate expr mode estate)))
 297 )
 298
 299 ; Translate parsed RTL expression X to a string of C code.
 300 ; EXPR must have already been fed through rtx-canonicalize.
 301 ; MODE is the desired mode of the value or DFLT for "natural mode".
 302 ; MODE is a <mode> object.
 303 ; OVERRIDES is a #:keyword/value list of arguments to build the eval state
 304 ; with.
 305
 306 (define (rtl-c-parsed mode expr . overrides)
 307   ;; ??? If we're passed insn-compiled-semantics the output of xops is
 308   ;; confusing.  Fix by subclassing <operand> -> <xoperand>, and
 309   ;; have <xoperand> provide original source expr.
 310   (let ((estate (estate-make-for-rtl-c (cons #:outer-expr
 311                                              (cons expr overrides)))))
 312     (rtl-c-with-estate estate mode expr))
 313 )
 314
 315 ; Same as rtl-c-parsed but EXPR is unparsed.
 316 ; ISA-NAME-LIST is the list of ISA(s) in which to evaluate EXPR.
 317 ; EXTRA-VARS-ALIST is an association list of extra (symbol <mode> value)
 318 ; elements to be used during value lookup.
 319 ; MODE is a <mode> object.
 320
 321 (define (rtl-c mode isa-name-list extra-vars-alist expr . overrides)
 322   (let* ((canonical-rtl (rtx-canonicalize #f (obj:name mode)
 323                                           isa-name-list extra-vars-alist expr))
 324          (estate (estate-make-for-rtl-c (cons #:outer-expr
 325                                               (cons canonical-rtl overrides)))))
 326     (rtl-c-with-estate estate mode canonical-rtl))
 327 )
 328
 329 ; Same as rtl-c-with-estate except return a <c-expr> object.
 330 ; MODE is a <mode> object.
 331
 332 (define (rtl-c-expr-with-estate estate mode expr)
 333   (rtl-c-get estate mode (rtx-eval-with-estate expr mode estate))
 334 )
 335
 336 ; Same as rtl-c-parsed except return a <c-expr> object.
 337 ; MODE is a <mode> object.
 338
 339 (define (rtl-c-expr-parsed mode expr . overrides)
 340   ;; ??? If we're passed insn-compiled-semantics the output of xops is
 341   ;; confusing.  Fix by subclassing <operand> -> <xoperand>, and
 342   ;; have <xoperand> provide original source expr.
 343   (let ((estate (estate-make-for-rtl-c (cons #:outer-expr
 344                                              (cons expr overrides)))))
 345     (rtl-c-expr-with-estate estate mode expr))
 346 )
 347
 348 ; Same as rtl-c-expr-parsed but EXPR is unparsed.
 349 ; MODE is a <mode> object.
 350
 351 (define (rtl-c-expr mode isa-name-list extra-vars-alist expr . overrides)
 352   (let* ((canonical-rtl (rtx-canonicalize #f (obj:name mode)
 353                                           isa-name-list extra-vars-alist expr))
 354          (estate (estate-make-for-rtl-c (cons #:outer-expr
 355                                               (cons canonical-rtl overrides)))))
 356     (rtl-c-expr-with-estate estate mode canonical-rtl))
 357 )
 358 \f
 359 ; C++ versions of rtl-c routines.
 360
 361 ; Build an estate for use in generating C++.
 362 ; OVERRIDES is a #:keyword/value list of parameters to apply last.
 363
 364 (define (estate-make-for-rtl-c++ overrides)
 365   (estate-make-for-rtl-c (cons #:output-language (cons "c++" overrides)))
 366 )
 367
 368 ; Translate parsed RTL expression X to a string of C++ code.
 369 ; EXPR must have already been fed through rtx-canonicalize.
 370 ; MODE is the desired mode of the value or DFLT for "natural mode".
 371 ; MODE is a <mode> object.
 372 ; OVERRIDES is a #:keyword/value list of arguments to build the eval state
 373 ; with.
 374
 375 (define (rtl-c++-parsed mode expr . overrides)
 376   ;; ??? If we're passed insn-compiled-semantics the output of xops is
 377   ;; confusing.  Fix by subclassing <operand> -> <xoperand>, and
 378   ;; have <xoperand> provide original source expr.
 379   (let ((estate (estate-make-for-rtl-c++ (cons #:outer-expr
 380                                                (cons expr overrides)))))
 381     (rtl-c-with-estate estate mode expr))
 382 )
 383
 384 ; Same as rtl-c++-parsed but EXPR is unparsed.
 385 ; MODE is a <mode> object.
 386
 387 (define (rtl-c++ mode isa-name-list extra-vars-alist expr . overrides)
 388   (let* ((canonical-rtl (rtx-canonicalize #f (obj:name mode)
 389                                           isa-name-list extra-vars-alist expr))
 390          (estate (estate-make-for-rtl-c++ (cons #:outer-expr
 391                                                 (cons canonical-rtl overrides)))))
 392     (rtl-c-with-estate estate mode canonical-rtl))
 393 )
 394 \f
 395 ; Top level routines for getting/setting values.
 396
 397 ; Return a <c-expr> node to get the value of SRC in mode MODE.
 398 ; ESTATE is the current rtl evaluation state.
 399 ; MODE is a <mode> object.
 400 ; SRC is one of:
 401 ; - <c-expr> node
 402 ; - rtl expression (e.g. '(add WI dr sr))
 403 ; - sequence's local variable name
 404 ; - sequence's local variable object
 405 ; - operand name
 406 ; - operand object
 407 ; - an integer
 408 ; - a string of C code
 409 ; FIXME: Reduce acceptable values of SRC.
 410 ; The result has mode MODE, unless MODE is the "default mode indicator"
 411 ; (DFLT) in which case the mode of the result is derived from SRC.
 412 ;
 413 ; ??? mode compatibility checks are wip
 414
 415 (define (/rtl-c-get estate mode src)
 416   (let ((mode mode)) ;;(mode:lookup mode)))
 417
 418     (cond ((c-expr? src)
 419            (cond ((or (mode:eq? 'VOID mode)
 420                       (mode:eq? 'DFLT mode)
 421                       (mode:eq? (cx:mode src) mode))
 422                   src)
 423                  ((rtx-mode-compatible? mode (cx:mode src))
 424                   (cx-new-mode mode src))
 425                  (else
 426                   (estate-error
 427                    estate
 428                    (string-append "incompatible mode: "
 429                                   "(" (obj:str-name (cx:mode src)) " vs "
 430                                   (obj:str-name mode) ") in "
 431                                   "\"" (cx:c src) "\"")
 432                    (obj:name mode)))))
 433
 434           ; The recursive call to /rtl-c-get is in case the result of rtx-eval
 435           ; is a hardware object, rtx-func object, or another rtl expression.
 436           ; FIXME: simplify
 437           ((rtx? src)
 438            (let ((evald-src (rtx-eval-with-estate src mode estate)))
 439              ; There must have been some change, otherwise we'll loop forever.
 440              (assert (not (eq? src evald-src)))
 441              (/rtl-c-get estate mode evald-src)))
 442
 443           ;; FIXME: Can we ever get a symbol here?
 444           ((or (and (symbol? src) (current-op-lookup src))
 445                (operand? src))
 446            (begin
 447              (if (symbol? src)
 448                  (set! src (current-op-lookup src)))
 449              (cond ((mode:eq? 'DFLT mode)
 450                     ; FIXME: Can we get called with 'DFLT anymore?
 451                     ; FIXME: If we fetch the mode here, operands can assume
 452                     ; they never get called with "default mode".
 453                     (send src 'cxmake-get estate mode #f #f))
 454                    ((rtx-mode-compatible? mode (op:mode src))
 455                     (let ((mode (op:mode src))) ;; FIXME: (rtx-sem-mode mode)))
 456                       (send src 'cxmake-get estate mode #f #f)))
 457                    (else
 458                     ;; FIXME: canonicalization should have already caught this
 459                     (estate-error
 460                      estate
 461                      (string-append "operand " (obj:str-name src)
 462                                     " referenced in incompatible mode")
 463                      (obj:name mode))))))
 464
 465           ;; FIXME: Can we ever get a symbol here?
 466           ((or (and (symbol? src) (rtx-temp-lookup (estate-env-stack estate) src))
 467                (rtx-temp? src))
 468            (begin
 469              (if (symbol? src)
 470                  (set! src (rtx-temp-lookup (estate-env-stack estate) src)))
 471              (cond ((mode:eq? 'DFLT mode)
 472                     (send src 'cxmake-get estate (rtx-temp-mode src) #f #f))
 473                    ((rtx-mode-compatible? mode (rtx-temp-mode src))
 474                     (let ((mode (rtx-temp-mode src))) ;; FIXME: (rtx-sem-mode mode)))
 475                       (send src 'cxmake-get estate mode #f #f)))
 476                    (else
 477                     ;; FIXME: canonicalization should have already caught this
 478                     (estate-error
 479                      estate
 480                      (string-append "sequence temp " (rtx-temp-name src)
 481                                     " referenced in incompatible mode")
 482                      (obj:name mode))))))
 483
 484           ((integer? src)
 485            ; Default mode of integer argument is INT.
 486            (if (or (mode:eq? 'DFLT mode) (mode:eq? 'VOID mode))
 487                (cx:make INT (number->string src))
 488                (cx:make mode (number->string src))))
 489
 490           ((string? src)
 491            ; Default mode of string argument is INT.
 492            (if (or (mode:eq? 'DFLT mode) (mode:eq? 'VOID mode))
 493                (cx:make INT src)
 494                (cx:make mode src)))
 495
 496           (else (estate-error estate "/rtl-c-get: invalid argument" src))))
 497 )
 498
 499 ;; MODE is either a <mode> object or the mode name.
 500
 501 (define (rtl-c-get estate mode src)
 502   (let ((mode (mode-maybe-lookup mode)))
 503     (logit 4 (spaces (estate-depth estate))
 504            "(rtl-c-get " (mode-real-name mode) " " (rtx-strdump src) ")\n")
 505     (let ((result (/rtl-c-get estate mode src)))
 506       (logit 4 (spaces (estate-depth estate))
 507              "(rtl-c-get " (mode-real-name mode) " " (rtx-strdump src) ") => "
 508              (cx:c result) "\n")
 509       result))
 510 )
 511
 512 ; Return a <c-expr> object to set the value of DEST to SRC.
 513 ; ESTATE is the current rtl evaluation state.
 514 ; MODE is the mode of DEST or DFLT which means fetch the real mode from DEST.
 515 ; MODE is either a <mode> object or the mode name.
 516 ; DEST is one of:
 517 ; - <c-expr> node
 518 ; - rtl expression (e.g. '(mem QI dr))
 519 ; SRC is an RTX expression.  It is important that we evaluate it, instead of
 520 ; our caller, because only we know the mode of DEST (which we need to pass
 521 ; when evaluating SRC if MODE is DFLT).  ??? Can no longer get DFLT, but
 522 ; it feels right to continue to evaluate SRC here.
 523 ; The mode of the result is always VOID (void).
 524 ;
 525 ; ??? One possible optimization is to pass the address of the result
 526 ; to the computation of SRC.  Seems dodgey though.
 527
 528 (define (rtl-c-set-quiet estate mode dest src)
 529   ;(display (list 'rtl-c-set-quiet mode dest src)) (newline)
 530   (let* ((mode (mode-maybe-lookup mode))
 531          (xdest (cond ((c-expr? dest)
 532                        dest)
 533                       ((rtx? dest)
 534                        (rtx-eval-with-estate dest mode estate))
 535                       (else
 536                        (estate-error estate
 537                                      "rtl-c-set-quiet: invalid dest"
 538                                      dest)))))
 539     (assert (mode? mode))
 540     (if (not (object? xdest))
 541         (estate-error estate "rtl-c-set-quiet: invalid dest" dest))
 542     (cx:make VOID (send xdest 'gen-set-quiet
 543                         estate mode #f #f
 544                         (rtl-c-get estate mode src))))
 545 )
 546
 547 ; Same as rtl-c-set-quiet except also print TRACE_RESULT message.
 548 ; MODE is either a <mode> object or the mode name.
 549 ; ??? One possible change is to defer the (rtl-c-get src) call to dest's
 550 ; set handler.  Such sources would be marked accordingly and rtl-c-get
 551 ; would recognize them.  This would allow, for example, passing the address
 552 ; of the result to the computation.
 553
 554 (define (rtl-c-set-trace estate mode dest src)
 555   ;(display (list 'rtl-c-set-trace mode dest src)) (newline)
 556   (let* ((mode (mode-maybe-lookup mode))
 557          (xdest (cond ((c-expr? dest)
 558                        dest)
 559                       ((rtx? dest)
 560                        (rtx-eval-with-estate dest mode estate))
 561                       (else
 562                        (estate-error estate
 563                                      "rtl-c-set-trace: invalid dest"
 564                                      dest)))))
 565     (assert (mode? mode))
 566     (if (not (object? xdest))
 567         (estate-error estate "rtl-c-set-trace: invalid dest" dest))
 568     (cx:make VOID (send xdest 'gen-set-trace
 569                         estate mode #f #f
 570                         (rtl-c-get estate mode src))))
 571 )
 572 \f
 573 ; Emit C code for each rtx function.
 574
 575 ; Table mapping rtx function to C generator.
 576
 577 (define /rtl-c-gen-table #f)
 578
 579 ; Return the C generator for <rtx-func> F.
 580
 581 (define (rtl-c-generator f)
 582   (vector-ref /rtl-c-gen-table (rtx-num f))
 583 )
 584 \f
 585 ; Support for explicit C/C++ code.
 586 ; MODE is the mode name.
 587 ; ??? Actually, "support for explicit foreign language code".
 588 ; s-c-call needs a better name but "unspec" seems like obfuscation.
 589 ; ??? Need to distinguish owner of call (cpu, ???).
 590
 591 (define (s-c-call estate mode name . args)
 592   (cx:make mode
 593            (string-append
 594             (if (estate-output-language-c++? estate)
 595                 (string-append "current_cpu->" name " (")
 596                 ; FIXME: Prepend @cpu@_ to name here, and delete @cpu@_ from
 597                 ; description file.
 598                 (string-append name " (current_cpu"))
 599             (let ((c-args
 600                    (string-map (lambda (arg)
 601                                  (string-append
 602                                   ", "
 603                                   (cx:c (rtl-c-get estate DFLT arg))))
 604                                args)))
 605               (if (estate-output-language-c++? estate)
 606                   (string-drop 2 c-args)
 607                   c-args))
 608             ; If the mode is VOID, this is a statement.
 609             ; Otherwise it's an expression.
 610             ; ??? Bad assumption!  VOID expressions may be used
 611             ; within sequences without local vars, which are translated
 612             ; to comma-expressions.
 613             (if (or (mode:eq? 'DFLT mode) ;; FIXME: can't get DFLT anymore
 614                     (mode:eq? 'VOID mode))
 615                 ");\n"
 616                 ")")
 617             ))
 618 )
 619
 620 ; Same as c-call except there is no particular owner of the call.
 621 ; In general this means making a call to a non-member function,
 622 ; whereas c-call makes calls to member functions (in C++ parlance).
 623 ; MODE is the mode name.
 624
 625 (define (s-c-raw-call estate mode name . args)
 626   (cx:make mode
 627            (string-append
 628             name " ("
 629             (string-drop 2
 630                          (string-map (lambda (elm)
 631                                        (string-append
 632                                         ", " (cx:c (rtl-c-get estate DFLT elm))))
 633                                      args))
 634             ; If the mode is VOID, this is a statement.
 635             ; Otherwise it's an expression.
 636             ; ??? Bad assumption!  VOID expressions may be used
 637             ; within sequences without local vars, which are translated
 638             ; to comma-expressions.
 639             (if (or (mode:eq? 'DFLT mode) ;; FIXME: can't get DFLT anymore
 640                     (mode:eq? 'VOID mode))
 641                 ");\n"
 642                 ")")
 643             ))
 644 )
 645 \f
 646 ; Standard arithmetic operations.
 647
 648 ; Return a boolean indicating if a cover function/macro should be emitted
 649 ; to perform an operation.
 650 ; C-OP is a string containing the C operation or #f if there is none.
 651 ; MODE is the mode of the operation.
 652
 653 (define (/rtx-use-sem-fn? estate c-op mode)
 654   ; If no C operation has been provided, use a macro, or
 655   ; if this is the simulator and MODE is not a host mode, use a macro.
 656 ;  (or (not c-op)
 657 ;      (and (estate-rtl-cover-fns? estate)
 658 ;          (not (mode:host? mode))))
 659   ; FIXME: The current definition is a temporary hack while host/target-ness
 660   ; of INT/UINT is unresolved.
 661   (and (not (obj-has-attr? mode 'FORCE-C))
 662        (or (not c-op)
 663            (and (estate-rtl-cover-fns? estate)
 664                 ;; NOTE: We can't check (insn? (estate-owner estate)) here.
 665                 ;; It's not necessarily present for semantic fragments.
 666                 (or (estate-for-insn? estate)
 667                     (not (mode:host? mode))))))
 668 )
 669
 670 ; One operand referenced, result is in same mode.
 671 ; MODE is the mode name.
 672
 673 (define (s-unop estate name c-op mode src)
 674   (let* ((val (rtl-c-get estate mode src))
 675          ; Refetch mode in case it was DFLT and ensure unsigned->signed.
 676          (mode (mode:lookup mode)) ;;(cx:mode val)) ;; FIXME: can't get DFLT anymore
 677          (sem-mode (rtx-sem-mode mode)))
 678     ; FIXME: Argument checking.
 679
 680     (if (/rtx-use-sem-fn? estate c-op mode)
 681         (if (mode-float? mode)
 682             (cx:make sem-mode
 683                      (string-append "CGEN_CPU_FPU (current_cpu)->ops->"
 684                                     (string-downcase name)
 685                                     (string-downcase (obj:str-name sem-mode))
 686                                     " (CGEN_CPU_FPU (current_cpu), "
 687                                     (cx:c val) ")"))
 688             (cx:make sem-mode
 689                      (string-append name (obj:str-name sem-mode)
 690                                     " (" (cx:c val) ")")))
 691         (cx:make mode ; not sem-mode on purpose
 692                  (string-append "(" c-op " ("
 693                                 (cx:c val) "))"))))
 694 )
 695
 696 ; Two operands referenced in the same mode producing a result in the same mode.
 697 ; MODE is the mode name.
 698 ;
 699 ; ??? Will eventually want to handle floating point modes specially.  Since
 700 ; bigger modes may get clumsily passed (there is no pass by reference in C) and
 701 ; since we want to eventually handle lazy transformation, FP values could be
 702 ; passed by reference.  This is easy in C++.  C requires more work and is
 703 ; defered until it's warranted.
 704 ; Implementing this should probably be via a new cxmake-get-ref method,
 705 ; rather then complicating cxmake-get.  Ditto for rtl-c-get-ref/rtl-c-get.
 706
 707 (define (s-binop estate name c-op mode src1 src2)
 708   ;(display (list "binop " name ", mode " mode)) (newline)
 709   (let* ((val1 (rtl-c-get estate mode src1))
 710          ; Refetch mode in case it was DFLT and ensure unsigned->signed.
 711          (mode (mode:lookup mode)) ;;(cx:mode val1)) ;; FIXME: can't get DFLT anymore
 712          (sem-mode (rtx-sem-mode mode))
 713          (val2 (rtl-c-get estate mode src2)))
 714     ; FIXME: Argument checking.
 715
 716     (if (/rtx-use-sem-fn? estate c-op mode)
 717         (if (mode-float? mode)
 718             (cx:make sem-mode
 719                      (string-append "CGEN_CPU_FPU (current_cpu)->ops->"
 720                                     (string-downcase name)
 721                                     (string-downcase (obj:str-name sem-mode))
 722                                     " (CGEN_CPU_FPU (current_cpu), "
 723                                     (cx:c val1) ", "
 724                                     (cx:c val2) ")"))
 725             (cx:make sem-mode
 726                      (string-append name (obj:str-name sem-mode)
 727                                     " (" (cx:c val1) ", "
 728                                     (cx:c val2) ")")))
 729         (cx:make mode ; not sem-mode on purpose
 730                  (string-append "(("
 731                                 (cx:c val1)
 732                                 ") " c-op " ("
 733                                 (cx:c val2)
 734                                 "))"))))
 735 )
 736
 737 ; Same as s-binop except there's a third argument which is always one bit.
 738 ; MODE is the mode name.
 739
 740 (define (s-binop-with-bit estate name mode src1 src2 src3)
 741   (let* ((val1 (rtl-c-get estate mode src1))
 742          ; Refetch mode in case it was DFLT and ensure unsigned->signed.
 743          (mode (mode:lookup mode)) ;;(cx:mode val1)) ;; FIXME: can't get DFLT anymore
 744          (sem-mode (rtx-sem-mode mode))
 745          (val2 (rtl-c-get estate mode src2))
 746          (val3 (rtl-c-get estate 'BI src3)))
 747     ; FIXME: Argument checking.
 748
 749     (cx:make mode
 750           (string-append name (obj:str-name sem-mode)
 751                          " ("
 752                          (cx:c val1) ", "
 753                          (cx:c val2) ", "
 754                          (cx:c val3)
 755                          ")")))
 756 )
 757
 758 ; Shift operations are slightly different than binary operations:
 759 ; the mode of src2 is any integral mode.
 760 ; MODE is the mode name.
 761 ; ??? Note that some cpus have a signed shift left that is semantically
 762 ; different from a logical one.  May need to create `sla' some day.  Later.
 763
 764 (define (s-shop estate name c-op mode src1 src2)
 765   ;(display (list "shop " name ", mode " mode)) (newline)
 766   (let* ((val1 (rtl-c-get estate mode src1))
 767          ; Refetch mode in case it was DFLT and ensure unsigned->signed
 768          ; [sign of operation is determined from operation name, not mode].
 769          (mode (mode:lookup mode)) ;;(cx:mode val1)) ;; FIXME: can't get DFLT anymore
 770          (sem-mode (rtx-sem-mode mode))
 771          (val2 (rtl-c-get estate mode src2)))
 772     ; FIXME: Argument checking.
 773
 774     (if (/rtx-use-sem-fn? estate c-op mode)
 775         (cx:make sem-mode
 776                  (string-append name (obj:str-name sem-mode)
 777                                 " (" (cx:c val1) ", "
 778                                 (cx:c val2) ")"))
 779         (cx:make mode ; not sem-mode on purpose
 780                  (string-append "("
 781                                 ;; Ensure correct sign of shift.
 782                                 (cond ((equal? name "SRL")
 783                                        (string-append
 784                                         "("
 785                                         (cond ((mode-unsigned? mode) (mode:c-type mode))
 786                                               ((mode:eq? mode 'INT) (mode:c-type UINT))
 787                                               (else (mode:c-type (mode-find (mode:bits mode) 'UINT))))
 788                                         ") "))
 789                                       ((equal? name "SRA")
 790                                        (string-append
 791                                         "("
 792                                         (cond ((mode-signed? mode) (mode:c-type mode))
 793                                               ((mode:eq? mode 'UINT) (mode:c-type INT))
 794                                               (else (mode:c-type (mode-find (mode:bits mode) 'INT))))
 795                                         ") "))
 796                                       ;; May wish to make this unsigned if not
 797                                       ;; already.  Later.
 798                                       (else ""))
 799                                 "(" (cx:c val1) ") "
 800                                 c-op
 801                                 " (" (cx:c val2) "))"))))
 802 )
 803
 804 ; Process andif, orif.
 805 ; SRC1 and SRC2 have any arithmetic mode.
 806 ; MODE is the mode name.
 807 ; The result has mode BI.
 808 ; ??? May want to use INT as BI may introduce some slowness
 809 ; in the generated code.
 810
 811 (define (s-boolifop estate name c-op src1 src2)
 812   (let* ((val1 (rtl-c-get estate DFLT src1))
 813          (val2 (rtl-c-get estate DFLT src2)))
 814     ; FIXME: Argument checking.
 815
 816     ; If this is the simulator and MODE is not a host mode, use a macro.
 817     ; ??? MODE here being the mode of SRC1.  Maybe later.
 818     (if (estate-rtl-cover-fns? estate)
 819         (cx:make (mode:lookup 'BI)
 820                  (string-append name ; "BI", leave off mode, no need for it
 821                                 " (" (cx:c val1) ", "
 822                                 (cx:c val2) ")"))
 823         (cx:make (mode:lookup 'BI)
 824                  (string-append "(("
 825                                 (cx:c val1)
 826                                 ") " c-op " ("
 827                                 (cx:c val2)
 828                                 "))"))))
 829 )
 830
 831 ; Mode conversions.
 832 ; MODE is the mode name.
 833
 834 (define (s-convop estate name mode s1)
 835   ; Get S1 in its normal mode, then convert.
 836   (let ((s (rtl-c-get estate DFLT s1))
 837         (mode (mode:lookup mode)))
 838     (if (and (not (estate-rtl-cover-fns? estate))
 839              (mode:host? (cx:mode s)))
 840         (cx:make mode
 841                  (string-append "((" (obj:str-name mode) ")"
 842                                 " (" (obj:str-name (cx:mode s)) ")"
 843                                 " (" (cx:c s) "))"))
 844         (if (or (mode-float? mode)
 845                 (mode-float? (cx:mode s)))
 846             (cx:make mode
 847                      (string-append "CGEN_CPU_FPU (current_cpu)->ops->"
 848                                     (string-downcase name)
 849                                     (string-downcase (obj:str-name (rtx-sem-mode (cx:mode s))))
 850                                     (string-downcase (obj:str-name (rtx-sem-mode mode)))
 851                                     " (CGEN_CPU_FPU (current_cpu), "
 852                                     (cx:c s) ")"))
 853             (cx:make mode
 854                      (string-append name
 855                                     (obj:str-name (rtx-sem-mode (cx:mode s)))
 856                                     (obj:str-name (rtx-sem-mode mode))
 857                                     " (" (cx:c s) ")")))))
 858 )
 859
 860 ; Compare SRC1 and SRC2 in mode MODE.
 861 ; NAME is one of eq,ne,lt,le,gt,ge,ltu,leu,gtu,geu.
 862 ; MODE is the mode name.
 863 ; The result has mode BI.
 864 ; ??? May want a host int mode result as BI may introduce some slowness
 865 ; in the generated code.
 866
 867 (define (s-cmpop estate name c-op mode src1 src2)
 868   (let* ((val1 (rtl-c-get estate mode src1))
 869          ; Refetch mode in case it was DFLT.
 870          (mode (mode:lookup mode)) ;;(cx:mode val1)) ;; FIXME: can't get DFLT anymore
 871          (val2 (rtl-c-get estate mode src2)))
 872     ; FIXME: Argument checking.
 873
 874     ; If no C operation has been provided, use a macro, or
 875     ; if this is the simulator and MODE is not a host mode, use a macro.
 876     (if (/rtx-use-sem-fn? estate c-op mode)
 877         (if (mode-float? mode)
 878             (cx:make (mode:lookup 'BI)
 879                      (string-append "CGEN_CPU_FPU (current_cpu)->ops->"
 880                                     (string-downcase (symbol->string name))
 881                                     (string-downcase (obj:str-name (rtx-sem-mode mode)))
 882                                     " (CGEN_CPU_FPU (current_cpu), "
 883                                     (cx:c val1) ", "
 884                                     (cx:c val2) ")"))
 885             (cx:make (mode:lookup 'BI)
 886                      (string-append (string-upcase (symbol->string name))
 887                                     (if (memq name '(eq ne))
 888                                         (obj:str-name (rtx-sem-mode mode))
 889                                         (obj:str-name mode))
 890                                     " (" (cx:c val1) ", "
 891                                     (cx:c val2) ")")))
 892         (cx:make (mode:lookup 'BI)
 893                  (string-append "(("
 894                                 (cx:c val1)
 895                                 ") " c-op " ("
 896                                 (cx:c val2)
 897                                 "))"))))
 898 )
 899 \f
 900 ; Conditional execution.
 901
 902 ; `if' in RTL has a result, like ?: in C.
 903 ; We support both: one with a result (non VOID mode), and one without (VOID mode).
 904 ; The non-VOID case must have an else part.
 905 ; MODE is the mode of the result, not the comparison.
 906 ; MODE is the mode name.
 907 ; The comparison is expected to return a zero/non-zero value.
 908 ; ??? Perhaps this should be a syntax-expr.  Later.
 909
 910 (define (s-if estate mode cond then . else)
 911   (if (> (length else) 1)
 912       (estate-error estate "if: too many elements in `else' part" else))
 913   (let ()
 914     (if (or (mode:eq? 'DFLT mode) ;; FIXME: can't get DFLT anymore
 915             (mode:eq? 'VOID mode))
 916         (cx:make mode
 917                  (string-append "if (" (cx:c (rtl-c-get estate DFLT cond)) ")"
 918                                 " {\n" (cx:c (rtl-c-get estate mode then)) "}"
 919                                 (if (not (null? else))
 920                                     (string-append " else {\n"
 921                                                    (cx:c (rtl-c-get estate mode (car else)))
 922                                                    "}\n")
 923                                     "\n")
 924                                 ))
 925         (if (= (length else) 1)
 926             (cx:make mode
 927                      (string-append "(("
 928                                     (cx:c (rtl-c-get estate DFLT cond))
 929                                     ") ? ("
 930                                     (cx:c (rtl-c-get estate mode then))
 931                                     ") : ("
 932                                     (cx:c (rtl-c-get estate mode (car else)))
 933                                     "))"))
 934             (estate-error estate "non-void-mode `if' must have `else' part"))))
 935 )
 936
 937 ; A multiway `if'.
 938 ; MODE is the mode name.
 939 ; If MODE is VOID emit a series of if/else's.
 940 ; If MODE is not VOID, emit a series of ?:'s.
 941 ; COND-CODE-LIST is a list of lists, each sublist is a list of two elements:
 942 ; condition, code.  The condition part must return a zero/non-zero value, and
 943 ; the code part is treated as a `sequence'.
 944 ; This defer argument evaluation, the syntax
 945 ; ((... condition ...) ... action ...)
 946 ; needs special parsing.
 947 ; FIXME: Need more error checking of arguments.
 948
 949 (define (s-cond estate mode . cond-code-list)
 950   ;; FIXME: can't get DFLT anymore
 951   (let ((vm? (or (mode:eq? 'DFLT mode) (mode:eq? 'VOID mode))))
 952     (if (null? cond-code-list)
 953         (estate-error estate "empty `cond'"))
 954     (let ((if-part (if vm?  "if (" "("))
 955           (then-part (if vm? ") " ") ? "))
 956           (elseif-part (if vm? " else if (" " : ("))
 957           (else-part (if vm? " else " " : "))
 958           (fi-part (if vm? "" ")")))
 959       (let loop ((result
 960                   (string-append
 961                    if-part
 962                    (cx:c (rtl-c-get estate DFLT (caar cond-code-list)))
 963                    then-part
 964                    (cx:c (apply s-sequence
 965                                 (cons estate
 966                                       (cons mode
 967                                             (cons nil
 968                                                   (cdar cond-code-list))))))))
 969                  (ccl (cdr cond-code-list)))
 970         (cond ((null? ccl) (cx:make mode result))
 971               ((eq? (caar ccl) 'else)
 972                (cx:make mode
 973                         (string-append
 974                          result
 975                          else-part
 976                          (cx:c (apply s-sequence
 977                                       (cons estate
 978                                             (cons mode
 979                                                   (cons nil
 980                                                         (cdar ccl)))))))))
 981               (else (loop (string-append
 982                            result
 983                            elseif-part
 984                            (cx:c (rtl-c-get estate DFLT (caar ccl)))
 985                            then-part
 986                            (cx:c (apply s-sequence
 987                                         (cons estate
 988                                               (cons mode
 989                                                     (cons nil
 990                                                           (cdar ccl)))))))
 991                           (cdr ccl)))))))
 992 )
 993
 994 ; Utility of s-case to print a case prefix (for lack of a better term).
 995
 996 (define (/gen-case-prefix val)
 997   (string-append "  case "
 998                  (cond ((number? val)
 999                         (number->string val))
1000                        ((symbol? val)
1001                         (string-upcase (gen-c-symbol val))) ; yes, upcase
1002                        ((string? val) val)
1003                        (else
1004                         (parse-error (make-prefix-context "case:")
1005                                      "bad case" val)))
1006                  " : ")
1007 )
1008
1009 ; Utility of s-case to handle a void result.
1010
1011 (define (s-case-vm estate test case-list)
1012   (cx:make
1013    VOID
1014    (string-append
1015     "  switch ("
1016     (cx:c (rtl-c-get estate DFLT test))
1017     ")\n"
1018     "  {\n"
1019     (string-map (lambda (case-entry)
1020                   (let ((caseval (car case-entry))
1021                         (code (cdr case-entry)))
1022                     (string-append
1023                      (cond ((list? caseval)
1024                             (string-map /gen-case-prefix caseval))
1025                            ((eq? 'else caseval)
1026                             (string-append "  default : "))
1027                            (else
1028                             (/gen-case-prefix caseval)))
1029                      (cx:c (apply s-sequence
1030                                   (cons estate (cons VOID (cons nil code)))))
1031                      "    break;\n")))
1032                 case-list)
1033     "  }\n"))
1034 )
1035
1036 ; Utility of s-case-non-vm to generate code to perform the test.
1037 ; MODE is the mode name.
1038
1039 (define (/gen-non-vm-case-test estate mode test cases)
1040   (assert (not (null? cases)))
1041   (let loop ((result "") (cases cases))
1042     (if (null? cases)
1043         result
1044         (let ((case (cond ((number? (car cases))
1045                            (car cases))
1046                           ((symbol? (car cases))
1047                            (if (enum-lookup-val (car cases))
1048                                (rtx-make 'enum mode (car cases))
1049                                (estate-error estate
1050                                              "symbol not an enum"
1051                                              (car cases))))
1052                           (else
1053                            (estate-error estate "invalid case" (car cases))))))
1054           (loop (string-append
1055                  result
1056                  (if (= (string-length result) 0)
1057                      ""
1058                      " || ")
1059                  (cx:c (rtl-c-get estate mode test))
1060                  " == "
1061                  (cx:c (rtl-c-get estate mode case)))
1062                 (cdr cases)))))
1063 )
1064
1065 ; Utility of s-case to handle a non-void result.
1066 ; This is expanded as a series of ?:'s.
1067 ; MODE is the mode name.
1068
1069 (define (s-case-non-vm estate mode test case-list)
1070   (let ((if-part "(")
1071         (then-part ") ? ")
1072         (elseif-part " : (")
1073         (else-part " : ")
1074         (fi-part ")"))
1075     (let loop ((result
1076                 (string-append
1077                  if-part
1078                  (/gen-non-vm-case-test estate mode test (caar case-list))
1079                  then-part
1080                  (cx:c (apply s-sequence
1081                               (cons estate
1082                                     (cons mode
1083                                           (cons nil
1084                                                 (cdar case-list))))))))
1085                (cl (cdr case-list)))
1086       (cond ((null? cl) (cx:make mode result))
1087             ((eq? (caar cl) 'else)
1088              (cx:make mode
1089                       (string-append
1090                        result
1091                        else-part
1092                        (cx:c (apply s-sequence
1093                                     (cons estate
1094                                           (cons mode
1095                                                 (cons nil
1096                                                       (cdar cl)))))))))
1097             (else (loop (string-append
1098                          result
1099                          elseif-part
1100                          (/gen-non-vm-case-test estate mode test (caar cl))
1101                          then-part
1102                          (cx:c (apply s-sequence
1103                                       (cons estate
1104                                             (cons mode
1105                                                   (cons nil
1106                                                         (cdar cl)))))))
1107                         (cdr cl))))))
1108 )
1109
1110 ; C switch statement
1111 ; To follow convention, MODE is the first arg.
1112 ; MODE is the mode name.
1113 ; FIXME: What to allow for case choices is wip.
1114
1115 (define (s-case estate mode test . case-list)
1116   ;; FIXME: can't get DFLT anymore
1117   (if (or (mode:eq? 'DFLT mode) (mode:eq? 'VOID mode))
1118       (s-case-vm estate test case-list)
1119       (s-case-non-vm estate mode test case-list))
1120 )
1121 \f
1122 ; Parallels and Sequences
1123
1124 ; Temps for `parallel' are recorded differently than for `sequence'.
1125 ; ??? I believe this is because there was an interaction between the two.
1126
1127 (define /par-temp-list nil)
1128
1129 ; Record a temporary needed for a parallel in mode MODE.
1130 ; We just need to record the mode with a unique name so we use a <c-expr>
1131 ; object where the "expression" is the variable's name.
1132
1133 (define (/par-new-temp! mode)
1134   (set! /par-temp-list
1135         (cons (cx:make mode (string-append "temp"
1136                                            (number->string
1137                                             (length /par-temp-list))))
1138               /par-temp-list))
1139   (car /par-temp-list)
1140 )
1141
1142 ; Return the next temp from the list, and leave the list pointing to the
1143 ; next one.
1144
1145 (define (/par-next-temp!)
1146   (let ((result (car /par-temp-list)))
1147     (set! /par-temp-list (cdr /par-temp-list))
1148     result)
1149 )
1150
1151 (define (/gen-par-temp-defns temp-list)
1152   ;(display temp-list) (newline)
1153   (string-append
1154    "  "
1155    ; ??? mode:c-type
1156    (string-map (lambda (temp) (string-append (obj:str-name (cx:mode temp))
1157                                              " " (cx:c temp) ";"))
1158                temp-list)
1159    "\n")
1160 )
1161
1162 ;; Parallels are handled by converting them into two sequences.  The first has
1163 ;; all set destinations replaced with temps, and the second has all set sources
1164 ;; replaced with those temps.
1165
1166 ;; rtl-traverse expr-fn to replace the dest of sets with the parallel temp.
1167
1168 (define (/par-replace-set-dest-expr-fn rtx-obj expr parent-expr op-pos
1169                                        tstate appstuff)
1170   (case (car expr)
1171     ((set set-quiet)
1172      (let ((name (rtx-name expr))
1173            (options (rtx-options expr))
1174            (mode (rtx-mode expr))
1175            (dest (rtx-set-dest expr))
1176            (src (rtx-set-src expr)))
1177        (list name options mode (/par-new-temp! mode) src)))
1178     (else #f))
1179 )
1180
1181 ;; rtl-traverse expr-fn to replace the src of sets with the parallel temp.
1182 ;; This must process expressions in the same order as /par-replace-set-dests.
1183
1184 (define (/par-replace-set-src-expr-fn rtx-obj expr parent-expr op-pos
1185                                       tstate appstuff)
1186   (case (car expr)
1187     ((set set-quiet)
1188      (let ((name (rtx-name expr))
1189            (options (rtx-options expr))
1190            (mode (rtx-mode expr))
1191            (dest (rtx-set-dest expr))
1192            (src (rtx-set-src expr)))
1193        (list name options mode dest (/par-next-temp!))))
1194     (else #f))
1195 )
1196
1197 ;; Return a <c-expr> node for a `parallel'.
1198
1199 (define (s-parallel estate . exprs)
1200   (begin
1201
1202     ;; Initialize /par-temp-list for /par-replace-set-dests.
1203     (set! /par-temp-list nil)
1204
1205     (let* ((set-dest-exprs
1206             ;; Use map-in-order because we need temp creation and usage to
1207             ;; follow the same order.
1208             (map-in-order (lambda (expr)
1209                             (rtx-traverse (estate-context estate)
1210                                           (estate-owner estate)
1211                                           expr
1212                                           /par-replace-set-dest-expr-fn
1213                                           #f))
1214                           exprs))
1215            (set-dests (string-map (lambda (expr)
1216                                     (rtl-c-with-estate estate VOID expr))
1217                                   set-dest-exprs))
1218            (temps (reverse! /par-temp-list)))
1219
1220       ;; Initialize /par-temp-list for /par-replace-set-srcs.
1221       (set! /par-temp-list temps)
1222
1223       (let* ((set-src-exprs
1224               ;; Use map-in-order because we need temp creation and usage to
1225               ;; follow the same order.
1226               (map-in-order (lambda (expr)
1227                               (rtx-traverse (estate-context estate)
1228                                             (estate-owner estate)
1229                                             expr
1230                                             /par-replace-set-src-expr-fn
1231                                             #f))
1232                             exprs))
1233              (set-srcs (string-map (lambda (expr)
1234                                      (rtl-c-with-estate estate VOID expr))
1235                                     set-src-exprs)))
1236
1237         (cx:make VOID
1238                  (string-append
1239                   ;; ??? do {} while (0); doesn't get "optimized out"
1240                   ;; internally by gcc, meaning two labels and a loop are
1241                   ;; created for it to have to process.  We can generate pretty
1242                   ;; big files and can cause gcc to require *lots* of memory.
1243                   ;; So let's try just {} ...
1244                   "{\n"
1245                   (/gen-par-temp-defns temps)
1246                   set-dests
1247                   set-srcs
1248                   "}\n")
1249                  ))))
1250 )
1251
1252 ;; Subroutine of s-sequence to simplify it.
1253 ;; Return a boolean indicating if GCC's "statement expression" extension
1254 ;; is necessary to implement (sequence MODE ENV EXPR-LIST).
1255 ;; Only use GCC "statement expression" extension if necessary.
1256 ;;
1257 ;; Avoid using statement expressions for
1258 ;; (sequence non-VOID-mode (error "mumble") expr).
1259 ;; Some targets, e.g. cris, use this.
1260
1261 (define (/use-gcc-stmt-expr? mode env expr-list)
1262   (if (not (rtx-env-empty? env))
1263       #t
1264       (case (length expr-list)
1265         ((1) #f)
1266         ((2) (if (eq? (rtx-name (car expr-list)) 'error)
1267                  #f
1268                  #t))
1269         (else #t)))
1270 )
1271
1272 ;; Return a <c-expr> node for a `sequence'.
1273 ;; MODE is the mode name.
1274
1275 (define (s-sequence estate mode env . exprs)
1276   (let* ((env (rtx-env-make-locals env)) ;; compile env
1277          (estate (estate-push-env estate env)))
1278
1279     (if (or (mode:eq? 'DFLT mode) ;; FIXME: DFLT can't appear anymore
1280             (mode:eq? 'VOID mode))
1281
1282         (cx:make VOID
1283                  (string-append
1284                   ;; ??? do {} while (0); doesn't get "optimized out"
1285                   ;; internally by gcc, meaning two labels and a loop are
1286                   ;; created for it to have to process.  We can generate pretty
1287                   ;; big files and can cause gcc to require *lots* of memory.
1288                   ;; So let's try just {} ...
1289                   "{\n"
1290                   (gen-temp-defs estate env)
1291                   (string-map (lambda (e)
1292                                 (rtl-c-with-estate estate VOID e))
1293                               exprs)
1294                   "}\n"))
1295
1296         (let ((use-stmt-expr? (/use-gcc-stmt-expr? mode env exprs)))
1297           (cx:make mode
1298                    (string-append
1299                     (if use-stmt-expr? "({ " "(")
1300                     (gen-temp-defs estate env)
1301                     (string-drop 2
1302                                  (string-map
1303                                   (lambda (e)
1304                                     (string-append
1305                                      (if use-stmt-expr? "; " ", ")
1306                                      ;; Strip off gratuitous ";\n" at end of expressions that
1307                                      ;; misguessed themselves to be in statement context.
1308                                      ;; See s-c-call, s-c-call-raw above.
1309                                      (let ((substmt (rtl-c-with-estate estate DFLT e)))
1310                                        (if (and (not use-stmt-expr?)
1311                                                 (string=? (string-take -2 substmt) ";\n"))
1312                                            (string-drop -2 substmt)
1313                                            substmt))))
1314                                   exprs))
1315                     (if use-stmt-expr? "; })" ")"))))))
1316 )
1317
1318 ; Return a <c-expr> node for a `do-count'.
1319
1320 (define (s-do-count estate iter-var nr-times . exprs)
1321   (let* ((limit-var (rtx-make-iteration-limit-var iter-var))
1322          (env (rtx-env-make-iteration-locals iter-var))
1323          (estate (estate-push-env estate env))
1324          (temp-iter (rtx-temp-lookup (estate-env-stack estate) iter-var))
1325          (temp-limit (rtx-temp-lookup (estate-env-stack estate) limit-var))
1326          (c-iter-var (rtx-temp-value temp-iter))
1327          (c-limit-var (rtx-temp-value temp-limit)))
1328     (cx:make VOID
1329              (string-append
1330               "{\n"
1331               (gen-temp-defs estate env)
1332               "  " c-limit-var " = "
1333               (cx:c (rtl-c-get estate (rtx-temp-mode temp-limit) nr-times))
1334               ";\n"
1335               "  for (" c-iter-var " = 0;\n"
1336               "       " c-iter-var " < " c-limit-var ";\n"
1337               "       ++" c-iter-var ")\n"
1338               "  {\n"
1339               (string-map (lambda (e)
1340                             (rtl-c-with-estate estate VOID e))
1341                           exprs)
1342               "  }\n"
1343               "}\n"))
1344     )
1345 )
1346 \f
1347 ; *****************************************************************************
1348 ;
1349 ; RTL->C generators for each rtx function.
1350
1351 ; Return code to set FN as the generator for RTX.
1352
1353 (defmacro define-fn (rtx args expr . rest)
1354   `(begin
1355      (assert (rtx-lookup (quote ,rtx)))
1356      (vector-set! table (rtx-num (rtx-lookup (quote ,rtx)))
1357                   (lambda ,args ,@(cons expr rest))))
1358 )
1359
1360 (define (rtl-c-init!)
1361   (set! /rtl-c-gen-table (/rtl-c-build-table))
1362   *UNSPECIFIED*
1363 )
1364
1365 ; The rest of this file is one big function to return the rtl->c lookup table.
1366 ; For each of these functions, MODE is the name of the mode.
1367
1368 (define (/rtl-c-build-table)
1369   (let ((table (make-vector (rtx-max-num) #f)))
1370
1371 ; Error generation
1372
1373 (define-fn error (*estate* options mode message)
1374   (let ((c-call (s-c-call *estate* mode "cgen_rtx_error"
1375                           (string-append "\""
1376                                          (backslash "\"" message)
1377                                          "\""))))
1378     (if (mode:eq? mode VOID)
1379         c-call
1380         (cx:make mode (string-append "(" (cx:c c-call) ", 0)"))))
1381 )
1382
1383 ; Enum support
1384
1385 (define-fn enum (*estate* options mode name)
1386   (cx:make mode (string-upcase (gen-c-symbol name)))
1387 )
1388
1389 ; Instruction field support.
1390 ; ??? This should build an operand object like -build-ifield-operand! does
1391 ; in semantics.scm.
1392
1393 (define-fn ifield (*estate* options mode ifld-name)
1394   (if (estate-ifield-var? *estate*)
1395       (cx:make mode (gen-c-symbol ifld-name))
1396       (cx:make mode (string-append "FLD (" (gen-c-symbol ifld-name) ")")))
1397 ;  (let ((f (current-ifld-lookup ifld-name)))
1398 ;    (make <operand> (obj-location f) ifld-name ifld-name
1399 ;         (atlist-cons (bool-attr-make 'SEM-ONLY #t)
1400 ;                      (obj-atlist f))
1401 ;         (obj:name (ifld-hw-type f))
1402 ;         (obj:name (ifld-mode f))
1403 ;         (make <hw-index> 'anonymous
1404 ;               'ifield (ifld-mode f) f)
1405 ;         nil #f #f))
1406 )
1407
1408 ;; Operand support.
1409
1410 (define-fn operand (*estate* options mode object-or-name)
1411   (cond ((operand? object-or-name)
1412          ;; FIXME: <operand> objects is what xop is for
1413          ;; mode checking to be done during canonicalization
1414          object-or-name)
1415         ((symbol? object-or-name)
1416          (let ((object (current-op-lookup object-or-name)))
1417            (if (not object)
1418                (estate-error *estate* "undefined operand" object-or-name))
1419            ;; mode checking to be done during canonicalization
1420            object))
1421         (else
1422          (estate-error *estate* "bad arg to `operand'" object-or-name)))
1423 )
1424
1425 (define-fn xop (*estate* options mode object)
1426   (let ((delayed (assoc '#:delay (estate-modifiers *estate*))))
1427     (if (and delayed
1428              (equal? APPLICATION 'SID-SIMULATOR)
1429              (operand? object))
1430         ;; if we're looking at an operand inside a (delay ...) rtx, then we
1431         ;; are talking about a _delayed_ operand, which is a different
1432         ;; beast.  rather than try to work out what context we were
1433         ;; constructed within, we just clone the operand instance and set
1434         ;; the new one to have a delayed value. the setters and getters
1435         ;; will work it out.
1436         (let ((obj (object-copy object))
1437               (amount (cadr delayed)))
1438           (op:set-delay! obj amount)
1439           obj)
1440         ;; else return the normal object
1441         object)))
1442
1443 (define-fn local (*estate* options mode object-or-name)
1444   (cond ((rtx-temp? object-or-name)
1445          object-or-name)
1446         ((symbol? object-or-name)
1447          (let ((object (rtx-temp-lookup (estate-env-stack *estate*) object-or-name)))
1448            (if (not object)
1449                (estate-error *estate* "undefined local" object-or-name))
1450            object))
1451         (else
1452          (estate-error *estate* "bad arg to `local'" object-or-name)))
1453 )
1454
1455 (define-fn reg (*estate* options mode hw-elm . indx-sel)
1456   (let ((indx (or (list-maybe-ref indx-sel 0) 0))
1457         (sel (or (list-maybe-ref indx-sel 1) hw-selector-default)))
1458     (s-hw *estate* mode hw-elm indx sel))
1459 )
1460
1461 (define-fn raw-reg (*estate* options mode hw-elm . indx-sel)
1462   (let ((indx (or (list-maybe-ref indx-sel 0) 0))
1463         (sel (or (list-maybe-ref indx-sel 1) hw-selector-default)))
1464     (let ((result (s-hw *estate* mode hw-elm indx sel)))
1465       (obj-cons-attr! result (bool-attr-make 'RAW #t))
1466       result))
1467 )
1468
1469 (define-fn mem (*estate* options mode addr . sel)
1470   (s-hw *estate* mode 'h-memory addr
1471         (if (pair? sel) (car sel) hw-selector-default))
1472 )
1473
1474 ; ??? Hmmm... needed?  The pc is usually specified as `pc' which is shorthand
1475 ; for (operand pc).
1476 ;(define-fn pc (*estate* options mode)
1477 ;  s-pc
1478 ;)
1479
1480 (define-fn ref (*estate* options mode name)
1481   (if (not (insn? (estate-owner *estate*)))
1482       (estate-error *estate* "ref: not processing an insn"
1483                     (obj:name (estate-owner *estate*))))
1484   (cx:make 'UINT
1485            (string-append
1486             "(referenced & (1 << "
1487             (number->string
1488              (op:num (insn-lookup-op (estate-owner *estate*) name)))
1489             "))"))
1490 )
1491
1492 ; ??? Maybe this should return an operand object.
1493 (define-fn index-of (*estate* options mode op)
1494   (send (op:index (rtx-eval-with-estate op DFLT *estate*))
1495         'cxmake-get *estate* (mode:lookup mode))
1496 )
1497
1498 (define-fn clobber (*estate* options mode object)
1499   (cx:make VOID "; /*clobber*/\n")
1500 )
1501
1502 (define-fn delay (*estate* options mode num-node rtx)
1503   ;; FIXME: Try to move SID stuff into sid-foo.scm.
1504   (case APPLICATION
1505     ((SID-SIMULATOR)
1506      (let* ((n (cadddr num-node))
1507             (old-delay (let ((old (assoc '#:delay (estate-modifiers *estate*))))
1508                          (if old (cadr old) 0)))
1509             (new-delay (+ n old-delay)))
1510        (begin
1511          ;; check for proper usage
1512          (if (let* ((hw (case (car rtx)
1513                           ((operand) (op:type (current-op-lookup (rtx-arg1 rtx))))
1514                           ((xop) (op:type (rtx-xop-obj rtx)))
1515                           (else #f))))
1516                (not (and hw (or (pc? hw) (memory? hw) (register? hw)))))
1517              (estate-error
1518               *estate*
1519               "(delay ...) rtx applied to wrong type of operand, should be pc, register or memory"
1520                (car rtx)))
1521          ;; signal an error if we're delayed and not in a "parallel-insns" CPU
1522          (if (not (with-parallel?))
1523              (estate-error *estate* "delayed operand in a non-parallel cpu"
1524                            (car rtx)))
1525          ;; update cpu-global pipeline bound
1526          (cpu-set-max-delay! (current-cpu) (max (cpu-max-delay (current-cpu)) new-delay))
1527          ;; pass along new delay to embedded rtx
1528          (rtx-eval-with-estate rtx (mode:lookup mode)
1529                                (estate-with-modifiers *estate* `((#:delay ,new-delay)))))))
1530
1531     ;; not in sid-land
1532     (else (s-sequence (estate-with-modifiers *estate* '((#:delay))) VOID '() rtx)))
1533 )
1534
1535 ; Gets expanded as a macro.
1536 ;(define-fn annul (*estate* yes?)
1537 ;  (s-c-call *estate* 'VOID "SEM_ANNUL_INSN" "pc" yes?)
1538 ;)
1539
1540 (define-fn skip (*estate* options mode yes?)
1541   (send pc 'cxmake-skip *estate* yes?)
1542   ;(s-c-call *estate* 'VOID "SEM_SKIP_INSN" "pc" yes?)
1543 )
1544
1545 (define-fn eq-attr (*estate* options mode obj attr-name value)
1546   (cx:make 'INT
1547            (string-append "(GET_ATTR ("
1548                           (gen-c-symbol attr-name)
1549                           ") == "
1550                           (gen-c-symbol value)
1551                           ")"))
1552 )
1553
1554 (define-fn int-attr (*estate* options mode owner attr-name)
1555   (cond ((or (equal? owner '(current-insn () DFLT)) ;; FIXME: delete in time
1556              (equal? owner '(current-insn () INSN)))
1557          (s-c-raw-call *estate* 'INT "GET_ATTR"
1558                        (string-upcase (gen-c-symbol attr-name))))
1559         (else
1560          (estate-error *estate* "attr: unsupported object type" owner)))
1561 )
1562
1563 (define-fn const (*estate* options mode c)
1564   (assert (not (mode:eq? 'VOID mode)))
1565   (if (mode:eq? 'DFLT mode) ;; FIXME: can't get DFLT anymore
1566       (set! mode 'INT))
1567   (let ((mode (mode:lookup mode)))
1568     (cx:make mode
1569              (cond ((or (mode:eq? 'DI mode)
1570                         (mode:eq? 'UDI mode)
1571                         (< #xffffffff c)
1572                         (> #x-80000000 c))
1573                     (string-append "MAKEDI ("
1574                                    (gen-integer (high-part c)) ", "
1575                                    (gen-integer (low-part c))
1576                                    ")"))
1577                    ((and (<= #x-80000000 c) (> #x80000000 c))
1578                     (number->string c))
1579                    ((and (<= #x80000000 c) (>= #xffffffff c))
1580                     ; ??? GCC complains if not affixed with "U" but that's not k&r.
1581                     ;(string-append (number->string val) "U"))
1582                     (string-append "0x" (number->string c 16)))
1583                    ; Else punt.
1584                    (else (number->string c)))))
1585 )
1586
1587 (define-fn join (*estate* options out-mode in-mode arg1 . arg-rest)
1588   ; FIXME: Endianness issues undecided.
1589   ; FIXME: Ensure correct number of args for in/out modes.
1590   ; Ensure compatible modes.
1591   (apply s-c-raw-call (cons *estate*
1592                             (cons out-mode
1593                                   (cons (stringsym-append "JOIN"
1594                                                           in-mode
1595                                                           out-mode)
1596                                         (cons arg1 arg-rest)))))
1597 )
1598
1599 (define-fn subword (*estate* options mode value word-num)
1600   (let* ((mode (mode:lookup mode))
1601          (val (rtl-c-get *estate* DFLT value))
1602          (val-mode (cx:mode val)))
1603     (cx:make mode
1604              (string-append "SUBWORD"
1605                             (obj:str-name val-mode) (obj:str-name mode)
1606                             " (" (cx:c val)
1607                             (if (mode-bigger? val-mode mode)
1608                                 (string-append
1609                                  ", "
1610                                  (if (number? word-num)
1611                                      (number->string word-num)
1612                                      (cx:c (rtl-c-get *estate* DFLT word-num))))
1613                                 "")
1614                             ")")))
1615 )
1616
1617 (define-fn c-code (*estate* options mode text)
1618   (cx:make mode text)
1619 )
1620
1621 (define-fn c-call (*estate* options mode name . args)
1622   (apply s-c-call (cons *estate* (cons mode (cons name args))))
1623 )
1624
1625 (define-fn c-raw-call (*estate* options mode name . args)
1626   (apply s-c-raw-call (cons *estate* (cons mode (cons name args))))
1627 )
1628
1629 (define-fn nop (*estate* options mode)
1630   (cx:make VOID "((void) 0); /*nop*/\n")
1631 )
1632
1633 (define-fn set (*estate* options mode dst src)
1634   (if (estate-for-insn? *estate*)
1635       (rtl-c-set-trace *estate* mode dst src)
1636       (rtl-c-set-quiet *estate* mode dst src))
1637 )
1638
1639 (define-fn set-quiet (*estate* options mode dst src)
1640   (rtl-c-set-quiet *estate* mode dst src)
1641 )
1642
1643 (define-fn neg (*estate* options mode s1)
1644   (s-unop *estate* "NEG" "-" mode s1)
1645 )
1646
1647 (define-fn abs (*estate* options mode s1)
1648   (s-unop *estate* "ABS" #f mode s1)
1649 )
1650
1651 (define-fn inv (*estate* options mode s1)
1652   (s-unop *estate* "INV" "~" mode s1)
1653 )
1654
1655 (define-fn not (*estate* options mode s1)
1656   (s-unop *estate* "NOT" "!" mode s1)
1657 )
1658
1659 (define-fn add (*estate* options mode s1 s2)
1660   (s-binop *estate* "ADD" "+" mode s1 s2)
1661 )
1662 (define-fn sub (*estate* options mode s1 s2)
1663   (s-binop *estate* "SUB" "-" mode s1 s2)
1664 )
1665
1666 (define-fn addc (*estate* options mode s1 s2 s3)
1667   (s-binop-with-bit *estate* "ADDC" mode s1 s2 s3)
1668 )
1669 ;; ??? Whether to rename ADDCF/ADDOF -> ADDCCF/ADDCOF is debatable.
1670 (define-fn addc-cflag (*estate* options mode s1 s2 s3)
1671   (s-binop-with-bit *estate* "ADDCF" mode s1 s2 s3)
1672 )
1673 (define-fn addc-oflag (*estate* options mode s1 s2 s3)
1674   (s-binop-with-bit *estate* "ADDOF" mode s1 s2 s3)
1675 )
1676
1677 (define-fn subc (*estate* options mode s1 s2 s3)
1678   (s-binop-with-bit *estate* "SUBC" mode s1 s2 s3)
1679 )
1680 ;; ??? Whether to rename SUBCF/SUBOF -> SUBCCF/SUBCOF is debatable.
1681 (define-fn subc-cflag (*estate* options mode s1 s2 s3)
1682   (s-binop-with-bit *estate* "SUBCF" mode s1 s2 s3)
1683 )
1684 (define-fn subc-oflag (*estate* options mode s1 s2 s3)
1685   (s-binop-with-bit *estate* "SUBOF" mode s1 s2 s3)
1686 )
1687
1688 ;; ??? These are deprecated.  Delete in time.
1689 (define-fn add-cflag (*estate* options mode s1 s2 s3)
1690   (s-binop-with-bit *estate* "ADDCF" mode s1 s2 s3)
1691 )
1692 (define-fn add-oflag (*estate* options mode s1 s2 s3)
1693   (s-binop-with-bit *estate* "ADDOF" mode s1 s2 s3)
1694 )
1695 (define-fn sub-cflag (*estate* options mode s1 s2 s3)
1696   (s-binop-with-bit *estate* "SUBCF" mode s1 s2 s3)
1697 )
1698 (define-fn sub-oflag (*estate* options mode s1 s2 s3)
1699   (s-binop-with-bit *estate* "SUBOF" mode s1 s2 s3)
1700 )
1701
1702 ;(define-fn zflag (*estate* options mode value)
1703 ;  (list 'eq mode value (list 'const mode 0))
1704 ;)
1705
1706 ;(define-fn nflag (*estate* options mode value)
1707 ;  (list 'lt mode value (list 'const mode 0))
1708 ;)
1709
1710 (define-fn mul (*estate* options mode s1 s2)
1711   (s-binop *estate* "MUL" "*" mode s1 s2)
1712 )
1713 (define-fn div (*estate* options mode s1 s2)
1714   (s-binop *estate* "DIV" "/" mode s1 s2)
1715 )
1716 (define-fn udiv (*estate* options mode s1 s2)
1717   (s-binop *estate* "UDIV" "/" mode s1 s2)
1718 )
1719 (define-fn mod (*estate* options mode s1 s2)
1720   (s-binop *estate* "MOD" "%" mode s1 s2)
1721 )
1722 (define-fn umod (*estate* options mode s1 s2)
1723   (s-binop *estate* "UMOD" "%" mode s1 s2)
1724 )
1725
1726 (define-fn sqrt (*estate* options mode s1)
1727   (s-unop *estate* "SQRT" #f mode s1)
1728 )
1729 (define-fn cos (*estate* options mode s1)
1730   (s-unop *estate* "COS" #f mode s1)
1731 )
1732 (define-fn sin (*estate* options mode s1)
1733   (s-unop *estate* "SIN" #f mode s1)
1734 )
1735
1736 (define-fn min (*estate* options mode s1 s2)
1737   (s-binop *estate* "MIN" #f mode s1 s2)
1738 )
1739 (define-fn max (*estate* options mode s1 s2)
1740   (s-binop *estate* "MAX" #f mode s1 s2)
1741 )
1742 (define-fn umin (*estate* options mode s1 s2)
1743   (s-binop *estate* "UMIN" #f mode s1 s2)
1744 )
1745 (define-fn umax (*estate* options mode s1 s2)
1746   (s-binop *estate* "UMAX" #f mode s1 s2)
1747 )
1748
1749 (define-fn and (*estate* options mode s1 s2)
1750   (s-binop *estate* "AND" "&" mode s1 s2)
1751 )
1752 (define-fn or (*estate* options mode s1 s2)
1753   (s-binop *estate* "OR" "|" mode s1 s2)
1754 )
1755 (define-fn xor (*estate* options mode s1 s2)
1756   (s-binop *estate* "XOR" "^" mode s1 s2)
1757 )
1758
1759 (define-fn sll (*estate* options mode s1 s2)
1760   (s-shop *estate* "SLL" "<<" mode s1 s2)
1761 )
1762 (define-fn srl (*estate* options mode s1 s2)
1763   (s-shop *estate* "SRL" ">>" mode s1 s2)
1764 )
1765 (define-fn sra (*estate* options mode s1 s2)
1766   (s-shop *estate* "SRA" ">>" mode s1 s2)
1767 )
1768 (define-fn ror (*estate* options mode s1 s2)
1769   (s-shop *estate* "ROR" #f mode s1 s2)
1770 )
1771 (define-fn rol (*estate* options mode s1 s2)
1772   (s-shop *estate* "ROL" #f mode s1 s2)
1773 )
1774
1775 (define-fn andif (*estate* options mode s1 s2)
1776   (s-boolifop *estate* "ANDIF" "&&" s1 s2)
1777 )
1778 (define-fn orif (*estate* options mode s1 s2)
1779   (s-boolifop *estate* "ORIF" "||" s1 s2)
1780 )
1781
1782 (define-fn ext (*estate* options mode s1)
1783   (s-convop *estate* "EXT" mode s1)
1784 )
1785 (define-fn zext (*estate* options mode s1)
1786   (s-convop *estate* "ZEXT" mode s1)
1787 )
1788 (define-fn trunc (*estate* options mode s1)
1789   (s-convop *estate* "TRUNC" mode s1)
1790 )
1791 (define-fn fext (*estate* options mode s1)
1792   (s-convop *estate* "FEXT" mode s1)
1793 )
1794 (define-fn ftrunc (*estate* options mode s1)
1795   (s-convop *estate* "FTRUNC" mode s1)
1796 )
1797 (define-fn float (*estate* options mode s1)
1798   (s-convop *estate* "FLOAT" mode s1)
1799 )
1800 (define-fn ufloat (*estate* options mode s1)
1801   (s-convop *estate* "UFLOAT" mode s1)
1802 )
1803 (define-fn fix (*estate* options mode s1)
1804   (s-convop *estate* "FIX" mode s1)
1805 )
1806 (define-fn ufix (*estate* options mode s1)
1807   (s-convop *estate* "UFIX" mode s1)
1808 )
1809
1810 (define-fn eq (*estate* options mode s1 s2)
1811   (s-cmpop *estate* 'eq "==" mode s1 s2)
1812 )
1813 (define-fn ne (*estate* options mode s1 s2)
1814   (s-cmpop *estate* 'ne "!=" mode s1 s2)
1815 )
1816
1817 (define-fn lt (*estate* options mode s1 s2)
1818   (s-cmpop *estate* 'lt "<" mode s1 s2)
1819 )
1820 (define-fn le (*estate* options mode s1 s2)
1821   (s-cmpop *estate* 'le "<=" mode s1 s2)
1822 )
1823 (define-fn gt (*estate* options mode s1 s2)
1824   (s-cmpop *estate* 'gt ">" mode s1 s2)
1825 )
1826 (define-fn ge (*estate* options mode s1 s2)
1827   (s-cmpop *estate* 'ge ">=" mode s1 s2)
1828 )
1829
1830 (define-fn ltu (*estate* options mode s1 s2)
1831   (s-cmpop *estate* 'ltu "<" mode s1 s2)
1832 )
1833 (define-fn leu (*estate* options mode s1 s2)
1834   (s-cmpop *estate* 'leu "<=" mode s1 s2)
1835 )
1836 (define-fn gtu (*estate* options mode s1 s2)
1837   (s-cmpop *estate* 'gtu ">" mode s1 s2)
1838 )
1839 (define-fn geu (*estate* options mode s1 s2)
1840   (s-cmpop *estate* 'geu ">=" mode s1 s2)
1841 )
1842
1843 (define-fn member (*estate* options mode value set)
1844   ;; NOTE: There are multiple evalutions of VALUE in the generated code.
1845   ;; It's probably ok, this comment is more for completeness sake.
1846   (let ((c-value (rtl-c-get *estate* mode value))
1847         (set (rtx-number-list-values set)))
1848     (let loop ((set (cdr set))
1849                (code (string-append "(" (cx:c c-value)
1850                                     " == "
1851                                     (gen-integer (car set))
1852                                     ")")))
1853       (if (null? set)
1854           (cx:make (mode:lookup 'BI) (string-append "(" code ")"))
1855           (loop (cdr set)
1856                 (string-append code
1857                                " || ("
1858                                (cx:c c-value)
1859                                " == "
1860                                (gen-integer (car set))
1861                                ")")))))
1862 )
1863
1864 (define-fn if (*estate* options mode cond then . else)
1865   (apply s-if (append! (list *estate* mode cond then) else))
1866 )
1867
1868 (define-fn cond (*estate* options mode . cond-code-list)
1869   (apply s-cond (cons *estate* (cons mode cond-code-list)))
1870 )
1871
1872 (define-fn case (*estate* options mode test . case-list)
1873   (apply s-case (cons *estate* (cons mode (cons test case-list))))
1874 )
1875
1876 (define-fn parallel (*estate* options mode ignore expr . exprs)
1877   (apply s-parallel (cons *estate* (cons expr exprs)))
1878 )
1879
1880 (define-fn sequence (*estate* options mode locals expr . exprs)
1881   (apply s-sequence
1882          (cons *estate* (cons mode (cons locals (cons expr exprs)))))
1883 )
1884
1885 (define-fn do-count (*estate* options mode iter-var nr-times expr . exprs)
1886   (apply s-do-count
1887          (cons *estate* (cons iter-var (cons nr-times (cons expr exprs)))))
1888 )
1889
1890 (define-fn closure (*estate* options mode isa-name-list env-stack expr)
1891   (rtl-c-with-estate (estate-make-closure *estate* isa-name-list
1892                                           (rtx-make-env-stack env-stack))
1893                      (mode:lookup mode) expr)
1894 )
1895 \f
1896 ;; The result is the rtl->c generator table.
1897 ;; FIXME: verify all elements are filled
1898
1899 table
1900
1901 )) ;; End of /rtl-c-build-table