; Basic RTL support.
-; Copyright (C) 2000 Red Hat, Inc.
+; Copyright (C) 2000, 2001 Red Hat, Inc.
; This file is part of CGEN.
; See file COPYING.CGEN for details.
(method-make! <rtx-func> 'get-name (lambda (self) (elm-get self 'name)))
+; List of mode types for arg-types.
+
+(define -rtx-valid-mode-types
+ '(
+ ANYMODE INTMODE FLOATMODE NUMMODE EXPLNUMMODE NONVOIDMODE VOIDMODE DFLTMODE
+ )
+)
+
; List of valid values for arg-types, not including mode names.
(define -rtx-valid-types
- '(OPTIONS
- ANYMODE INTMODE FLOATMODE NUMMODE EXPLNUMMODE NONVOIDMODE VOIDMODE DFLTMODE
- RTX TESTRTX CONDRTX CASERTX
- LOCALS ENV ATTRS SYMBOL STRING NUMBER SYMORNUM OBJECT)
+ (append
+ '(OPTIONS)
+ -rtx-valid-mode-types
+ '(RTX SETRTX TESTRTX CONDRTX CASERTX)
+ '(LOCALS ENV ATTRS SYMBOL STRING NUMBER SYMORNUM OBJECT)
+ )
)
; List of valid mode matchers, excluding mode names.
class
'function
(if action
- (eval (list 'lambda (cons '*estate* args) action))
+ (eval1 (list 'lambda (cons '*estate* args) action))
#f)
-rtx-num-next)))
; Add it to the table of rtx handlers.
class
'syntax
(if action
- (eval (list 'lambda (cons '*estate* args) action))
+ (eval1 (list 'lambda (cons '*estate* args) action))
#f)
-rtx-num-next)))
; Add it to the table of rtx handlers.
arg-types arg-modes
class
'operand
- (eval (list 'lambda (cons '*estate* args) action))
+ (eval1 (list 'lambda (cons '*estate* args) action))
-rtx-num-next)))
; Add it to the table of rtx handlers.
(hashq-set! -rtx-func-table name rtx)
(let ((rtx (make <rtx-func> name args #f #f
#f ; class
'macro
- (eval (list 'lambda args action))
+ (eval1 (list 'lambda args action))
-rtx-num-next)))
; Add it to the table of rtx macros.
(hashq-set! -rtx-macro-table name rtx)
locals))
)
-; Return a semi-pretty symbol describing RTX.
+; Return a semi-pretty string describing RTX.
; This is used by hw to include the index in the element's name.
(define (rtx-pretty-name rtx)
(if (pair? rtx)
(case (car rtx)
((const) (number->string (rtx-const-value rtx)))
- ((operand) (obj:name (rtx-operand-obj rtx)))
- ((local) (rtx-local-name rtx))
- ((xop) (obj:name (rtx-xop-obj rtx)))
+ ((operand) (symbol->string (obj:name (rtx-operand-obj rtx))))
+ ((local) (symbol->string (rtx-local-name rtx)))
+ ((xop) (symbol->string (obj:name (rtx-xop-obj rtx))))
(else
(if (null? (cdr rtx))
(car rtx)
- (apply string-append
+ (apply stringsym-append
(cons (car rtx)
(map (lambda (elm)
(string-append "-" (rtx-pretty-name elm)))
(stringize rtx "-"))
)
\f
-; RTL expression traversal support.
-; Traversal (and compilation) involves validating the source form and
-; converting it to internal form.
-; ??? At present the internal form is also the source form (easier debugging).
-
-; Set to #t to debug rtx traversal.
-
-(define -rtx-traverse-debug? #f)
-
-; Container to record the current state of traversal.
-; This is initialized before traversal, and modified (in a copy) as the
-; traversal state changes.
-; This doesn't record all traversal state, just the more static elements.
-; There's no point in recording things like the parent expression and operand
-; position as they change for every sub-traversal.
-; The main raison d'etre for this class is so we can add more state without
-; having to modify all the traversal handlers.
-; ??? At present it's not a proper "class" as there's no real need.
-;
-; CONTEXT is a <context> object or #f if there is none.
-; It is used for error messages.
-;
-; EXPR-FN is a dual-purpose beast. The first purpose is to just process
-; the current expression and return the result. The second purpose is to
-; lookup the function which will then process the expression.
-; It is applied recursively to the expression and each sub-expression.
-; It must be defined as
-; (lambda (rtx-obj expr mode parent-expr op-pos tstate appstuff) ...).
-; If the result of EXPR-FN is a lambda, it is applied to
-; (cons TSTATE (cdr EXPR)). TSTATE is prepended to the arguments.
-; For syntax expressions if the result of EXPR-FN is #f, the operands are
-; processed using the builtin traverser.
-; So to repeat: EXPR-FN can process the expression, and if its result is a
-; lambda then it also processes the expression. The arguments to EXPR-FN
-; are (rtx-obj expr mode parent-expr op-pos tstate appstuff). The format
-; of the result of EXPR-FN are (cons TSTATE (cdr EXPR)).
-; The reason for the duality is that when trying to understand EXPR (e.g. when
-; computing the insn format) EXPR-FN processes the expression itself, and
-; when evaluating EXPR it's the result of EXPR-FN that computes the value.
-;
-; ENV is the current environment. This is a stack of sequence locals.
-;
-; COND? is a boolean indicating if the current expression is on a conditional
-; execution path. This is for optimization purposes only and it is always ok
-; to pass #t, except for the top-level caller which must pass #f (since the top
-; level expression obviously isn't subject to any condition).
-; It is used, for example, to speed up the simulator: there's no need to keep
-; track of whether an operand has been assigned to (or potentially read from)
-; if it's known it's always assigned to.
-;
-; SET? is a boolean indicating if the current expression is an operand being
-; set.
-;
-; OWNER is the owner of the expression or #f if there is none.
-; Typically it is an <insn> object.
-;
-; KNOWN is an alist of known values. This is used by rtx-simplify.
-; Each element is (name . value) where
-; NAME is either an ifield or operand name (in the future it might be a
-; sequence local name), and
-; VALUE is either (const mode value) or (numlist mode value1 value2 ...).
-;
-; DEPTH is the current traversal depth.
-
-(define (tstate-make context owner expr-fn env cond? set? known depth)
- (vector context owner expr-fn env cond? set? known depth)
-)
-
-(define (tstate-context state) (vector-ref state 0))
-(define (tstate-set-context! state newval) (vector-set! state 0 newval))
-(define (tstate-owner state) (vector-ref state 1))
-(define (tstate-set-owner! state newval) (vector-set! state 1 newval))
-(define (tstate-expr-fn state) (vector-ref state 2))
-(define (tstate-set-expr-fn! state newval) (vector-set! state 2 newval))
-(define (tstate-env state) (vector-ref state 3))
-(define (tstate-set-env! state newval) (vector-set! state 3 newval))
-(define (tstate-cond? state) (vector-ref state 4))
-(define (tstate-set-cond?! state newval) (vector-set! state 4 newval))
-(define (tstate-set? state) (vector-ref state 5))
-(define (tstate-set-set?! state newval) (vector-set! state 5 newval))
-(define (tstate-known state) (vector-ref state 6))
-(define (tstate-set-known! state newval) (vector-set! state 6 newval))
-(define (tstate-depth state) (vector-ref state 7))
-(define (tstate-set-depth! state newval) (vector-set! state 7 newval))
-
-; Create a copy of STATE.
-
-(define (tstate-copy state)
- ; A fast vector-copy would be nice, but this is simple and portable.
- (list->vector (vector->list state))
-)
-
-; Create a copy of STATE with a new environment ENV.
-
-(define (tstate-new-env state env)
- (let ((result (tstate-copy state)))
- (tstate-set-env! result env)
- result)
-)
-
-; Create a copy of STATE with environment ENV pushed onto the existing
-; environment list.
-; There's no routine to pop the environment list as there's no current
-; need for it: we make a copy of the state when we push.
-
-(define (tstate-push-env state env)
- (let ((result (tstate-copy state)))
- (tstate-set-env! result (cons env (tstate-env result)))
- result)
-)
-
-; Create a copy of STATE with a new COND? value.
-
-(define (tstate-new-cond? state cond?)
- (let ((result (tstate-copy state)))
- (tstate-set-cond?! result cond?)
- result)
-)
-
-; Create a copy of STATE with a new SET? value.
-
-(define (tstate-new-set? state set?)
- (let ((result (tstate-copy state)))
- (tstate-set-set?! result set?)
- result)
-)
-
-; Lookup NAME in the known value table. Returns the value or #f if not found.
-
-(define (tstate-known-lookup tstate name)
- (let ((known (tstate-known tstate)))
- (assq-ref known name))
-)
-
-; Increment the recorded traversal depth of TSTATE.
-
-(define (tstate-incr-depth! tstate)
- (tstate-set-depth! tstate (1+ (tstate-depth tstate)))
-)
-
-; Decrement the recorded traversal depth of TSTATE.
-
-(define (tstate-decr-depth! tstate)
- (tstate-set-depth! tstate (1- (tstate-depth tstate)))
-)
-\f
-; Traversal/compilation support.
-
-; Return a boolean indicating if X is a mode.
-
-(define (-rtx-any-mode? x)
- (->bool (mode:lookup x))
-)
-
-; Return a boolean indicating if X is a symbol or rtx.
-
-(define (-rtx-symornum? x)
- (or (symbol? x) (number? x))
-)
-
-; Traverse a list of rtx's.
-
-(define (-rtx-traverse-rtx-list rtx-list mode expr op-num tstate appstuff)
- (map (lambda (rtx)
- ; ??? Shouldn't OP-NUM change for each element?
- (-rtx-traverse rtx 'RTX mode expr op-num tstate appstuff))
- rtx-list)
-)
-
-; Cover-fn to context-error for signalling an error during rtx traversal.
-
-(define (-rtx-traverse-error tstate errmsg expr op-num)
-; (parse-error context (string-append errmsg ", operand number "
-; (number->string op-num))
-; (rtx-dump expr))
- (context-error (tstate-context tstate)
- (string-append errmsg ", operand #" (number->string op-num))
- (rtx-strdump expr))
-)
-
-; Rtx traversers.
-; These are defined as individual functions that are then built into a table
-; so that we can use Hobbit's "fastcall" support.
-;
-; The result is either a pair of the parsed VAL and new TSTATE,
-; or #f meaning there is no change (saves lots of unnecessarying cons'ing).
-
-(define (-rtx-traverse-options val mode expr op-num tstate appstuff)
- #f
-)
-
-(define (-rtx-traverse-anymode val mode expr op-num tstate appstuff)
- (let ((val-obj (mode:lookup val)))
- (if (not val-obj)
- (-rtx-traverse-error tstate "expecting a mode"
- expr op-num))
- #f)
-)
-
-(define (-rtx-traverse-intmode val mode expr op-num tstate appstuff)
- (let ((val-obj (mode:lookup val)))
- (if (and val-obj
- (or (memq (mode:class val-obj) '(INT UINT))
- (eq? val 'DFLT)))
- #f
- (-rtx-traverse-error tstate "expecting an integer mode"
- expr op-num)))
-)
-
-(define (-rtx-traverse-floatmode val mode expr op-num tstate appstuff)
- (let ((val-obj (mode:lookup val)))
- (if (and val-obj
- (or (memq (mode:class val-obj) '(FLOAT))
- (eq? val 'DFLT)))
- #f
- (-rtx-traverse-error tstate "expecting a float mode"
- expr op-num)))
-)
-
-(define (-rtx-traverse-nummode val mode expr op-num tstate appstuff)
- (let ((val-obj (mode:lookup val)))
- (if (and val-obj
- (or (memq (mode:class val-obj) '(INT UINT FLOAT))
- (eq? val 'DFLT)))
- #f
- (-rtx-traverse-error tstate "expecting a numeric mode"
- expr op-num)))
-)
-
-(define (-rtx-traverse-explnummode val mode expr op-num tstate appstuff)
- (let ((val-obj (mode:lookup val)))
- (if (not val-obj)
- (-rtx-traverse-error tstate "expecting a mode"
- expr op-num))
- (if (memq val '(DFLT VOID))
- (-rtx-traverse-error tstate "DFLT and VOID not allowed here"
- expr op-num))
- #f)
-)
-
-(define (-rtx-traverse-nonvoidmode val mode expr op-num tstate appstuff)
- (if (eq? val 'VOID)
- (-rtx-traverse-error tstate "mode can't be VOID"
- expr op-num))
- #f
-)
-
-(define (-rtx-traverse-voidmode val mode expr op-num tstate appstuff)
- (if (memq val '(DFLT VOID))
- #f
- (-rtx-traverse-error tstate "expecting mode VOID"
- expr op-num))
-)
-
-(define (-rtx-traverse-dfltmode val mode expr op-num tstate appstuff)
- (if (eq? val 'DFLT)
- #f
- (-rtx-traverse-error tstate "expecting mode DFLT"
- expr op-num))
-)
-
-(define (-rtx-traverse-rtx val mode expr op-num tstate appstuff)
-; Commented out 'cus it doesn't quite work yet.
-; (if (not (rtx? val))
-; (-rtx-traverse-error tstate "expecting an rtx"
-; expr op-num))
- (cons (-rtx-traverse val 'RTX mode expr op-num tstate appstuff)
- tstate)
-)
-
-(define (-rtx-traverse-setrtx val mode expr op-num tstate appstuff)
- ; FIXME: Still need to turn it off for sub-exprs.
- ; e.g. (mem (reg ...))
-; Commented out 'cus it doesn't quite work yet.
-; (if (not (rtx? val))
-; (-rtx-traverse-error tstate "expecting an rtx"
-; expr op-num))
- (cons (-rtx-traverse val 'SETRTX mode expr op-num
- (tstate-new-set? tstate #t)
- appstuff)
- tstate)
-)
-
-; This is the test of an `if'.
-
-(define (-rtx-traverse-testrtx val mode expr op-num tstate appstuff)
-; Commented out 'cus it doesn't quite work yet.
-; (if (not (rtx? val))
-; (-rtx-traverse-error tstate "expecting an rtx"
-; expr op-num))
- (cons (-rtx-traverse val 'RTX mode expr op-num tstate appstuff)
- (tstate-new-cond?
- tstate
- (not (rtx-compile-time-constant? val))))
-)
-
-(define (-rtx-traverse-condrtx val mode expr op-num tstate appstuff)
- (if (not (pair? val))
- (-rtx-traverse-error tstate "expecting an expression"
- expr op-num))
- (if (eq? (car val) 'else)
- (begin
- (if (!= (+ op-num 2) (length expr))
- (-rtx-traverse-error tstate
- "`else' clause not last"
- expr op-num))
- (cons (cons 'else
- (-rtx-traverse-rtx-list
- (cdr val) mode expr op-num
- (tstate-new-cond? tstate #t)
- appstuff))
- (tstate-new-cond? tstate #t)))
- (cons (cons
- ; ??? Entries after the first are conditional.
- (-rtx-traverse (car val) 'RTX 'ANY expr op-num tstate appstuff)
- (-rtx-traverse-rtx-list
- (cdr val) mode expr op-num
- (tstate-new-cond? tstate #t)
- appstuff))
- (tstate-new-cond? tstate #t)))
-)
-
-(define (-rtx-traverse-casertx val mode expr op-num tstate appstuff)
- (if (or (not (list? val))
- (< (length val) 2))
- (-rtx-traverse-error tstate
- "invalid `case' expression"
- expr op-num))
- ; car is either 'else or list of symbols/numbers
- (if (not (or (eq? (car val) 'else)
- (and (list? (car val))
- (not (null? (car val)))
- (all-true? (map -rtx-symornum?
- (car val))))))
- (-rtx-traverse-error tstate
- "invalid `case' choice"
- expr op-num))
- (if (and (eq? (car val) 'else)
- (!= (+ op-num 2) (length expr)))
- (-rtx-traverse-error tstate "`else' clause not last"
- expr op-num))
- (cons (cons (car val)
- (-rtx-traverse-rtx-list
- (cdr val) mode expr op-num
- (tstate-new-cond? tstate #t)
- appstuff))
- (tstate-new-cond? tstate #t))
-)
-
-(define (-rtx-traverse-locals val mode expr op-num tstate appstuff)
- (if (not (list? val))
- (-rtx-traverse-error tstate "bad locals list"
- expr op-num))
- (for-each (lambda (var)
- (if (or (not (list? var))
- (!= (length var) 2)
- (not (-rtx-any-mode? (car var)))
- (not (symbol? (cadr var))))
- (-rtx-traverse-error tstate
- "bad locals list"
- expr op-num)))
- val)
- (let ((env (rtx-env-make-locals val)))
- (cons val (tstate-push-env tstate env)))
-)
-
-(define (-rtx-traverse-env val mode expr op-num tstate appstuff)
- ; VAL is an environment stack.
- (if (not (list? val))
- (-rtx-traverse-error tstate "environment not a list"
- expr op-num))
- (cons val (tstate-new-env tstate val))
-)
-
-(define (-rtx-traverse-attrs val mode expr op-num tstate appstuff)
-; (cons val ; (atlist-source-form (atlist-parse val "" "with-attr"))
-; tstate)
- #f
-)
-
-(define (-rtx-traverse-symbol val mode expr op-num tstate appstuff)
- (if (not (symbol? val))
- (-rtx-traverse-error tstate "expecting a symbol"
- expr op-num))
- #f
-)
-
-(define (-rtx-traverse-string val mode expr op-num tstate appstuff)
- (if (not (string? val))
- (-rtx-traverse-error tstate "expecting a string"
- expr op-num))
- #f
-)
-
-(define (-rtx-traverse-number val mode expr op-num tstate appstuff)
- (if (not (number? val))
- (-rtx-traverse-error tstate "expecting a number"
- expr op-num))
- #f
-)
-
-(define (-rtx-traverse-symornum val mode expr op-num tstate appstuff)
- (if (not (or (symbol? val) (number? val)))
- (-rtx-traverse-error tstate
- "expecting a symbol or number"
- expr op-num))
- #f
-)
-
-(define (-rtx-traverse-object val mode expr op-num tstate appstuff)
- #f
-)
-
-; Table of rtx traversers.
-; This is a vector of size rtx-max-num.
-; Each entry is a list of (arg-type-name . traverser) elements
-; for rtx-arg-types.
-
-(define -rtx-traverser-table #f)
-
-; Return a hash table of standard operand traversers.
-; The result of each traverser is a pair of the compiled form of `val' and
-; a possibly new traversal state or #f if there is no change.
-
-(define (-rtx-make-traverser-table)
- (let ((hash-tab (make-hash-table 31))
- (traversers
- (list
- ; /fastcall-make is recognized by Hobbit and handled specially.
- ; When not using Hobbit it is a macro that returns its argument.
- (cons 'OPTIONS (/fastcall-make -rtx-traverse-options))
- (cons 'ANYMODE (/fastcall-make -rtx-traverse-anymode))
- (cons 'INTMODE (/fastcall-make -rtx-traverse-intmode))
- (cons 'FLOATMODE (/fastcall-make -rtx-traverse-floatmode))
- (cons 'NUMMODE (/fastcall-make -rtx-traverse-nummode))
- (cons 'EXPLNUMMODE (/fastcall-make -rtx-traverse-explnummode))
- (cons 'NONVOIDFLTODE (/fastcall-make -rtx-traverse-nonvoidmode))
- (cons 'VOIDFLTODE (/fastcall-make -rtx-traverse-voidmode))
- (cons 'DFLTMODE (/fastcall-make -rtx-traverse-dfltmode))
- (cons 'RTX (/fastcall-make -rtx-traverse-rtx))
- (cons 'SETRTX (/fastcall-make -rtx-traverse-setrtx))
- (cons 'TESTRTX (/fastcall-make -rtx-traverse-testrtx))
- (cons 'CONDRTX (/fastcall-make -rtx-traverse-condrtx))
- (cons 'CASERTX (/fastcall-make -rtx-traverse-casertx))
- (cons 'LOCALS (/fastcall-make -rtx-traverse-locals))
- (cons 'ENV (/fastcall-make -rtx-traverse-env))
- (cons 'ATTRS (/fastcall-make -rtx-traverse-attrs))
- (cons 'SYMBOL (/fastcall-make -rtx-traverse-symbol))
- (cons 'STRING (/fastcall-make -rtx-traverse-string))
- (cons 'NUMBER (/fastcall-make -rtx-traverse-number))
- (cons 'SYMORNUM (/fastcall-make -rtx-traverse-symornum))
- (cons 'OBJECT (/fastcall-make -rtx-traverse-object))
- )))
-
- (for-each (lambda (traverser)
- (hashq-set! hash-tab (car traverser) (cdr traverser)))
- traversers)
-
- hash-tab)
-)
-
-; Traverse the operands of EXPR, a canonicalized RTL expression.
-; Here "canonicalized" means that -rtx-munge-mode&options has been called to
-; insert an option list and mode if they were absent in the original
-; expression.
-
-(define (-rtx-traverse-operands rtx-obj expr tstate appstuff)
- (if -rtx-traverse-debug?
- (begin
- (display (spaces (* 4 (tstate-depth tstate))))
- (display "Traversing operands of: ")
- (display (rtx-dump expr))
- (newline)
- (rtx-env-dump (tstate-env tstate))
- (force-output)
- ))
-
- (let loop ((operands (cdr expr))
- (op-num 0)
- (arg-types (vector-ref -rtx-traverser-table (rtx-num rtx-obj)))
- (arg-modes (rtx-arg-modes rtx-obj))
- (result nil)
- )
-
- (let ((varargs? (and (pair? arg-types) (symbol? (car arg-types)))))
-
- (if -rtx-traverse-debug?
- (begin
- (display (spaces (* 4 (tstate-depth tstate))))
- (if (null? operands)
- (display "end of operands")
- (begin
- (display "op-num ") (display op-num) (display ": ")
- (display (rtx-dump (car operands)))
- (display ", ")
- (display (if varargs? (car arg-types) (caar arg-types)))
- (display ", ")
- (display (if varargs? arg-modes (car arg-modes)))
- ))
- (newline)
- (force-output)
- ))
-
- (cond ((null? operands)
- ; Out of operands, check if we have the expected number.
- (if (or (null? arg-types)
- varargs?)
- (reverse! result)
- (context-error (tstate-context tstate)
- "missing operands" (rtx-strdump expr))))
-
- ((null? arg-types)
- (context-error (tstate-context tstate)
- "too many operands" (rtx-strdump expr)))
-
- (else
- (let ((type (if varargs? arg-types (car arg-types)))
- (mode (let ((mode-spec (if varargs?
- arg-modes
- (car arg-modes))))
- ; This is small enough that this is fast enough,
- ; and the number of entries should be stable.
- ; FIXME: for now
- (case mode-spec
- ((ANY) 'DFLT)
- ((NA) #f)
- ((OP0) (rtx-mode expr))
- ((MATCH1)
- ; If there is an explicit mode, use it.
- ; Otherwise we have to look at operand 1.
- (if (eq? (rtx-mode expr) 'DFLT)
- 'DFLT
- (rtx-mode expr)))
- ((MATCH2)
- ; If there is an explicit mode, use it.
- ; Otherwise we have to look at operand 2.
- (if (eq? (rtx-mode expr) 'DFLT)
- 'DFLT
- (rtx-mode expr)))
- (else mode-spec))))
- (val (car operands))
- )
-
- ; Look up the traverser for this kind of operand and perform it.
- (let ((traverser (cdr type)))
- (let ((traversed-val (fastcall6 traverser val mode expr op-num tstate appstuff)))
- (if traversed-val
- (begin
- (set! val (car traversed-val))
- (set! tstate (cdr traversed-val))))))
-
- ; Done with this operand, proceed to the next.
- (loop (cdr operands)
- (+ op-num 1)
- (if varargs? arg-types (cdr arg-types))
- (if varargs? arg-modes (cdr arg-modes))
- (cons val result)))))))
-)
-
-; Publically accessible version of -rtx-traverse-operands as EXPR-FN may
-; need to call it.
-
-(define rtx-traverse-operands -rtx-traverse-operands)
-
-; Subroutine of -rtx-munge-mode&options.
-; Return boolean indicating if X is an rtx option.
-
-(define (-rtx-option? x)
- (and (symbol? x)
- (char=? (string-ref x 0) #\:))
-)
-
-; Subroutine of -rtx-munge-mode&options.
-; Return boolean indicating if X is an rtx option list.
-
-(define (-rtx-option-list? x)
- (or (null? x)
- (and (pair? x)
- (-rtx-option? (car x))))
-)
-
-; Subroutine of -rtx-traverse-expr to fill in the mode if absent and to
-; collect the options into one list.
-; ARGS is the list of arguments to the rtx function
-; (e.g. (1 2) in (add 1 2)).
-; ??? "munge" is an awkward name to use here, but I like it for now because
-; it's easy to grep for.
-; ??? An empty option list requires a mode to be present so that the empty
-; list in `(sequence () foo bar)' is unambiguously recognized as the locals
-; list. Icky, sure, but less icky than the alternatives thus far.
-
-(define (-rtx-munge-mode&options args)
- (let ((options nil)
- (mode-name 'DFLT))
- ; Pick off the option list if present.
- (if (and (pair? args)
- (-rtx-option-list? (car args))
- ; Handle `(sequence () foo bar)'. If empty list isn't followed
- ; by a mode, it is not an option list.
- (or (not (null? (car args)))
- (and (pair? (cdr args))
- (mode-name? (cadr args)))))
- (begin
- (set! options (car args))
- (set! args (cdr args))))
- ; Pick off the mode if present.
- (if (and (pair? args)
- (mode-name? (car args)))
- (begin
- (set! mode-name (car args))
- (set! args (cdr args))))
- ; Now put option list and mode back.
- (cons options (cons mode-name args)))
-)
-
-; Traverse an expression.
-; For syntax expressions arguments are not pre-evaluated before calling the
-; user's expression handler. Otherwise they are.
-; If EXPR-FN wants to just scan the operands, rather than evaluating them,
-; one thing it can do is call back to rtx-traverse-operands.
-; If EXPR-FN returns #f, traverse the operands normally and return
-; (rtx's-name traversed-operand1 ...).
-; This is for semantic-compile's sake and all traversal handlers are
-; required to do this if EXPR-FN returns #f.
-
-(define (-rtx-traverse-expr rtx-obj expr mode parent-expr op-pos tstate appstuff)
- (let* ((expr2 (cons (car expr)
- (-rtx-munge-mode&options (cdr expr))))
- (fn (fastcall7 (tstate-expr-fn tstate)
- rtx-obj expr2 mode parent-expr op-pos tstate appstuff)))
- (if fn
- (if (procedure? fn)
- ; Don't traverse operands for syntax expressions.
- (if (rtx-style-syntax? rtx-obj)
- (apply fn (cons tstate (cdr expr2)))
- (let ((operands (-rtx-traverse-operands rtx-obj expr2 tstate appstuff)))
- (apply fn (cons tstate operands))))
- fn)
- (let ((operands (-rtx-traverse-operands rtx-obj expr2 tstate appstuff)))
- (cons (car expr2) operands))))
-)
-
-; Main entry point for expression traversal.
-; (Actually rtx-traverse is, but it's just a cover function for this.)
-;
-; The result is the result of the lambda EXPR-FN looks up in the case of
-; expressions or an operand object (usually <operand>) in the case of operands.
-;
-; EXPR is the expression to be traversed.
-;
-; MODE is the name of the mode of EXPR.
-;
-; PARENT-EXPR is the expression EXPR is contained in. The top-level
-; caller must pass #f for it.
-;
-; OP-POS is the position EXPR appears in PARENT-EXPR. The
-; top-level caller must pass 0 for it.
-;
-; EXPECTED is one of `-rtx-valid-types' and indicates the expected rtx type
-; or #f if it doesn't matter.
-;
-; TSTATE is the current traversal state.
-;
-; APPSTUFF is for application specific use.
-;
-; All macros are expanded here. User code never sees them.
-; All operand shortcuts are also expand here. User code never sees them.
-; These are:
-; - operands, ifields, and numbers appearing where an rtx is expected are
-; converted to use `operand', `ifield', or `const'.
-
-(define (-rtx-traverse expr expected mode parent-expr op-pos tstate appstuff)
- (if -rtx-traverse-debug?
- (begin
- (display (spaces (* 4 (tstate-depth tstate))))
- (display "Traversing expr: ")
- (display expr)
- (newline)
- (display (spaces (* 4 (tstate-depth tstate))))
- (display "-expected: ")
- (display expected)
- (newline)
- (display (spaces (* 4 (tstate-depth tstate))))
- (display "-mode: ")
- (display mode)
- (newline)
- (force-output)
- ))
-
- (if (pair? expr) ; pair? -> cheap non-null-list?
-
- (let ((rtx-obj (rtx-lookup (car expr))))
- (tstate-incr-depth! tstate)
- (let ((result
- (if rtx-obj
- (-rtx-traverse-expr rtx-obj expr mode parent-expr op-pos tstate appstuff)
- (let ((rtx-obj (-rtx-macro-lookup (car expr))))
- (if rtx-obj
- (-rtx-traverse (-rtx-macro-expand expr rtx-evaluator)
- expected mode parent-expr op-pos tstate appstuff)
- (context-error (tstate-context tstate) "unknown rtx function"
- expr))))))
- (tstate-decr-depth! tstate)
- result))
-
- ; EXPR is not a list.
- ; See if it's an operand shortcut.
- (if (memq expected '(RTX SETRTX))
-
- (cond ((symbol? expr)
- (cond ((current-op-lookup expr)
- (-rtx-traverse
- (rtx-make-operand expr) ; (current-op-lookup expr))
- expected mode parent-expr op-pos tstate appstuff))
- ((rtx-temp-lookup (tstate-env tstate) expr)
- (-rtx-traverse
- (rtx-make-local expr) ; (rtx-temp-lookup (tstate-env tstate) expr))
- expected mode parent-expr op-pos tstate appstuff))
- ((current-ifld-lookup expr)
- (-rtx-traverse
- (rtx-make-ifield expr)
- expected mode parent-expr op-pos tstate appstuff))
- ((enum-lookup-val expr)
- (-rtx-traverse
- (rtx-make-enum 'INT expr)
- expected mode parent-expr op-pos tstate appstuff))
- (else
- (context-error (tstate-context tstate)
- "unknown operand" expr))))
- ((integer? expr)
- (-rtx-traverse (rtx-make-const 'INT expr)
- expected mode parent-expr op-pos tstate appstuff))
- (else
- (context-error (tstate-context tstate)
- "unexpected operand"
- expr)))
-
- ; Not expecting RTX or SETRTX.
- (context-error (tstate-context tstate)
- "unexpected operand"
- expr)))
-)
-
-; User visible procedures to traverse an rtl expression.
-; These calls -rtx-traverse to do most of the work.
-; See tstate-make for an explanation of EXPR-FN.
-; CONTEXT is a <context> object or #f if there is none.
-; LOCALS is a list of (mode . name) elements (the locals arg to `sequence').
-; APPSTUFF is for application specific use.
-
-(define (rtx-traverse context owner expr expr-fn appstuff)
- (-rtx-traverse expr #f 'DFLT #f 0
- (tstate-make context owner expr-fn (rtx-env-empty-stack)
- #f #f nil 0)
- appstuff)
-)
-
-(define (rtx-traverse-with-locals context owner expr expr-fn locals appstuff)
- (-rtx-traverse expr #f 'DFLT #f 0
- (tstate-make context owner expr-fn
- (rtx-env-push (rtx-env-empty-stack)
- (rtx-env-make-locals locals))
- #f #f nil 0)
- appstuff)
-)
-
-; Traverser debugger.
-
-(define (rtx-traverse-debug expr)
- (rtx-traverse
- #f #f expr
- (lambda (rtx-obj expr mode parent-expr op-pos tstate appstuff)
- (display "-expr: ")
- (display (string-append "rtx=" (obj:name rtx-obj)))
- (display " expr=")
- (display expr)
- (display " mode=")
- (display mode)
- (display " parent=")
- (display parent-expr)
- (display " op-pos=")
- (display op-pos)
- (display " cond?=")
- (display (tstate-cond? tstate))
- (newline)
- #f)
- #f
- )
-)
-
-; Convert rtl expression EXPR from source form to compiled form.
-; The expression is validated and rtx macros are expanded as well.
-; CONTEXT is a <context> object or #f if there is none.
-; It is used in error messages.
-; EXTRA-VARS-ALIST is an association list of extra (symbol <mode> value)
-; elements to be used during value lookup.
-;
-; This does the same operation that rtx-traverse does, except that it provides
-; a standard value for EXPR-FN.
-;
-; ??? In the future the compiled form may be the same as the source form
-; except that all elements would be converted to their respective objects.
-
-(define (-compile-expr-fn rtx-obj expr mode parent-expr op-pos tstate appstuff)
-; (cond
-; The intent of this is to handle sequences/closures, but is it needed?
-; ((rtx-style-syntax? rtx-obj)
-; ((rtx-evaluator rtx-obj) rtx-obj expr mode
-; parent-expr op-pos tstate))
-; (else
- (cons (car expr) ; rtx-obj
- (-rtx-traverse-operands rtx-obj expr tstate appstuff))
-)
-
-(define (rtx-compile context expr extra-vars-alist)
- (-rtx-traverse expr #f 'DFLT #f 0
- (tstate-make context #f
- (/fastcall-make -compile-expr-fn)
- (rtx-env-init-stack1 extra-vars-alist)
- #f #f nil 0)
- #f)
-)
-\f
; Various rtx utilities.
; Dump an rtx expression.
(hashq-ref -rtx-macro-table (car x)))))
)
\f
-; RTL evaluation state.
-; Applications may subclass <eval-state> if they need to add things.
-;
-; This is initialized before evaluation, and modified (in a copy) as the
-; evaluation state changes.
-; This doesn't record all evaluation state, just the less dynamic elements.
-; There's no point in recording things like the parent expression and operand
-; position as they change for every sub-eval.
-; The main raison d'etre for this class is so we can add more state without
-; having to modify all the eval handlers.
-
-(define <eval-state>
- (class-make '<eval-state> nil
- '(
- ; <context> object or #f if there is none
- (context . #f)
-
- ; Current object rtl is being evaluated for.
- ; We need to be able to access the current instruction while
- ; generating semantic code. However, the semantic description
- ; doesn't specify it as an argument to anything (and we don't
- ; want it to). So we record the value here.
- (owner . #f)
-
- ; EXPR-FN is a dual-purpose beast. The first purpose is to
- ; just process the current expression and return the result.
- ; The second purpose is to lookup the function which will then
- ; process the expression. It is applied recursively to the
- ; expression and each sub-expression. It must be defined as
- ; (lambda (rtx-obj expr mode estate) ...).
- ; If the result of EXPR-FN is a lambda, it is applied to
- ; (cons ESTATE (cdr EXPR)). ESTATE is prepended to the
- ; arguments.
- ; For syntax expressions if the result of EXPR-FN is #f,
- ; the operands are processed using the builtin evaluator.
- ; FIXME: This special handling of syntax expressions is
- ; not currently done.
- ; So to repeat: EXPR-FN can process the expression, and if its
- ; result is a lambda then it also processes the expression.
- ; The arguments to EXPR-FN are
- ; (rtx-obj expr mode estate).
- ; The arguments to the result of EXPR-FN are
- ; (cons ESTATE (cdr EXPR)).
- ; The reason for the duality is mostly history.
- ; In time things should be simplified.
- (expr-fn . #f)
-
- ; Current environment. This is a stack of sequence locals.
- (env . ())
-
- ; Current evaluation depth. This is used, for example, to
- ; control indentation in generated output.
- (depth . 0)
-
- ; Associative list of modifiers.
- ; This is here to support things like `delay'.
- (modifiers . ())
- )
- nil)
-)
-
-; Create an <eval-state> object using a list of keyword/value elements.
-; ARGS is a list of #:keyword/value elements.
-; The result is a list of the unrecognized elements.
-; Subclasses should override this method and send-next it first, then
-; see if they recognize anything in the result, returning what isn't
-; recognized.
-
-(method-make!
- <eval-state> 'vmake!
- (lambda (self args)
- (let loop ((args args) (unrecognized nil))
- (if (null? args)
- (reverse! unrecognized) ; ??? Could invoke method to initialize here.
- (begin
- (case (car args)
- ((#:context)
- (elm-set! self 'context (cadr args)))
- ((#:owner)
- (elm-set! self 'owner (cadr args)))
- ((#:expr-fn)
- (elm-set! self 'expr-fn (cadr args)))
- ((#:env)
- (elm-set! self 'env (cadr args)))
- ((#:depth)
- (elm-set! self 'depth (cadr args)))
- ((#:modifiers)
- (elm-set! self 'modifiers (cadr args)))
- (else
- ; Build in reverse order, as we reverse it back when we're done.
- (set! unrecognized
- (cons (cadr args) (cons (car args) unrecognized)))))
- (loop (cddr args) unrecognized)))))
-)
-
-; Accessors.
-
-(define-getters <eval-state> estate
- (context owner expr-fn env depth modifiers)
-)
-(define-setters <eval-state> estate
- (context owner expr-fn env depth modifiers)
-)
-
-; Build an estate for use in producing a value from rtl.
-; CONTEXT is a <context> object or #f if there is none.
-; OWNER is the owner of the expression or #f if there is none.
-
-(define (estate-make-for-eval context owner)
- (vmake <eval-state>
- #:context context
- #:owner owner
- #:expr-fn (lambda (rtx-obj expr mode estate)
- (rtx-evaluator rtx-obj)))
-)
-
-; Create a copy of ESTATE.
-
-(define (estate-copy estate)
- (object-copy-top estate)
-)
-
-; Create a copy of STATE with a new environment ENV.
-
-(define (estate-new-env state env)
- (let ((result (estate-copy state)))
- (estate-set-env! result env)
- result)
-)
-
-; Create a copy of STATE with environment ENV pushed onto the existing
-; environment list.
-; There's no routine to pop the environment list as there's no current
-; need for it: we make a copy of the state when we push.
-
-(define (estate-push-env state env)
- (let ((result (estate-copy state)))
- (estate-set-env! result (cons env (estate-env result)))
- result)
-)
-
-; Create a copy of STATE with modifiers MODS.
-
-(define (estate-with-modifiers state mods)
- (let ((result (estate-copy state)))
- (estate-set-modifiers! result (append mods (estate-modifiers result)))
- result)
-)
-
-; Convert a tstate to an estate.
-
-(define (tstate->estate t)
- (vmake <eval-state>
- #:context (tstate-context t)
- #:env (tstate-env t))
-)
-\f
-; RTL expression evaluation.
-;
-; ??? These used eval2 at one point. Not sure which is faster but I suspect
-; eval2 is by far. On the otherhand this has yet to be compiled. And this way
-; is more portable, more flexible, and works with guile 1.2 (which has
-; problems with eval'ing self referential vectors, though that's one reason to
-; use smobs).
-
-; Set to #t to debug rtx evaluation.
-
-(define -rtx-eval-debug? #f)
-
-; RTX expression evaluator.
-;
-; EXPR is the expression to be eval'd. It must be in compiled form.
-; MODE is the mode of EXPR, a <mode> object or its name.
-; ESTATE is the current evaluation state.
-
-(define (rtx-eval-with-estate expr mode estate)
- (if -rtx-eval-debug?
- (begin
- (display "Traversing ")
- (display expr)
- (newline)
- (rtx-env-dump (estate-env estate))
- ))
-
- (if (pair? expr) ; pair? -> cheap non-null-list?
-
- (let* ((rtx-obj (rtx-lookup (car expr)))
- (fn ((estate-expr-fn estate) rtx-obj expr mode estate)))
- (if fn
- (if (procedure? fn)
- (apply fn (cons estate (cdr expr)))
-; ; Don't eval operands for syntax expressions.
-; (if (rtx-style-syntax? rtx-obj)
-; (apply fn (cons estate (cdr expr)))
-; (let ((operands
-; (-rtx-eval-operands rtx-obj expr estate)))
-; (apply fn (cons estate operands))))
- fn)
- ; Leave expr unchanged.
- expr))
-; (let ((operands
-; (-rtx-traverse-operands rtx-obj expr estate)))
-; (cons rtx-obj operands))))
-
- ; EXPR is not a list
- (error "argument to rtx-eval-with-estate is not a list" expr))
-)
-
-; Evaluate rtx expression EXPR and return the computed value.
-; EXPR must already be in compiled form (the result of rtx-compile).
-; OWNER is the owner of the value, used for attribute computation,
-; or #f if there isn't one.
-; FIXME: context?
-
-(define (rtx-value expr owner)
- (rtx-eval-with-estate expr 'DFLT (estate-make-for-eval #f owner))
-)
-\f
; Instruction field support.
; Return list of ifield names refered to in EXPR.
(cond ((hw-scalar? hw)
hw-name)
((rtx? index-arg)
- (symbol-append hw-name '- (rtx-pretty-name index-arg)))
+ (symbolstr-append hw-name '- (rtx-pretty-name index-arg)))
(else
- (symbol-append hw-name ; (obj:name (op:type self))
- '-
- ; (obj:name (op:index self)))))
- (stringize index-arg "-"))))
+ (symbolstr-append hw-name ; (obj:name (op:type self))
+ '-
+ ; (obj:name (op:index self)))))
+ (stringize index-arg "-"))))
)
; Return the <operand> object described by
(if (not hw)
(parse-error "hw" "invalid hardware element" hw-name))
- (let ((mode (if (eq? mode-name 'DFLT) (hw-mode hw) (mode:lookup mode-name)))
- (result (new <operand>))) ; ??? lookup-for-new?
+ (let* ((mode (if (eq? mode-name 'DFLT) (hw-mode hw) (mode:lookup mode-name)))
+ (hw-name-with-mode (symbol-append hw-name '- (obj:name mode)))
+ (result (new <operand>))) ; ??? lookup-for-new?
(if (not mode)
(parse-error "hw" "invalid mode" mode-name))
(if (not (hw-mode-ok? hw (obj:name mode) (elm-xget result 'index)))
(parse-error "hw" "invalid mode for hardware" mode-name))
+ (elm-xset! result 'hw-name hw-name)
(elm-xset! result 'type hw)
+ (elm-xset! result 'mode-name mode-name)
(elm-xset! result 'mode mode)
+ (op:set-pretty-sem-name! result hw-name)
+
; The name of the operand must include the index so that multiple copies
; of a hardware object (e.g. h-gr[0], h-gr[14]) can be distinguished.
- (let ((name (-rtx-hw-name hw hw-name index-arg)))
+ (let ((name (-rtx-hw-name hw hw-name-with-mode index-arg)))
(send result 'set-name! name)
(op:set-sem-name! result name))
(set! -rtx-macro-table (make-hash-table 127))
(set! -rtx-num-next 0)
(def-rtx-funcs)
+
+ ; Sanity checks.
+ ; All rtx take options for the first arg and a mode for the second.
+ (for-each (lambda (rtx-name)
+ (let ((rtx (rtx-lookup rtx-name)))
+ (if rtx
+ (begin
+ (if (null? (rtx-arg-types rtx))
+ #f ; pc is the one exception, blech
+ (begin
+ (assert (eq? (car (rtx-arg-types rtx)) 'OPTIONS))
+ (assert (memq (cadr (rtx-arg-types rtx)) -rtx-valid-mode-types)))))
+ #f) ; else a macro
+ ))
+ -rtx-name-list)
+
(reader-add-command! 'define-subr
"\
Define an rtx subroutine, name/value pair list version.
OSDN Git Service
