cgen/rtl-xform.scm

   1 ;; Various RTL transformations.
   2 ;;
   3 ;; Copyright (C) 2000, 2009 Red Hat, Inc.
   4 ;; This file is part of CGEN.
   5 ;; See file COPYING.CGEN for details.
   6 ;;
   7 ;; In particular:
   8 ;; rtx-simplify
   9 ;; rtx-solve
  10 ;; rtx-trim-for-doc
  11 \f
  12 ;; Utility to verify there are no DFLT modes present in EXPR
  13
  14 ;; Subroutine of rtx-verify-no-dflt-modes to simplify it.
  15 ;; This is the EXPR-FN argument to rtl-traverse.
  16
  17 (define (/rtx-verify-no-dflt-modes-expr-fn rtx-obj expr parent-expr op-pos
  18                                            tstate appstuff)
  19   (if (eq? (rtx-mode expr) 'DFLT)
  20       (tstate-error tstate "DFLT mode present" expr))
  21
  22   ;; Leave EXPR unchanged and continue.
  23   #f
  24 )
  25
  26 ;; Entry point.  Verify there are no DFLT modes in EXPR.
  27
  28 (define (rtx-verify-no-dflt-modes context expr)
  29   (rtx-traverse context #f expr /rtx-verify-no-dflt-modes-expr-fn #f)
  30 )
  31 \f
  32 ;; rtx-simplify (and supporting cast)
  33
  34 ; Subroutine of /rtx-simplify-expr-fn to compare two values for equality.
  35 ; If both are constants and they're equal return #f/#t.
  36 ; INVERT? = #f -> return #t if equal, #t -> return #f if equal.
  37 ; Returns 'unknown if either argument is not a constant.
  38
  39 (define (/rtx-const-equal arg0 arg1 invert?)
  40   (if (and (rtx-constant? arg0)
  41            (rtx-constant? arg1))
  42       (if invert?
  43           (!= (rtx-constant-value arg0)
  44               (rtx-constant-value arg1))
  45           (= (rtx-constant-value arg0)
  46              (rtx-constant-value arg1)))
  47       'unknown)
  48 )
  49
  50 ; Subroutine of /rtx-simplify-expr-fn to see if MAYBE-CONST is
  51 ; an element of NUMBER-LIST.
  52 ; NUMBER-LIST is a `number-list' rtx.
  53 ; INVERT? is #t if looking for non-membership.
  54 ; #f/#t is only returned for definitive answers.
  55 ; If INVERT? is #f:
  56 ; - return #f if MAYBE-CONST is not in NUMBER-LIST
  57 ; - return #t if MAYBE-CONST is in NUMBER-LIST and it has only one member
  58 ; - return 'member if MAYBE-CONST is in NUMBER-LIST and it has many members
  59 ; - otherwise return 'unknown
  60 ; If INVERT? is #t:
  61 ; - return #t if MAYBE-CONST is not in NUMBER-LIST
  62 ; - return #f if MAYBE-CONST is in NUMBER-LIST and it has only one member
  63 ; - return 'member if MAYBE-CONST is in NUMBER-LIST and it has many members
  64 ; - otherwise return 'unknown
  65
  66 (define (/rtx-const-list-equal maybe-const number-list invert?)
  67   (assert (rtx-kind? 'number-list number-list))
  68   (if (rtx-constant? maybe-const)
  69       (let ((values (rtx-number-list-values number-list)))
  70         (if invert?
  71             (if (memq (rtx-constant-value maybe-const) values)
  72                 (if (= (length values) 1)
  73                     #f
  74                     'member)
  75                 #t)
  76             (if (memq (rtx-constant-value maybe-const) values)
  77                 (if (= (length values) 1)
  78                     #t
  79                     'member)
  80                 #f)))
  81       'unknown)
  82 )
  83
  84 ; Subroutine of /rtx-simplify-expr-fn to simplify an eq-attr of (current-mach).
  85 ; CONTEXT is a <context> object or #f if there is none.
  86
  87 (define (/rtx-simplify-eq-attr-mach rtx context)
  88   (let ((attr (rtx-eq-attr-attr rtx))
  89         (value (rtx-eq-attr-value rtx)))
  90     ; If all currently selected machs will yield the same value
  91     ; for the attribute, we can simplify.
  92     (let ((values (map (lambda (m)
  93                          (obj-attr-value m attr))
  94                        (current-mach-list))))
  95       ; Ensure at least one mach is selected.
  96       (if (null? values)
  97           (context-error context
  98                          "While simplifying rtl"
  99                          "no machs selected"
 100                          (rtx-strdump rtx)))
 101       ; All values equal to the first one?
 102       (if (all-true? (map (lambda (val)
 103                             (equal? val (car values)))
 104                           values))
 105           (if (equal? value
 106                       ; Convert internal boolean attribute value
 107                       ; #f/#t to external value FALSE/TRUE.
 108                       ; FIXME:revisit.
 109                       (case (car values)
 110                         ((#f) 'FALSE)
 111                         ((#t) 'TRUE)
 112                         (else (car values))))
 113               (rtx-true)
 114               (rtx-false))
 115           ; couldn't simplify
 116           rtx)))
 117 )
 118
 119 ; Subroutine of /rtx-simplify-expr-fn to simplify an eq-attr of (current-insn).
 120
 121 (define (/rtx-simplify-eq-attr-insn rtx insn context)
 122   (let ((attr (rtx-eq-attr-attr rtx))
 123         (value (rtx-eq-attr-value rtx)))
 124     (if (not (insn? insn))
 125         (context-error context
 126                        "While simplifying rtl"
 127                        "No current insn for `(current-insn)'"
 128                        (rtx-strdump rtx)))
 129     (let ((attr-value (obj-attr-value insn attr)))
 130       (if (eq? value attr-value)
 131           (rtx-true)
 132           (rtx-false))))
 133 )
 134
 135 ; Subroutine of rtx-simplify.
 136 ; This is the EXPR-FN argument to rtx-traverse.
 137
 138 (define (/rtx-simplify-expr-fn rtx-obj expr parent-expr op-pos
 139                                tstate appstuff)
 140
 141   ;(display "Processing ") (display (rtx-dump expr)) (newline)
 142
 143   (case (rtx-name expr)
 144
 145     ((not)
 146      (let* ((arg (/rtx-traverse (rtx-alu-op-arg expr 0)
 147                                 'RTX expr 1 tstate appstuff))
 148             (no-side-effects? (not (rtx-side-effects? arg))))
 149        (cond ((and no-side-effects? (rtx-false? arg))
 150               (rtx-true))
 151              ((and no-side-effects? (rtx-true? arg))
 152               (rtx-false))
 153              (else (rtx-make 'not (rtx-alu-op-mode expr) arg)))))
 154
 155     ((orif)
 156      (let ((arg0 (/rtx-traverse (rtx-boolif-op-arg expr 0)
 157                                 'RTX expr 0 tstate appstuff))
 158            (arg1 (/rtx-traverse (rtx-boolif-op-arg expr 1)
 159                                 'RTX expr 1 tstate appstuff)))
 160        (let ((no-side-effects-0? (not (rtx-side-effects? arg0)))
 161              (no-side-effects-1? (not (rtx-side-effects? arg1))))
 162          (cond ((and no-side-effects-0? (rtx-true? arg0))
 163                 (rtx-true))
 164                ((and no-side-effects-0? (rtx-false? arg0))
 165                 (rtx-canonical-bool arg1))
 166                ; Value of arg0 is unknown or has side-effects.
 167                ((and no-side-effects-1? (rtx-true? arg1))
 168                 (if no-side-effects-0?
 169                     (rtx-true)
 170                     (rtx-make 'orif arg0 (rtx-true))))
 171                ((and no-side-effects-1? (rtx-false? arg1))
 172                 arg0)
 173                (else
 174                 (rtx-make 'orif arg0 arg1))))))
 175
 176     ((andif)
 177      (let ((arg0 (/rtx-traverse (rtx-boolif-op-arg expr 0)
 178                                 'RTX expr 0 tstate appstuff))
 179            (arg1 (/rtx-traverse (rtx-boolif-op-arg expr 1)
 180                                 'RTX expr 1 tstate appstuff)))
 181        (let ((no-side-effects-0? (not (rtx-side-effects? arg0)))
 182              (no-side-effects-1? (not (rtx-side-effects? arg1))))
 183          (cond ((and no-side-effects-0? (rtx-false? arg0))
 184                 (rtx-false))
 185                ((and no-side-effects-0? (rtx-true? arg0))
 186                 (rtx-canonical-bool arg1))
 187                ; Value of arg0 is unknown or has side-effects.
 188                ((and no-side-effects-1? (rtx-false? arg1))
 189                 (if no-side-effects-0?
 190                     (rtx-false)
 191                     (rtx-make 'andif arg0 (rtx-false))))
 192                ((and no-side-effects-1? (rtx-true? arg1))
 193                 arg0)
 194                (else
 195                 (rtx-make 'andif arg0 arg1))))))
 196
 197     ; Fold if's to their then or else part if we can determine the
 198     ; result of the test.
 199     ((if)
 200      (let ((test
 201             ; ??? Was this but that calls rtx-traverse again which
 202             ; resets the temp stack!
 203             ; (rtx-simplify context (caddr expr))))
 204             (/rtx-traverse (rtx-if-test expr) 'RTX expr 1 tstate appstuff)))
 205        (cond ((rtx-true? test)
 206               (/rtx-traverse (rtx-if-then expr) 'RTX expr 2 tstate appstuff))
 207              ((rtx-false? test)
 208               (if (rtx-if-else expr)
 209                   (/rtx-traverse (rtx-if-else expr) 'RTX expr 3 tstate appstuff)
 210                   ; Sanity check, mode must be VOID.
 211                   ; FIXME: DFLT can no longer appear
 212                   (if (or (mode:eq? 'DFLT (rtx-mode expr))
 213                           (mode:eq? 'VOID (rtx-mode expr)))
 214                       (rtx-make 'nop 'VOID)
 215                       (error "rtx-simplify: non-void-mode `if' missing `else' part" expr))))
 216              ; Can't simplify.
 217              ; We could traverse the then/else clauses here, but it's simpler
 218              ; to have our caller do it (by returning #f).
 219              ; The cost is retraversing `test'.
 220              (else #f))))
 221
 222     ((eq ne)
 223      (let ((name (rtx-name expr))
 224            (cmp-mode (rtx-cmp-op-mode expr))
 225            (arg0 (/rtx-traverse (rtx-cmp-op-arg expr 0) 'RTX
 226                                 expr 1 tstate appstuff))
 227            (arg1 (/rtx-traverse (rtx-cmp-op-arg expr 1) 'RTX
 228                                 expr 2 tstate appstuff)))
 229        (if (or (rtx-side-effects? arg0) (rtx-side-effects? arg1))
 230            (rtx-make name cmp-mode arg0 arg1)
 231            (case (/rtx-const-equal arg0 arg1 (rtx-kind? 'ne expr))
 232              ((#f) (rtx-false))
 233              ((#t) (rtx-true))
 234              (else
 235               ; That didn't work.  See if we have an ifield/operand with a
 236               ; known range of values.  We don't need to check for a known
 237               ; single value, that is handled below.
 238               (case (rtx-name arg0)
 239                 ((ifield)
 240                  (let ((known-val (tstate-known-lookup tstate
 241                                                        (rtx-ifield-name arg0))))
 242                    (if (and known-val (rtx-kind? 'number-list known-val))
 243                        (case (/rtx-const-list-equal arg1 known-val
 244                                                     (rtx-kind? 'ne expr))
 245                          ((#f) (rtx-false))
 246                          ((#t) (rtx-true))
 247                          (else
 248                           (rtx-make name cmp-mode arg0 arg1)))
 249                        (rtx-make name cmp-mode arg0 arg1))))
 250                 ((operand)
 251                  (let ((known-val (tstate-known-lookup tstate
 252                                                        (rtx-operand-name arg0))))
 253                    (if (and known-val (rtx-kind? 'number-list known-val))
 254                        (case (/rtx-const-list-equal arg1 known-val
 255                                                     (rtx-kind? 'ne expr))
 256                          ((#f) (rtx-false))
 257                          ((#t) (rtx-true))
 258                          (else
 259                           (rtx-make name cmp-mode arg0 arg1)))
 260                        (rtx-make name cmp-mode arg0 arg1))))
 261                 (else
 262                  (rtx-make name cmp-mode arg0 arg1))))))))
 263
 264     ; Recognize attribute requests of current-insn, current-mach.
 265     ((eq-attr)
 266      (cond ((rtx-kind? 'current-mach (rtx-eq-attr-owner expr))
 267             (/rtx-simplify-eq-attr-mach expr (tstate-context tstate)))
 268            ((rtx-kind? 'current-insn (rtx-eq-attr-owner expr))
 269             (/rtx-simplify-eq-attr-insn expr (tstate-owner tstate) (tstate-context tstate)))
 270            (else expr)))
 271
 272     ((ifield)
 273      (let ((known-val (tstate-known-lookup tstate (rtx-ifield-name expr))))
 274        ; If the value is a single number, return that.
 275        ; It can be one of several, represented as a number list.
 276        (if (and known-val (rtx-constant? known-val))
 277            known-val ; (rtx-make 'const 'INT known-val)
 278            #f)))
 279
 280     ((operand)
 281      (let ((known-val (tstate-known-lookup tstate (rtx-operand-name expr))))
 282        ; If the value is a single number, return that.
 283        ; It can be one of several, represented as a number list.
 284        (if (and known-val (rtx-constant? known-val))
 285            known-val ; (rtx-make 'const 'INT known-val)
 286            #f)))
 287
 288     ((closure)
 289      (let ((simplified-expr (/rtx-traverse (rtx-closure-expr expr)
 290                                            'RTX expr 2 tstate appstuff)))
 291        simplified-expr))
 292
 293     ; Leave EXPR unchanged and continue.
 294     (else #f))
 295 )
 296
 297 ; Simplify an rtl expression.
 298 ;
 299 ; EXPR must be in canonical source form.
 300 ; The result is a possibly simplified EXPR, still in source form.
 301 ;
 302 ; CONTEXT is a <context> object or #f, used for error messages.
 303 ; OWNER is the owner of the expression (e.g. <insn>) or #f if there is none.
 304 ;
 305 ; KNOWN is an alist of known values.  Each element is (name . value) where
 306 ; NAME is an ifield/operand name and VALUE is a const/number-list rtx.
 307 ; FIXME: Need ranges, later.
 308 ;
 309 ; The following operations are performed:
 310 ; - unselected machine dependent code is removed (eq-attr of (current-mach))
 311 ; - if's are reduced to either then/else if we can determine that the test is
 312 ;   a compile-time constant
 313 ; - orif/andif
 314 ; - eq/ne
 315 ; - not
 316 ;
 317 ; ??? Will become more intelligent as needed.
 318
 319 (define (rtx-simplify context owner expr known)
 320   (/rtx-traverse expr #f #f 0
 321                  (tstate-make context owner
 322                               /rtx-simplify-expr-fn
 323                               #f ;; ok since EXPR is fully canonical
 324                               (rtx-env-empty-stack)
 325                               #f known 0)
 326                  #f)
 327 )
 328
 329 ;; Return an insn's semantics simplified.
 330 ;; CONTEXT is a <context> object or #f, used for error messages.
 331
 332 (define (rtx-simplify-insn context insn)
 333   (rtx-simplify context insn (insn-canonical-semantics insn)
 334                 (insn-build-known-values insn))
 335 )
 336 \f
 337 ;; rtx-solve (and supporting cast)
 338
 339 ; Utilities for equation solving.
 340 ; ??? At the moment this is only focused on ifield assertions.
 341 ; ??? That there exist more sophisticated versions than this one can take
 342 ; as a given.  This works for the task at hand and will evolve or be replaced
 343 ; as necessary.
 344 ; ??? This makes the simplifying assumption that no expr has side-effects.
 345
 346 ; Subroutine of rtx-solve.
 347 ; This is the EXPR-FN argument to rtx-traverse.
 348
 349 (define (/solve-expr-fn rtx-obj expr parent-expr op-pos tstate appstuff)
 350   #f ; wip
 351 )
 352
 353 ; Return a boolean indicating if {expr} equates to "true".
 354 ; If the expression can't be reduced to #f/#t, return '?.
 355 ; ??? Use rtx-eval instead of rtx-traverse?
 356 ;
 357 ; EXPR must be in source form.
 358 ; CONTEXT is a <context> object, used for error messages.
 359 ; OWNER is the owner of the expression (e.g. <insn>) or #f if there is none.
 360 ; KNOWN is an alist of known values.  Each element is (name . value) where
 361 ; NAME is an ifield/operand name and VALUE is a const/number-list rtx.
 362 ; FIXME: Need ranges, later.
 363 ;
 364 ; This is akin to rtx-simplify except it's geared towards solving ifield
 365 ; assertions.  It's not unreasonable to combine them.  The worry is the
 366 ; efficiency lost.
 367 ; ??? Will become more intelligent as needed.
 368
 369 (define (rtx-solve context owner expr known)
 370   ; First simplify, then solve.
 371   (let* ((simplified-expr (rtx-simplify context owner expr known))
 372          (maybe-solved-expr
 373           simplified-expr) ; FIXME: for now
 374 ;         (/rtx-traverse simplified-expr #f #f 0
 375 ;                        (tstate-make context owner
 376 ;                                     /solve-expr-fn
 377 ;                                     #f (rtx-env-empty-stack)
 378 ;                                     #f known 0)
 379 ;                        #f))
 380          )
 381     (cond ((rtx-true? maybe-solved-expr) #t)
 382           ((rtx-false? maybe-solved-expr) #f)
 383           (else '?)))
 384 )
 385 \f
 386 ;; rtx-trim-for-doc (and supporting cast)
 387 ;; RTX trimming (removing fluff not normally needed for the human viewer).
 388
 389 ;; Subroutine of /rtx-trim-args to simplify it.
 390 ;; Trim a list of rtxes.
 391
 392 (define (/rtx-trim-rtx-list rtx-list)
 393   (map /rtx-rtim-for-doc rtx-list)
 394 )
 395
 396 ; Subroutine of /rtx-trim-for-doc to simplify it.
 397 ; Trim the arguments of rtx NAME.
 398 ; ARGS has already had options,mode removed.
 399
 400 (define (/rtx-trim-args name args)
 401   (logit 4 "Trimming args of " name ": " args "\n")
 402   (let* ((rtx-obj (rtx-lookup name))
 403          (arg-types (rtx-arg-types rtx-obj)))
 404
 405     (let loop ((args args)
 406                (types (cddr arg-types)) ; skip options, mode
 407                (result nil))
 408
 409       (if (null? args)
 410
 411           (reverse! result)
 412
 413           (let ((arg (car args))
 414                 ; Remember, types may be an improper list.
 415                 (type (if (pair? types) (car types) types))
 416                 (new-arg (car args)))
 417
 418             ;(display arg (current-error-port)) (newline (current-error-port))
 419             ;(display type (current-error-port)) (newline (current-error-port))
 420
 421             (case type
 422               ((OPTIONS)
 423                (assert #f)) ; shouldn't get here
 424
 425               ((ANYINTMODE ANYFLOATMODE ANYNUMMODE ANYEXPRMODE EXPLNUMMODE
 426                 VOIDORNUMMODE VOIDMODE BIMODE INTMODE
 427                 SYMMODE INSNMODE MACHMODE)
 428                #f) ; leave arg untouched
 429
 430               ((RTX SETRTX TESTRTX)
 431                (set! new-arg (/rtx-trim-for-doc arg)))
 432
 433               ((CONDRTX)
 434                (assert (= (length arg) 2))
 435                (if (eq? (car arg) 'else)
 436                    (set! new-arg (cons 'else (/rtx-trim-for-doc (cadr arg))))
 437                    (set! new-arg (list (/rtx-trim-for-doc (car arg))
 438                                        (/rtx-trim-for-doc (cadr arg)))))
 439                )
 440
 441               ((CASERTX)
 442                (assert (= (length arg) 2))
 443                (set! new-arg (list (car arg) (/rtx-trim-for-doc (cadr arg))))
 444                )
 445
 446               ((LOCALS)
 447                #f) ; leave arg untouched
 448
 449               ((ITERATION SYMBOLLIST ENVSTACK)
 450                #f) ; leave arg untouched for now
 451
 452               ((ATTRS)
 453                #f) ; leave arg untouched for now
 454
 455               ((SYMBOL STRING NUMBER SYMORNUM)
 456                #f) ; leave arg untouched
 457
 458               ((OBJECT)
 459                (assert #f)) ; hopefully(wip!) shouldn't get here
 460
 461               (else
 462                (assert #f))) ; unknown arg type
 463
 464             (loop (cdr args)
 465                   (if (pair? types) (cdr types) types)
 466                   (cons new-arg result))))))
 467 )
 468
 469 ; Given a canonical rtl expression, usually the result of rtx-simplify,
 470 ; remove bits unnecessary for documentation purposes.
 471 ; Canonical rtl too verbose for docs.
 472 ; Examples of things to remove:
 473 ; - empty options list
 474 ; - ifield/operand/local/const wrappers
 475 ; - modes of operations that don't need them to convey meaning
 476 ;
 477 ; NOTE: While having to trim the result of rtx-simplify may seem ironic,
 478 ; it isn't.  You need to keep separate the notions of simplifying "1+1" to "2"
 479 ; and trimming the clutter from "(const () BI 0)" yielding "0".
 480
 481 (define (/rtx-trim-for-doc rtx)
 482   (if (pair? rtx) ; ??? cheap rtx?
 483
 484       (let ((name (car rtx))
 485             (options (cadr rtx))
 486             (mode (caddr rtx))
 487             (rest (cdddr rtx)))
 488
 489         (case name
 490
 491           ((const ifield operand local)
 492            (if (null? options)
 493                (car rest)
 494                rtx))
 495
 496           ((set set-quiet)
 497            (let ((trimmed-args (/rtx-trim-args name rest)))
 498              (if (null? options)
 499                  (cons name trimmed-args)
 500                  (cons name (cons options (cons mode trimmed-args))))))
 501
 502           ((eq ne lt le gt ge ltu leu gtu geu index-of)
 503            (let ((trimmed-args (/rtx-trim-args name rest)))
 504              (if (null? options)
 505                  (cons name trimmed-args)
 506                  (cons name (cons options (cons mode trimmed-args))))))
 507
 508           ((if)
 509            (let ((trimmed-args (/rtx-trim-args name rest)))
 510              (if (null? options)
 511                  (if (eq? mode 'VOID)
 512                      (cons name trimmed-args)
 513                      (cons name (cons mode trimmed-args)))
 514                  (cons name (cons options (cons mode trimmed-args))))))
 515
 516           ((sequence parallel)
 517            ; No special support is needed, except it's nice to remove nop
 518            ; statements.  These can be created when an `if' get simplified.
 519            (let ((trimmed-args (/rtx-trim-args name rest))
 520                  (result nil))
 521              (for-each (lambda (rtx)
 522                          (if (equal? rtx '(nop))
 523                              #f ; ignore
 524                              (set! result (cons rtx result))))
 525                        trimmed-args)
 526              (if (null? options)
 527                  (if (eq? mode 'VOID)
 528                      (cons name (reverse result))
 529                      (cons name (cons mode (reverse result))))
 530                  (cons name (cons options (cons mode (reverse result)))))))
 531
 532           ((nop)
 533            (list 'nop))
 534
 535           ((closure)
 536            ;; Remove outer closures, they are artificially added, and are
 537            ;; basically noise to the human trying to understand the semantics.
 538            ;; ??? Since we currently can't distinguish outer closures,
 539            ;; just remove them all.
 540            (let ((trimmed-expr (/rtx-trim-for-doc (rtx-closure-expr rtx))))
 541              (if (and (null? options) (null? (rtx-closure-env-stack rtx)))
 542                  trimmed-expr
 543                  (rtx-make 'closure options mode
 544                            (rtx-closure-isas rtx)
 545                            (rtx-closure-env-stack rtx)
 546                            trimmed-expr))))
 547
 548           (else
 549            (let ((trimmed-args (/rtx-trim-args name rest)))
 550              (if (null? options)
 551                  (if (eq? mode 'DFLT) ;; FIXME: DFLT can no longer appear
 552                      (cons name trimmed-args)
 553                      (cons name (cons mode trimmed-args)))
 554                  (cons name (cons options (cons mode trimmed-args))))))))
 555
 556       ; Not an rtx expression, must be number, symbol, string.
 557       rtx)
 558 )
 559
 560 (define (rtx-trim-for-doc rtx)
 561   (/rtx-trim-for-doc rtx)
 562 )