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 ;; Process fp predicates, e.g. nan, qnan, snan.
 832 ;; SRC-MODE is the mode name of SRC.
 833 ;; The result has mode BI.
 834
 835 (define (s-float-predop estate name src-mode src)
 836   (let* ((val (rtl-c-get estate src-mode src))
 837          (mode (cx:mode val))
 838          (sem-mode (rtx-sem-mode mode)))
 839     ;; FIXME: Argument checking.
 840
 841     (if (not (mode-float? mode))
 842         (estate-error estate "non floating-point mode" src-mode))
 843
 844     (cx:make (mode:lookup 'BI)
 845              (string-append "CGEN_CPU_FPU (current_cpu)->ops->"
 846                             (string-downcase name)
 847                             (string-downcase (obj:str-name sem-mode))
 848                             " (CGEN_CPU_FPU (current_cpu), "
 849                             (cx:c val) ")")))
 850 )
 851
 852 ;; Integer mode conversions.
 853 ;; MODE is the mode name.
 854
 855 (define (s-int-convop estate name mode s1)
 856   ;; Get S1 in its normal mode, then convert.
 857   (let ((s (rtl-c-get estate DFLT s1))
 858         (mode (mode:lookup mode)))
 859     (if (and (not (estate-rtl-cover-fns? estate))
 860              (mode:host? (cx:mode s)))
 861         (cx:make mode
 862                  (string-append "((" (obj:str-name mode) ")"
 863                                 " (" (obj:str-name (cx:mode s)) ")"
 864                                 " (" (cx:c s) "))"))
 865         (cx:make mode
 866                  (string-append name
 867                                 (obj:str-name (rtx-sem-mode (cx:mode s)))
 868                                 (obj:str-name (rtx-sem-mode mode))
 869                                 " (" (cx:c s) ")"))))
 870 )
 871
 872 ;; Floating point mode conversions.
 873 ;; MODE is the mode name.
 874
 875 (define (s-float-convop estate name mode how1 s1)
 876   ;; Get S1 in its normal mode, then convert.
 877   (let ((s (rtl-c-get estate DFLT s1))
 878         (mode (mode:lookup mode))
 879         (how (rtl-c-get estate DFLT how1)))
 880     (if (and (not (estate-rtl-cover-fns? estate))
 881              (mode:host? (cx:mode s)))
 882         (cx:make mode
 883                  (string-append "((" (obj:str-name mode) ")"
 884                                 " (" (obj:str-name (cx:mode s)) ")"
 885                                 " (" (cx:c s) "))"))
 886         (cx:make mode
 887                  (string-append "CGEN_CPU_FPU (current_cpu)->ops->"
 888                                 (string-downcase name)
 889                                 (string-downcase (obj:str-name (rtx-sem-mode (cx:mode s))))
 890                                 (string-downcase (obj:str-name (rtx-sem-mode mode)))
 891                                 " (CGEN_CPU_FPU (current_cpu), "
 892                                 (cx:c how) ", "
 893                                 (cx:c s) ")"))))
 894 )
 895
 896 ; Compare SRC1 and SRC2 in mode MODE.
 897 ; NAME is one of eq,ne,lt,le,gt,ge,ltu,leu,gtu,geu.
 898 ; MODE is the mode name.
 899 ; The result has mode BI.
 900 ; ??? May want a host int mode result as BI may introduce some slowness
 901 ; in the generated code.
 902
 903 (define (s-cmpop estate name c-op mode src1 src2)
 904   (let* ((val1 (rtl-c-get estate mode src1))
 905          ; Refetch mode in case it was DFLT.
 906          (mode (mode:lookup mode)) ;;(cx:mode val1)) ;; FIXME: can't get DFLT anymore
 907          (val2 (rtl-c-get estate mode src2)))
 908     ; FIXME: Argument checking.
 909
 910     ; If no C operation has been provided, use a macro, or
 911     ; if this is the simulator and MODE is not a host mode, use a macro.
 912     (if (/rtx-use-sem-fn? estate c-op mode)
 913         (if (mode-float? mode)
 914             (cx:make (mode:lookup 'BI)
 915                      (string-append "CGEN_CPU_FPU (current_cpu)->ops->"
 916                                     (string-downcase (symbol->string name))
 917                                     (string-downcase (obj:str-name (rtx-sem-mode mode)))
 918                                     " (CGEN_CPU_FPU (current_cpu), "
 919                                     (cx:c val1) ", "
 920                                     (cx:c val2) ")"))
 921             (cx:make (mode:lookup 'BI)
 922                      (string-append (string-upcase (symbol->string name))
 923                                     (if (memq name '(eq ne))
 924                                         (obj:str-name (rtx-sem-mode mode))
 925                                         (obj:str-name mode))
 926                                     " (" (cx:c val1) ", "
 927                                     (cx:c val2) ")")))
 928         (cx:make (mode:lookup 'BI)
 929                  (string-append "(("
 930                                 (cx:c val1)
 931                                 ") " c-op " ("
 932                                 (cx:c val2)
 933                                 "))"))))
 934 )
 935 \f
 936 ; Conditional execution.
 937
 938 ; `if' in RTL has a result, like ?: in C.
 939 ; We support both: one with a result (non VOID mode), and one without (VOID mode).
 940 ; The non-VOID case must have an else part.
 941 ; MODE is the mode of the result, not the comparison.
 942 ; MODE is the mode name.
 943 ; The comparison is expected to return a zero/non-zero value.
 944 ; ??? Perhaps this should be a syntax-expr.  Later.
 945
 946 (define (s-if estate mode cond then . else)
 947   (if (> (length else) 1)
 948       (estate-error estate "if: too many elements in `else' part" else))
 949   (let ()
 950     (if (or (mode:eq? 'DFLT mode) ;; FIXME: can't get DFLT anymore
 951             (mode:eq? 'VOID mode))
 952         (cx:make mode
 953                  (string-append "if (" (cx:c (rtl-c-get estate DFLT cond)) ")"
 954                                 " {\n" (cx:c (rtl-c-get estate mode then)) "}"
 955                                 (if (not (null? else))
 956                                     (string-append " else {\n"
 957                                                    (cx:c (rtl-c-get estate mode (car else)))
 958                                                    "}\n")
 959                                     "\n")
 960                                 ))
 961         (if (= (length else) 1)
 962             (cx:make mode
 963                      (string-append "(("
 964                                     (cx:c (rtl-c-get estate DFLT cond))
 965                                     ") ? ("
 966                                     (cx:c (rtl-c-get estate mode then))
 967                                     ") : ("
 968                                     (cx:c (rtl-c-get estate mode (car else)))
 969                                     "))"))
 970             (estate-error estate "non-void-mode `if' must have `else' part"))))
 971 )
 972
 973 ; A multiway `if'.
 974 ; MODE is the mode name.
 975 ; If MODE is VOID emit a series of if/else's.
 976 ; If MODE is not VOID, emit a series of ?:'s.
 977 ; COND-CODE-LIST is a list of lists, each sublist is a list of two elements:
 978 ; condition, code.  The condition part must return a zero/non-zero value, and
 979 ; the code part is treated as a `sequence'.
 980 ; This defer argument evaluation, the syntax
 981 ; ((... condition ...) ... action ...)
 982 ; needs special parsing.
 983 ; FIXME: Need more error checking of arguments.
 984
 985 (define (s-cond estate mode . cond-code-list)
 986   ;; FIXME: can't get DFLT anymore
 987   (let ((vm? (or (mode:eq? 'DFLT mode) (mode:eq? 'VOID mode))))
 988     (if (null? cond-code-list)
 989         (estate-error estate "empty `cond'"))
 990     (let ((if-part (if vm?  "if (" "("))
 991           (then-part (if vm? ") " ") ? "))
 992           (elseif-part (if vm? " else if (" " : ("))
 993           (else-part (if vm? " else " " : "))
 994           (fi-part (if vm? "" ")")))
 995       (let loop ((result
 996                   (string-append
 997                    if-part
 998                    (cx:c (rtl-c-get estate DFLT (caar cond-code-list)))
 999                    then-part
1000                    (cx:c (apply s-sequence
1001                                 (cons estate
1002                                       (cons mode
1003                                             (cons nil
1004                                                   (cdar cond-code-list))))))))
1005                  (ccl (cdr cond-code-list)))
1006         (cond ((null? ccl) (cx:make mode result))
1007               ((eq? (caar ccl) 'else)
1008                (cx:make mode
1009                         (string-append
1010                          result
1011                          else-part
1012                          (cx:c (apply s-sequence
1013                                       (cons estate
1014                                             (cons mode
1015                                                   (cons nil
1016                                                         (cdar ccl)))))))))
1017               (else (loop (string-append
1018                            result
1019                            elseif-part
1020                            (cx:c (rtl-c-get estate DFLT (caar ccl)))
1021                            then-part
1022                            (cx:c (apply s-sequence
1023                                         (cons estate
1024                                               (cons mode
1025                                                     (cons nil
1026                                                           (cdar ccl)))))))
1027                           (cdr ccl)))))))
1028 )
1029
1030 ; Utility of s-case to print a case prefix (for lack of a better term).
1031
1032 (define (/gen-case-prefix val)
1033   (string-append "  case "
1034                  (cond ((number? val)
1035                         (number->string val))
1036                        ((symbol? val)
1037                         (string-upcase (gen-c-symbol val))) ; yes, upcase
1038                        ((string? val) val)
1039                        (else
1040                         (parse-error (make-prefix-context "case:")
1041                                      "bad case" val)))
1042                  " : ")
1043 )
1044
1045 ; Utility of s-case to handle a void result.
1046
1047 (define (s-case-vm estate test case-list)
1048   (cx:make
1049    VOID
1050    (string-append
1051     "  switch ("
1052     (cx:c (rtl-c-get estate DFLT test))
1053     ")\n"
1054     "  {\n"
1055     (string-map (lambda (case-entry)
1056                   (let ((caseval (car case-entry))
1057                         (code (cdr case-entry)))
1058                     (string-append
1059                      (cond ((list? caseval)
1060                             (string-map /gen-case-prefix caseval))
1061                            ((eq? 'else caseval)
1062                             (string-append "  default : "))
1063                            (else
1064                             (/gen-case-prefix caseval)))
1065                      (cx:c (apply s-sequence
1066                                   (cons estate (cons VOID (cons nil code)))))
1067                      "    break;\n")))
1068                 case-list)
1069     "  }\n"))
1070 )
1071
1072 ; Utility of s-case-non-vm to generate code to perform the test.
1073 ; MODE is the mode name.
1074
1075 (define (/gen-non-vm-case-test estate mode test cases)
1076   (assert (not (null? cases)))
1077   (let loop ((result "") (cases cases))
1078     (if (null? cases)
1079         result
1080         (let ((case (cond ((number? (car cases))
1081                            (car cases))
1082                           ((symbol? (car cases))
1083                            (if (enum-lookup-val (car cases))
1084                                (rtx-make 'enum mode (car cases))
1085                                (estate-error estate
1086                                              "symbol not an enum"
1087                                              (car cases))))
1088                           (else
1089                            (estate-error estate "invalid case" (car cases))))))
1090           (loop (string-append
1091                  result
1092                  (if (= (string-length result) 0)
1093                      ""
1094                      " || ")
1095                  (cx:c (rtl-c-get estate mode test))
1096                  " == "
1097                  (cx:c (rtl-c-get estate mode case)))
1098                 (cdr cases)))))
1099 )
1100
1101 ; Utility of s-case to handle a non-void result.
1102 ; This is expanded as a series of ?:'s.
1103 ; MODE is the mode name.
1104
1105 (define (s-case-non-vm estate mode test case-list)
1106   (let ((if-part "(")
1107         (then-part ") ? ")
1108         (elseif-part " : (")
1109         (else-part " : ")
1110         (fi-part ")"))
1111     (let loop ((result
1112                 (string-append
1113                  if-part
1114                  (/gen-non-vm-case-test estate mode test (caar case-list))
1115                  then-part
1116                  (cx:c (apply s-sequence
1117                               (cons estate
1118                                     (cons mode
1119                                           (cons nil
1120                                                 (cdar case-list))))))))
1121                (cl (cdr case-list)))
1122       (cond ((null? cl) (cx:make mode result))
1123             ((eq? (caar cl) 'else)
1124              (cx:make mode
1125                       (string-append
1126                        result
1127                        else-part
1128                        (cx:c (apply s-sequence
1129                                     (cons estate
1130                                           (cons mode
1131                                                 (cons nil
1132                                                       (cdar cl)))))))))
1133             (else (loop (string-append
1134                          result
1135                          elseif-part
1136                          (/gen-non-vm-case-test estate mode test (caar cl))
1137                          then-part
1138                          (cx:c (apply s-sequence
1139                                       (cons estate
1140                                             (cons mode
1141                                                   (cons nil
1142                                                         (cdar cl)))))))
1143                         (cdr cl))))))
1144 )
1145
1146 ; C switch statement
1147 ; To follow convention, MODE is the first arg.
1148 ; MODE is the mode name.
1149 ; FIXME: What to allow for case choices is wip.
1150
1151 (define (s-case estate mode test . case-list)
1152   ;; FIXME: can't get DFLT anymore
1153   (if (or (mode:eq? 'DFLT mode) (mode:eq? 'VOID mode))
1154       (s-case-vm estate test case-list)
1155       (s-case-non-vm estate mode test case-list))
1156 )
1157 \f
1158 ; Parallels and Sequences
1159
1160 ; Temps for `parallel' are recorded differently than for `sequence'.
1161 ; ??? I believe this is because there was an interaction between the two.
1162
1163 (define /par-temp-list nil)
1164
1165 ; Record a temporary needed for a parallel in mode MODE.
1166 ; We just need to record the mode with a unique name so we use a <c-expr>
1167 ; object where the "expression" is the variable's name.
1168
1169 (define (/par-new-temp! mode)
1170   (set! /par-temp-list
1171         (cons (cx:make mode (string-append "temp"
1172                                            (number->string
1173                                             (length /par-temp-list))))
1174               /par-temp-list))
1175   (car /par-temp-list)
1176 )
1177
1178 ; Return the next temp from the list, and leave the list pointing to the
1179 ; next one.
1180
1181 (define (/par-next-temp!)
1182   (let ((result (car /par-temp-list)))
1183     (set! /par-temp-list (cdr /par-temp-list))
1184     result)
1185 )
1186
1187 (define (/gen-par-temp-defns temp-list)
1188   ;(display temp-list) (newline)
1189   (string-append
1190    "  "
1191    ; ??? mode:c-type
1192    (string-map (lambda (temp) (string-append (obj:str-name (cx:mode temp))
1193                                              " " (cx:c temp) ";"))
1194                temp-list)
1195    "\n")
1196 )
1197
1198 ;; Parallels are handled by converting them into two sequences.  The first has
1199 ;; all set destinations replaced with temps, and the second has all set sources
1200 ;; replaced with those temps.
1201
1202 ;; rtl-traverse expr-fn to replace the dest of sets with the parallel temp.
1203
1204 (define (/par-replace-set-dest-expr-fn rtx-obj expr parent-expr op-pos
1205                                        tstate appstuff)
1206   (case (car expr)
1207     ((set set-quiet)
1208      (let ((name (rtx-name expr))
1209            (options (rtx-options expr))
1210            (mode (rtx-mode expr))
1211            (dest (rtx-set-dest expr))
1212            (src (rtx-set-src expr)))
1213        (list name options mode (/par-new-temp! mode) src)))
1214     (else #f))
1215 )
1216
1217 ;; rtl-traverse expr-fn to replace the src of sets with the parallel temp.
1218 ;; This must process expressions in the same order as /par-replace-set-dests.
1219
1220 (define (/par-replace-set-src-expr-fn rtx-obj expr parent-expr op-pos
1221                                       tstate appstuff)
1222   (case (car expr)
1223     ((set set-quiet)
1224      (let ((name (rtx-name expr))
1225            (options (rtx-options expr))
1226            (mode (rtx-mode expr))
1227            (dest (rtx-set-dest expr))
1228            (src (rtx-set-src expr)))
1229        (list name options mode dest (/par-next-temp!))))
1230     (else #f))
1231 )
1232
1233 ;; Return a <c-expr> node for a `parallel'.
1234
1235 (define (s-parallel estate . exprs)
1236   (begin
1237
1238     ;; Initialize /par-temp-list for /par-replace-set-dests.
1239     (set! /par-temp-list nil)
1240
1241     (let* ((set-dest-exprs
1242             ;; Use map-in-order because we need temp creation and usage to
1243             ;; follow the same order.
1244             (map-in-order (lambda (expr)
1245                             (rtx-traverse (estate-context estate)
1246                                           (estate-owner estate)
1247                                           expr
1248                                           /par-replace-set-dest-expr-fn
1249                                           #f))
1250                           exprs))
1251            (set-dests (string-map (lambda (expr)
1252                                     (rtl-c-with-estate estate VOID expr))
1253                                   set-dest-exprs))
1254            (temps (reverse! /par-temp-list)))
1255
1256       ;; Initialize /par-temp-list for /par-replace-set-srcs.
1257       (set! /par-temp-list temps)
1258
1259       (let* ((set-src-exprs
1260               ;; Use map-in-order because we need temp creation and usage to
1261               ;; follow the same order.
1262               (map-in-order (lambda (expr)
1263                               (rtx-traverse (estate-context estate)
1264                                             (estate-owner estate)
1265                                             expr
1266                                             /par-replace-set-src-expr-fn
1267                                             #f))
1268                             exprs))
1269              (set-srcs (string-map (lambda (expr)
1270                                      (rtl-c-with-estate estate VOID expr))
1271                                     set-src-exprs)))
1272
1273         (cx:make VOID
1274                  (string-append
1275                   ;; ??? do {} while (0); doesn't get "optimized out"
1276                   ;; internally by gcc, meaning two labels and a loop are
1277                   ;; created for it to have to process.  We can generate pretty
1278                   ;; big files and can cause gcc to require *lots* of memory.
1279                   ;; So let's try just {} ...
1280                   "{\n"
1281                   (/gen-par-temp-defns temps)
1282                   set-dests
1283                   set-srcs
1284                   "}\n")
1285                  ))))
1286 )
1287
1288 ;; Subroutine of s-sequence to simplify it.
1289 ;; Return a boolean indicating if GCC's "statement expression" extension
1290 ;; is necessary to implement (sequence MODE ENV EXPR-LIST).
1291 ;; Only use GCC "statement expression" extension if necessary.
1292 ;;
1293 ;; Avoid using statement expressions for
1294 ;; (sequence non-VOID-mode (error "mumble") expr).
1295 ;; Some targets, e.g. cris, use this.
1296
1297 (define (/use-gcc-stmt-expr? mode env expr-list)
1298   (if (not (rtx-env-empty? env))
1299       #t
1300       (case (length expr-list)
1301         ((1) #f)
1302         ((2) (if (eq? (rtx-name (car expr-list)) 'error)
1303                  #f
1304                  #t))
1305         (else #t)))
1306 )
1307
1308 ;; Return a <c-expr> node for a `sequence'.
1309 ;; MODE is the mode name.
1310
1311 (define (s-sequence estate mode env . exprs)
1312   (let* ((env (rtx-env-make-locals env)) ;; compile env
1313          (estate (estate-push-env estate env)))
1314
1315     (if (or (mode:eq? 'DFLT mode) ;; FIXME: DFLT can't appear anymore
1316             (mode:eq? 'VOID mode))
1317
1318         (cx:make VOID
1319                  (string-append
1320                   ;; ??? do {} while (0); doesn't get "optimized out"
1321                   ;; internally by gcc, meaning two labels and a loop are
1322                   ;; created for it to have to process.  We can generate pretty
1323                   ;; big files and can cause gcc to require *lots* of memory.
1324                   ;; So let's try just {} ...
1325                   "{\n"
1326                   (gen-temp-defs estate env)
1327                   (string-map (lambda (e)
1328                                 (rtl-c-with-estate estate VOID e))
1329                               exprs)
1330                   "}\n"))
1331
1332         (let ((use-stmt-expr? (/use-gcc-stmt-expr? mode env exprs)))
1333           (cx:make mode
1334                    (string-append
1335                     (if use-stmt-expr? "({ " "(")
1336                     (gen-temp-defs estate env)
1337                     (string-drop 2
1338                                  (string-map
1339                                   (lambda (e)
1340                                     (string-append
1341                                      (if use-stmt-expr? "; " ", ")
1342                                      ;; Strip off gratuitous ";\n" at end of expressions that
1343                                      ;; misguessed themselves to be in statement context.
1344                                      ;; See s-c-call, s-c-call-raw above.
1345                                      (let ((substmt (rtl-c-with-estate estate DFLT e)))
1346                                        (if (and (not use-stmt-expr?)
1347                                                 (string=? (string-take -2 substmt) ";\n"))
1348                                            (string-drop -2 substmt)
1349                                            substmt))))
1350                                   exprs))
1351                     (if use-stmt-expr? "; })" ")"))))))
1352 )
1353
1354 ; Return a <c-expr> node for a `do-count'.
1355
1356 (define (s-do-count estate iter-var nr-times . exprs)
1357   (let* ((limit-var (rtx-make-iteration-limit-var iter-var))
1358          (env (rtx-env-make-iteration-locals iter-var))
1359          (estate (estate-push-env estate env))
1360          (temp-iter (rtx-temp-lookup (estate-env-stack estate) iter-var))
1361          (temp-limit (rtx-temp-lookup (estate-env-stack estate) limit-var))
1362          (c-iter-var (rtx-temp-value temp-iter))
1363          (c-limit-var (rtx-temp-value temp-limit)))
1364     (cx:make VOID
1365              (string-append
1366               "{\n"
1367               (gen-temp-defs estate env)
1368               "  " c-limit-var " = "
1369               (cx:c (rtl-c-get estate (rtx-temp-mode temp-limit) nr-times))
1370               ";\n"
1371               "  for (" c-iter-var " = 0;\n"
1372               "       " c-iter-var " < " c-limit-var ";\n"
1373               "       ++" c-iter-var ")\n"
1374               "  {\n"
1375               (string-map (lambda (e)
1376                             (rtl-c-with-estate estate VOID e))
1377                           exprs)
1378               "  }\n"
1379               "}\n"))
1380     )
1381 )
1382 \f
1383 ; *****************************************************************************
1384 ;
1385 ; RTL->C generators for each rtx function.
1386
1387 ; Return code to set FN as the generator for RTX.
1388
1389 (defmacro define-fn (rtx args expr . rest)
1390   `(begin
1391      (assert (rtx-lookup (quote ,rtx)))
1392      (vector-set! table (rtx-num (rtx-lookup (quote ,rtx)))
1393                   (lambda ,args ,@(cons expr rest))))
1394 )
1395
1396 (define (rtl-c-init!)
1397   (set! /rtl-c-gen-table (/rtl-c-build-table))
1398   *UNSPECIFIED*
1399 )
1400
1401 ; The rest of this file is one big function to return the rtl->c lookup table.
1402 ; For each of these functions, MODE is the name of the mode.
1403
1404 (define (/rtl-c-build-table)
1405   (let ((table (make-vector (rtx-max-num) #f)))
1406
1407 ; Error generation
1408
1409 (define-fn error (*estate* options mode message)
1410   (let ((c-call (s-c-call *estate* mode "cgen_rtx_error"
1411                           (string-append "\""
1412                                          (backslash "\"" message)
1413                                          "\""))))
1414     (if (mode:eq? mode VOID)
1415         c-call
1416         (cx:make mode (string-append "(" (cx:c c-call) ", 0)"))))
1417 )
1418
1419 ; Enum support
1420
1421 (define-fn enum (*estate* options mode name)
1422   (cx:make mode (string-upcase (gen-c-symbol name)))
1423 )
1424
1425 ; Instruction field support.
1426 ; ??? This should build an operand object like -build-ifield-operand! does
1427 ; in semantics.scm.
1428
1429 (define-fn ifield (*estate* options mode ifld-name)
1430   (if (estate-ifield-var? *estate*)
1431       (cx:make mode (gen-c-symbol ifld-name))
1432       (cx:make mode (string-append "FLD (" (gen-c-symbol ifld-name) ")")))
1433 ;  (let ((f (current-ifld-lookup ifld-name)))
1434 ;    (make <operand> (obj-location f) ifld-name ifld-name
1435 ;         (atlist-cons (bool-attr-make 'SEM-ONLY #t)
1436 ;                      (obj-atlist f))
1437 ;         (obj:name (ifld-hw-type f))
1438 ;         (obj:name (ifld-mode f))
1439 ;         (make <hw-index> 'anonymous
1440 ;               'ifield (ifld-mode f) f)
1441 ;         nil #f #f))
1442 )
1443
1444 ;; Operand support.
1445
1446 (define-fn operand (*estate* options mode object-or-name)
1447   (cond ((operand? object-or-name)
1448          ;; FIXME: <operand> objects is what xop is for
1449          ;; mode checking to be done during canonicalization
1450          object-or-name)
1451         ((symbol? object-or-name)
1452          (let ((object (current-op-lookup object-or-name)))
1453            (if (not object)
1454                (estate-error *estate* "undefined operand" object-or-name))
1455            ;; mode checking to be done during canonicalization
1456            object))
1457         (else
1458          (estate-error *estate* "bad arg to `operand'" object-or-name)))
1459 )
1460
1461 (define-fn xop (*estate* options mode object)
1462   (let ((delayed (assoc '#:delay (estate-modifiers *estate*))))
1463     (if (and delayed
1464              (equal? APPLICATION 'SID-SIMULATOR)
1465              (operand? object))
1466         ;; if we're looking at an operand inside a (delay ...) rtx, then we
1467         ;; are talking about a _delayed_ operand, which is a different
1468         ;; beast.  rather than try to work out what context we were
1469         ;; constructed within, we just clone the operand instance and set
1470         ;; the new one to have a delayed value. the setters and getters
1471         ;; will work it out.
1472         (let ((obj (object-copy object))
1473               (amount (cadr delayed)))
1474           (op:set-delay! obj amount)
1475           obj)
1476         ;; else return the normal object
1477         object)))
1478
1479 (define-fn local (*estate* options mode object-or-name)
1480   (cond ((rtx-temp? object-or-name)
1481          object-or-name)
1482         ((symbol? object-or-name)
1483          (let ((object (rtx-temp-lookup (estate-env-stack *estate*) object-or-name)))
1484            (if (not object)
1485                (estate-error *estate* "undefined local" object-or-name))
1486            object))
1487         (else
1488          (estate-error *estate* "bad arg to `local'" object-or-name)))
1489 )
1490
1491 (define-fn reg (*estate* options mode hw-elm . indx-sel)
1492   (let ((indx (or (list-maybe-ref indx-sel 0) 0))
1493         (sel (or (list-maybe-ref indx-sel 1) hw-selector-default)))
1494     (s-hw *estate* mode hw-elm indx sel))
1495 )
1496
1497 (define-fn raw-reg (*estate* options mode hw-elm . indx-sel)
1498   (let ((indx (or (list-maybe-ref indx-sel 0) 0))
1499         (sel (or (list-maybe-ref indx-sel 1) hw-selector-default)))
1500     (let ((result (s-hw *estate* mode hw-elm indx sel)))
1501       (obj-cons-attr! result (bool-attr-make 'RAW #t))
1502       result))
1503 )
1504
1505 (define-fn mem (*estate* options mode addr . sel)
1506   (s-hw *estate* mode 'h-memory addr
1507         (if (pair? sel) (car sel) hw-selector-default))
1508 )
1509
1510 ; ??? Hmmm... needed?  The pc is usually specified as `pc' which is shorthand
1511 ; for (operand pc).
1512 ;(define-fn pc (*estate* options mode)
1513 ;  s-pc
1514 ;)
1515
1516 (define-fn ref (*estate* options mode name)
1517   (if (not (insn? (estate-owner *estate*)))
1518       (estate-error *estate* "ref: not processing an insn"
1519                     (obj:name (estate-owner *estate*))))
1520   (cx:make 'UINT
1521            (string-append
1522             "(referenced & (1 << "
1523             (number->string
1524              (op:num (insn-lookup-op (estate-owner *estate*) name)))
1525             "))"))
1526 )
1527
1528 ; ??? Maybe this should return an operand object.
1529 (define-fn index-of (*estate* options mode op)
1530   (send (op:index (rtx-eval-with-estate op DFLT *estate*))
1531         'cxmake-get *estate* (mode:lookup mode))
1532 )
1533
1534 (define-fn clobber (*estate* options mode object)
1535   (cx:make VOID "; /*clobber*/\n")
1536 )
1537
1538 (define-fn delay (*estate* options mode num-node rtx)
1539   ;; FIXME: Try to move SID stuff into sid-foo.scm.
1540   (case APPLICATION
1541     ((SID-SIMULATOR)
1542      (let* ((n (cadddr num-node))
1543             (old-delay (let ((old (assoc '#:delay (estate-modifiers *estate*))))
1544                          (if old (cadr old) 0)))
1545             (new-delay (+ n old-delay)))
1546        (begin
1547          ;; check for proper usage
1548          (if (let* ((hw (case (car rtx)
1549                           ((operand) (op:type (current-op-lookup (rtx-arg1 rtx))))
1550                           ((xop) (op:type (rtx-xop-obj rtx)))
1551                           (else #f))))
1552                (not (and hw (or (pc? hw) (memory? hw) (register? hw)))))
1553              (estate-error
1554               *estate*
1555               "(delay ...) rtx applied to wrong type of operand, should be pc, register or memory"
1556                (car rtx)))
1557          ;; signal an error if we're delayed and not in a "parallel-insns" CPU
1558          (if (not (with-parallel?))
1559              (estate-error *estate* "delayed operand in a non-parallel cpu"
1560                            (car rtx)))
1561          ;; update cpu-global pipeline bound
1562          (cpu-set-max-delay! (current-cpu) (max (cpu-max-delay (current-cpu)) new-delay))
1563          ;; pass along new delay to embedded rtx
1564          (rtx-eval-with-estate rtx (mode:lookup mode)
1565                                (estate-with-modifiers *estate* `((#:delay ,new-delay)))))))
1566
1567     ;; not in sid-land
1568     (else (s-sequence (estate-with-modifiers *estate* '((#:delay))) VOID '() rtx)))
1569 )
1570
1571 ; Gets expanded as a macro.
1572 ;(define-fn annul (*estate* yes?)
1573 ;  (s-c-call *estate* 'VOID "SEM_ANNUL_INSN" "pc" yes?)
1574 ;)
1575
1576 (define-fn skip (*estate* options mode yes?)
1577   (send pc 'cxmake-skip *estate* yes?)
1578   ;(s-c-call *estate* 'VOID "SEM_SKIP_INSN" "pc" yes?)
1579 )
1580
1581 (define-fn eq-attr (*estate* options mode obj attr-name value)
1582   (cx:make 'INT
1583            (string-append "(GET_ATTR ("
1584                           (gen-c-symbol attr-name)
1585                           ") == "
1586                           (gen-c-symbol value)
1587                           ")"))
1588 )
1589
1590 (define-fn int-attr (*estate* options mode owner attr-name)
1591   (cond ((or (equal? owner '(current-insn () DFLT)) ;; FIXME: delete in time
1592              (equal? owner '(current-insn () INSN)))
1593          (s-c-raw-call *estate* 'INT "GET_ATTR"
1594                        (string-upcase (gen-c-symbol attr-name))))
1595         (else
1596          (estate-error *estate* "attr: unsupported object type" owner)))
1597 )
1598
1599 (define-fn const (*estate* options mode c)
1600   (assert (not (mode:eq? 'VOID mode)))
1601   (if (mode:eq? 'DFLT mode) ;; FIXME: can't get DFLT anymore
1602       (set! mode 'INT))
1603   (let ((mode (mode:lookup mode)))
1604     (cx:make mode
1605              (cond ((or (mode:eq? 'DI mode)
1606                         (mode:eq? 'UDI mode)
1607                         (< #xffffffff c)
1608                         (> #x-80000000 c))
1609                     (string-append "MAKEDI ("
1610                                    (gen-integer (high-part c)) ", "
1611                                    (gen-integer (low-part c))
1612                                    ")"))
1613                    ((and (<= #x-80000000 c) (> #x80000000 c))
1614                     (number->string c))
1615                    ((and (<= #x80000000 c) (>= #xffffffff c))
1616                     ; ??? GCC complains if not affixed with "U" but that's not k&r.
1617                     ;(string-append (number->string val) "U"))
1618                     (string-append "0x" (number->string c 16)))
1619                    ; Else punt.
1620                    (else (number->string c)))))
1621 )
1622
1623 (define-fn join (*estate* options out-mode in-mode arg1 . arg-rest)
1624   ; FIXME: Endianness issues undecided.
1625   ; FIXME: Ensure correct number of args for in/out modes.
1626   ; Ensure compatible modes.
1627   (apply s-c-raw-call (cons *estate*
1628                             (cons out-mode
1629                                   (cons (stringsym-append "JOIN"
1630                                                           in-mode
1631                                                           out-mode)
1632                                         (cons arg1 arg-rest)))))
1633 )
1634
1635 (define-fn subword (*estate* options mode value word-num)
1636   (let* ((mode (mode:lookup mode))
1637          (val (rtl-c-get *estate* DFLT value))
1638          (val-mode (cx:mode val)))
1639     (cx:make mode
1640              (string-append "SUBWORD"
1641                             (obj:str-name val-mode) (obj:str-name mode)
1642                             " (" (cx:c val)
1643                             (if (mode-bigger? val-mode mode)
1644                                 (string-append
1645                                  ", "
1646                                  (if (number? word-num)
1647                                      (number->string word-num)
1648                                      (cx:c (rtl-c-get *estate* DFLT word-num))))
1649                                 "")
1650                             ")")))
1651 )
1652
1653 (define-fn c-code (*estate* options mode text)
1654   (cx:make mode text)
1655 )
1656
1657 (define-fn c-call (*estate* options mode name . args)
1658   (apply s-c-call (cons *estate* (cons mode (cons name args))))
1659 )
1660
1661 (define-fn c-raw-call (*estate* options mode name . args)
1662   (apply s-c-raw-call (cons *estate* (cons mode (cons name args))))
1663 )
1664
1665 (define-fn nop (*estate* options mode)
1666   (cx:make VOID "((void) 0); /*nop*/\n")
1667 )
1668
1669 (define-fn set (*estate* options mode dst src)
1670   (if (estate-for-insn? *estate*)
1671       (rtl-c-set-trace *estate* mode dst src)
1672       (rtl-c-set-quiet *estate* mode dst src))
1673 )
1674
1675 (define-fn set-quiet (*estate* options mode dst src)
1676   (rtl-c-set-quiet *estate* mode dst src)
1677 )
1678
1679 (define-fn neg (*estate* options mode s1)
1680   (s-unop *estate* "NEG" "-" mode s1)
1681 )
1682
1683 (define-fn abs (*estate* options mode s1)
1684   (s-unop *estate* "ABS" #f mode s1)
1685 )
1686
1687 (define-fn inv (*estate* options mode s1)
1688   (s-unop *estate* "INV" "~" mode s1)
1689 )
1690
1691 (define-fn not (*estate* options mode s1)
1692   (s-unop *estate* "NOT" "!" mode s1)
1693 )
1694
1695 (define-fn add (*estate* options mode s1 s2)
1696   (s-binop *estate* "ADD" "+" mode s1 s2)
1697 )
1698 (define-fn sub (*estate* options mode s1 s2)
1699   (s-binop *estate* "SUB" "-" mode s1 s2)
1700 )
1701
1702 (define-fn addc (*estate* options mode s1 s2 s3)
1703   (s-binop-with-bit *estate* "ADDC" mode s1 s2 s3)
1704 )
1705 ;; ??? Whether to rename ADDCF/ADDOF -> ADDCCF/ADDCOF is debatable.
1706 (define-fn addc-cflag (*estate* options mode s1 s2 s3)
1707   (s-binop-with-bit *estate* "ADDCF" mode s1 s2 s3)
1708 )
1709 (define-fn addc-oflag (*estate* options mode s1 s2 s3)
1710   (s-binop-with-bit *estate* "ADDOF" mode s1 s2 s3)
1711 )
1712
1713 (define-fn subc (*estate* options mode s1 s2 s3)
1714   (s-binop-with-bit *estate* "SUBC" mode s1 s2 s3)
1715 )
1716 ;; ??? Whether to rename SUBCF/SUBOF -> SUBCCF/SUBCOF is debatable.
1717 (define-fn subc-cflag (*estate* options mode s1 s2 s3)
1718   (s-binop-with-bit *estate* "SUBCF" mode s1 s2 s3)
1719 )
1720 (define-fn subc-oflag (*estate* options mode s1 s2 s3)
1721   (s-binop-with-bit *estate* "SUBOF" mode s1 s2 s3)
1722 )
1723
1724 ;; ??? These are deprecated.  Delete in time.
1725 (define-fn add-cflag (*estate* options mode s1 s2 s3)
1726   (s-binop-with-bit *estate* "ADDCF" mode s1 s2 s3)
1727 )
1728 (define-fn add-oflag (*estate* options mode s1 s2 s3)
1729   (s-binop-with-bit *estate* "ADDOF" mode s1 s2 s3)
1730 )
1731 (define-fn sub-cflag (*estate* options mode s1 s2 s3)
1732   (s-binop-with-bit *estate* "SUBCF" mode s1 s2 s3)
1733 )
1734 (define-fn sub-oflag (*estate* options mode s1 s2 s3)
1735   (s-binop-with-bit *estate* "SUBOF" mode s1 s2 s3)
1736 )
1737
1738 ;(define-fn zflag (*estate* options mode value)
1739 ;  (list 'eq mode value (list 'const mode 0))
1740 ;)
1741
1742 ;(define-fn nflag (*estate* options mode value)
1743 ;  (list 'lt mode value (list 'const mode 0))
1744 ;)
1745
1746 (define-fn mul (*estate* options mode s1 s2)
1747   (s-binop *estate* "MUL" "*" mode s1 s2)
1748 )
1749 (define-fn div (*estate* options mode s1 s2)
1750   (s-binop *estate* "DIV" "/" mode s1 s2)
1751 )
1752 (define-fn udiv (*estate* options mode s1 s2)
1753   (s-binop *estate* "UDIV" "/" mode s1 s2)
1754 )
1755 (define-fn mod (*estate* options mode s1 s2)
1756   (s-binop *estate* "MOD" "%" mode s1 s2)
1757 )
1758 (define-fn umod (*estate* options mode s1 s2)
1759   (s-binop *estate* "UMOD" "%" mode s1 s2)
1760 )
1761
1762 (define-fn sqrt (*estate* options mode s1)
1763   (s-unop *estate* "SQRT" #f mode s1)
1764 )
1765 (define-fn cos (*estate* options mode s1)
1766   (s-unop *estate* "COS" #f mode s1)
1767 )
1768 (define-fn sin (*estate* options mode s1)
1769   (s-unop *estate* "SIN" #f mode s1)
1770 )
1771
1772 (define-fn nan (*estate* options mode s1)
1773   (s-float-predop *estate* "NAN" mode s1)
1774 )
1775 (define-fn qnan (*estate* options mode s1)
1776   (s-float-predop *estate* "QNAN" mode s1)
1777 )
1778 (define-fn snan (*estate* options mode s1)
1779   (s-float-predop *estate* "SNAN" mode s1)
1780 )
1781
1782 (define-fn min (*estate* options mode s1 s2)
1783   (s-binop *estate* "MIN" #f mode s1 s2)
1784 )
1785 (define-fn max (*estate* options mode s1 s2)
1786   (s-binop *estate* "MAX" #f mode s1 s2)
1787 )
1788 (define-fn umin (*estate* options mode s1 s2)
1789   (s-binop *estate* "UMIN" #f mode s1 s2)
1790 )
1791 (define-fn umax (*estate* options mode s1 s2)
1792   (s-binop *estate* "UMAX" #f mode s1 s2)
1793 )
1794
1795 (define-fn and (*estate* options mode s1 s2)
1796   (s-binop *estate* "AND" "&" mode s1 s2)
1797 )
1798 (define-fn or (*estate* options mode s1 s2)
1799   (s-binop *estate* "OR" "|" mode s1 s2)
1800 )
1801 (define-fn xor (*estate* options mode s1 s2)
1802   (s-binop *estate* "XOR" "^" mode s1 s2)
1803 )
1804
1805 (define-fn sll (*estate* options mode s1 s2)
1806   (s-shop *estate* "SLL" "<<" mode s1 s2)
1807 )
1808 (define-fn srl (*estate* options mode s1 s2)
1809   (s-shop *estate* "SRL" ">>" mode s1 s2)
1810 )
1811 (define-fn sra (*estate* options mode s1 s2)
1812   (s-shop *estate* "SRA" ">>" mode s1 s2)
1813 )
1814 (define-fn ror (*estate* options mode s1 s2)
1815   (s-shop *estate* "ROR" #f mode s1 s2)
1816 )
1817 (define-fn rol (*estate* options mode s1 s2)
1818   (s-shop *estate* "ROL" #f mode s1 s2)
1819 )
1820
1821 (define-fn andif (*estate* options mode s1 s2)
1822   (s-boolifop *estate* "ANDIF" "&&" s1 s2)
1823 )
1824 (define-fn orif (*estate* options mode s1 s2)
1825   (s-boolifop *estate* "ORIF" "||" s1 s2)
1826 )
1827
1828 (define-fn ext (*estate* options mode s1)
1829   (s-int-convop *estate* "EXT" mode s1)
1830 )
1831 (define-fn zext (*estate* options mode s1)
1832   (s-int-convop *estate* "ZEXT" mode s1)
1833 )
1834 (define-fn trunc (*estate* options mode s1)
1835   (s-int-convop *estate* "TRUNC" mode s1)
1836 )
1837
1838 (define-fn fext (*estate* options mode how s1)
1839   (s-float-convop *estate* "FEXT" mode how s1)
1840 )
1841 (define-fn ftrunc (*estate* options mode how s1)
1842   (s-float-convop *estate* "FTRUNC" mode how s1)
1843 )
1844 (define-fn float (*estate* options mode how s1)
1845   (s-float-convop *estate* "FLOAT" mode how s1)
1846 )
1847 (define-fn ufloat (*estate* options mode how s1)
1848   (s-float-convop *estate* "UFLOAT" mode how s1)
1849 )
1850 (define-fn fix (*estate* options mode how s1)
1851   (s-float-convop *estate* "FIX" mode how s1)
1852 )
1853 (define-fn ufix (*estate* options mode how s1)
1854   (s-float-convop *estate* "UFIX" mode how s1)
1855 )
1856
1857 (define-fn eq (*estate* options mode s1 s2)
1858   (s-cmpop *estate* 'eq "==" mode s1 s2)
1859 )
1860 (define-fn ne (*estate* options mode s1 s2)
1861   (s-cmpop *estate* 'ne "!=" mode s1 s2)
1862 )
1863
1864 (define-fn lt (*estate* options mode s1 s2)
1865   (s-cmpop *estate* 'lt "<" mode s1 s2)
1866 )
1867 (define-fn le (*estate* options mode s1 s2)
1868   (s-cmpop *estate* 'le "<=" mode s1 s2)
1869 )
1870 (define-fn gt (*estate* options mode s1 s2)
1871   (s-cmpop *estate* 'gt ">" mode s1 s2)
1872 )
1873 (define-fn ge (*estate* options mode s1 s2)
1874   (s-cmpop *estate* 'ge ">=" mode s1 s2)
1875 )
1876
1877 (define-fn ltu (*estate* options mode s1 s2)
1878   (s-cmpop *estate* 'ltu "<" mode s1 s2)
1879 )
1880 (define-fn leu (*estate* options mode s1 s2)
1881   (s-cmpop *estate* 'leu "<=" mode s1 s2)
1882 )
1883 (define-fn gtu (*estate* options mode s1 s2)
1884   (s-cmpop *estate* 'gtu ">" mode s1 s2)
1885 )
1886 (define-fn geu (*estate* options mode s1 s2)
1887   (s-cmpop *estate* 'geu ">=" mode s1 s2)
1888 )
1889
1890 (define-fn member (*estate* options mode value set)
1891   ;; NOTE: There are multiple evalutions of VALUE in the generated code.
1892   ;; It's probably ok, this comment is more for completeness sake.
1893   (let ((c-value (rtl-c-get *estate* mode value))
1894         (set (rtx-number-list-values set)))
1895     (let loop ((set (cdr set))
1896                (code (string-append "(" (cx:c c-value)
1897                                     " == "
1898                                     (gen-integer (car set))
1899                                     ")")))
1900       (if (null? set)
1901           (cx:make (mode:lookup 'BI) (string-append "(" code ")"))
1902           (loop (cdr set)
1903                 (string-append code
1904                                " || ("
1905                                (cx:c c-value)
1906                                " == "
1907                                (gen-integer (car set))
1908                                ")")))))
1909 )
1910
1911 (define-fn if (*estate* options mode cond then . else)
1912   (apply s-if (append! (list *estate* mode cond then) else))
1913 )
1914
1915 (define-fn cond (*estate* options mode . cond-code-list)
1916   (apply s-cond (cons *estate* (cons mode cond-code-list)))
1917 )
1918
1919 (define-fn case (*estate* options mode test . case-list)
1920   (apply s-case (cons *estate* (cons mode (cons test case-list))))
1921 )
1922
1923 (define-fn parallel (*estate* options mode ignore expr . exprs)
1924   (apply s-parallel (cons *estate* (cons expr exprs)))
1925 )
1926
1927 (define-fn sequence (*estate* options mode locals expr . exprs)
1928   (apply s-sequence
1929          (cons *estate* (cons mode (cons locals (cons expr exprs)))))
1930 )
1931
1932 (define-fn do-count (*estate* options mode iter-var nr-times expr . exprs)
1933   (apply s-do-count
1934          (cons *estate* (cons iter-var (cons nr-times (cons expr exprs)))))
1935 )
1936
1937 (define-fn closure (*estate* options mode isa-name-list env-stack expr)
1938   (rtl-c-with-estate (estate-make-closure *estate* isa-name-list
1939                                           (rtx-make-env-stack env-stack))
1940                      (mode:lookup mode) expr)
1941 )
1942 \f
1943 ;; The result is the rtl->c generator table.
1944 ;; FIXME: verify all elements are filled
1945
1946 table
1947
1948 )) ;; End of /rtl-c-build-table