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-iteration val mode expr op-num tstate appstuff)
 382   (if (not (symbol? val))
 383       (-rtx-traverse-error tstate "bad iteration variable name"
 384                            expr op-num))
 385   (let ((env (rtx-env-make-iteration-locals val)))
 386     (cons val (tstate-push-env tstate env)))
 387 )
 388
 389 (define (-rtx-traverse-env val mode expr op-num tstate appstuff)
 390   ; VAL is an environment stack.
 391   (if (not (list? val))
 392       (-rtx-traverse-error tstate "environment not a list"
 393                            expr op-num))
 394   (cons val (tstate-new-env tstate val))
 395 )
 396
 397 (define (-rtx-traverse-attrs val mode expr op-num tstate appstuff)
 398 ;  (cons val ; (atlist-source-form (atlist-parse (make-prefix-context "with-attr") val ""))
 399 ;       tstate)
 400   #f
 401 )
 402
 403 (define (-rtx-traverse-symbol val mode expr op-num tstate appstuff)
 404   (if (not (symbol? val))
 405       (-rtx-traverse-error tstate "expecting a symbol"
 406                            expr op-num))
 407   #f
 408 )
 409
 410 (define (-rtx-traverse-string val mode expr op-num tstate appstuff)
 411   (if (not (string? val))
 412       (-rtx-traverse-error tstate "expecting a string"
 413                            expr op-num))
 414   #f
 415 )
 416
 417 (define (-rtx-traverse-number val mode expr op-num tstate appstuff)
 418   (if (not (number? val))
 419       (-rtx-traverse-error tstate "expecting a number"
 420                            expr op-num))
 421   #f
 422 )
 423
 424 (define (-rtx-traverse-symornum val mode expr op-num tstate appstuff)
 425   (if (not (or (symbol? val) (number? val)))
 426       (-rtx-traverse-error tstate
 427                            "expecting a symbol or number"
 428                            expr op-num))
 429   #f
 430 )
 431
 432 (define (-rtx-traverse-object val mode expr op-num tstate appstuff)
 433   #f
 434 )
 435
 436 ; Table of rtx traversers.
 437 ; This is a vector of size rtx-max-num.
 438 ; Each entry is a list of (arg-type-name . traverser) elements
 439 ; for rtx-arg-types.
 440
 441 (define -rtx-traverser-table #f)
 442
 443 ; Return a hash table of standard operand traversers.
 444 ; The result of each traverser is a pair of the compiled form of `val' and
 445 ; a possibly new traversal state or #f if there is no change.
 446
 447 (define (-rtx-make-traverser-table)
 448   (let ((hash-tab (make-hash-table 31))
 449         (traversers
 450          (list
 451           ; /fastcall-make is recognized by Hobbit and handled specially.
 452           ; When not using Hobbit it is a macro that returns its argument.
 453           (cons 'OPTIONS (/fastcall-make -rtx-traverse-options))
 454           (cons 'ANYMODE (/fastcall-make -rtx-traverse-anymode))
 455           (cons 'INTMODE (/fastcall-make -rtx-traverse-intmode))
 456           (cons 'FLOATMODE (/fastcall-make -rtx-traverse-floatmode))
 457           (cons 'NUMMODE (/fastcall-make -rtx-traverse-nummode))
 458           (cons 'EXPLNUMMODE (/fastcall-make -rtx-traverse-explnummode))
 459           (cons 'NONVOIDMODE (/fastcall-make -rtx-traverse-nonvoidmode))
 460           (cons 'VOIDMODE (/fastcall-make -rtx-traverse-voidmode))
 461           (cons 'DFLTMODE (/fastcall-make -rtx-traverse-dfltmode))
 462           (cons 'RTX (/fastcall-make -rtx-traverse-rtx))
 463           (cons 'SETRTX (/fastcall-make -rtx-traverse-setrtx))
 464           (cons 'TESTRTX (/fastcall-make -rtx-traverse-testrtx))
 465           (cons 'CONDRTX (/fastcall-make -rtx-traverse-condrtx))
 466           (cons 'CASERTX (/fastcall-make -rtx-traverse-casertx))
 467           (cons 'LOCALS (/fastcall-make -rtx-traverse-locals))
 468           (cons 'ITERATION (/fastcall-make -rtx-traverse-iteration))
 469           (cons 'ENV (/fastcall-make -rtx-traverse-env))
 470           (cons 'ATTRS (/fastcall-make -rtx-traverse-attrs))
 471           (cons 'SYMBOL (/fastcall-make -rtx-traverse-symbol))
 472           (cons 'STRING (/fastcall-make -rtx-traverse-string))
 473           (cons 'NUMBER (/fastcall-make -rtx-traverse-number))
 474           (cons 'SYMORNUM (/fastcall-make -rtx-traverse-symornum))
 475           (cons 'OBJECT (/fastcall-make -rtx-traverse-object))
 476           )))
 477
 478     (for-each (lambda (traverser)
 479                 (hashq-set! hash-tab (car traverser) (cdr traverser)))
 480               traversers)
 481
 482     hash-tab)
 483 )
 484
 485 ; Traverse the operands of EXPR, a canonicalized RTL expression.
 486 ; Here "canonicalized" means that -rtx-munge-mode&options has been called to
 487 ; insert an option list and mode if they were absent in the original
 488 ; expression.
 489 ; Note that this means that, yes, the options and mode are "traversed" too.
 490
 491 (define (-rtx-traverse-operands rtx-obj expr tstate appstuff)
 492   (if -rtx-traverse-debug?
 493       (begin
 494         (display (spaces (* 4 (tstate-depth tstate))))
 495         (display "Traversing operands of: ")
 496         (display (rtx-dump expr))
 497         (newline)
 498         (rtx-env-dump (tstate-env tstate))
 499         (force-output)
 500         ))
 501
 502   (let loop ((operands (cdr expr))
 503              (op-num 0)
 504              (arg-types (vector-ref -rtx-traverser-table (rtx-num rtx-obj)))
 505              (arg-modes (rtx-arg-modes rtx-obj))
 506              (result nil)
 507              )
 508
 509     (let ((varargs? (and (pair? arg-types) (symbol? (car arg-types)))))
 510
 511       (if -rtx-traverse-debug?
 512           (begin
 513             (display (spaces (* 4 (tstate-depth tstate))))
 514             (if (null? operands)
 515                 (display "end of operands")
 516                 (begin
 517                   (display "op-num ") (display op-num) (display ": ")
 518                   (display (rtx-dump (car operands)))
 519                   (display ", ")
 520                   (display (if varargs? (car arg-types) (caar arg-types)))
 521                   (display ", ")
 522                   (display (if varargs? arg-modes (car arg-modes)))
 523                   ))
 524             (newline)
 525             (force-output)
 526             ))
 527
 528       (cond ((null? operands)
 529              ; Out of operands, check if we have the expected number.
 530              (if (or (null? arg-types)
 531                      varargs?)
 532                  (reverse! result)
 533                  (tstate-error tstate "missing operands" (rtx-strdump expr))))
 534
 535             ((null? arg-types)
 536              (tstate-error tstate "too many operands" (rtx-strdump expr)))
 537
 538             (else
 539              (let ((type (if varargs? arg-types (car arg-types)))
 540                    (mode (let ((mode-spec (if varargs?
 541                                               arg-modes
 542                                               (car arg-modes))))
 543                            ; This is small enough that this is fast enough,
 544                            ; and the number of entries should be stable.
 545                            ; FIXME: for now
 546                            (case mode-spec
 547                              ((ANY) 'DFLT)
 548                              ((NA) #f)
 549                              ((OP0) (rtx-mode expr))
 550                              ((MATCH1)
 551                               ; If there is an explicit mode, use it.
 552                               ; Otherwise we have to look at operand 1.
 553                               (if (eq? (rtx-mode expr) 'DFLT)
 554                                   'DFLT
 555                                   (rtx-mode expr)))
 556                              ((MATCH2)
 557                               ; If there is an explicit mode, use it.
 558                               ; Otherwise we have to look at operand 2.
 559                               (if (eq? (rtx-mode expr) 'DFLT)
 560                                   'DFLT
 561                                   (rtx-mode expr)))
 562                              (else mode-spec))))
 563                    (val (car operands))
 564                    )
 565
 566                ; Look up the traverser for this kind of operand and perform it.
 567                (let ((traverser (cdr type)))
 568                  (let ((traversed-val (fastcall6 traverser val mode expr op-num tstate appstuff)))
 569                    (if traversed-val
 570                        (begin
 571                          (set! val (car traversed-val))
 572                          (set! tstate (cdr traversed-val))))))
 573
 574                ; Done with this operand, proceed to the next.
 575                (loop (cdr operands)
 576                      (+ op-num 1)
 577                      (if varargs? arg-types (cdr arg-types))
 578                      (if varargs? arg-modes (cdr arg-modes))
 579                      (cons val result)))))))
 580 )
 581
 582 ; Publically accessible version of -rtx-traverse-operands as EXPR-FN may
 583 ; need to call it.
 584
 585 (define rtx-traverse-operands -rtx-traverse-operands)
 586
 587 ; Subroutine of -rtx-munge-mode&options.
 588 ; Return boolean indicating if X is an rtx option.
 589
 590 (define (-rtx-option? x)
 591   (and (symbol? x)
 592        (char=? (string-ref (symbol->string x) 0) #\:))
 593 )
 594
 595 ; Subroutine of -rtx-munge-mode&options.
 596 ; Return boolean indicating if X is an rtx option list.
 597
 598 (define (-rtx-option-list? x)
 599   (or (null? x)
 600       (and (pair? x)
 601            (-rtx-option? (car x))))
 602 )
 603
 604 ; Subroutine of -rtx-traverse-expr to fill in the mode if absent and to
 605 ; collect the options into one list.
 606 ;
 607 ; ARGS is the list of arguments to the rtx function
 608 ; (e.g. (1 2) in (add 1 2)).
 609 ; ??? "munge" is an awkward name to use here, but I like it for now because
 610 ; it's easy to grep for.
 611 ; ??? An empty option list requires a mode to be present so that the empty
 612 ; list in `(sequence () foo bar)' is unambiguously recognized as the locals
 613 ; list.  Icky, sure, but less icky than the alternatives thus far.
 614
 615 (define (-rtx-munge-mode&options args)
 616   (let ((options nil)
 617         (mode-name 'DFLT))
 618     ; Pick off the option list if present.
 619     (if (and (pair? args)
 620              (-rtx-option-list? (car args))
 621              ; Handle `(sequence () foo bar)'.  If empty list isn't followed
 622              ; by a mode, it is not an option list.
 623              (or (not (null? (car args)))
 624                  (and (pair? (cdr args))
 625                       (mode-name? (cadr args)))))
 626         (begin
 627           (set! options (car args))
 628           (set! args (cdr args))))
 629     ; Pick off the mode if present.
 630     (if (and (pair? args)
 631              (mode-name? (car args)))
 632         (begin
 633           (set! mode-name (car args))
 634           (set! args (cdr args))))
 635     ; Now put option list and mode back.
 636     (cons options (cons mode-name args)))
 637 )
 638
 639 ; Subroutine of -rtx-traverse to traverse an expression.
 640 ;
 641 ; RTX-OBJ is the <rtx-func> object of the (outer) expression being traversed.
 642 ;
 643 ; EXPR is the expression to be traversed.
 644 ;
 645 ; MODE is the name of the mode of EXPR.
 646 ;
 647 ; PARENT-EXPR is the expression EXPR is contained in.  The top-level
 648 ; caller must pass #f for it.
 649 ;
 650 ; OP-POS is the position EXPR appears in PARENT-EXPR.  The
 651 ; top-level caller must pass 0 for it.
 652 ;
 653 ; TSTATE is the current traversal state.
 654 ;
 655 ; APPSTUFF is for application specific use.
 656 ;
 657 ; For syntax expressions arguments are not pre-evaluated before calling the
 658 ; user's expression handler.  Otherwise they are.
 659 ;
 660 ; If (tstate-expr-fn TSTATE) wants to just scan the operands, rather than
 661 ; evaluating them, one thing it can do is call back to rtx-traverse-operands.
 662 ; If (tstate-expr-fn TSTATE) returns #f, traverse the operands normally and
 663 ; return (rtx's-name ([options]) mode traversed-operand1 ...),
 664 ; i.e., the canonicalized form.
 665 ; This is for semantic-compile's sake and all traversal handlers are
 666 ; required to do this if the expr-fn returns #f.
 667
 668 (define (-rtx-traverse-expr rtx-obj expr mode parent-expr op-pos tstate appstuff)
 669   (let* ((expr2 (cons (car expr)
 670                       (-rtx-munge-mode&options (cdr expr))))
 671          (fn (fastcall7 (tstate-expr-fn tstate)
 672                         rtx-obj expr2 mode parent-expr op-pos tstate appstuff)))
 673     (if fn
 674         (if (procedure? fn)
 675             ; Don't traverse operands for syntax expressions.
 676             (if (rtx-style-syntax? rtx-obj)
 677                 (apply fn (cons tstate (cdr expr2)))
 678                 (let ((operands (-rtx-traverse-operands rtx-obj expr2 tstate appstuff)))
 679                   (apply fn (cons tstate operands))))
 680             fn)
 681         (let ((operands (-rtx-traverse-operands rtx-obj expr2 tstate appstuff)))
 682           (cons (car expr2) operands))))
 683 )
 684
 685 ; Main entry point for expression traversal.
 686 ; (Actually rtx-traverse is, but it's just a cover function for this.)
 687 ;
 688 ; The result is the result of the lambda (tstate-expr-fn TSTATE) looks up
 689 ; in the case of expressions, or an operand object (usually <operand>)
 690 ; in the case of operands.
 691 ;
 692 ; EXPR is the expression to be traversed.
 693 ;
 694 ; EXPECTED is one of `-rtx-valid-types' and indicates the expected rtx type
 695 ; or #f if it doesn't matter.
 696 ;
 697 ; MODE is the name of the mode of EXPR.
 698 ;
 699 ; PARENT-EXPR is the expression EXPR is contained in.  The top-level
 700 ; caller must pass #f for it.
 701 ;
 702 ; OP-POS is the position EXPR appears in PARENT-EXPR.  The
 703 ; top-level caller must pass 0 for it.
 704 ;
 705 ; TSTATE is the current traversal state.
 706 ;
 707 ; APPSTUFF is for application specific use.
 708 ;
 709 ; All macros are expanded here.  User code never sees them.
 710 ; All operand shortcuts are also expand here.  User code never sees them.
 711 ; These are:
 712 ; - operands, ifields, and numbers appearing where an rtx is expected are
 713 ;   converted to use `operand', `ifield', or `const'.
 714
 715 (define (-rtx-traverse expr expected mode parent-expr op-pos tstate appstuff)
 716   (if -rtx-traverse-debug?
 717       (begin
 718         (display (spaces (* 4 (tstate-depth tstate))))
 719         (display "Traversing expr: ")
 720         (display expr)
 721         (newline)
 722         (display (spaces (* 4 (tstate-depth tstate))))
 723         (display "-expected:       ")
 724         (display expected)
 725         (newline)
 726         (display (spaces (* 4 (tstate-depth tstate))))
 727         (display "-mode:           ")
 728         (display mode)
 729         (newline)
 730         (force-output)
 731         ))
 732
 733   (if (pair? expr) ; pair? -> cheap non-null-list?
 734
 735       (let ((rtx-obj (rtx-lookup (car expr))))
 736         (tstate-incr-depth! tstate)
 737         (let ((result
 738                (if rtx-obj
 739                    (-rtx-traverse-expr rtx-obj expr mode parent-expr op-pos tstate appstuff)
 740                    (let ((rtx-obj (-rtx-macro-lookup (car expr))))
 741                      (if rtx-obj
 742                          (-rtx-traverse (-rtx-macro-expand expr rtx-evaluator)
 743                                         expected mode parent-expr op-pos tstate appstuff)
 744                          (tstate-error tstate "unknown rtx function" expr))))))
 745           (tstate-decr-depth! tstate)
 746           result))
 747
 748       ; EXPR is not a list.
 749       ; See if it's an operand shortcut.
 750       (if (memq expected '(RTX SETRTX))
 751
 752           (cond ((symbol? expr)
 753                  (cond ((current-op-lookup expr)
 754                         (-rtx-traverse
 755                          (rtx-make-operand expr) ; (current-op-lookup expr))
 756                          expected mode parent-expr op-pos tstate appstuff))
 757                        ((rtx-temp-lookup (tstate-env tstate) expr)
 758                         (-rtx-traverse
 759                          (rtx-make-local expr) ; (rtx-temp-lookup (tstate-env tstate) expr))
 760                          expected mode parent-expr op-pos tstate appstuff))
 761                        ((current-ifld-lookup expr)
 762                         (-rtx-traverse
 763                          (rtx-make-ifield expr)
 764                          expected mode parent-expr op-pos tstate appstuff))
 765                        ((enum-lookup-val expr)
 766                         ;; ??? If enums could have modes other than INT,
 767                         ;; we'd want to propagate that mode here.
 768                         (-rtx-traverse
 769                          (rtx-make-enum 'INT expr)
 770                          expected mode parent-expr op-pos tstate appstuff))
 771                        (else
 772                         (tstate-error tstate "unknown operand" expr))))
 773                 ((integer? expr)
 774                  (-rtx-traverse (rtx-make-const 'INT expr)
 775                                 expected mode parent-expr op-pos tstate appstuff))
 776                 (else
 777                  (tstate-error tstate "unexpected operand" expr)))
 778
 779           ; Not expecting RTX or SETRTX.
 780           (tstate-error tstate "unexpected operand" expr)))
 781 )
 782
 783 ; User visible procedures to traverse an rtl expression.
 784 ; These calls -rtx-traverse to do most of the work.
 785 ; See tstate-make for explanations of OWNER, EXPR-FN.
 786 ; CONTEXT is a <context> object or #f if there is none.
 787 ; LOCALS is a list of (mode . name) elements (the locals arg to `sequence').
 788 ; APPSTUFF is for application specific use.
 789
 790 (define (rtx-traverse context owner expr expr-fn appstuff)
 791   (-rtx-traverse expr #f 'DFLT #f 0
 792                  (tstate-make context owner expr-fn (rtx-env-empty-stack)
 793                               #f #f nil 0)
 794                  appstuff)
 795 )
 796
 797 (define (rtx-traverse-with-locals context owner expr expr-fn locals appstuff)
 798   (-rtx-traverse expr #f 'DFLT #f 0
 799                  (tstate-make context owner expr-fn
 800                               (rtx-env-push (rtx-env-empty-stack)
 801                                             (rtx-env-make-locals locals))
 802                               #f #f nil 0)
 803                  appstuff)
 804 )
 805
 806 ; Traverser debugger.
 807
 808 (define (rtx-traverse-debug expr)
 809   (rtx-traverse
 810    #f #f expr
 811    (lambda (rtx-obj expr mode parent-expr op-pos tstate appstuff)
 812      (display "-expr:    ")
 813      (display (string-append "rtx=" (obj:str-name rtx-obj)))
 814      (display " expr=")
 815      (display expr)
 816      (display " mode=")
 817      (display mode)
 818      (display " parent=")
 819      (display parent-expr)
 820      (display " op-pos=")
 821      (display op-pos)
 822      (display " cond?=")
 823      (display (tstate-cond? tstate))
 824      (newline)
 825      #f)
 826    #f
 827    )
 828 )
 829 \f
 830 ; RTL evaluation state.
 831 ; Applications may subclass <eval-state> if they need to add things.
 832 ;
 833 ; This is initialized before evaluation, and modified (in a copy) as the
 834 ; evaluation state changes.
 835 ; This doesn't record all evaluation state, just the less dynamic elements.
 836 ; There's no point in recording things like the parent expression and operand
 837 ; position as they change for every sub-eval.
 838 ; The main raison d'etre for this class is so we can add more state without
 839 ; having to modify all the eval handlers.
 840
 841 (define <eval-state>
 842   (class-make '<eval-state> nil
 843               '(
 844                 ; <context> object or #f if there is none
 845                 (context . #f)
 846
 847                 ; Current object rtl is being evaluated for.
 848                 ; We need to be able to access the current instruction while
 849                 ; generating semantic code.  However, the semantic description
 850                 ; doesn't specify it as an argument to anything (and we don't
 851                 ; want it to).  So we record the value here.
 852                 (owner . #f)
 853
 854                 ; EXPR-FN is a dual-purpose beast.  The first purpose is to
 855                 ; just process the current expression and return the result.
 856                 ; The second purpose is to lookup the function which will then
 857                 ; process the expression.  It is applied recursively to the
 858                 ; expression and each sub-expression.  It must be defined as
 859                 ; (lambda (rtx-obj expr mode estate) ...).
 860                 ; If the result of EXPR-FN is a lambda, it is applied to
 861                 ; (cons ESTATE (cdr EXPR)).  ESTATE is prepended to the
 862                 ; arguments.
 863                 ; For syntax expressions if the result of EXPR-FN is #f,
 864                 ; the operands are processed using the builtin evaluator.
 865                 ; FIXME: This special handling of syntax expressions is
 866                 ; not currently done.
 867                 ; So to repeat: EXPR-FN can process the expression, and if its
 868                 ; result is a lambda then it also processes the expression.
 869                 ; The arguments to EXPR-FN are
 870                 ; (rtx-obj expr mode estate).
 871                 ; The arguments to the result of EXPR-FN are
 872                 ; (cons ESTATE (cdr EXPR)).
 873                 ; The reason for the duality is mostly history.
 874                 ; In time things should be simplified.
 875                 (expr-fn . #f)
 876
 877                 ; Current environment.  This is a stack of sequence locals.
 878                 (env . ())
 879
 880                 ; Current evaluation depth.  This is used, for example, to
 881                 ; control indentation in generated output.
 882                 (depth . 0)
 883
 884                 ; Associative list of modifiers.
 885                 ; This is here to support things like `delay'.
 886                 (modifiers . ())
 887                 )
 888               nil)
 889 )
 890
 891 ; Create an <eval-state> object using a list of keyword/value elements.
 892 ; ARGS is a list of #:keyword/value elements.
 893 ; The result is a list of the unrecognized elements.
 894 ; Subclasses should override this method and send-next it first, then
 895 ; see if they recognize anything in the result, returning what isn't
 896 ; recognized.
 897
 898 (method-make!
 899  <eval-state> 'vmake!
 900  (lambda (self args)
 901    (let loop ((args args) (unrecognized nil))
 902      (if (null? args)
 903          (reverse! unrecognized) ; ??? Could invoke method to initialize here.
 904          (begin
 905            (case (car args)
 906              ((#:context)
 907               (elm-set! self 'context (cadr args)))
 908              ((#:owner)
 909               (elm-set! self 'owner (cadr args)))
 910              ((#:expr-fn)
 911               (elm-set! self 'expr-fn (cadr args)))
 912              ((#:env)
 913               (elm-set! self 'env (cadr args)))
 914              ((#:depth)
 915               (elm-set! self 'depth (cadr args)))
 916              ((#:modifiers)
 917               (elm-set! self 'modifiers (cadr args)))
 918              (else
 919               ; Build in reverse order, as we reverse it back when we're done.
 920               (set! unrecognized
 921                     (cons (cadr args) (cons (car args) unrecognized)))))
 922            (loop (cddr args) unrecognized)))))
 923 )
 924
 925 ; Accessors.
 926
 927 (define-getters <eval-state> estate
 928   (context owner expr-fn env depth modifiers)
 929 )
 930 (define-setters <eval-state> estate
 931   (context owner expr-fn env depth modifiers)
 932 )
 933
 934 ; Build an estate for use in producing a value from rtl.
 935 ; CONTEXT is a <context> object or #f if there is none.
 936 ; OWNER is the owner of the expression or #f if there is none.
 937
 938 (define (estate-make-for-eval context owner)
 939   (vmake <eval-state>
 940          #:context context
 941          #:owner owner
 942          #:expr-fn (lambda (rtx-obj expr mode estate)
 943                      (rtx-evaluator rtx-obj)))
 944 )
 945
 946 ; Create a copy of ESTATE.
 947
 948 (define (estate-copy estate)
 949   (object-copy-top estate)
 950 )
 951
 952 ; Create a copy of ESTATE with a new environment ENV.
 953
 954 (define (estate-new-env estate env)
 955   (let ((result (estate-copy estate)))
 956     (estate-set-env! result env)
 957     result)
 958 )
 959
 960 ; Create a copy of ESTATE with environment ENV pushed onto the existing
 961 ; environment list.
 962 ; There's no routine to pop the environment list as there's no current
 963 ; need for it: we make a copy of the state when we push.
 964
 965 (define (estate-push-env estate env)
 966   (let ((result (estate-copy estate)))
 967     (estate-set-env! result (cons env (estate-env result)))
 968     result)
 969 )
 970
 971 ; Create a copy of ESTATE with the depth incremented by one.
 972
 973 (define (estate-deepen estate)
 974   (let ((result (estate-copy estate)))
 975     (estate-set-depth! result (1+ (estate-depth estate)))
 976     result)
 977 )
 978
 979 ; Create a copy of ESTATE with modifiers MODS.
 980
 981 (define (estate-with-modifiers estate mods)
 982   (let ((result (estate-copy estate)))
 983     (estate-set-modifiers! result (append mods (estate-modifiers result)))
 984     result)
 985 )
 986
 987 ; Convert a tstate to an estate.
 988
 989 (define (tstate->estate t)
 990   (vmake <eval-state>
 991          #:context (tstate-context t)
 992          #:env (tstate-env t))
 993 )
 994
 995 ; Issue an error given an estate.
 996
 997 (define (estate-error estate errmsg . expr)
 998   (apply context-owner-error
 999          (cons (estate-context estate)
1000                (cons (estate-owner estate)
1001                      (cons "During rtx evalution"
1002                            (cons errmsg expr)))))
1003 )
1004 \f
1005 ; RTL expression evaluation.
1006 ;
1007 ; ??? These used eval2 at one point.  Not sure which is faster but I suspect
1008 ; eval2 is by far.  On the otherhand this has yet to be compiled.  And this way
1009 ; is more portable, more flexible, and works with guile 1.2 (which has
1010 ; problems with eval'ing self referential vectors, though that's one reason to
1011 ; use smobs).
1012
1013 ; Set to #t to debug rtx evaluation.
1014
1015 (define -rtx-eval-debug? #f)
1016
1017 ; RTX expression evaluator.
1018 ;
1019 ; EXPR is the expression to be eval'd.  It must be in compiled form.
1020 ; MODE is the mode of EXPR, a <mode> object or its name.
1021 ; ESTATE is the current evaluation state.
1022
1023 (define (rtx-eval-with-estate expr mode estate)
1024   (if -rtx-eval-debug?
1025       (begin
1026         (display "Traversing ")
1027         (display expr)
1028         (newline)
1029         (rtx-env-dump (estate-env estate))
1030         ))
1031
1032   (if (pair? expr) ; pair? -> cheap non-null-list?
1033
1034       (let* ((rtx-obj (rtx-lookup (car expr)))
1035              (fn ((estate-expr-fn estate) rtx-obj expr mode estate)))
1036         (if fn
1037             (if (procedure? fn)
1038                 (apply fn (cons estate (cdr expr)))
1039 ;               ; Don't eval operands for syntax expressions.
1040 ;               (if (rtx-style-syntax? rtx-obj)
1041 ;                   (apply fn (cons estate (cdr expr)))
1042 ;                   (let ((operands
1043 ;                          (-rtx-eval-operands rtx-obj expr estate)))
1044 ;                     (apply fn (cons estate operands))))
1045                 fn)
1046             ; Leave expr unchanged.
1047             expr))
1048 ;           (let ((operands
1049 ;                  (-rtx-traverse-operands rtx-obj expr estate)))
1050 ;             (cons rtx-obj operands))))
1051
1052       ; EXPR is not a list
1053       (error "argument to rtx-eval-with-estate is not a list" expr))
1054 )
1055
1056 ; Evaluate rtx expression EXPR and return the computed value.
1057 ; EXPR must already be in compiled form (the result of rtx-compile).
1058 ; OWNER is the owner of the value, used for attribute computation,
1059 ; or #f if there isn't one.
1060 ; FIXME: context?
1061
1062 (define (rtx-value expr owner)
1063   (rtx-eval-with-estate expr 'DFLT (estate-make-for-eval #f owner))
1064 )