cgen/rtl-traverse.scm

   1 ; RTL traversing support.
   2 ; Copyright (C) 2000, 2001, 2009 Red Hat, Inc.
   3 ; This file is part of CGEN.
   4 ; See file COPYING.CGEN for details.
   5
   6 ; RTL expression traversal support.
   7 ; Traversal (and compilation) involves validating the source form and
   8 ; converting it to internal form.
   9 ; ??? At present the internal form is also the source form (easier debugging).
  10
  11 ; Set to #t to debug rtx traversal.
  12
  13 (define -rtx-traverse-debug? #f)
  14
  15 ; Container to record the current state of traversal.
  16 ; This is initialized before traversal, and modified (in a copy) as the
  17 ; traversal state changes.
  18 ; This doesn't record all traversal state, just the more static elements.
  19 ; There's no point in recording things like the parent expression and operand
  20 ; position as they change for every sub-traversal.
  21 ; The main raison d'etre for this class is so we can add more state without
  22 ; having to modify all the traversal handlers.
  23 ; ??? At present it's not a proper "class" as there's no real need.
  24 ;
  25 ; CONTEXT is a <context> object or #f if there is none.
  26 ; It is used for error messages.
  27 ;
  28 ; EXPR-FN is a dual-purpose beast.  The first purpose is to just process
  29 ; the current expression and return the result.  The second purpose is to
  30 ; lookup the function which will then process the expression.
  31 ; It is applied recursively to the expression and each sub-expression.
  32 ; It must be defined as
  33 ; (lambda (rtx-obj expr mode parent-expr op-pos tstate appstuff) ...).
  34 ; If the result of EXPR-FN is a lambda, it is applied to
  35 ; (cons TSTATE (cdr EXPR)).  TSTATE is prepended to the arguments.
  36 ; For syntax expressions if the result of EXPR-FN is #f, the operands are
  37 ; processed using the builtin traverser.
  38 ; So to repeat: EXPR-FN can process the expression, and if its result is a
  39 ; lambda then it also processes the expression.  The arguments to EXPR-FN
  40 ; are (rtx-obj expr mode parent-expr op-pos tstate appstuff).  The format
  41 ; of the result of EXPR-FN are (cons TSTATE (cdr EXPR)).
  42 ; The reason for the duality is that when trying to understand EXPR (e.g. when
  43 ; computing the insn format) EXPR-FN processes the expression itself, and
  44 ; when evaluating EXPR it's the result of EXPR-FN that computes the value.
  45 ;
  46 ; ENV is the current environment.  This is a stack of sequence locals.
  47 ;
  48 ; COND? is a boolean indicating if the current expression is on a conditional
  49 ; execution path.  This is for optimization purposes only and it is always ok
  50 ; to pass #t, except for the top-level caller which must pass #f (since the top
  51 ; level expression obviously isn't subject to any condition).
  52 ; It is used, for example, to speed up the simulator: there's no need to keep
  53 ; track of whether an operand has been assigned to (or potentially read from)
  54 ; if it's known it's always assigned to.
  55 ;
  56 ; SET? is a boolean indicating if the current expression is an operand being
  57 ; set.
  58 ;
  59 ; OWNER is the owner of the expression or #f if there is none.
  60 ; Typically it is an <insn> object.
  61 ;
  62 ; KNOWN is an alist of known values.  This is used by rtx-simplify.
  63 ; Each element is (name . value) where
  64 ; NAME is either an ifield or operand name (in the future it might be a
  65 ; sequence local name), and
  66 ; VALUE is either (const mode value) or (numlist mode value1 value2 ...).
  67 ;
  68 ; DEPTH is the current traversal depth.
  69
  70 (define (tstate-make context owner expr-fn env cond? set? known depth)
  71   (vector context owner expr-fn env cond? set? known depth)
  72 )
  73
  74 (define (tstate-context state)             (vector-ref state 0))
  75 (define (tstate-set-context! state newval) (vector-set! state 0 newval))
  76 (define (tstate-owner state)               (vector-ref state 1))
  77 (define (tstate-set-owner! state newval)   (vector-set! state 1 newval))
  78 (define (tstate-expr-fn state)             (vector-ref state 2))
  79 (define (tstate-set-expr-fn! state newval) (vector-set! state 2 newval))
  80 (define (tstate-env state)                 (vector-ref state 3))
  81 (define (tstate-set-env! state newval)     (vector-set! state 3 newval))
  82 (define (tstate-cond? state)               (vector-ref state 4))
  83 (define (tstate-set-cond?! state newval)   (vector-set! state 4 newval))
  84 (define (tstate-set? state)                (vector-ref state 5))
  85 (define (tstate-set-set?! state newval)    (vector-set! state 5 newval))
  86 (define (tstate-known state)               (vector-ref state 6))
  87 (define (tstate-set-known! state newval)   (vector-set! state 6 newval))
  88 (define (tstate-depth state)               (vector-ref state 7))
  89 (define (tstate-set-depth! state newval)   (vector-set! state 7 newval))
  90
  91 ; Create a copy of STATE.
  92
  93 (define (tstate-copy state)
  94   ; A fast vector-copy would be nice, but this is simple and portable.
  95   (list->vector (vector->list state))
  96 )
  97
  98 ; Create a copy of STATE with a new environment ENV.
  99
 100 (define (tstate-new-env state env)
 101   (let ((result (tstate-copy state)))
 102     (tstate-set-env! result env)
 103     result)
 104 )
 105
 106 ; Create a copy of STATE with environment ENV pushed onto the existing
 107 ; environment list.
 108 ; There's no routine to pop the environment list as there's no current
 109 ; need for it: we make a copy of the state when we push.
 110
 111 (define (tstate-push-env state env)
 112   (let ((result (tstate-copy state)))
 113     (tstate-set-env! result (cons env (tstate-env result)))
 114     result)
 115 )
 116
 117 ; Create a copy of STATE with a new COND? value.
 118
 119 (define (tstate-new-cond? state cond?)
 120   (let ((result (tstate-copy state)))
 121     (tstate-set-cond?! result cond?)
 122     result)
 123 )
 124
 125 ; Create a copy of STATE with a new SET? value.
 126
 127 (define (tstate-new-set? state set?)
 128   (let ((result (tstate-copy state)))
 129     (tstate-set-set?! result set?)
 130     result)
 131 )
 132
 133 ; Lookup NAME in the known value table.  Returns the value or #f if not found.
 134
 135 (define (tstate-known-lookup tstate name)
 136   (let ((known (tstate-known tstate)))
 137     (assq-ref known name))
 138 )
 139
 140 ; Increment the recorded traversal depth of TSTATE.
 141
 142 (define (tstate-incr-depth! tstate)
 143   (tstate-set-depth! tstate (1+ (tstate-depth tstate)))
 144 )
 145
 146 ; Decrement the recorded traversal depth of TSTATE.
 147
 148 (define (tstate-decr-depth! tstate)
 149   (tstate-set-depth! tstate (1- (tstate-depth tstate)))
 150 )
 151
 152 ; Issue an error given a tstate.
 153
 154 (define (tstate-error tstate errmsg . expr)
 155   (apply context-owner-error
 156          (cons (tstate-context tstate)
 157                (cons (tstate-owner tstate)
 158                      (cons "During rtx traversal"
 159                            (cons errmsg expr)))))
 160 )
 161 \f
 162 ; Traversal/compilation support.
 163
 164 ; Return a boolean indicating if X is a mode.
 165
 166 (define (-rtx-any-mode? x)
 167   (->bool (mode:lookup x))
 168 )
 169
 170 ; Return a boolean indicating if X is a symbol or rtx.
 171
 172 (define (-rtx-symornum? x)
 173   (or (symbol? x) (number? x))
 174 )
 175
 176 ; Traverse a list of rtx's.
 177
 178 (define (-rtx-traverse-rtx-list rtx-list mode expr op-num tstate appstuff)
 179   (map (lambda (rtx)
 180          ; ??? Shouldn't OP-NUM change for each element?
 181          (-rtx-traverse rtx 'RTX mode expr op-num tstate appstuff))
 182        rtx-list)
 183 )
 184
 185 ; Cover-fn to tstate-error for signalling an error during rtx traversal
 186 ; of operand OP-NUM.
 187 ; RTL-EXPR must be an rtl expression.
 188
 189 (define (-rtx-traverse-error tstate errmsg rtl-expr op-num)
 190   (tstate-error tstate
 191                 (string-append errmsg ", operand #" (number->string op-num))
 192                 (rtx-strdump rtl-expr))
 193 )
 194
 195 ; Rtx traversers.
 196 ; These are defined as individual functions that are then built into a table
 197 ; so that we can use Hobbit's "fastcall" support.
 198 ;
 199 ; The result is either a pair of the parsed VAL and new TSTATE,
 200 ; or #f meaning there is no change (saves lots of unnecessarying cons'ing).
 201
 202 (define (-rtx-traverse-options val mode expr op-num tstate appstuff)
 203   #f
 204 )
 205
 206 (define (-rtx-traverse-anymode val mode expr op-num tstate appstuff)
 207   (let ((val-obj (mode:lookup val)))
 208     (if (not val-obj)
 209         (-rtx-traverse-error tstate "expecting a mode"
 210                              expr op-num))
 211     #f)
 212 )
 213
 214 (define (-rtx-traverse-intmode val mode expr op-num tstate appstuff)
 215   (let ((val-obj (mode:lookup val)))
 216     (if (and val-obj
 217              (or (memq (mode:class val-obj) '(INT UINT))
 218                  (eq? val 'DFLT)))
 219         #f
 220         (-rtx-traverse-error tstate "expecting an integer mode"
 221                              expr op-num)))
 222 )
 223
 224 (define (-rtx-traverse-floatmode val mode expr op-num tstate appstuff)
 225   (let ((val-obj (mode:lookup val)))
 226     (if (and val-obj
 227              (or (memq (mode:class val-obj) '(FLOAT))
 228                  (eq? val 'DFLT)))
 229         #f
 230         (-rtx-traverse-error tstate "expecting a float mode"
 231                              expr op-num)))
 232 )
 233
 234 (define (-rtx-traverse-nummode val mode expr op-num tstate appstuff)
 235   (let ((val-obj (mode:lookup val)))
 236     (if (and val-obj
 237              (or (memq (mode:class val-obj) '(INT UINT FLOAT))
 238                  (eq? val 'DFLT)))
 239         #f
 240         (-rtx-traverse-error tstate "expecting a numeric mode"
 241                              expr op-num)))
 242 )
 243
 244 (define (-rtx-traverse-explnummode val mode expr op-num tstate appstuff)
 245   (let ((val-obj (mode:lookup val)))
 246     (if (not val-obj)
 247         (-rtx-traverse-error tstate "expecting a mode"
 248                              expr op-num))
 249     (if (memq val '(DFLT VOID))
 250         (-rtx-traverse-error tstate "DFLT and VOID not allowed here"
 251                              expr op-num))
 252     #f)
 253 )
 254
 255 (define (-rtx-traverse-nonvoidmode val mode expr op-num tstate appstuff)
 256   (if (eq? val 'VOID)
 257       (-rtx-traverse-error tstate "mode can't be VOID"
 258                            expr op-num))
 259   #f
 260 )
 261
 262 (define (-rtx-traverse-voidmode val mode expr op-num tstate appstuff)
 263   (if (memq val '(DFLT VOID))
 264       #f
 265       (-rtx-traverse-error tstate "expecting mode VOID"
 266                            expr op-num))
 267 )
 268
 269 (define (-rtx-traverse-dfltmode val mode expr op-num tstate appstuff)
 270   (if (eq? val 'DFLT)
 271       #f
 272       (-rtx-traverse-error tstate "expecting mode DFLT"
 273                            expr op-num))
 274 )
 275
 276 (define (-rtx-traverse-rtx val mode expr op-num tstate appstuff)
 277 ; Commented out 'cus it doesn't quite work yet.
 278 ; (if (not (rtx? val))
 279 ;     (-rtx-traverse-error tstate "expecting an rtx"
 280 ;                          expr op-num))
 281   (cons (-rtx-traverse val 'RTX mode expr op-num tstate appstuff)
 282         tstate)
 283 )
 284
 285 (define (-rtx-traverse-setrtx val mode expr op-num tstate appstuff)
 286   ; FIXME: Still need to turn it off for sub-exprs.
 287   ; e.g. (mem (reg ...))
 288 ; Commented out 'cus it doesn't quite work yet.
 289 ; (if (not (rtx? val))
 290 ;     (-rtx-traverse-error tstate "expecting an rtx"
 291 ;                                 expr op-num))
 292   (cons (-rtx-traverse val 'SETRTX mode expr op-num
 293                        (tstate-new-set? tstate #t)
 294                        appstuff)
 295         tstate)
 296 )
 297
 298 ; This is the test of an `if'.
 299
 300 (define (-rtx-traverse-testrtx val mode expr op-num tstate appstuff)
 301 ; Commented out 'cus it doesn't quite work yet.
 302 ; (if (not (rtx? val))
 303 ;     (-rtx-traverse-error tstate "expecting an rtx"
 304 ;                                 expr op-num))
 305   (cons (-rtx-traverse val 'RTX mode expr op-num tstate appstuff)
 306         (tstate-new-cond?
 307          tstate
 308          (not (rtx-compile-time-constant? val))))
 309 )
 310
 311 (define (-rtx-traverse-condrtx val mode expr op-num tstate appstuff)
 312   (if (not (pair? val))
 313       (-rtx-traverse-error tstate "expecting an expression"
 314                            expr op-num))
 315   (if (eq? (car val) 'else)
 316       (begin
 317         (if (!= (+ op-num 2) (length expr))
 318             (-rtx-traverse-error tstate
 319                                  "`else' clause not last"
 320                                  expr op-num))
 321         (cons (cons 'else
 322                     (-rtx-traverse-rtx-list
 323                      (cdr val) mode expr op-num
 324                      (tstate-new-cond? tstate #t)
 325                      appstuff))
 326               (tstate-new-cond? tstate #t)))
 327       (cons (cons
 328              ; ??? Entries after the first are conditional.
 329              (-rtx-traverse (car val) 'RTX 'ANY expr op-num tstate appstuff)
 330              (-rtx-traverse-rtx-list
 331               (cdr val) mode expr op-num
 332               (tstate-new-cond? tstate #t)
 333               appstuff))
 334             (tstate-new-cond? tstate #t)))
 335 )
 336
 337 (define (-rtx-traverse-casertx val mode expr op-num tstate appstuff)
 338   (if (or (not (list? val))
 339           (< (length val) 2))
 340       (-rtx-traverse-error tstate
 341                            "invalid `case' expression"
 342                            expr op-num))
 343   ; car is either 'else or list of symbols/numbers
 344   (if (not (or (eq? (car val) 'else)
 345                (and (list? (car val))
 346                     (not (null? (car val)))
 347                     (all-true? (map -rtx-symornum?
 348                                     (car val))))))
 349       (-rtx-traverse-error tstate
 350                            "invalid `case' choice"
 351                            expr op-num))
 352   (if (and (eq? (car val) 'else)
 353            (!= (+ op-num 2) (length expr)))
 354       (-rtx-traverse-error tstate "`else' clause not last"
 355                            expr op-num))
 356   (cons (cons (car val)
 357               (-rtx-traverse-rtx-list
 358                (cdr val) mode expr op-num
 359                (tstate-new-cond? tstate #t)
 360                appstuff))
 361         (tstate-new-cond? tstate #t))
 362 )
 363
 364 (define (-rtx-traverse-locals val mode expr op-num tstate appstuff)
 365   (if (not (list? val))
 366       (-rtx-traverse-error tstate "bad locals list"
 367                            expr op-num))
 368   (for-each (lambda (var)
 369               (if (or (not (list? var))
 370                       (!= (length var) 2)
 371                       (not (-rtx-any-mode? (car var)))
 372                       (not (symbol? (cadr var))))
 373                   (-rtx-traverse-error tstate
 374                                        "bad locals list"
 375                                        expr op-num)))
 376             val)
 377   (let ((env (rtx-env-make-locals val)))
 378     (cons val (tstate-push-env tstate env)))
 379 )
 380
 381 (define (-rtx-traverse-env val mode expr op-num tstate appstuff)
 382   ; VAL is an environment stack.
 383   (if (not (list? val))
 384       (-rtx-traverse-error tstate "environment not a list"
 385                            expr op-num))
 386   (cons val (tstate-new-env tstate val))
 387 )
 388
 389 (define (-rtx-traverse-attrs val mode expr op-num tstate appstuff)
 390 ;  (cons val ; (atlist-source-form (atlist-parse (make-prefix-context "with-attr") val ""))
 391 ;       tstate)
 392   #f
 393 )
 394
 395 (define (-rtx-traverse-symbol val mode expr op-num tstate appstuff)
 396   (if (not (symbol? val))
 397       (-rtx-traverse-error tstate "expecting a symbol"
 398                            expr op-num))
 399   #f
 400 )
 401
 402 (define (-rtx-traverse-string val mode expr op-num tstate appstuff)
 403   (if (not (string? val))
 404       (-rtx-traverse-error tstate "expecting a string"
 405                            expr op-num))
 406   #f
 407 )
 408
 409 (define (-rtx-traverse-number val mode expr op-num tstate appstuff)
 410   (if (not (number? val))
 411       (-rtx-traverse-error tstate "expecting a number"
 412                            expr op-num))
 413   #f
 414 )
 415
 416 (define (-rtx-traverse-symornum val mode expr op-num tstate appstuff)
 417   (if (not (or (symbol? val) (number? val)))
 418       (-rtx-traverse-error tstate
 419                            "expecting a symbol or number"
 420                            expr op-num))
 421   #f
 422 )
 423
 424 (define (-rtx-traverse-object val mode expr op-num tstate appstuff)
 425   #f
 426 )
 427
 428 ; Table of rtx traversers.
 429 ; This is a vector of size rtx-max-num.
 430 ; Each entry is a list of (arg-type-name . traverser) elements
 431 ; for rtx-arg-types.
 432
 433 (define -rtx-traverser-table #f)
 434
 435 ; Return a hash table of standard operand traversers.
 436 ; The result of each traverser is a pair of the compiled form of `val' and
 437 ; a possibly new traversal state or #f if there is no change.
 438
 439 (define (-rtx-make-traverser-table)
 440   (let ((hash-tab (make-hash-table 31))
 441         (traversers
 442          (list
 443           ; /fastcall-make is recognized by Hobbit and handled specially.
 444           ; When not using Hobbit it is a macro that returns its argument.
 445           (cons 'OPTIONS (/fastcall-make -rtx-traverse-options))
 446           (cons 'ANYMODE (/fastcall-make -rtx-traverse-anymode))
 447           (cons 'INTMODE (/fastcall-make -rtx-traverse-intmode))
 448           (cons 'FLOATMODE (/fastcall-make -rtx-traverse-floatmode))
 449           (cons 'NUMMODE (/fastcall-make -rtx-traverse-nummode))
 450           (cons 'EXPLNUMMODE (/fastcall-make -rtx-traverse-explnummode))
 451           (cons 'NONVOIDMODE (/fastcall-make -rtx-traverse-nonvoidmode))
 452           (cons 'VOIDMODE (/fastcall-make -rtx-traverse-voidmode))
 453           (cons 'DFLTMODE (/fastcall-make -rtx-traverse-dfltmode))
 454           (cons 'RTX (/fastcall-make -rtx-traverse-rtx))
 455           (cons 'SETRTX (/fastcall-make -rtx-traverse-setrtx))
 456           (cons 'TESTRTX (/fastcall-make -rtx-traverse-testrtx))
 457           (cons 'CONDRTX (/fastcall-make -rtx-traverse-condrtx))
 458           (cons 'CASERTX (/fastcall-make -rtx-traverse-casertx))
 459           (cons 'LOCALS (/fastcall-make -rtx-traverse-locals))
 460           (cons 'ENV (/fastcall-make -rtx-traverse-env))
 461           (cons 'ATTRS (/fastcall-make -rtx-traverse-attrs))
 462           (cons 'SYMBOL (/fastcall-make -rtx-traverse-symbol))
 463           (cons 'STRING (/fastcall-make -rtx-traverse-string))
 464           (cons 'NUMBER (/fastcall-make -rtx-traverse-number))
 465           (cons 'SYMORNUM (/fastcall-make -rtx-traverse-symornum))
 466           (cons 'OBJECT (/fastcall-make -rtx-traverse-object))
 467           )))
 468
 469     (for-each (lambda (traverser)
 470                 (hashq-set! hash-tab (car traverser) (cdr traverser)))
 471               traversers)
 472
 473     hash-tab)
 474 )
 475
 476 ; Traverse the operands of EXPR, a canonicalized RTL expression.
 477 ; Here "canonicalized" means that -rtx-munge-mode&options has been called to
 478 ; insert an option list and mode if they were absent in the original
 479 ; expression.
 480 ; Note that this means that, yes, the options and mode are "traversed" too.
 481
 482 (define (-rtx-traverse-operands rtx-obj expr tstate appstuff)
 483   (if -rtx-traverse-debug?
 484       (begin
 485         (display (spaces (* 4 (tstate-depth tstate))))
 486         (display "Traversing operands of: ")
 487         (display (rtx-dump expr))
 488         (newline)
 489         (rtx-env-dump (tstate-env tstate))
 490         (force-output)
 491         ))
 492
 493   (let loop ((operands (cdr expr))
 494              (op-num 0)
 495              (arg-types (vector-ref -rtx-traverser-table (rtx-num rtx-obj)))
 496              (arg-modes (rtx-arg-modes rtx-obj))
 497              (result nil)
 498              )
 499
 500     (let ((varargs? (and (pair? arg-types) (symbol? (car arg-types)))))
 501
 502       (if -rtx-traverse-debug?
 503           (begin
 504             (display (spaces (* 4 (tstate-depth tstate))))
 505             (if (null? operands)
 506                 (display "end of operands")
 507                 (begin
 508                   (display "op-num ") (display op-num) (display ": ")
 509                   (display (rtx-dump (car operands)))
 510                   (display ", ")
 511                   (display (if varargs? (car arg-types) (caar arg-types)))
 512                   (display ", ")
 513                   (display (if varargs? arg-modes (car arg-modes)))
 514                   ))
 515             (newline)
 516             (force-output)
 517             ))
 518
 519       (cond ((null? operands)
 520              ; Out of operands, check if we have the expected number.
 521              (if (or (null? arg-types)
 522                      varargs?)
 523                  (reverse! result)
 524                  (tstate-error tstate "missing operands" (rtx-strdump expr))))
 525
 526             ((null? arg-types)
 527              (tstate-error tstate "too many operands" (rtx-strdump expr)))
 528
 529             (else
 530              (let ((type (if varargs? arg-types (car arg-types)))
 531                    (mode (let ((mode-spec (if varargs?
 532                                               arg-modes
 533                                               (car arg-modes))))
 534                            ; This is small enough that this is fast enough,
 535                            ; and the number of entries should be stable.
 536                            ; FIXME: for now
 537                            (case mode-spec
 538                              ((ANY) 'DFLT)
 539                              ((NA) #f)
 540                              ((OP0) (rtx-mode expr))
 541                              ((MATCH1)
 542                               ; If there is an explicit mode, use it.
 543                               ; Otherwise we have to look at operand 1.
 544                               (if (eq? (rtx-mode expr) 'DFLT)
 545                                   'DFLT
 546                                   (rtx-mode expr)))
 547                              ((MATCH2)
 548                               ; If there is an explicit mode, use it.
 549                               ; Otherwise we have to look at operand 2.
 550                               (if (eq? (rtx-mode expr) 'DFLT)
 551                                   'DFLT
 552                                   (rtx-mode expr)))
 553                              (else mode-spec))))
 554                    (val (car operands))
 555                    )
 556
 557                ; Look up the traverser for this kind of operand and perform it.
 558                (let ((traverser (cdr type)))
 559                  (let ((traversed-val (fastcall6 traverser val mode expr op-num tstate appstuff)))
 560                    (if traversed-val
 561                        (begin
 562                          (set! val (car traversed-val))
 563                          (set! tstate (cdr traversed-val))))))
 564
 565                ; Done with this operand, proceed to the next.
 566                (loop (cdr operands)
 567                      (+ op-num 1)
 568                      (if varargs? arg-types (cdr arg-types))
 569                      (if varargs? arg-modes (cdr arg-modes))
 570                      (cons val result)))))))
 571 )
 572
 573 ; Publically accessible version of -rtx-traverse-operands as EXPR-FN may
 574 ; need to call it.
 575
 576 (define rtx-traverse-operands -rtx-traverse-operands)
 577
 578 ; Subroutine of -rtx-munge-mode&options.
 579 ; Return boolean indicating if X is an rtx option.
 580
 581 (define (-rtx-option? x)
 582   (and (symbol? x)
 583        (char=? (string-ref (symbol->string x) 0) #\:))
 584 )
 585
 586 ; Subroutine of -rtx-munge-mode&options.
 587 ; Return boolean indicating if X is an rtx option list.
 588
 589 (define (-rtx-option-list? x)
 590   (or (null? x)
 591       (and (pair? x)
 592            (-rtx-option? (car x))))
 593 )
 594
 595 ; Subroutine of -rtx-traverse-expr to fill in the mode if absent and to
 596 ; collect the options into one list.
 597 ;
 598 ; ARGS is the list of arguments to the rtx function
 599 ; (e.g. (1 2) in (add 1 2)).
 600 ; ??? "munge" is an awkward name to use here, but I like it for now because
 601 ; it's easy to grep for.
 602 ; ??? An empty option list requires a mode to be present so that the empty
 603 ; list in `(sequence () foo bar)' is unambiguously recognized as the locals
 604 ; list.  Icky, sure, but less icky than the alternatives thus far.
 605
 606 (define (-rtx-munge-mode&options args)
 607   (let ((options nil)
 608         (mode-name 'DFLT))
 609     ; Pick off the option list if present.
 610     (if (and (pair? args)
 611              (-rtx-option-list? (car args))
 612              ; Handle `(sequence () foo bar)'.  If empty list isn't followed
 613              ; by a mode, it is not an option list.
 614              (or (not (null? (car args)))
 615                  (and (pair? (cdr args))
 616                       (mode-name? (cadr args)))))
 617         (begin
 618           (set! options (car args))
 619           (set! args (cdr args))))
 620     ; Pick off the mode if present.
 621     (if (and (pair? args)
 622              (mode-name? (car args)))
 623         (begin
 624           (set! mode-name (car args))
 625           (set! args (cdr args))))
 626     ; Now put option list and mode back.
 627     (cons options (cons mode-name args)))
 628 )
 629
 630 ; Subroutine of -rtx-traverse to traverse an expression.
 631 ;
 632 ; RTX-OBJ is the <rtx-func> object of the (outer) expression being traversed.
 633 ;
 634 ; EXPR is the expression to be traversed.
 635 ;
 636 ; MODE is the name of the mode of EXPR.
 637 ;
 638 ; PARENT-EXPR is the expression EXPR is contained in.  The top-level
 639 ; caller must pass #f for it.
 640 ;
 641 ; OP-POS is the position EXPR appears in PARENT-EXPR.  The
 642 ; top-level caller must pass 0 for it.
 643 ;
 644 ; TSTATE is the current traversal state.
 645 ;
 646 ; APPSTUFF is for application specific use.
 647 ;
 648 ; For syntax expressions arguments are not pre-evaluated before calling the
 649 ; user's expression handler.  Otherwise they are.
 650 ;
 651 ; If (tstate-expr-fn TSTATE) wants to just scan the operands, rather than
 652 ; evaluating them, one thing it can do is call back to rtx-traverse-operands.
 653 ; If (tstate-expr-fn TSTATE) returns #f, traverse the operands normally and
 654 ; return (rtx's-name ([options]) mode traversed-operand1 ...),
 655 ; i.e., the canonicalized form.
 656 ; This is for semantic-compile's sake and all traversal handlers are
 657 ; required to do this if the expr-fn returns #f.
 658
 659 (define (-rtx-traverse-expr rtx-obj expr mode parent-expr op-pos tstate appstuff)
 660   (let* ((expr2 (cons (car expr)
 661                       (-rtx-munge-mode&options (cdr expr))))
 662          (fn (fastcall7 (tstate-expr-fn tstate)
 663                         rtx-obj expr2 mode parent-expr op-pos tstate appstuff)))
 664     (if fn
 665         (if (procedure? fn)
 666             ; Don't traverse operands for syntax expressions.
 667             (if (rtx-style-syntax? rtx-obj)
 668                 (apply fn (cons tstate (cdr expr2)))
 669                 (let ((operands (-rtx-traverse-operands rtx-obj expr2 tstate appstuff)))
 670                   (apply fn (cons tstate operands))))
 671             fn)
 672         (let ((operands (-rtx-traverse-operands rtx-obj expr2 tstate appstuff)))
 673           (cons (car expr2) operands))))
 674 )
 675
 676 ; Main entry point for expression traversal.
 677 ; (Actually rtx-traverse is, but it's just a cover function for this.)
 678 ;
 679 ; The result is the result of the lambda (tstate-expr-fn TSTATE) looks up
 680 ; in the case of expressions, or an operand object (usually <operand>)
 681 ; in the case of operands.
 682 ;
 683 ; EXPR is the expression to be traversed.
 684 ;
 685 ; EXPECTED is one of `-rtx-valid-types' and indicates the expected rtx type
 686 ; or #f if it doesn't matter.
 687 ;
 688 ; MODE is the name of the mode of EXPR.
 689 ;
 690 ; PARENT-EXPR is the expression EXPR is contained in.  The top-level
 691 ; caller must pass #f for it.
 692 ;
 693 ; OP-POS is the position EXPR appears in PARENT-EXPR.  The
 694 ; top-level caller must pass 0 for it.
 695 ;
 696 ; TSTATE is the current traversal state.
 697 ;
 698 ; APPSTUFF is for application specific use.
 699 ;
 700 ; All macros are expanded here.  User code never sees them.
 701 ; All operand shortcuts are also expand here.  User code never sees them.
 702 ; These are:
 703 ; - operands, ifields, and numbers appearing where an rtx is expected are
 704 ;   converted to use `operand', `ifield', or `const'.
 705
 706 (define (-rtx-traverse expr expected mode parent-expr op-pos tstate appstuff)
 707   (if -rtx-traverse-debug?
 708       (begin
 709         (display (spaces (* 4 (tstate-depth tstate))))
 710         (display "Traversing expr: ")
 711         (display expr)
 712         (newline)
 713         (display (spaces (* 4 (tstate-depth tstate))))
 714         (display "-expected:       ")
 715         (display expected)
 716         (newline)
 717         (display (spaces (* 4 (tstate-depth tstate))))
 718         (display "-mode:           ")
 719         (display mode)
 720         (newline)
 721         (force-output)
 722         ))
 723
 724   (if (pair? expr) ; pair? -> cheap non-null-list?
 725
 726       (let ((rtx-obj (rtx-lookup (car expr))))
 727         (tstate-incr-depth! tstate)
 728         (let ((result
 729                (if rtx-obj
 730                    (-rtx-traverse-expr rtx-obj expr mode parent-expr op-pos tstate appstuff)
 731                    (let ((rtx-obj (-rtx-macro-lookup (car expr))))
 732                      (if rtx-obj
 733                          (-rtx-traverse (-rtx-macro-expand expr rtx-evaluator)
 734                                         expected mode parent-expr op-pos tstate appstuff)
 735                          (tstate-error tstate "unknown rtx function" expr))))))
 736           (tstate-decr-depth! tstate)
 737           result))
 738
 739       ; EXPR is not a list.
 740       ; See if it's an operand shortcut.
 741       (if (memq expected '(RTX SETRTX))
 742
 743           (cond ((symbol? expr)
 744                  (cond ((current-op-lookup expr)
 745                         (-rtx-traverse
 746                          (rtx-make-operand expr) ; (current-op-lookup expr))
 747                          expected mode parent-expr op-pos tstate appstuff))
 748                        ((rtx-temp-lookup (tstate-env tstate) expr)
 749                         (-rtx-traverse
 750                          (rtx-make-local expr) ; (rtx-temp-lookup (tstate-env tstate) expr))
 751                          expected mode parent-expr op-pos tstate appstuff))
 752                        ((current-ifld-lookup expr)
 753                         (-rtx-traverse
 754                          (rtx-make-ifield expr)
 755                          expected mode parent-expr op-pos tstate appstuff))
 756                        ((enum-lookup-val expr)
 757                         ;; ??? If enums could have modes other than INT,
 758                         ;; we'd want to propagate that mode here.
 759                         (-rtx-traverse
 760                          (rtx-make-enum 'INT expr)
 761                          expected mode parent-expr op-pos tstate appstuff))
 762                        (else
 763                         (tstate-error tstate "unknown operand" expr))))
 764                 ((integer? expr)
 765                  (-rtx-traverse (rtx-make-const 'INT expr)
 766                                 expected mode parent-expr op-pos tstate appstuff))
 767                 (else
 768                  (tstate-error tstate "unexpected operand" expr)))
 769
 770           ; Not expecting RTX or SETRTX.
 771           (tstate-error tstate "unexpected operand" expr)))
 772 )
 773
 774 ; User visible procedures to traverse an rtl expression.
 775 ; These calls -rtx-traverse to do most of the work.
 776 ; See tstate-make for explanations of OWNER, EXPR-FN.
 777 ; CONTEXT is a <context> object or #f if there is none.
 778 ; LOCALS is a list of (mode . name) elements (the locals arg to `sequence').
 779 ; APPSTUFF is for application specific use.
 780
 781 (define (rtx-traverse context owner expr expr-fn appstuff)
 782   (-rtx-traverse expr #f 'DFLT #f 0
 783                  (tstate-make context owner expr-fn (rtx-env-empty-stack)
 784                               #f #f nil 0)
 785                  appstuff)
 786 )
 787
 788 (define (rtx-traverse-with-locals context owner expr expr-fn locals appstuff)
 789   (-rtx-traverse expr #f 'DFLT #f 0
 790                  (tstate-make context owner expr-fn
 791                               (rtx-env-push (rtx-env-empty-stack)
 792                                             (rtx-env-make-locals locals))
 793                               #f #f nil 0)
 794                  appstuff)
 795 )
 796
 797 ; Traverser debugger.
 798
 799 (define (rtx-traverse-debug expr)
 800   (rtx-traverse
 801    #f #f expr
 802    (lambda (rtx-obj expr mode parent-expr op-pos tstate appstuff)
 803      (display "-expr:    ")
 804      (display (string-append "rtx=" (obj:str-name rtx-obj)))
 805      (display " expr=")
 806      (display expr)
 807      (display " mode=")
 808      (display mode)
 809      (display " parent=")
 810      (display parent-expr)
 811      (display " op-pos=")
 812      (display op-pos)
 813      (display " cond?=")
 814      (display (tstate-cond? tstate))
 815      (newline)
 816      #f)
 817    #f
 818    )
 819 )
 820 \f
 821 ; RTL evaluation state.
 822 ; Applications may subclass <eval-state> if they need to add things.
 823 ;
 824 ; This is initialized before evaluation, and modified (in a copy) as the
 825 ; evaluation state changes.
 826 ; This doesn't record all evaluation state, just the less dynamic elements.
 827 ; There's no point in recording things like the parent expression and operand
 828 ; position as they change for every sub-eval.
 829 ; The main raison d'etre for this class is so we can add more state without
 830 ; having to modify all the eval handlers.
 831
 832 (define <eval-state>
 833   (class-make '<eval-state> nil
 834               '(
 835                 ; <context> object or #f if there is none
 836                 (context . #f)
 837
 838                 ; Current object rtl is being evaluated for.
 839                 ; We need to be able to access the current instruction while
 840                 ; generating semantic code.  However, the semantic description
 841                 ; doesn't specify it as an argument to anything (and we don't
 842                 ; want it to).  So we record the value here.
 843                 (owner . #f)
 844
 845                 ; EXPR-FN is a dual-purpose beast.  The first purpose is to
 846                 ; just process the current expression and return the result.
 847                 ; The second purpose is to lookup the function which will then
 848                 ; process the expression.  It is applied recursively to the
 849                 ; expression and each sub-expression.  It must be defined as
 850                 ; (lambda (rtx-obj expr mode estate) ...).
 851                 ; If the result of EXPR-FN is a lambda, it is applied to
 852                 ; (cons ESTATE (cdr EXPR)).  ESTATE is prepended to the
 853                 ; arguments.
 854                 ; For syntax expressions if the result of EXPR-FN is #f,
 855                 ; the operands are processed using the builtin evaluator.
 856                 ; FIXME: This special handling of syntax expressions is
 857                 ; not currently done.
 858                 ; So to repeat: EXPR-FN can process the expression, and if its
 859                 ; result is a lambda then it also processes the expression.
 860                 ; The arguments to EXPR-FN are
 861                 ; (rtx-obj expr mode estate).
 862                 ; The arguments to the result of EXPR-FN are
 863                 ; (cons ESTATE (cdr EXPR)).
 864                 ; The reason for the duality is mostly history.
 865                 ; In time things should be simplified.
 866                 (expr-fn . #f)
 867
 868                 ; Current environment.  This is a stack of sequence locals.
 869                 (env . ())
 870
 871                 ; Current evaluation depth.  This is used, for example, to
 872                 ; control indentation in generated output.
 873                 (depth . 0)
 874
 875                 ; Associative list of modifiers.
 876                 ; This is here to support things like `delay'.
 877                 (modifiers . ())
 878                 )
 879               nil)
 880 )
 881
 882 ; Create an <eval-state> object using a list of keyword/value elements.
 883 ; ARGS is a list of #:keyword/value elements.
 884 ; The result is a list of the unrecognized elements.
 885 ; Subclasses should override this method and send-next it first, then
 886 ; see if they recognize anything in the result, returning what isn't
 887 ; recognized.
 888
 889 (method-make!
 890  <eval-state> 'vmake!
 891  (lambda (self args)
 892    (let loop ((args args) (unrecognized nil))
 893      (if (null? args)
 894          (reverse! unrecognized) ; ??? Could invoke method to initialize here.
 895          (begin
 896            (case (car args)
 897              ((#:context)
 898               (elm-set! self 'context (cadr args)))
 899              ((#:owner)
 900               (elm-set! self 'owner (cadr args)))
 901              ((#:expr-fn)
 902               (elm-set! self 'expr-fn (cadr args)))
 903              ((#:env)
 904               (elm-set! self 'env (cadr args)))
 905              ((#:depth)
 906               (elm-set! self 'depth (cadr args)))
 907              ((#:modifiers)
 908               (elm-set! self 'modifiers (cadr args)))
 909              (else
 910               ; Build in reverse order, as we reverse it back when we're done.
 911               (set! unrecognized
 912                     (cons (cadr args) (cons (car args) unrecognized)))))
 913            (loop (cddr args) unrecognized)))))
 914 )
 915
 916 ; Accessors.
 917
 918 (define-getters <eval-state> estate
 919   (context owner expr-fn env depth modifiers)
 920 )
 921 (define-setters <eval-state> estate
 922   (context owner expr-fn env depth modifiers)
 923 )
 924
 925 ; Build an estate for use in producing a value from rtl.
 926 ; CONTEXT is a <context> object or #f if there is none.
 927 ; OWNER is the owner of the expression or #f if there is none.
 928
 929 (define (estate-make-for-eval context owner)
 930   (vmake <eval-state>
 931          #:context context
 932          #:owner owner
 933          #:expr-fn (lambda (rtx-obj expr mode estate)
 934                      (rtx-evaluator rtx-obj)))
 935 )
 936
 937 ; Create a copy of ESTATE.
 938
 939 (define (estate-copy estate)
 940   (object-copy-top estate)
 941 )
 942
 943 ; Create a copy of ESTATE with a new environment ENV.
 944
 945 (define (estate-new-env estate env)
 946   (let ((result (estate-copy estate)))
 947     (estate-set-env! result env)
 948     result)
 949 )
 950
 951 ; Create a copy of ESTATE with environment ENV pushed onto the existing
 952 ; environment list.
 953 ; There's no routine to pop the environment list as there's no current
 954 ; need for it: we make a copy of the state when we push.
 955
 956 (define (estate-push-env estate env)
 957   (let ((result (estate-copy estate)))
 958     (estate-set-env! result (cons env (estate-env result)))
 959     result)
 960 )
 961
 962 ; Create a copy of ESTATE with the depth incremented by one.
 963
 964 (define (estate-deepen estate)
 965   (let ((result (estate-copy estate)))
 966     (estate-set-depth! result (1+ (estate-depth estate)))
 967     result)
 968 )
 969
 970 ; Create a copy of ESTATE with modifiers MODS.
 971
 972 (define (estate-with-modifiers estate mods)
 973   (let ((result (estate-copy estate)))
 974     (estate-set-modifiers! result (append mods (estate-modifiers result)))
 975     result)
 976 )
 977
 978 ; Convert a tstate to an estate.
 979
 980 (define (tstate->estate t)
 981   (vmake <eval-state>
 982          #:context (tstate-context t)
 983          #:env (tstate-env t))
 984 )
 985
 986 ; Issue an error given an estate.
 987
 988 (define (estate-error estate errmsg . expr)
 989   (apply context-owner-error
 990          (cons (estate-context estate)
 991                (cons (estate-owner estate)
 992                      (cons "During rtx evalution"
 993                            (cons errmsg expr)))))
 994 )
 995 \f
 996 ; RTL expression evaluation.
 997 ;
 998 ; ??? These used eval2 at one point.  Not sure which is faster but I suspect
 999 ; eval2 is by far.  On the otherhand this has yet to be compiled.  And this way
1000 ; is more portable, more flexible, and works with guile 1.2 (which has
1001 ; problems with eval'ing self referential vectors, though that's one reason to
1002 ; use smobs).
1003
1004 ; Set to #t to debug rtx evaluation.
1005
1006 (define -rtx-eval-debug? #f)
1007
1008 ; RTX expression evaluator.
1009 ;
1010 ; EXPR is the expression to be eval'd.  It must be in compiled form.
1011 ; MODE is the mode of EXPR, a <mode> object or its name.
1012 ; ESTATE is the current evaluation state.
1013
1014 (define (rtx-eval-with-estate expr mode estate)
1015   (if -rtx-eval-debug?
1016       (begin
1017         (display "Traversing ")
1018         (display expr)
1019         (newline)
1020         (rtx-env-dump (estate-env estate))
1021         ))
1022
1023   (if (pair? expr) ; pair? -> cheap non-null-list?
1024
1025       (let* ((rtx-obj (rtx-lookup (car expr)))
1026              (fn ((estate-expr-fn estate) rtx-obj expr mode estate)))
1027         (if fn
1028             (if (procedure? fn)
1029                 (apply fn (cons estate (cdr expr)))
1030 ;               ; Don't eval operands for syntax expressions.
1031 ;               (if (rtx-style-syntax? rtx-obj)
1032 ;                   (apply fn (cons estate (cdr expr)))
1033 ;                   (let ((operands
1034 ;                          (-rtx-eval-operands rtx-obj expr estate)))
1035 ;                     (apply fn (cons estate operands))))
1036                 fn)
1037             ; Leave expr unchanged.
1038             expr))
1039 ;           (let ((operands
1040 ;                  (-rtx-traverse-operands rtx-obj expr estate)))
1041 ;             (cons rtx-obj operands))))
1042
1043       ; EXPR is not a list
1044       (error "argument to rtx-eval-with-estate is not a list" expr))
1045 )
1046
1047 ; Evaluate rtx expression EXPR and return the computed value.
1048 ; EXPR must already be in compiled form (the result of rtx-compile).
1049 ; OWNER is the owner of the value, used for attribute computation,
1050 ; or #f if there isn't one.
1051 ; FIXME: context?
1052
1053 (define (rtx-value expr owner)
1054   (rtx-eval-with-estate expr 'DFLT (estate-make-for-eval #f owner))
1055 )