+2009-09-07 Doug Evans <dje@sebabeach.org>
+
+ * read.scm (rtl-version-equal?): New function.
+ (rtl-version-at-least?, rtl-version-older?): New functions.
+
+ * *.scm: Use / to prefix "local" vars/fns, for r6rs compliance.
+ * pmacros.scm (/pmacro-builtin-splice): Refer to $unsplice for
+ rtl versions >= 0.9.
+ (pmacros-init!): Tweak to prepare for $<pmacro> for builtin pmacros.
+
2009-09-03 Doug Evans <dje@sebabeach.org>
* rtl.scm (rtx-pretty-name): Fix thinko, don't assume (car rtx)
;;; RIGHT-TYPE? is a procedure that verifies the value is the right type.
;;; MESSAGE is printed if there is an error.
-(define (-parse-simple-attribute right-type? message)
+(define (/parse-simple-attribute right-type? message)
(lambda (self context val)
(if (and (not (null? val))
(right-type? (car val))
(method-make!
<boolean-attribute> 'parse-value
- (-parse-simple-attribute boolean? "boolean attribute not one of #f/#t")
+ (/parse-simple-attribute boolean? "boolean attribute not one of #f/#t")
)
(method-make!
<string-attribute> 'parse-value
- (-parse-simple-attribute string? "invalid argument to string attribute"))
+ (/parse-simple-attribute string? "invalid argument to string attribute"))
; A bitset attribute's value is a comma separated list of elements.
; We don't validate the values. In the case of the MACH attribute,
(method-make!
<bitset-attribute> 'parse-value
- (-parse-simple-attribute (lambda (x) (or (symbol? x) (string? x)))
+ (/parse-simple-attribute (lambda (x) (or (symbol? x) (string? x)))
"improper bitset attribute")
)
(method-make!
<integer-attribute> 'parse-value
- (-parse-simple-attribute (lambda (x) (or (number? x) (symbol? x)))
+ (/parse-simple-attribute (lambda (x) (or (number? x) (symbol? x)))
"improper integer attribute")
)
(method-make!
<enum-attribute> 'parse-value
- (-parse-simple-attribute (lambda (x) (or (symbol? x) (string? x)))
+ (/parse-simple-attribute (lambda (x) (or (symbol? x) (string? x)))
"improper enum attribute")
)
; If DEFAULT is #f, use the first value.
; ??? Allowable values for integer attributes is wip.
-(define (-attr-parse context type-class name comment attrs for default values)
+(define (/attr-parse context type-class name comment attrs for default values)
(logit 2 "Processing attribute " name " ...\n")
;; Pick out name first to augment the error context.
; This is the main routine for analyzing attributes in the .cpu file.
; CONTEXT is a <context> object for error messages.
; ARG-LIST is an associative list of field name and field value.
-; -attr-parse is invoked to create the attribute object.
+; /attr-parse is invoked to create the attribute object.
-(define (-attr-read context . arg-list)
+(define (/attr-read context . arg-list)
(let (
(type-class 'not-set) ; attribute type
(name #f)
)
; Now that we've identified the elements, build the object.
- (-attr-parse context type-class name comment attrs for default values))
+ (/attr-parse context type-class name comment attrs for default values))
)
; Main routines for defining attributes in .cpu files.
(define define-attr
(lambda arg-list
- (let ((a (apply -attr-read (cons (make-current-context "define-attr")
+ (let ((a (apply /attr-read (cons (make-current-context "define-attr")
arg-list))))
(current-attr-add! a)
a))
; OWNER is needed if an attribute is defined in terms of other attributes.
; If it's #f obviously ATVAL can't be defined in terms of others.
-(define (-attr-eval atval owner)
+(define (/attr-eval atval owner)
(let* ((estate (estate-make-for-eval #f owner))
(expr (rtx-compile #f (rtx-simplify #f owner atval nil) nil))
(value (rtx-eval-with-estate expr 'DFLT estate)))
(cond ((symbol? value) value)
((number? value) value)
- (error "-attr-eval: internal error, unsupported result:" value)))
+ (error "/attr-eval: internal error, unsupported result:" value)))
)
; Return value of ATTR in attribute alist ALIST.
(let ((a (assq-ref alist attr)))
(if a
(if (pair? a) ; pair? -> cheap non-null-list?
- (-attr-eval a owner)
+ (/attr-eval a owner)
a)
(attr-lookup-default attr owner)))
)
(let ((a (assq-ref (atlist-attrs atlist) attr)))
(if a
(if (pair? a) ; pair? -> cheap non-null-list?
- (-attr-eval a owner)
+ (/attr-eval a owner)
a)
nil))
)
(let ((deflt (attr-default at)))
(if deflt
(if (pair? deflt) ; pair? -> cheap non-null-list?
- (-attr-eval deflt owner)
+ (/attr-eval deflt owner)
deflt)
; If no default was provided, use the first value.
(caar (attr-values at)))))
; ATTR-OBJ-LIST is a list of <attribute> objects (always subclassed of course).
(define (attr-list-enum-list attr-obj-list)
- (let ((sorted-attrs (-attr-sort (attr-remove-meta-attrs attr-obj-list))))
+ (let ((sorted-attrs (/attr-sort (attr-remove-meta-attrs attr-obj-list))))
(assert (<= (length (car sorted-attrs)) 32))
(append!
(map (lambda (bool-attr)
; Boolean attributes appear as (NAME . #t/#f), non-boolean ones appear as
; (NAME . VALUE). Attributes of the same type are sorted by name.
-(define (-attr-sort-alist alist)
+(define (/attr-sort-alist alist)
(sort alist
(lambda (a b)
;(display (list a b "\n"))
; FIXME: Record index number with the INDEX attribute and sort on it.
; At present it's just a boolean.
-(define (-attr-sort attr-list)
+(define (/attr-sort attr-list)
(let loop ((fixed-non-bools nil)
(non-fixed-non-bools nil)
(fixed-bools nil)
(let ((accessor (lambda (elm) (atlist-attrs (accessor elm)))))
(attr-remove-meta-attrs-alist
(attr-nub
- (-attr-sort-alist
+ (/attr-sort-alist
(append
(apply append
(map (lambda (table-elm)
; FIXME: The output shouldn't be required to be sorted.
(define (current-attr-list-for type)
- (let ((sorted (-attr-sort (find (lambda (a)
+ (let ((sorted (/attr-sort (find (lambda (a)
(if (atlist-for a)
(memq type (atlist-for a))
#t))
; class-, object-, elm-, method-.
; The exceptions are make, new, parent, send.
\f
-(define -class-tag "class")
-(define -object-tag "object")
+(define /class-tag "class")
+(define /object-tag "object")
; List of all classes.
-(define -class-list '())
+(define /class-list '())
; ??? Were written as a procedures for Hobbit's sake (I think).
-(define -object-unspecified #:unspecified)
-(define -object-unbound #:unbound)
+(define /object-unspecified #:unspecified)
+(define /object-unbound #:unbound)
; Associative list of classes to be traced.
-(define -object-debug-classes #f)
+(define /object-debug-classes #f)
; Associative list of elements to be traced.
-(define -object-debug-elements #f)
+(define /object-debug-elements #f)
; Associative list of messages to be traced.
-(define -object-debug-methods #f)
+(define /object-debug-methods #f)
; True if error messages are verbose and debugging messages are printed.
-(define -object-verbose? #f)
+(define /object-verbose? #f)
; Cover fn to set verbosity.
(define (object-set-verbose! verbose?)
- (set! -object-verbose? verbose?)
+ (set! /object-verbose? verbose?)
)
; Signal error if not class/object.
-(define (-class-check maybe-class proc-name . extra-text)
+(define (/class-check maybe-class proc-name . extra-text)
(if (not (class? maybe-class))
- (apply -object-error
+ (apply /object-error
(append! (list proc-name maybe-class "not a class")
extra-text)))
- -object-unspecified
+ /object-unspecified
)
-(define (-object-check-name maybe-name proc-name . extra-text)
+(define (/object-check-name maybe-name proc-name . extra-text)
(if (not (symbol? maybe-name))
- (apply -object-error
+ (apply /object-error
(append! (list proc-name maybe-name) extra-text)))
- -object-unspecified
+ /object-unspecified
)
-(define (-object-check maybe-object proc-name . extra-text)
+(define (/object-check maybe-object proc-name . extra-text)
(if (not (object? maybe-object))
- (apply -object-error
+ (apply /object-error
(append! (list proc-name maybe-object "not an object")
extra-text)))
- -object-unspecified
+ /object-unspecified
)
; X is any arbitrary Scheme data.
-(define (-object-error proc-name x . text)
+(define (/object-error proc-name x . text)
(error (string-append proc-name ": " (apply string-append text)
(if (object? x)
(string-append
- " (class: " (-object-class-name x)
+ " (class: " (/object-class-name x)
(if (method-present? x 'get-name)
(string-append ", name: "
(send x 'get-name))
; Return boolean indicating if X is a class.
(define (class? class)
- (and (vector? class) (eq? -class-tag (vector-ref class 0)))
+ (and (vector? class) (eq? /class-tag (vector-ref class 0)))
)
; Accessors.
-(define (-class-name class) (vector-ref class 1))
-(define (-class-parents class) (vector-ref class 2))
-(define (-class-elements class) (vector-ref class 3))
-(define (-class-methods class) (vector-ref class 4))
-(define (-class-all-initial-values class) (vector-ref class 5))
-(define (-class-all-methods class) (vector-ref class 6))
-(define (-class-class-desc class) (vector-ref class 7))
+(define (/class-name class) (vector-ref class 1))
+(define (/class-parents class) (vector-ref class 2))
+(define (/class-elements class) (vector-ref class 3))
+(define (/class-methods class) (vector-ref class 4))
+(define (/class-all-initial-values class) (vector-ref class 5))
+(define (/class-all-methods class) (vector-ref class 6))
+(define (/class-class-desc class) (vector-ref class 7))
-(define (-class-set-parents! class parents)
+(define (/class-set-parents! class parents)
(vector-set! class 2 parents)
)
-(define (-class-set-elements! class elm-alist)
+(define (/class-set-elements! class elm-alist)
(vector-set! class 3 elm-alist)
)
-(define (-class-set-methods! class method-alist)
+(define (/class-set-methods! class method-alist)
(vector-set! class 4 method-alist)
)
-(define (-class-set-all-initial-values! class init-list)
+(define (/class-set-all-initial-values! class init-list)
(vector-set! class 5 init-list)
)
-(define (-class-set-all-methods! class all-meth-list)
+(define (/class-set-all-methods! class all-meth-list)
(vector-set! class 6 all-meth-list)
)
-(define (-class-set-class-desc! class parent-list)
+(define (/class-set-class-desc! class parent-list)
(vector-set! class 7 parent-list)
)
; Make a class.
; The new definition overrides any existing definition.
-(define (-class-make! name parents elements methods)
- (let ((class (vector -class-tag name parents elements methods #f #f #f))
- (list-entry (assq name -class-list)))
+(define (/class-make! name parents elements methods)
+ (let ((class (vector /class-tag name parents elements methods #f #f #f))
+ (list-entry (assq name /class-list)))
(if list-entry
(set-cdr! list-entry class)
- (set! -class-list (acons name class -class-list)))
+ (set! /class-list (acons name class /class-list)))
class)
)
; Lookup a class given its name.
; The result is the class or #f if not found.
-(define (class-lookup name) (assq-ref -class-list name))
+(define (class-lookup name) (assq-ref /class-list name))
; Return a list of all direct parent classes of CLASS.
-(define (-class-parent-classes class)
- ; -class-parents returns the names, we want the actual classes.
- (let loop ((parents (-class-parents class))
+(define (/class-parent-classes class)
+ ; /class-parents returns the names, we want the actual classes.
+ (let loop ((parents (/class-parents class))
(result '()))
(if (null? parents)
(reverse! result)
(if (not parent)
; The proc name we pass here is made up as we don't
; want it to be the name of an internal proc.
- (-object-error "class" (car parents) "not a class"))
+ (/object-error "class" (car parents) "not a class"))
(loop (cdr parents) (cons parent result)))))
)
-; Cover proc of -class-name for the outside world to use.
+; Cover proc of /class-name for the outside world to use.
; The result is the name of the class or #f if CLASS is not a class.
; We could issue an error here, but to be consistent with object-class-name
; we don't.
(define (class-name class)
(if (class? class)
- (-class-name class)
+ (/class-name class)
#f)
)
; Return a boolean indicating if CLASS or any parent class has
; multiple inheritance.
-(define (-class-mi? class)
- (-class-desc-mi? (-class-class-desc class))
+(define (/class-mi? class)
+ (/class-desc-mi? (/class-class-desc class))
)
\f
; Class descriptor utilities.
; A class-descriptor is:
; (class mi? (base-offset . delta) child-backpointer (parent1-entry) ...)
-;(define (-class-desc-make class offset bkptr parents)
+;(define (/class-desc-make class offset bkptr parents)
; (append (list class offset bkptr) parents)
;)
-(define (-class-desc? maybe-class-desc)
+(define (/class-desc? maybe-class-desc)
(and (pair? maybe-class-desc)
(class? (car maybe-class-desc)))
)
-(define -class-desc-class car)
-(define -class-desc-mi? cadr)
-(define -class-desc-offset caddr)
-(define -class-desc-offset-base caaddr)
-(define -class-desc-offset-delta cdaddr)
-(define -class-desc-child cadddr)
-(define -class-desc-parents cddddr)
+(define /class-desc-class car)
+(define /class-desc-mi? cadr)
+(define /class-desc-offset caddr)
+(define /class-desc-offset-base caaddr)
+(define /class-desc-offset-delta cdaddr)
+(define /class-desc-child cadddr)
+(define /class-desc-parents cddddr)
; Note that this is an assq on the classes themselves, not their names.
; The result is the parent's class-descriptor.
-(define -class-desc-lookup-parent assq)
+(define /class-desc-lookup-parent assq)
; Compute the class descriptor of CLASS.
; OFFSET is the beginning offset in the element vector.
; CHILD is the backlink to the direct child class or #f for the top class.
; ??? Is the use of `top' backwards from traditional usage?
-(define (-class-compute-class-desc class offset child)
+(define (/class-compute-class-desc class offset child)
; OFFSET must be global to the calculation because it is continually
; incremented as we recurse down through the hierarchy (actually, as we
; The correct values are set later.
(let ((result (list class #f (cons 999 999) child))
- (mi? (> (length (-class-parents class)) 1)))
+ (mi? (> (length (/class-parents class)) 1)))
; Recurse on the parents.
; We use `append!' here as the location of `result' is now fixed so
; that our parent's child-backpointer remains stable.
(append! result
- (let loop ((parents (-class-parents class))
+ (let loop ((parents (/class-parents class))
(parent-descs '())
(base-offset base-offset))
(if (null? parents)
(if (not parent)
; The proc name we pass here is made up as we don't
; want it to be the name of an internal proc.
- (-object-error "class" (car parents) "not a class"))
+ (/object-error "class" (car parents) "not a class"))
(if (and (not mi?)
- (-class-mi? parent))
+ (/class-mi? parent))
(set! mi? #t))
(let ((parent-desc (compute1 parent result base-offset)))
(loop (cdr parents)
(list-set! result 1 mi?)
(list-set! result 2 (cons base-offset (- offset base-offset)))
- (set! offset (+ offset (length (-class-elements class))))
+ (set! offset (+ offset (length (/class-elements class))))
result))
(compute1 class child offset)
; Return the top level class-descriptor of CLASS-DESC.
-(define (-class-desc-top class-desc)
- (if (-class-desc-child class-desc)
- (-class-desc-top (-class-desc-child class-desc))
+(define (/class-desc-top class-desc)
+ (if (/class-desc-child class-desc)
+ (/class-desc-top (/class-desc-child class-desc))
class-desc)
)
(define (class-desc-dump class-desc)
(let* ((cep (current-error-port))
- (top-desc (-class-desc-top class-desc))
+ (top-desc (/class-desc-top class-desc))
(spaces (lambda (n port)
(display (make-string n #\space) port)))
(writeln (lambda (indent port . args)
)
(letrec ((dump (lambda (cd indent)
(writeln indent cep "Class: "
- (-class-name (-class-desc-class cd)))
+ (/class-name (/class-desc-class cd)))
(writeln indent cep " mi?: "
- (-class-desc-mi? cd))
+ (/class-desc-mi? cd))
(writeln indent cep " base offset: "
- (-class-desc-offset-base cd))
+ (/class-desc-offset-base cd))
(writeln indent cep " delta: "
- (-class-desc-offset-delta cd))
+ (/class-desc-offset-delta cd))
(writeln indent cep " child: "
- (if (-class-desc-child cd)
- (-class-name (-class-desc-class
- (-class-desc-child cd)))
+ (if (/class-desc-child cd)
+ (/class-name (/class-desc-class
+ (/class-desc-child cd)))
"-top-"))
(for-each (lambda (parent-cd) (dump parent-cd (+ indent 4)))
- (-class-desc-parents cd))
+ (/class-desc-parents cd))
)))
(display "Top level class: " cep)
- (display (-class-name (-class-desc-class top-desc)) cep)
+ (display (/class-name (/class-desc-class top-desc)) cep)
(newline cep)
(dump class-desc 0)
))
; Make an object.
; All elements get initial (or unbound) values.
-(define (-object-make! class)
- (-class-check-init! class)
- (vector (apply vector (append! (list -object-tag class)
- (-class-all-initial-values class)))
- (-class-class-desc class))
+(define (/object-make! class)
+ (/class-check-init! class)
+ (vector (apply vector (append! (list /object-tag class)
+ (/class-all-initial-values class)))
+ (/class-class-desc class))
)
; Make an object using VALUES.
; VALUES must specify all elements in the class (and parent classes).
-(define (-object-make-with-values! class class-desc values)
- (-class-check-init! class)
- (vector (apply vector (append! (list -object-tag class) values))
+(define (/object-make-with-values! class class-desc values)
+ (/class-check-init! class)
+ (vector (apply vector (append! (list /object-tag class) values))
class-desc)
)
; discarded.
; WARNING: A shallow copy is currently done on the elements!
-(define (-object-copy obj top?)
+(define (/object-copy obj top?)
(if top?
- (vector (-object-vector-copy (-object-elements obj))
- (-class-class-desc (-object-top-class obj)))
- (vector (-object-vector-copy (-object-elements obj))
- (-object-class-desc obj)))
+ (vector (/object-vector-copy (/object-elements obj))
+ (/class-class-desc (/object-top-class obj)))
+ (vector (/object-vector-copy (/object-elements obj))
+ (/object-class-desc obj)))
)
; Specialize an object to be one from a parent class.
; The result is the same object, but with a different view (confined to
; a particular parent class).
-(define (-object-specialize obj class-desc)
- (vector (-object-elements obj) class-desc)
+(define (/object-specialize obj class-desc)
+ (vector (/object-elements obj) class-desc)
)
; Accessors.
-(define (-object-elements obj) (vector-ref obj 0))
-(define (-object-class-desc obj) (vector-ref obj 1))
-(define (-object-class obj) (-class-desc-class (-object-class-desc obj)))
-(define (-object-class-name obj) (-class-name (-object-class obj)))
-(define (-object-top-class obj) (vector-ref (-object-elements obj) 1))
+(define (/object-elements obj) (vector-ref obj 0))
+(define (/object-class-desc obj) (vector-ref obj 1))
+(define (/object-class obj) (/class-desc-class (/object-class-desc obj)))
+(define (/object-class-name obj) (/class-name (/object-class obj)))
+(define (/object-top-class obj) (vector-ref (/object-elements obj) 1))
-(define (-object-elm-get obj class-desc elm-base-offset)
- (vector-ref (-object-elements obj)
- (+ (-class-desc-offset-base class-desc) elm-base-offset))
+(define (/object-elm-get obj class-desc elm-base-offset)
+ (vector-ref (/object-elements obj)
+ (+ (/class-desc-offset-base class-desc) elm-base-offset))
)
-(define (-object-elm-set! obj class-desc elm-base-offset new-val)
- (vector-set! (-object-elements obj)
- (+ (-class-desc-offset-base class-desc) elm-base-offset)
+(define (/object-elm-set! obj class-desc elm-base-offset new-val)
+ (vector-set! (/object-elements obj)
+ (+ (/class-desc-offset-base class-desc) elm-base-offset)
new-val)
- -object-unspecified
+ /object-unspecified
)
; Return a boolean indicating of OBJ has multiple-inheritance.
-(define (-object-mi? obj)
- (-class-mi? (-object-top-class obj))
+(define (/object-mi? obj)
+ (/class-mi? (/object-top-class obj))
)
; Return boolean indicating if X is an object.
(and (vector? obj)
(= (vector-length obj) 2)
(vector? (vector-ref obj 0))
- (eq? -object-tag (vector-ref (vector-ref obj 0) 0))
- (-class-desc? (vector-ref obj 1)))
+ (eq? /object-tag (vector-ref (vector-ref obj 0) 0))
+ (/class-desc? (vector-ref obj 1)))
)
; Return the class of an object.
(define (object-class obj)
- (-object-check obj "object-class")
- (-object-class obj)
+ (/object-check obj "object-class")
+ (/object-class obj)
)
-; Cover proc of -object-class-name for the outside world to use.
+; Cover proc of /object-class-name for the outside world to use.
; The result is the name of the class or #f if OBJ is not an object.
(define (object-class-name obj)
(if (object? obj)
- (-object-class-name obj)
+ (/object-class-name obj)
#f)
)
\f
; Return the list of initial values for CLASS.
; The result does not include parent classes.
-(define (-class-my-initial-values class)
- (map cadr (-class-elements class))
+(define (/class-my-initial-values class)
+ (map cadr (/class-elements class))
)
; Initialize class if not already done.
; FIXME: Need circularity check. Later.
-(define (-class-check-init! class)
+(define (/class-check-init! class)
; This should be fast the second time through, so don't do any
; computation until we know it's necessary.
- (if (not (-class-all-initial-values class))
+ (if (not (/class-all-initial-values class))
(begin
; First pass ensures all parents are initialized.
- (for-each -class-check-init!
- (-class-parent-classes class))
+ (for-each /class-check-init!
+ (/class-parent-classes class))
; Next pass initializes the initial value list.
(letrec ((get-inits
(lambda (class)
- (let ((parents (-class-parent-classes class)))
+ (let ((parents (/class-parent-classes class)))
(append (apply append (map get-inits parents))
- (-class-my-initial-values class))))))
+ (/class-my-initial-values class))))))
- (let* ((parents (-class-parent-classes class))
+ (let* ((parents (/class-parent-classes class))
(inits (append (apply append (map get-inits parents))
- (-class-my-initial-values class))))
- (-class-set-all-initial-values! class inits)))
+ (/class-my-initial-values class))))
+ (/class-set-all-initial-values! class inits)))
; Next pass initializes the class's class-descriptor.
; Object elements begin at offset 2 in the element vector.
- (-class-set-class-desc! class
- (-class-compute-class-desc class 2 #f))
+ (/class-set-class-desc! class
+ (/class-compute-class-desc class 2 #f))
))
- -object-unspecified
+ /object-unspecified
)
; Make a class.
(+ index 1)
(cdr elms))
(loop (acons (car elms)
- (cons -object-unbound (cons #f index))
+ (cons /object-unbound (cons #f index))
elm-list-tmp)
(+ index 1)
(cdr elms)))))
- (let ((result (-class-make! name parents elm-list methods)))
+ (let ((result (/class-make! name parents elm-list methods)))
; Create the standard `make!' method.
; The caller can override afterwards if desired.
(let ((self (car args)))
; Ensure exactly all of the elements are provided.
(if (not (= (length args)
- (- (vector-length (-object-elements self)) 1)))
- (-object-error "make!" "" "wrong number of arguments to method `make!'"))
- (-object-make-with-values! (-object-top-class self)
- (-object-class-desc self)
+ (- (vector-length (/object-elements self)) 1)))
+ (/object-error "make!" "" "wrong number of arguments to method `make!'"))
+ (/object-make-with-values! (/object-top-class self)
+ (/object-class-desc self)
(cdr args)))))
result))
; Create an object of a class CLASS.
(define (new class)
- (-class-check class "new")
+ (/class-check class "new")
- (if -object-verbose?
- (display (string-append "Instantiating class " (-class-name class) ".\n")
+ (if /object-verbose?
+ (display (string-append "Instantiating class " (/class-name class) ".\n")
(current-error-port)))
- (-object-make! class)
+ (/object-make! class)
)
; Make a copy of OBJ.
; WARNING: A shallow copy is done on the elements!
(define (object-copy obj)
- (-object-check obj "object-copy")
- (-object-copy obj #f)
+ (/object-check obj "object-copy")
+ (/object-copy obj #f)
)
; Make a copy of OBJ.
; WARNING: A shallow copy is done on the elements!
(define (object-copy-top obj)
- (-object-check obj "object-copy-top")
- (-object-copy obj #t)
+ (/object-check obj "object-copy-top")
+ (/object-copy obj #t)
)
; Utility to define a standard `make!' method.
; Return #t if class X is a subclass of BASE-NAME.
-(define (-class-subclass? base-name x)
- (if (eq? base-name (-class-name x))
+(define (/class-subclass? base-name x)
+ (if (eq? base-name (/class-name x))
#t
- (let loop ((parents (-class-parents x)))
+ (let loop ((parents (/class-parents x)))
(if (null? parents)
#f
- (if (-class-subclass? base-name (class-lookup (car parents)))
+ (if (/class-subclass? base-name (class-lookup (car parents)))
#t
(loop (cdr parents))))))
)
; intended to be used in class predicates.
(define (class-instance? class object)
- (-class-check class "class-instance?")
+ (/class-check class "class-instance?")
(if (object? object)
- (-class-subclass? (-class-name class) (-object-class object))
+ (/class-subclass? (/class-name class) (/object-class object))
#f)
)
\f
; ??? We could define accessors of the result but knowledge of its format
; is restricted to this section of the source.
-(define (-class-lookup-element class-desc elm-name)
- (let* ((class (-class-desc-class class-desc))
- (elm (assq elm-name (-class-elements class))))
+(define (/class-lookup-element class-desc elm-name)
+ (let* ((class (/class-desc-class class-desc))
+ (elm (assq elm-name (/class-elements class))))
(if elm
(cons class-desc (cddr elm))
- (let loop ((parents (-class-desc-parents class-desc)))
+ (let loop ((parents (/class-desc-parents class-desc)))
(if (null? parents)
#f
- (let ((elm (-class-lookup-element (car parents) elm-name)))
+ (let ((elm (/class-lookup-element (car parents) elm-name)))
(if elm
elm
(loop (cdr parents)))))
)
)
-; Given the result of -class-lookup-element, return the element's delta
+; Given the result of /class-lookup-element, return the element's delta
; from base-offset.
-(define (-elm-delta index)
- (+ (-class-desc-offset-delta (car index))
+(define (/elm-delta index)
+ (+ (/class-desc-offset-delta (car index))
(cddr index))
)
; Return a boolean indicating if ELM is bound in OBJ.
(define (elm-bound? obj elm)
- (-object-check obj "elm-bound?")
- (let* ((index (-class-lookup-element (-object-class-desc obj) elm))
- (val (-object-elm-get obj (car index) (-elm-delta index))))
- (not (eq? val -object-unbound)))
+ (/object-check obj "elm-bound?")
+ (let* ((index (/class-lookup-element (/object-class-desc obj) elm))
+ (val (/object-elm-get obj (car index) (/elm-delta index))))
+ (not (eq? val /object-unbound)))
)
; Subroutine of elm-get.
-(define (-elm-make-method-getter self name)
- (-object-check self "elm-get")
- (let ((index (-class-lookup-element (-object-class-desc self) name)))
+(define (/elm-make-method-getter self name)
+ (/object-check self "elm-get")
+ (let ((index (/class-lookup-element (/object-class-desc self) name)))
(if index
(procedure->memoizing-macro
(lambda (exp env)
`(lambda (obj)
- (-object-elm-get obj (-object-class-desc obj)
- ,(-elm-delta index)))))
- (-object-error "elm-get" self "element not present: " name)))
+ (/object-elm-get obj (/object-class-desc obj)
+ ,(/elm-delta index)))))
+ (/object-error "elm-get" self "element not present: " name)))
)
; Get an element from an object.
(defmacro elm-get (self name)
(if (eq? self 'self)
- `(((-elm-make-method-getter ,self ,name)) ,self)
+ `(((/elm-make-method-getter ,self ,name)) ,self)
`(elm-xget ,self ,name))
)
; Subroutine of elm-set!.
-(define (-elm-make-method-setter self name)
- (-object-check self "elm-set!")
- (let ((index (-class-lookup-element (-object-class-desc self) name)))
+(define (/elm-make-method-setter self name)
+ (/object-check self "elm-set!")
+ (let ((index (/class-lookup-element (/object-class-desc self) name)))
(if index
(procedure->memoizing-macro
(lambda (exp env)
`(lambda (obj new-val)
- (-object-elm-set! obj (-object-class-desc obj)
- ,(-elm-delta index) new-val))))
- (-object-error "elm-set!" self "element not present: " name)))
+ (/object-elm-set! obj (/object-class-desc obj)
+ ,(/elm-delta index) new-val))))
+ (/object-error "elm-set!" self "element not present: " name)))
)
; Set an element in an object.
(defmacro elm-set! (self name new-val)
(if (eq? self 'self)
- `(((-elm-make-method-setter ,self ,name)) ,self ,new-val)
+ `(((/elm-make-method-setter ,self ,name)) ,self ,new-val)
`(elm-xset! ,self ,name ,new-val))
)
; use elm-make-getter. It should be used sparingly.
(define (elm-xget obj name)
- (-object-check obj "elm-xget")
- (let ((index (-class-lookup-element (-object-class-desc obj) name)))
+ (/object-check obj "elm-xget")
+ (let ((index (/class-lookup-element (/object-class-desc obj) name)))
; FIXME: check private?
(if index
- (-object-elm-get obj (car index) (-elm-delta index))
- (-object-error "elm-xget" obj "element not present: " name)))
+ (/object-elm-get obj (car index) (/elm-delta index))
+ (/object-error "elm-xget" obj "element not present: " name)))
)
; Set an element in an object.
; use elm-make-setter. It should be used sparingly.
(define (elm-xset! obj name new-val)
- (-object-check obj "elm-xset!")
- (let ((index (-class-lookup-element (-object-class-desc obj) name)))
+ (/object-check obj "elm-xset!")
+ (let ((index (/class-lookup-element (/object-class-desc obj) name)))
; FIXME: check private?
(if index
- (-object-elm-set! obj (car index) (-elm-delta index) new-val)
- (-object-error "elm-xset!" obj "element not present: " name)))
+ (/object-elm-set! obj (car index) (/elm-delta index) new-val)
+ (/object-error "elm-xset!" obj "element not present: " name)))
)
; Return a boolean indicating if object OBJ has element NAME.
(define (elm-present? obj name)
- (-object-check obj "elm-present?")
- (->bool (-class-lookup-element (-object-class-desc obj) name))
+ (/object-check obj "elm-present?")
+ (->bool (/class-lookup-element (/object-class-desc obj) name))
)
; Return lambda to get element NAME in CLASS.
; FIXME: validate name.
(define (elm-make-getter class name)
- (-class-check class "elm-make-getter")
+ (/class-check class "elm-make-getter")
; We use delay here as we can't assume parent classes have been
; initialized yet.
- (let ((fast-index (delay (-class-lookup-element
- (-class-class-desc class) name))))
+ (let ((fast-index (delay (/class-lookup-element
+ (/class-class-desc class) name))))
(lambda (obj)
; ??? Should be able to use fast-index in mi case.
; ??? Need to involve CLASS in lookup.
- (let ((index (if (-object-mi? obj)
- (-class-lookup-element (-object-class-desc obj) name)
+ (let ((index (if (/object-mi? obj)
+ (/class-lookup-element (/object-class-desc obj) name)
(force fast-index))))
- (-object-elm-get obj (car index) (-elm-delta index)))))
+ (/object-elm-get obj (car index) (/elm-delta index)))))
)
; Return lambda to set element NAME in CLASS.
; FIXME: validate name.
(define (elm-make-setter class name)
- (-class-check class "elm-make-setter")
+ (/class-check class "elm-make-setter")
; We use delay here as we can't assume parent classes have been
; initialized yet.
- (let ((fast-index (delay (-class-lookup-element
- (-class-class-desc class) name))))
+ (let ((fast-index (delay (/class-lookup-element
+ (/class-class-desc class) name))))
(lambda (obj newval)
; ??? Should be able to use fast-index in mi case.
; ??? Need to involve CLASS in lookup.
- (let ((index (if (-object-mi? obj)
- (-class-lookup-element (-object-class-desc obj) name)
+ (let ((index (if (/object-mi? obj)
+ (/class-lookup-element (/object-class-desc obj) name)
(force fast-index))))
- (-object-elm-set! obj (car index) (-elm-delta index) newval))))
+ (/object-elm-set! obj (car index) (/elm-delta index) newval))))
)
; Return a list of all elements in OBJ.
(define (elm-list obj)
- (cddr (vector->list (-object-elements obj)))
+ (cddr (vector->list (/object-elements obj)))
)
\f
; Method operations.
; ??? What should this do for virtual methods. At present we treat them as
; non-virtual.
-(define (-method-lookup-next class-desc method-name)
- (let loop ((parents (-class-desc-parents class-desc)))
+(define (/method-lookup-next class-desc method-name)
+ (let loop ((parents (/class-desc-parents class-desc)))
(if (null? parents)
#f
- (let ((meth (-method-lookup (car parents) method-name #f)))
+ (let ((meth (/method-lookup (car parents) method-name #f)))
(if meth
meth
(loop (cdr parents))))))
;
; FIXME: We don't yet implement the method cache.
-(define (-method-lookup class-desc method-name virtual?)
- (if -object-verbose?
+(define (/method-lookup class-desc method-name virtual?)
+ (if /object-verbose?
(display (string-append "Looking up method " method-name " in "
- (-class-name (-class-desc-class class-desc)) ".\n")
+ (/class-name (/class-desc-class class-desc)) ".\n")
(current-error-port)))
- (let ((meth (assq method-name (-class-methods (-class-desc-class class-desc)))))
+ (let ((meth (assq method-name (/class-methods (/class-desc-class class-desc)))))
(if meth
(if (and virtual? (cadr meth)) ; virtual?
; Traverse back up the inheritance chain looking for overriding
; methods. The closest one to the top is the one to use.
- (let loop ((child (-class-desc-child class-desc))
+ (let loop ((child (/class-desc-child class-desc))
(goal-class-desc class-desc)
(goal-meth meth))
(if child
(begin
- (if -object-verbose?
+ (if /object-verbose?
(display (string-append "Looking up virtual method "
method-name " in "
- (-class-name (-class-desc-class child))
+ (/class-name (/class-desc-class child))
".\n")
(current-error-port)))
- (let ((meth (assq method-name (-class-methods (-class-desc-class child)))))
+ (let ((meth (assq method-name (/class-methods (/class-desc-class child)))))
(if meth
; Method found, update goal object and method.
- (loop (-class-desc-child child) child meth)
+ (loop (/class-desc-child child) child meth)
; Method not found at this level.
- (loop (-class-desc-child child) goal-class-desc goal-meth))))
+ (loop (/class-desc-child child) goal-class-desc goal-meth))))
; Went all the way up to the top.
(cons goal-class-desc (cddr goal-meth))))
; Non-virtual, done.
(cons class-desc (cddr meth)))
; Method not found, search parents.
- (-method-lookup-next class-desc method-name)))
+ (/method-lookup-next class-desc method-name)))
)
; Return a boolean indicating if object OBJ has method NAME.
(define (method-present? obj name)
- (-object-check obj "method-present?")
- (->bool (-method-lookup (-object-class-desc obj) name #f))
+ (/object-check obj "method-present?")
+ (->bool (/method-lookup (/object-class-desc obj) name #f))
)
; Return method NAME of CLASS or #f if not present.
; ??? Assumes CLASS has been initialized.
(define (method-proc class name)
- (-class-check class "method-proc")
- (let ((meth (-method-lookup (-class-class-desc class) name #t)))
+ (/class-check class "method-proc")
+ (let ((meth (/method-lookup (/class-class-desc class) name #t)))
(if meth
(cdr meth)
#f))
; FIXME: ensure method-name is a symbol
(define (method-make! class method-name method)
- (-class-check class "method-make!")
+ (/class-check class "method-make!")
(if (not (procedure? method))
- (-object-error "method-make!" method "method must be a procedure"))
- (-class-set-methods! class (acons method-name
+ (/object-error "method-make!" method "method must be a procedure"))
+ (/class-set-methods! class (acons method-name
(cons #f method)
- (-class-methods class)))
- -object-unspecified
+ (/class-methods class)))
+ /object-unspecified
)
; Add a virtual method to a class.
; FIXME: ensure method-name is a symbol
(define (method-make-virtual! class method-name method)
- (-class-check class "method-make-virtual!")
+ (/class-check class "method-make-virtual!")
(if (not (procedure? method))
- (-object-error "method-make-virtual!" method "method must be a procedure"))
- (-class-set-methods! class (acons method-name
+ (/object-error "method-make-virtual!" method "method must be a procedure"))
+ (/class-set-methods! class (acons method-name
(cons #t method)
- (-class-methods class)))
- -object-unspecified
+ (/class-methods class)))
+ /object-unspecified
)
; Utility to create "forwarding" methods.
(cons (quote ,method-name)
(cdr args))))))))
methods)
- -object-unspecified
+ /object-unspecified
)
; Same as method-make-forward! but creates virtual methods.
(cons (quote ,method-name)
(cdr args))))))))
methods)
- -object-unspecified
+ /object-unspecified
)
; Utility of send, send-next.
-(define (-object-method-notify obj method-name maybe-next)
- (set! -object-verbose? #f)
+(define (/object-method-notify obj method-name maybe-next)
+ (set! /object-verbose? #f)
(display (string-append "Sending " maybe-next method-name " to"
(if (method-present? obj 'get-name)
(let ((name (send obj 'get-name)))
"")
" class " (object-class-name obj) ".\n")
(current-error-port))
- (set! -object-verbose? #t)
+ (set! /object-verbose? #t)
)
; Invoke a method in an object.
; a better name for this operation.
(define (send obj method-name . args)
- (-object-check obj "send")
- (-object-check-name method-name "send" "not a method name")
- (if -object-verbose? (-object-method-notify obj method-name ""))
+ (/object-check obj "send")
+ (/object-check-name method-name "send" "not a method name")
+ (if /object-verbose? (/object-method-notify obj method-name ""))
- (let ((class-desc.meth (-method-lookup (-object-class-desc obj)
+ (let ((class-desc.meth (/method-lookup (/object-class-desc obj)
method-name #t)))
(if class-desc.meth
(apply (cdr class-desc.meth)
- (cons (-object-specialize obj (car class-desc.meth))
+ (cons (/object-specialize obj (car class-desc.meth))
args))
- (-object-error "send" obj "method not supported: " method-name)))
+ (/object-error "send" obj "method not supported: " method-name)))
)
; Invoke the next method named METHOD-NAME in the heirarchy of OBJ.
; removed with a bit of effort, but is it worth it?
(define (send-next obj method-name . args)
- (-object-check obj "send-next")
- (-object-check-name method-name "send-next" "not a method name")
- (if -object-verbose? (-object-method-notify obj method-name "next "))
+ (/object-check obj "send-next")
+ (/object-check-name method-name "send-next" "not a method name")
+ (if /object-verbose? (/object-method-notify obj method-name "next "))
- (let ((class-desc.meth (-method-lookup-next (-object-class-desc obj)
+ (let ((class-desc.meth (/method-lookup-next (/object-class-desc obj)
method-name)))
(if class-desc.meth
(apply (cdr class-desc.meth)
- (cons (-object-specialize obj (car class-desc.meth))
+ (cons (/object-specialize obj (car class-desc.meth))
args))
- (-object-error "send-next" obj "method not supported: " method-name)))
+ (/object-error "send-next" obj "method not supported: " method-name)))
)
\f
; Parent operations.
; Subroutine of `parent' to lookup a (potentially nested) parent class.
; The result is the parent's class-descriptor or #f if not found.
-(define (-class-parent class-desc parent)
- (let* ((parent-descs (-class-desc-parents class-desc))
- (desc (-class-desc-lookup-parent parent parent-descs)))
+(define (/class-parent class-desc parent)
+ (let* ((parent-descs (/class-desc-parents class-desc))
+ (desc (/class-desc-lookup-parent parent parent-descs)))
(if desc
desc
(let loop ((parents parent-descs))
(if (null? parents)
#f
- (let ((desc (-class-parent (car parents) parent)))
+ (let ((desc (/class-parent (car parents) parent)))
(if desc
desc
(loop (cdr parents))))))))
; The result is the parent's class-descriptor or #f if not found.
; For completeness' sake, if PARENT-PATH is empty, CLASS-DESC is returned.
-(define (-class-parent-via-path class-desc parent-path)
+(define (/class-parent-via-path class-desc parent-path)
(if (null? parent-path)
class-desc
- (let ((desc (-class-desc-lookup-parent (car parent-path)
- (-class-desc-parents class-desc))))
+ (let ((desc (/class-desc-lookup-parent (car parent-path)
+ (/class-desc-parents class-desc))))
(if desc
(if (null? (cdr parent-path))
desc
- (-class-parent-via-path (car desc) (cdr parent-path)))
+ (/class-parent-via-path (car desc) (cdr parent-path)))
#f)))
)
; The result is OBJ, specialized to the found parent.
(define (object-parent obj class)
- (-object-check obj "object-parent")
+ (/object-check obj "object-parent")
(cond ((class? class) #t)
- ((list? class) (for-each (lambda (class) (-class-check class
+ ((list? class) (for-each (lambda (class) (/class-check class
"object-parent"))
class))
- (else (-object-error "object-parent" class "invalid parent path")))
+ (else (/object-error "object-parent" class "invalid parent path")))
; Hobbit generates C code that passes the function
- ; -class-parent-via-path or -class-parent, not the appropriate
+ ; /class-parent-via-path or /class-parent, not the appropriate
; SCM object.
; (let ((result ((if (or (null? class) (pair? class))
-; -class-parent-via-path
-; -class-parent)
+; /class-parent-via-path
+; /class-parent)
; obj class)))
; So it's rewritten like this.
(let ((result (if (class? class)
- (-class-parent (-object-class-desc obj) class)
- (-class-parent-via-path (-object-class-desc obj) class))))
+ (/class-parent (/object-class-desc obj) class)
+ (/class-parent-via-path (/object-class-desc obj) class))))
(if result
- (-object-specialize obj result)
- (-object-error "object-parent" obj "parent not present")))
+ (/object-specialize obj result)
+ (/object-error "object-parent" obj "parent not present")))
; FIXME: should print path in error message.
)
; method lookup).
(define (class-cons-parent! class parent-name)
- (-class-check class "class-cons-parent!")
- (-object-check-name parent-name "class-cons-parent!" "not a class name")
- (-class-set-parents! class (cons parent-name (-class-parents class)))
- -object-unspecified
+ (/class-check class "class-cons-parent!")
+ (/object-check-name parent-name "class-cons-parent!" "not a class name")
+ (/class-set-parents! class (cons parent-name (/class-parents class)))
+ /object-unspecified
)
; Make PARENT-NAME a parent of CLASS, cons'd unto the end of the search order.
; method lookup).
(define (class-append-parent! class parent-name)
- (-class-check class "class-append-parent!")
- (-object-check-name parent-name "class-append-parent!" "not a class name")
- (-class-set-parents! obj (append (-class-parents obj) (list parent-name)))
- -object-unspecified
+ (/class-check class "class-append-parent!")
+ (/object-check-name parent-name "class-append-parent!" "not a class name")
+ (/class-set-parents! obj (append (/class-parents obj) (list parent-name)))
+ /object-unspecified
)
\f
; Miscellaneous publically accessible utilities.
; Reset the object system (delete all classes).
(define (object-reset!)
- (set! -class-list '())
- -object-unspecified
+ (set! /class-list '())
+ /object-unspecified
)
; Call once to initialize the object system.
(define (object-init!)
(for-each (lambda (class)
- (-class-set-all-initial-values! class #f)
- (-class-set-all-methods! class #f)
- (-class-set-class-desc! class #f))
+ (/class-set-all-initial-values! class #f)
+ (/class-set-all-methods! class #f)
+ (/class-set-class-desc! class #f))
(class-list))
(for-each (lambda (class)
- (-class-check-init! class))
+ (/class-check-init! class))
(class-list))
- -object-unspecified
+ /object-unspecified
)
; Return list of all classes.
-(define (class-list) (map cdr -class-list))
+(define (class-list) (map cdr /class-list))
; Utility to map over a class and all its parent classes, recursively.
(define (class-map-over-class proc class)
(cons (proc class)
(map (lambda (class) (class-map-over-class proc class))
- (-class-parent-classes class)))
+ (/class-parent-classes class)))
)
; Return class tree of a class or object.
(cond ((class? class-or-object)
(class-map-over-class class-name class-or-object))
((object? class-or-object)
- (class-map-over-class class-name (-object-class class-or-object)))
- (else (-object-error "class-tree" class-or-object
+ (class-map-over-class class-name (/object-class class-or-object)))
+ (else (/object-error "class-tree" class-or-object
"not a class or object")))
)
; Return names of each alist.
-(define (-class-alist-names class)
- (list (-class-name class)
- (map car (-class-elements class))
- (map car (-class-methods class)))
+(define (/class-alist-names class)
+ (list (/class-name class)
+ (map car (/class-elements class))
+ (map car (/class-methods class)))
)
; Return complete layout of class-or-object.
(define (class-layout class-or-object)
(cond ((class? class-or-object)
- (class-map-over-class -class-alist-names class-or-object))
+ (class-map-over-class /class-alist-names class-or-object))
((object? class-or-object)
- (class-map-over-class -class-alist-names (-object-class class-or-object)))
- (else (-object-error "class-layout" class-or-object
+ (class-map-over-class /class-alist-names (/object-class class-or-object)))
+ (else (/object-error "class-layout" class-or-object
"not a class or object")))
)
; FIXME: Need deep copier instead.
(if (defined? 'vector-copy)
- (define -object-vector-copy vector-copy)
- (define (-object-vector-copy v) (list->vector (vector->list v)))
+ (define /object-vector-copy vector-copy)
+ (define (/object-vector-copy v) (list->vector (vector->list v)))
)
\f
; Profiling support
(proc-profile elm-get)
(proc-profile elm-xset!)
(proc-profile elm-present?)
- (proc-profile -method-lookup)
+ (proc-profile /method-lookup)
(proc-profile send)
(proc-profile new)
(proc-profile make)
;
; Main procedure call tree:
; decode-build-table
-; -build-slots
-; -build-decode-table-guts
-; -build-decode-table-entry
-; -build-slots
-; -build-decode-table-guts
+; /build-slots
+; /build-decode-table-guts
+; /build-decode-table-entry
+; /build-slots
+; /build-decode-table-guts
;
-; -build-slots/-build-decode-table-guts are recursively called to construct a
+; /build-slots//build-decode-table-guts are recursively called to construct a
; tree of "table-guts" elements, and then the application recurses on the
; result. For example see sim-decode.scm.
;
(define (subdtable-name st) (caddr st))
; List of decode subtables.
-(define -decode-subtables nil)
+(define /decode-subtables nil)
-(define (subdtable-lookup key) (assv key -decode-subtables))
+(define (subdtable-lookup key) (assv key /decode-subtables))
; Add SUBTABLE-GUTS to the subtables list if not already present.
; Result is the subtable entry already present, or new entry.
(entry (subdtable-lookup key)))
(if (not entry)
(begin
- (set! -decode-subtables (cons (subdtable-make key subtable-guts name)
- -decode-subtables))
- (car -decode-subtables))
+ (set! /decode-subtables (cons (subdtable-make key subtable-guts name)
+ /decode-subtables))
+ (car /decode-subtables))
entry))
)
; Return the name of the expr table for INSN-EXPRS,
; which is a list of exprtable-entry elements.
-(define (-gen-exprtable-name insn-exprs)
+(define (/gen-exprtable-name insn-exprs)
(string-map (lambda (x)
(string-append (obj:str-name (exprtable-entry-insn x))
"-"
; It would be better to compute use counts of all of them and then see
; if there's a cluster of high use counts.
-(define (-usable-decode-bit? masks mask-lens bitnum lsb0?)
+(define (/usable-decode-bit? masks mask-lens bitnum lsb0?)
(let* ((has-bit (map (lambda (msk len)
(bit-set? msk (if lsb0? bitnum (- len bitnum 1))))
masks mask-lens)))
; and all bits in the result must live in that window.
; If no distinguishing bit fits in the window, return an empty vector.
-(define (-distinguishing-bit-population masks mask-lens values lsb0?)
+(define (/distinguishing-bit-population masks mask-lens values lsb0?)
(let* ((max-length (apply max mask-lens))
(0-population (make-vector max-length 0))
(1-population (make-vector max-length 0))
1-population 0-population)))
(vector-set! chosen-pop-vector bitno
(+ 1 (vector-ref chosen-pop-vector bitno)))))))
- (-range len)))
+ (/range len)))
masks mask-lens values)
; Compute an aggregate "distinguishing value" for each bit.
(list->vector
; Return a list (0 ... LIMIT-1).
-(define (-range limit)
+(define (/range limit)
(let loop ((i 0)
(indices (list)))
(if (= i limit)
; Return a list (BASE ... BASE+SIZE-1).
-(define (-range2 base size)
+(define (/range2 base size)
(let loop ((i base)
(indices (list)))
(if (= i (+ base size))
; Return a copy of VECTOR, with all entries with given INDICES set
; to VALUE.
-(define (-vector-copy-set-all vector indices value)
+(define (/vector-copy-set-all vector indices value)
(let ((new-vector (make-vector (vector-length vector))))
(for-each (lambda (index)
(vector-set! new-vector index (if (memq index indices)
value
(vector-ref vector index))))
- (-range (vector-length vector)))
+ (/range (vector-length vector)))
new-vector)
)
; threshold.
; Sort them in decreasing order of popularity.
-(define (-population-above-threshold population threshold)
+(define (/population-above-threshold population threshold)
(let* ((unsorted
(find (lambda (index) (if (vector-ref population index)
(>= (vector-ref population index) threshold)
#f))
- (-range (vector-length population))))
+ (/range (vector-length population))))
(sorted
(sort unsorted (lambda (i1 i2) (> (vector-ref population i1)
(vector-ref population i2))))))
; ignoring any that are already used (marked by #f). Don't exceed
; `size' unless the clustering is just too good to pass up.
-(define (-population-top-few population size)
+(define (/population-top-few population size)
(let loop ((old-picks (list))
(remaining-population population)
(count-threshold (apply max (map (lambda (value) (or value 0))
(vector->list population)))))
- (let* ((new-picks (-population-above-threshold remaining-population count-threshold)))
- (logit 4 "-population-top-few"
+ (let* ((new-picks (/population-above-threshold remaining-population count-threshold)))
+ (logit 4 "/population-top-few"
" desired=" size
" picks=(" old-picks ") pop=(" remaining-population ")"
" threshold=" count-threshold " new-picks=(" new-picks ")\n")
; the generation of layers of subtables which resolve nothing. Generating
; these tables can slow the build by several orders of magnitude.
((= 0 count-threshold)
- (logit 2 "-population-top-few: count-threshold is zero!\n")
+ (logit 2 "/population-top-few: count-threshold is zero!\n")
old-picks)
; No new matches?
((null? new-picks)
(if (null? old-picks)
- (logit 2 "-population-top-few: No bits left to pick from!\n"))
+ (logit 2 "/population-top-few: No bits left to pick from!\n"))
old-picks)
; Way too many matches?
((> (+ (length new-picks) (length old-picks)) (+ size 3))
; Not enough? Lower the threshold a bit and try to add some more.
(else
(loop (append old-picks new-picks)
- (-vector-copy-set-all remaining-population new-picks #f)
+ (/vector-copy-set-all remaining-population new-picks #f)
; Notice magic clustering decay parameter
; vvvv
(* 0.75 count-threshold))))))
; we also have to handle the case where the initial set of decode bits misses
; some and thus we have to go back and look at them. It may also turn out
; that an opcode bit is skipped over because it doesn't contribute much
-; information to the decoding process (see -usable-decode-bit?). As the
+; information to the decoding process (see /usable-decode-bit?). As the
; possible insn list gets wittled down, the bit will become significant. Thus
; the optimization is left for later.
; Also, see preceding FIXME: We can't proceed past startbit + decode-bitsize
; until we've processed all bits up to startbit + decode-bitsize.
(define (decode-get-best-bits insn-list already-used startbit max decode-bitsize lsb0?)
- (let* ((raw-population (-distinguishing-bit-population (map insn-base-mask insn-list)
+ (let* ((raw-population (/distinguishing-bit-population (map insn-base-mask insn-list)
(map insn-base-mask-length insn-list)
(map insn-value insn-list)
lsb0?))
;; (undecoded (if lsb0?
- ;; (-range2 startbit (+ startbit decode-bitsize))
- ;; (-range2 (- startbit decode-bitsize) startbit)))
+ ;; (/range2 startbit (+ startbit decode-bitsize))
+ ;; (/range2 (- startbit decode-bitsize) startbit)))
(used+undecoded already-used) ; (append already-used undecoded))
- (filtered-population (-vector-copy-set-all raw-population used+undecoded #f))
- (favorite-indices (-population-top-few filtered-population max))
+ (filtered-population (/vector-copy-set-all raw-population used+undecoded #f))
+ (favorite-indices (/population-top-few filtered-population max))
(sorted-indices (sort favorite-indices (lambda (a b)
(if lsb0? (> a b) (< a b))))))
(logit 3
(if (or (= (length result) max) (= bitnum endbit))
(reverse! result)
(if (and (not (memq bitnum already-used))
- (-usable-decode-bit? masks mask-lens bitnum lsb0?))
+ (/usable-decode-bit? masks mask-lens bitnum lsb0?))
(loop (cons bitnum result) (+ bitnum incr))
(loop result (+ bitnum incr))))
))
; the those bits of INSN is #b1100xx (where 'x' indicates a non-constant
; part), then the result is (#b110000 #b110001 #b110010 #b110011).
-(define (-opcode-slots insn bitnums lsb0?)
+(define (/opcode-slots insn bitnums lsb0?)
(letrec ((opcode (insn-value insn))
(insn-len (insn-base-mask-length insn))
(decode-len (length bitnums))
(map (lambda (index) (+ opcode index)) indices)))
)
-; Subroutine of -build-slots.
+; Subroutine of /build-slots.
; Fill slot in INSN-VEC that INSN goes into.
; BITNUMS is the list of opcode bits.
; LSB0? is non-#f if bit number 0 is the least significant bit.
; part), then elements 48 49 50 51 of INSN-VEC are cons'd with INSN.
; Each "slot" is a list of matching instructions.
-(define (-fill-slot! insn-vec insn bitnums lsb0?)
+(define (/fill-slot! insn-vec insn bitnums lsb0?)
;(display (string-append "fill-slot!: " (obj:str-name insn) " ")) (display bitnums) (newline)
- (let ((slot-nums (-opcode-slots insn bitnums lsb0?)))
+ (let ((slot-nums (/opcode-slots insn bitnums lsb0?)))
;(display (list "Filling slot(s)" slot-nums "...")) (newline)
(for-each (lambda (slot-num)
(vector-set! insn-vec slot-num
; The result is a vector of insn lists. Each slot is a list of insns
; that go in that slot.
-(define (-build-slots insn-list bitnums lsb0?)
+(define (/build-slots insn-list bitnums lsb0?)
(let ((result (make-vector (integer-expt 2 (length bitnums)) nil)))
; Loop over each element, filling RESULT.
(for-each (lambda (insn)
- (-fill-slot! result insn bitnums lsb0?))
+ (/fill-slot! result insn bitnums lsb0?))
insn-list)
result)
)
; in reverse order of traversal (since they're built with cons).
; INDEX-LIST may be empty.
-(define (-gen-decode-table-name prefix index-list)
+(define (/gen-decode-table-name prefix index-list)
(set! index-list (reverse index-list))
(string-append
prefix
; The result is a dtable-entry element (or "slot").
; ??? For debugging.
-(define -build-decode-table-entry-args #f)
+(define /build-decode-table-entry-args #f)
-(define (-build-decode-table-entry insn-vec startbit decode-bitsize index index-list lsb0? invalid-insn)
+(define (/build-decode-table-entry insn-vec startbit decode-bitsize index index-list lsb0? invalid-insn)
(let ((slot (vector-ref insn-vec index)))
(logit 2 "Processing decode entry "
(number->string index)
" in "
- (-gen-decode-table-name "decode_" index-list)
+ (/gen-decode-table-name "decode_" index-list)
", "
(cond ((null? slot) "invalid")
((= 1 (length slot)) (insn-syntax (car slot)))
(if (not (all-true? assertions))
(begin
; Save arguments for debugging purposes.
- (set! -build-decode-table-entry-args
+ (set! /build-decode-table-entry-args
(list insn-vec startbit decode-bitsize index index-list lsb0? invalid-insn))
(error "Unable to resolve ambiguity (maybe need some ifield-assertion specs?)")))
; FIXME: Punt on even simple cleverness for now.
assertions))))
(dtable-entry-make index 'expr
(exprtable-make
- (-gen-exprtable-name exprtable-entries)
+ (/gen-exprtable-name exprtable-entries)
exprtable-entries))))))))
; There is no ambiguity so generate the subtable.
; Need to build `subtable' separately because we
- ; may be appending to -decode-subtables recursively.
- (let* ((insn-vec (-build-slots slot bitnums lsb0?))
+ ; may be appending to /decode-subtables recursively.
+ (let* ((insn-vec (/build-slots slot bitnums lsb0?))
(subtable
- (-build-decode-table-guts insn-vec bitnums startbit
+ (/build-decode-table-guts insn-vec bitnums startbit
decode-bitsize index-list lsb0?
invalid-insn)))
(dtable-entry-make index 'table
(subdtable-add subtable
- (-gen-decode-table-name "" index-list)))))))
+ (/gen-decode-table-name "" index-list)))))))
)
)
)
; as a list of 3 elements: bitnums, decode-bitsize, and list of entries.
; Bitnums is recorded with the guts so that tables whose contents are
; identical but are accessed by different bitnums are treated as separate in
-; -decode-subtables. Not sure this will ever happen, but play it safe.
+; /decode-subtables. Not sure this will ever happen, but play it safe.
;
; BITNUMS is the list of bit numbers used to build the slot table.
; STARTBIT is the bit offset of the instruction value that C variable `insn'
; LSB0? is non-#f if bit number 0 is the least significant bit.
; INVALID-INSN is an <insn> object representing invalid insns.
-(define (-build-decode-table-guts insn-vec bitnums startbit decode-bitsize index-list lsb0? invalid-insn)
+(define (/build-decode-table-guts insn-vec bitnums startbit decode-bitsize index-list lsb0? invalid-insn)
(logit 2 "Processing decoder for bits"
(numbers->string bitnums " ")
", startbit " startbit
(dtable-guts-make
bitnums startbit decode-bitsize
(map (lambda (index)
- (-build-decode-table-entry insn-vec startbit decode-bitsize index
+ (/build-decode-table-entry insn-vec startbit decode-bitsize index
(cons (cons bitnums index)
index-list)
lsb0? invalid-insn))
(define (decode-build-table insn-list bitnums decode-bitsize lsb0? invalid-insn)
; Initialize the list of subtables computed.
- (set! -decode-subtables nil)
+ (set! /decode-subtables nil)
; ??? Another way to handle simple forms of ifield-assertions (like those
; created by insn specialization) is to record a copy of the insn for each
; that recorded the necessary bits (insn, ifield-list, remaining
; ifield-assertions).
- (let ((insn-vec (-build-slots insn-list bitnums lsb0?)))
- (let ((table-guts (-build-decode-table-guts insn-vec bitnums
+ (let ((insn-vec (/build-slots insn-list bitnums lsb0?)))
+ (let ((table-guts (/build-decode-table-guts insn-vec bitnums
0 decode-bitsize
nil lsb0?
invalid-insn)))
; ISA support code.
-(define (-gen-isa-table-defns)
+(define (/gen-isa-table-defns)
(logit 2 "Generating isa table defns ...\n")
(string-list
; (map (lambda (elm) (list (obj:name elm) (mach-number elm)))
; (current-mach-list))))
-(define (-gen-mach-table-decls)
+(define (/gen-mach-table-decls)
(logit 2 "Generating machine table decls ...\n")
"" ; (gen-decl mach-table)
)
-(define (-gen-mach-table-defns)
+(define (/gen-mach-table-defns)
(logit 2 "Generating machine table defns ...\n")
(string-list
; Return C code to describe the various attributes.
-(define (-gen-attr-table-decls)
+(define (/gen-attr-table-decls)
(logit 2 "Generating attribute table decls ...\n")
(string-append
"/* Attributes. */\n"
"/* Ifield support. */\n\n"
"/* Ifield attribute indices. */\n\n"
(gen-attr-enum-decl "cgen_ifld" (current-ifld-attr-list))
- (-gen-attr-accessors "cgen_ifld" (current-ifld-attr-list))
+ (gen-attr-accessors "cgen_ifld" (current-ifld-attr-list))
(gen-enum-decl 'ifield_type "@arch@ ifield types"
"@ARCH@_"
(append (gen-obj-list-enums (non-derived-ifields (current-ifld-list)))
(string-list
"/* Hardware attribute indices. */\n\n"
(gen-attr-enum-decl "cgen_hw" (current-hw-attr-list))
- (-gen-attr-accessors "cgen_hw" (current-hw-attr-list))
+ (gen-attr-accessors "cgen_hw" (current-hw-attr-list))
(gen-enum-decl 'cgen_hw_type "@arch@ hardware types"
"HW_" ; FIXME: @ARCH@_
(append (nub (map (lambda (hw)
; Return declarations of variables tables used by HW.
-(define (-gen-hw-decl hw)
+(define (/gen-hw-decl hw)
(string-append
(if (hw-indices hw)
(gen-decl (hw-indices hw))
(logit 2 "Generating hardware table decls ...\n")
(string-list
"/* Hardware decls. */\n\n"
- (string-map -gen-hw-decl (current-hw-list))
+ (string-map /gen-hw-decl (current-hw-list))
"\n"
"extern const CGEN_HW_ENTRY @arch@_cgen_hw_table[];\n"
)
; Return definitions of variables tables used by HW.
; Only do this for `PRIVATE' elements. Public ones are emitted elsewhere.
-(define (-gen-hw-defn hw)
+(define (/gen-hw-defn hw)
(string-append
(if (and (hw-indices hw)
(obj-has-attr? (hw-indices hw) 'PRIVATE))
(num-non-bools (attr-count-non-bools all-attrs)))
(string-list
(string-list-map gen-defn (current-kw-list))
- (string-list-map -gen-hw-defn (current-hw-list))
+ (string-list-map /gen-hw-defn (current-hw-list))
"
/* The hardware table. */
; Return #define's of several constants.
; FIXME: Some of these to be moved into table of structs, one per cpu family.
-(define (-gen-hash-defines)
+(define (/gen-hash-defines)
(logit 2 "Generating #define's ...\n")
(string-list
"#include \"opcode/cgen-bitset.h\"\n"
(string-list
"/* Operand attribute indices. */\n\n"
(gen-attr-enum-decl "cgen_operand" (current-op-attr-list))
- (-gen-attr-accessors "cgen_operand" (current-op-attr-list))
+ (gen-attr-accessors "cgen_operand" (current-op-attr-list))
(gen-enum-decl 'cgen_operand_type "@arch@ operand types"
"@ARCH@_OPERAND_"
(nub (append (gen-obj-list-enums (current-op-list))
(string-list
"/* Insn attribute indices. */\n\n"
(gen-attr-enum-decl "cgen_insn" (current-insn-attr-list))
- (-gen-attr-accessors "cgen_insn" (current-insn-attr-list))
+ (gen-attr-accessors "cgen_insn" (current-insn-attr-list))
)
)
; and opcodes/cgen.sh modified to insert the generated part into the middle
; of the file like is done for assembler/disassembler support.
-(define (-gen-cpu-open)
+(define (/gen-cpu-open)
(string-append
"\
static const CGEN_MACH * lookup_mach_via_bfd_name (const CGEN_MACH *, const char *);
; General initialization C code
; Code is appended during processing.
-(define -cputab-init-code "")
+(define /cputab-init-code "")
(define (cputab-add-init! code)
- (set! -cputab-init-code (string-append -cputab-init-code code))
+ (set! /cputab-init-code (string-append /cputab-init-code code))
)
; Return the C code to define the various initialization functions.
static void
init_tables (void)
{\n"
- -cputab-init-code
+ /cputab-init-code
"}\n\n"
)
)
#define @ARCH@_CPU_H
"
- -gen-hash-defines
+ /gen-hash-defines
; This is defined in arch.h. It's not defined here as there is yet to
; be a need for it in the assembler/disassembler.
;(gen-enum-decl 'model_type "model types"
"/* cgen.h uses things we just defined. */\n"
"#include \"opcode/cgen.h\"\n\n"
"extern const struct cgen_ifld @arch@_cgen_ifld_table[];\n\n"
- -gen-attr-table-decls
- -gen-mach-table-decls
+ /gen-attr-table-decls
+ /gen-mach-table-decls
gen-hw-table-decls
"\n"
(lambda ()
(gen-extra-cpu.c (opc-file-path) (current-arch-name))
""))
gen-attr-table-defns
- -gen-isa-table-defns
- -gen-mach-table-defns
+ /gen-isa-table-defns
+ /gen-mach-table-defns
gen-hw-table-defns
gen-ifld-defns
gen-multi-ifield-nodes
gen-operand-table
gen-insn-table
gen-init-fns
- -gen-cpu-open
+ /gen-cpu-open
)
)
\f
; Parse an enum definition.
-; Utility of -enum-parse to parse the prefix.
+; Utility of /enum-parse to parse the prefix.
-(define (-enum-parse-prefix context prefix)
+(define (/enum-parse-prefix context prefix)
(if (symbol? prefix)
(set! prefix (symbol->string prefix)))
; description in the .cpu file.
; All arguments are in raw (non-evaluated) form.
-(define (-enum-parse context name comment attrs prefix vals)
+(define (/enum-parse context name comment attrs prefix vals)
(logit 2 "Processing enum " name " ...\n")
;; Pick out name first to augment the error context.
name
(parse-comment context comment)
(atlist-parse context attrs "enum")
- (-enum-parse-prefix context prefix)
+ (/enum-parse-prefix context prefix)
(parse-enum-vals context prefix vals)))
)
; This is the main routine for analyzing enums in the .cpu file.
; CONTEXT is a <context> object for error messages.
; ARG-LIST is an associative list of field name and field value.
-; -enum-parse is invoked to create the `enum' object.
+; /enum-parse is invoked to create the `enum' object.
-(define (-enum-read context . arg-list)
+(define (/enum-read context . arg-list)
(let (
(name #f)
(comment "")
(loop (cdr arg-list)))))
; Now that we've identified the elements, build the object.
- (-enum-parse context name comment attrs prefix values))
+ (/enum-parse context name comment attrs prefix values))
)
; Define an enum object, name/value pair list version.
(define define-enum
(lambda arg-list
- (let ((e (apply -enum-read (cons (make-current-context "define-enum")
+ (let ((e (apply /enum-read (cons (make-current-context "define-enum")
arg-list))))
(current-enum-add! e)
e))
; Define an enum object, all arguments specified.
(define (define-full-enum name comment attrs prefix vals)
- (let ((e (-enum-parse (make-current-context "define-full-enum")
+ (let ((e (/enum-parse (make-current-context "define-full-enum")
name comment attrs prefix vals)))
(current-enum-add! e)
e)
(parse-name context name)
(parse-comment context comment)
atlist
- (-enum-parse-prefix context prefix)
+ (/enum-parse-prefix context prefix)
fld-obj
(parse-enum-vals context prefix vals))))
(current-enum-add! e)
; ((r0 r1 r2) (r3 r4 r5) (2 3 8)) => ((r0 r3 2) (r1 r4 3) (r2 r5 8))
; L is a list of lists. All elements must have the same length.
-(define (-collate-test-set L)
+(define (/collate-test-set L)
(if (= (length (car L)) 0)
'()
(cons (map car L)
- (-collate-test-set (map cdr L))))
+ (/collate-test-set (map cdr L))))
)
; Given a list of operands for an instruction, return the test set
(let ((test-data (map (lambda (op) (operand-test-data op n)) op-list))
(len (length op-list)))
(cond ((= len 0) (list (list)))
- (else (-collate-test-set test-data))))
+ (else (/collate-test-set test-data))))
)
; Given an assembler expression and a set of operands build a testcase.
; some restrictions which can later be relaxed as necessary.
; ??? It would be useful to have two names for each value: asm name, enum name.
-(define (-keyword-parse context name comment attrs mode enum-prefix
+(define (/keyword-parse context name comment attrs mode enum-prefix
name-prefix values)
;; Pick out name first to augment the error context.
(let* ((name (parse-name context name))
; file.
; CONTEXT is a <context> object for error messages.
; ARG-LIST is an associative list of field name and field value.
-; -keyword-parse is invoked to create the <keyword> object.
+; /keyword-parse is invoked to create the <keyword> object.
-(define (-keyword-read context . arg-list)
+(define (/keyword-read context . arg-list)
(let (
(name #f)
(comment "")
(loop (cdr arg-list)))))
; Now that we've identified the elements, build the object.
- (-keyword-parse context name comment attrs mode
+ (/keyword-parse context name comment attrs mode
enum-prefix name-prefix values))
)
(define define-keyword
(lambda arg-list
- (let ((kw (apply -keyword-read (cons (make-current-context "define-keyword")
+ (let ((kw (apply /keyword-read (cons (make-current-context "define-keyword")
arg-list))))
(if kw
(begin
; List of hardware types.
; This maps names in the `type' entry of define-hardware to the class name.
-(define -hardware-types
+(define /hardware-types
'((register . <hw-register>)
(pc . <hw-pc>)
(memory . <hw-memory>)
; These are keywords defined inside something else.
; CONTAINER is the <ident> object of the container.
-(define (-hw-parse-keyword context args container mode)
+(define (/hw-parse-keyword context args container mode)
(if (!= (length args) 2)
(parse-error context "invalid keyword spec" args))
; They're needed to output the table.
; ??? This isn't quite right as some day a container may contain multiple
; keyword instances. To be fixed in time.
- (-keyword-parse context (obj:name container) (obj:comment container)
+ (/keyword-parse context (obj:name container) (obj:comment container)
;; PRIVATE: keyword table is implicitly defined, it isn't
;; accessible with current-kw-lookup.
(cons 'PRIVATE (atlist-source-form (obj-atlist container)))
; Otherwise MODE is used.
; The syntax is: (keyword keyword-spec) - see <keyword> for details.
-(define (-hw-parse-indices context indices container mode)
+(define (/hw-parse-indices context indices container mode)
(if (null? indices)
(make <hw-asm>
(obj:name container) (obj:comment container) (obj-atlist container)
(if (not (list? indices))
(parse-error context "invalid indices spec" indices))
(case (car indices)
- ((keyword) (-hw-parse-keyword context (cdr indices) container mode))
+ ((keyword) (/hw-parse-keyword context (cdr indices) container mode))
((extern-keyword) (begin
(if (null? (cdr indices))
(parse-error context "missing keyword name"
; Otherwise MODE is used.
; The syntax is: (keyword keyword-spec) - see <keyword> for details.
-(define (-hw-parse-values context values container mode)
+(define (/hw-parse-values context values container mode)
(if (null? values)
(make <hw-asm>
(obj:name container) (obj:comment container) (obj-atlist container)
(if (not (list? values))
(parse-error context "invalid values spec" values))
(case (car values)
- ((keyword) (-hw-parse-keyword context (cdr values) container mode))
+ ((keyword) (/hw-parse-keyword context (cdr values) container mode))
((extern-keyword) (begin
(if (null? (cdr values))
(parse-error context "missing keyword name"
; Parse a handlers spec.
; Each element is (name "string").
-(define (-hw-parse-handlers context handlers)
+(define (/hw-parse-handlers context handlers)
(parse-handlers context '(parse print) handlers)
)
; Omit `index' for scalar objects.
; Externally they're specified as `get'. Internally we use `getter'.
-(define (-hw-parse-getter context getter scalar?)
+(define (/hw-parse-getter context getter scalar?)
(if (null? getter)
#f ; use default
(let ((valid "((index) (expression))")
; Omit `index' for scalar objects.
; Externally they're specified as `set'. Internally we use `setter'.
-(define (-hw-parse-setter context setter scalar?)
+(define (/hw-parse-setter context setter scalar?)
(if (null? setter)
#f ; use default
(let ((valid "((index newval) (expression))")
; ??? Might want to redo to handle hardware type specific specs more cleanly.
; E.g. <hw-immediate> shouldn't have to see get/set specs.
-(define (-hw-parse context name comment attrs semantic-name type
+(define (/hw-parse context name comment attrs semantic-name type
indices values handlers get set layout)
(logit 2 "Processing hardware element " name " ...\n")
;; Pick out name first to augment the error context.
(let* ((name (parse-name context name))
(context (context-append-name context name))
- (class-name (assq-ref -hardware-types (car type)))
+ (class-name (assq-ref /hardware-types (car type)))
(atlist-obj (atlist-parse context attrs "cgen_hw")))
(if (not class-name)
; file.
; CONTEXT is a <context> object for error messages.
; ARG-LIST is an associative list of field name and field value.
-; -hw-parse is invoked to create the <hardware> object.
+; /hw-parse is invoked to create the <hardware> object.
-(define (-hw-read context . arg-list)
+(define (/hw-read context . arg-list)
(let (
(name nil)
(comment "")
(loop (cdr arg-list)))))
; Now that we've identified the elements, build the object.
- (-hw-parse context name comment attrs
+ (/hw-parse context name comment attrs
(if (null? semantic-name) name semantic-name)
type indices values handlers get set layout))
)
(define define-hardware
(lambda arg-list
- (let ((hw (apply -hw-read (cons (make-current-context "define-hardware")
+ (let ((hw (apply /hw-read (cons (make-current-context "define-hardware")
arg-list))))
(if hw
(current-hw-add! hw))
(define (define-full-hardware name comment attrs semantic-name type
indices values handlers get set layout)
- (let ((hw (-hw-parse (make-current-context "define-full-hardware")
+ (let ((hw (/hw-parse (make-current-context "define-full-hardware")
name comment attrs semantic-name type
indices values handlers get set layout)))
(if hw
; - (value length)
; - hardware-name
-(define (-hw-validate-layout context layout width)
+(define (/hw-validate-layout context layout width)
(if (not (list? layout))
(parse-error context "layout is not a list" layout))
; (or SI (sll SI (zext SI (reg h-hw2)) 1)
; (zext SI (reg h-hw3)))))
-(define (-hw-create-getter-from-layout context layout width)
+(define (/hw-create-getter-from-layout context layout width)
(let ((add-to-res (lambda (result mode-name val shift)
(if (null? result)
(rtx-make 'sll mode-name val shift)
; (set (reg h-hw3) (and (srl val 0) 1))
; ))
-(define (-hw-create-setter-from-layout context layout width)
+(define (/hw-create-setter-from-layout context layout width)
(let ((mode-name (obj:name (mode-find width 'UINT))))
(let loop ((sets nil) (layout (reverse layout)) (shift 0))
(if (null? layout)
; We don't override any provided get/set specs though.
(if (not (null? layout))
(let ((width (hw-bits self)))
- (-hw-validate-layout context layout width)
+ (/hw-validate-layout context layout width)
(if (null? getter)
(set! getter
- (-hw-create-getter-from-layout context layout width)))
+ (/hw-create-getter-from-layout context layout width)))
(if (null? setter)
(set! setter
- (-hw-create-setter-from-layout context layout width)))
+ (/hw-create-setter-from-layout context layout width)))
))
- (elm-set! self 'indices (-hw-parse-indices context indices self UINT))
- (elm-set! self 'values (-hw-parse-values context values self
+ (elm-set! self 'indices (/hw-parse-indices context indices self UINT))
+ (elm-set! self 'values (/hw-parse-values context values self
(send (elm-get self 'type)
'get-mode)))
- (elm-set! self 'handlers (-hw-parse-handlers context handlers))
- (elm-set! self 'get (-hw-parse-getter context getter (hw-scalar? self)))
- (elm-set! self 'set (-hw-parse-setter context setter (hw-scalar? self)))
+ (elm-set! self 'handlers (/hw-parse-handlers context handlers))
+ (elm-set! self 'get (/hw-parse-getter context getter (hw-scalar? self)))
+ (elm-set! self 'set (/hw-parse-setter context setter (hw-scalar? self)))
*UNSPECIFIED*)
)
(if (not (null? layout))
(parse-error context "layout specified for pc" values))
; The initial value of INDICES, VALUES is #f which is what we want.
- (elm-set! self 'handlers (-hw-parse-handlers context handlers))
- (elm-set! self 'get (-hw-parse-getter context getter (hw-scalar? self)))
- (elm-set! self 'set (-hw-parse-setter context setter (hw-scalar? self)))
+ (elm-set! self 'handlers (/hw-parse-handlers context handlers))
+ (elm-set! self 'get (/hw-parse-getter context getter (hw-scalar? self)))
+ (elm-set! self 'set (/hw-parse-setter context setter (hw-scalar? self)))
*UNSPECIFIED*)
)
(parse-error context "layout specified for memory" values))
(elm-set! self 'type (parse-type context type))
; Setting INDICES,VALUES here is mostly for experimentation at present.
- (elm-set! self 'indices (-hw-parse-indices context indices self AI))
- (elm-set! self 'values (-hw-parse-values context values self
+ (elm-set! self 'indices (/hw-parse-indices context indices self AI))
+ (elm-set! self 'values (/hw-parse-values context values self
(send (elm-get self 'type)
'get-mode)))
- (elm-set! self 'handlers (-hw-parse-handlers context handlers))
- (elm-set! self 'get (-hw-parse-getter context getter (hw-scalar? self)))
- (elm-set! self 'set (-hw-parse-setter context setter (hw-scalar? self)))
+ (elm-set! self 'handlers (/hw-parse-handlers context handlers))
+ (elm-set! self 'get (/hw-parse-getter context getter (hw-scalar? self)))
+ (elm-set! self 'set (/hw-parse-setter context setter (hw-scalar? self)))
*UNSPECIFIED*)
)
(parse-error context "indices specified for immediate" indices))
(if (not (null? layout))
(parse-error context "layout specified for immediate" values))
- (elm-set! self 'values (-hw-parse-values context values self
+ (elm-set! self 'values (/hw-parse-values context values self
(send (elm-get self 'type)
'get-mode)))
- (elm-set! self 'handlers (-hw-parse-handlers context handlers))
+ (elm-set! self 'handlers (/hw-parse-handlers context handlers))
(if (not (null? getter))
(parse-error context "getter specified for immediate" getter))
(if (not (null? setter))
(parse-error context "values specified for address" values))
(if (not (null? layout))
(parse-error context "layout specified for address" values))
- (elm-set! self 'values (-hw-parse-values context values self
+ (elm-set! self 'values (/hw-parse-values context values self
(send (elm-get self 'type)
'get-mode)))
- (elm-set! self 'handlers (-hw-parse-handlers context handlers))
+ (elm-set! self 'handlers (/hw-parse-handlers context handlers))
(if (not (null? getter))
(parse-error context "getter specified for address" getter))
(if (not (null? setter))
(define-setters <ifield> ifld (follows))
; internal fn
-(define -ifld-bitrange (elm-make-getter <ifield> 'bitrange))
+(define /ifld-bitrange (elm-make-getter <ifield> 'bitrange))
-(define (ifld-word-offset f) (bitrange-word-offset (-ifld-bitrange f)))
-(define (ifld-word-length f) (bitrange-word-length (-ifld-bitrange f)))
+(define (ifld-word-offset f) (bitrange-word-offset (/ifld-bitrange f)))
+(define (ifld-word-length f) (bitrange-word-length (/ifld-bitrange f)))
; Return the mode of the value passed to the encode rtl.
; This is the mode of the result of the decode rtl.
(method-make-virtual!
<ifield> 'field-start
(lambda (self word-len)
- (bitrange-start (-ifld-bitrange self)))
+ (bitrange-start (/ifld-bitrange self)))
)
(define (ifld-start ifld word-len)
(method-make!
<ifield> 'field-mask
(lambda (self base-len container)
- (let* ((container (or container (-ifld-bitrange self)))
- (bitrange (-ifld-bitrange self))
+ (let* ((container (or container (/ifld-bitrange self)))
+ (bitrange (/ifld-bitrange self))
(recorded-word-length (bitrange-word-length bitrange))
(word-offset (bitrange-word-offset bitrange)))
(let ((lsb0? (bitrange-lsb0? bitrange))
(method-make!
<ifield> 'field-value
(lambda (self base-len value)
- (let* ((bitrange (-ifld-bitrange self))
+ (let* ((bitrange (/ifld-bitrange self))
(recorded-word-length (bitrange-word-length bitrange))
(word-offset (bitrange-word-offset bitrange))
(word-length (or (and (= word-offset 0) base-len)
(method-make!
<ifield> 'field-lsb0?
(lambda (self)
- (bitrange-lsb0? (-ifld-bitrange self)))
+ (bitrange-lsb0? (/ifld-bitrange self)))
)
(define (ifld-lsb0? f) (send f 'field-lsb0?))
(method-make!
<ifield> 'set-word-offset!
(lambda (self word-offset)
- (let ((bitrange (object-copy-top (-ifld-bitrange self))))
+ (let ((bitrange (object-copy-top (/ifld-bitrange self))))
(bitrange-set-word-offset! bitrange word-offset)
(elm-set! self 'bitrange bitrange)
*UNSPECIFIED*))
(method-make!
<ifield> 'next-word
(lambda (self)
- (let ((br (-ifld-bitrange f)))
+ (let ((br (/ifld-bitrange f)))
(bitrange-next-word br)))
)
; different handling.
(define (ifld-precedes? f1 f2)
- (let ((br1 (-ifld-bitrange f1))
- (br2 (-ifld-bitrange f2)))
+ (let ((br1 (/ifld-bitrange f1))
+ (br2 (/ifld-bitrange f2)))
(cond ((< (bitrange-word-offset br1) (bitrange-word-offset br2))
#t)
((= (bitrange-word-offset br1) (bitrange-word-offset br2))
;
; FIXME: More error checking.
-(define (-ifield-parse context name comment attrs
+(define (/ifield-parse context name comment attrs
word-offset word-length start flength follows
mode encode decode)
(logit 2 "Processing ifield " name " ...\n")
(flength (parse-number context flength '(0 . 127)))
(lsb0? (current-arch-insn-lsb0?))
(mode-obj (parse-mode-name context mode))
- (follows-obj (-ifld-parse-follows context follows))
+ (follows-obj (/ifld-parse-follows context follows))
)
; Calculate the <bitrange> object.
; One can certainly argue the choice of the term
; "RISC-like" is inaccurate. Perhaps.
(let* ((diwb (isa-default-insn-word-bitsize isa))
- (word-offset (-get-ifld-word-offset start flength diwb lsb0?))
- (word-length (-get-ifld-word-length start flength diwb lsb0?))
+ (word-offset (/get-ifld-word-offset start flength diwb lsb0?))
+ (word-length (/get-ifld-word-length start flength diwb lsb0?))
(start (- start word-offset))
)
(make <bitrange>
atlist
mode-obj
bitrange
- (-ifld-parse-encode context encode)
- (-ifld-parse-decode context decode))))
+ (/ifld-parse-encode context encode)
+ (/ifld-parse-decode context decode))))
(if follows-obj
(ifld-set-follows! result follows-obj))
result)))
#f)))
)
-; Subroutine of -ifield-parse to simplify it.
+; Subroutine of /ifield-parse to simplify it.
; Given START,FLENGTH, return the "best" choice for the offset to the word
; containing the ifield.
; This is easy to visualize, hard to put into words.
; particular architecture. For those where this isn't correct, the ifield
; must be fully specified (i.e. word-offset,word-length explicitly specified).
-(define (-get-ifld-word-offset start flength diwb lsb0?)
+(define (/get-ifld-word-offset start flength diwb lsb0?)
(if lsb0?
; Convert to non-lsb0 case, then it's easy.
; NOTE: The conversion is seemingly wrong because `start' is misnamed.
(- start (remainder start diwb))
)
-; Subroutine of -ifield-parse to simplify it.
+; Subroutine of /ifield-parse to simplify it.
; Given START,FLENGTH, return the "best" choice for the length of the word
; containing the ifield.
; DIWB = default insn word bitsize
; See -get-ifld-word-offset for more info.
-(define (-get-ifld-word-length start flength diwb lsb0?)
+(define (/get-ifld-word-length start flength diwb lsb0?)
(if lsb0?
; Convert to non-lsb0 case, then it's easy.
; NOTE: The conversion is seemingly wrong because `start' is misnamed.
; This is the main routine for analyzing instruction fields in the .cpu file.
; CONTEXT is a <context> object for error messages.
; ARG-LIST is an associative list of field name and field value.
-; -ifield-parse is invoked to create the <ifield> object.
+; /ifield-parse is invoked to create the <ifield> object.
-(define (-ifield-read context . arg-list)
+(define (/ifield-read context . arg-list)
(let (
(name #f)
(comment "")
(set! decode #f))
; Now that we've identified the elements, build the object.
- (-ifield-parse context name comment attrs
+ (/ifield-parse context name comment attrs
word-offset word-length start length- follows
mode encode decode))
)
; Parse a `follows' spec.
-(define (-ifld-parse-follows context follows)
+(define (/ifld-parse-follows context follows)
(if follows
(let ((follows-obj (current-op-lookup follows)))
(if (not follows-obj)
; Do common parts of <ifield> encode/decode processing.
-(define (-ifld-parse-encode-decode context which value)
+(define (/ifld-parse-encode-decode context which value)
(if value
(begin
(if (or (not (list? value))
; Parse an <ifield> encode spec.
-(define (-ifld-parse-encode context encode)
- (-ifld-parse-encode-decode context "encode" encode)
+(define (/ifld-parse-encode context encode)
+ (/ifld-parse-encode-decode context "encode" encode)
)
; Parse an <ifield> decode spec.
-(define (-ifld-parse-decode context decode)
- (-ifld-parse-encode-decode context "decode" decode)
+(define (/ifld-parse-decode context decode)
+ (/ifld-parse-encode-decode context "decode" decode)
)
; Define an instruction field object, name/value pair list version.
(define define-ifield
(lambda arg-list
- (let ((f (apply -ifield-read (cons (make-current-context "define-ifield")
+ (let ((f (apply /ifield-read (cons (make-current-context "define-ifield")
arg-list))))
(if f
(current-ifld-add! f))
; FIXME: Eventually this should be fixed to take *all* arguments.
(define (define-full-ifield name comment attrs start length mode encode decode)
- (let ((f (-ifield-parse (make-current-context "define-full-ifield")
+ (let ((f (/ifield-parse (make-current-context "define-full-ifield")
name comment attrs
#f #f start length #f mode encode decode)))
(if f
f)
)
-(define (-ifield-add-commands!)
+(define (/ifield-add-commands!)
(reader-add-command! 'define-ifield
"\
Define an instruction field, name/value pair list version.
<multi-ifield> 'next-word
(lambda (self)
(apply max (map (lambda (f)
- (bitrange-next-word (-ifld-bitrange f)))
+ (bitrange-next-word (/ifld-bitrange f)))
(multi-ifld-subfields self))))
)
\f
; Multi-ifield parsing.
-; Subroutine of -multi-ifield-parse to build the default insert expression.
+; Subroutine of /multi-ifield-parse to build the default insert expression.
-(define (-multi-ifield-make-default-insert container-name subfields)
+(define (/multi-ifield-make-default-insert container-name subfields)
(let* ((lengths (map ifld-length subfields))
(shifts (list-tail-drop 1 (plus-scan (cons 0 lengths)))))
; Build RTL expression to shift and mask each ifield into right spot.
subfields exprs))))))
)
-; Subroutine of -multi-ifield-parse to build the default extract expression.
+; Subroutine of /multi-ifield-parse to build the default extract expression.
-(define (-multi-ifield-make-default-extract container-name subfields)
+(define (/multi-ifield-make-default-extract container-name subfields)
(let* ((lengths (map ifld-length subfields))
(shifts (list-tail-drop 1 (plus-scan (cons 0 lengths)))))
; Build RTL expression to shift and mask each ifield into right spot.
; All arguments are in raw (non-evaluated) form.
; The result is the parsed object or #f if object isn't for selected mach(s).
-(define (-multi-ifield-parse context name comment attrs mode
+(define (/multi-ifield-parse context name comment attrs mode
subfields insert extract encode decode)
(logit 2 "Processing multi-ifield element " name " ...\n")
(atlist-parse context (cons 'VIRTUAL attrs)
"multi-ifield"))
(elm-xset! result 'mode (parse-mode-name context mode))
- (elm-xset! result 'encode (-ifld-parse-encode context encode))
- (elm-xset! result 'decode (-ifld-parse-encode context decode))
+ (elm-xset! result 'encode (/ifld-parse-encode context encode))
+ (elm-xset! result 'decode (/ifld-parse-encode context decode))
(if insert
(elm-xset! result 'insert insert)
(elm-xset! result 'insert
- (-multi-ifield-make-default-insert name subfields)))
+ (/multi-ifield-make-default-insert name subfields)))
(if extract
(elm-xset! result 'extract extract)
(elm-xset! result 'extract
- (-multi-ifield-make-default-extract name subfields)))
+ (/multi-ifield-make-default-extract name subfields)))
(elm-xset! result 'subfields subfields)
result))
; This is the main routine for analyzing multi-ifields in the .cpu file.
; CONTEXT is a <context> object for error messages.
; ARG-LIST is an associative list of field name and field value.
-; -multi-ifield-parse is invoked to create the `multi-ifield' object.
+; /multi-ifield-parse is invoked to create the `multi-ifield' object.
-(define (-multi-ifield-read context . arg-list)
+(define (/multi-ifield-read context . arg-list)
(let (
(name nil)
(comment "")
(loop (cdr arg-list)))))
; Now that we've identified the elements, build the object.
- (-multi-ifield-parse context name comment attrs mode subflds
+ (/multi-ifield-parse context name comment attrs mode subflds
insert extract encode decode))
)
(define define-multi-ifield
(lambda arg-list
- (let ((f (apply -multi-ifield-read (cons (make-current-context "define-multi-ifield")
+ (let ((f (apply /multi-ifield-read (cons (make-current-context "define-multi-ifield")
arg-list))))
(if f
(current-ifld-add! f))
; FIXME: encode/decode arguments are missing.
(define (define-full-multi-ifield name comment attrs mode subflds insert extract)
- (let ((f (-multi-ifield-parse (make-current-context "define-full-multi-ifield")
+ (let ((f (/multi-ifield-parse (make-current-context "define-full-multi-ifield")
name comment attrs
mode subflds insert extract #f #f)))
(current-ifld-add! f)
<derived-ifield> 'next-word
(lambda (self)
(apply max (map (lambda (f)
- (bitrange-next-word (-ifld-bitrange f)))
+ (bitrange-next-word (/ifld-bitrange f)))
(derived-ifield-subfields self))))
)
; Called before loading the .cpu file to initialize.
(define (ifield-init!)
- (-ifield-add-commands!)
+ (/ifield-add-commands!)
*UNSPECIFIED*
)
; INSN is passed so that we can include its sanytize attribute, if present,
; so sanytized sources work (needed formats don't disappear).
-(define (-ifmt-search-key insn sorted-ifld-list)
+(define (/ifmt-search-key insn sorted-ifld-list)
(string-map (lambda (ifld)
(string-append " ("
(or (->string (obj-attr-value insn 'sanitize))
; the generated code smaller (and sometimes faster - more usable common
; fragments in pbb simulators). Don't cause spurious differences.
-(define (-sfmt-search-key insn cti? sorted-used-iflds sem-in-ops sem-out-ops)
+(define (/sfmt-search-key insn cti? sorted-used-iflds sem-in-ops sem-out-ops)
(let ((op-key (lambda (op)
(string-append " ("
(or (->string (obj-attr-value insn 'sanitize))
; Sort IFLDS by dependencies and then by starting bit number.
-(define (-sfmt-order-iflds iflds)
+(define (/sfmt-order-iflds iflds)
(let ((up?
; ??? Something like this is preferable.
;(not (ifld-lsb0? (car ifld-list)))
; The important points are to help distinguish sformat's by the ifields used
; and to put ifields that others depend on first.
-(define (-sfmt-used-iflds in-ops out-ops)
+(define (/sfmt-used-iflds in-ops out-ops)
(let ((in-iflds (map op-iflds-used in-ops))
(out-iflds (map op-iflds-used out-ops)))
(let ((all-iflds (nub (append (apply append in-iflds)
(apply append out-iflds))
obj:name)))
- (-sfmt-order-iflds all-iflds)))
+ (/sfmt-order-iflds all-iflds)))
)
\f
; The format descriptor is used to sort formats.
(list (make <fmt-desc>
cti? sorted-ifields in-ops out-ops
(if (and in-ops out-ops)
- (-sfmt-used-iflds in-ops out-ops)
+ (/sfmt-used-iflds in-ops out-ops)
#f)
attrs)
compiled-sem
; FMT-DESC is INSN's <fmt-desc> object.
; IFMT-LIST is append!'d to and the found iformat is stored in INSN.
-(define (-ifmt-lookup-ifmt! insn fmt-desc ifmt-list)
- (let* ((search-key (-ifmt-search-key insn (-fmt-desc-iflds fmt-desc)))
+(define (/ifmt-lookup-ifmt! insn fmt-desc ifmt-list)
+ (let* ((search-key (/ifmt-search-key insn (-fmt-desc-iflds fmt-desc)))
(ifmt (find-first (lambda (elm)
(equal? (ifmt-key elm) search-key))
ifmt-list)))
;
; We assume INSN's <iformat> has already been recorded.
-(define (-ifmt-lookup-sfmt! insn fmt-desc sfmt-list)
- (let* ((search-key (-sfmt-search-key insn (-fmt-desc-cti? fmt-desc)
+(define (/ifmt-lookup-sfmt! insn fmt-desc sfmt-list)
+ (let* ((search-key (/sfmt-search-key insn (-fmt-desc-cti? fmt-desc)
(-fmt-desc-used-iflds fmt-desc)
(-fmt-desc-in-ops fmt-desc)
(-fmt-desc-out-ops fmt-desc)))
(begin
; Must compute <iformat> before <sformat>, the latter
; needs the former.
- (-ifmt-lookup-ifmt! insn fmt-desc ifmt-list)
+ (/ifmt-lookup-ifmt! insn fmt-desc ifmt-list)
(if compute-sformat?
- (-ifmt-lookup-sfmt! insn fmt-desc sfmt-list)))
+ (/ifmt-lookup-sfmt! insn fmt-desc sfmt-list)))
; No field list present, use empty format.
(begin
(define (multi-insn? x) (class-instance? <multi-insn> x))
-; Subroutine of -sub-insn-make! to create the ifield list.
+; Subroutine of /sub-insn-make! to create the ifield list.
; Return encoding of {insn} with each element of {anyof-operands} replaced
; with {new-values}.
; {value-names} is a list of names of {anyof-operands}.
-(define (-sub-insn-ifields insn anyof-operands value-names new-values)
+(define (/sub-insn-ifields insn anyof-operands value-names new-values)
; (debug-repl-env insn anyof-operands value-names new-values)
; Delete ifields of {anyof-operands} and add those for {new-values}.
; NEW-VALUES is a list of the value to use for each corresponding element in
; ANYOF-OPERANDS. Each element is a <derived-operand>.
-(define (-sub-insn-make! insn anyof-operands new-values)
+(define (/sub-insn-make! insn anyof-operands new-values)
;(debug-repl-env insn anyof-operands new-values)
(assert (= (length anyof-operands) (length new-values)))
(assert (all-true? (map anyof-operand? anyof-operands)))
; (debug-repl-env insn anyof-operands new-values))
(let* ((value-names (map obj:name anyof-operands))
- (ifields (-sub-insn-ifields insn anyof-operands value-names new-values))
+ (ifields (/sub-insn-ifields insn anyof-operands value-names new-values))
(known-values (ifld-known-values ifields)))
; Don't create insn if ifield assertions fail.
new-values)))
(obj:comment insn)
(obj-atlist insn)
- (-anyof-merge-syntax (insn-syntax insn)
+ (/anyof-merge-syntax (insn-syntax insn)
value-names new-values)
ifields
(insn-ifield-assertion insn) ; FIXME
(let* ((indices (split-value lengths i))
(anyof-instances (map list-ref todo indices)))
(logit 4 "Derived: " (map obj:name anyof-instances) "\n")
- (-sub-insn-make! multi-insn anyof-operands anyof-instances)
+ (/sub-insn-make! multi-insn anyof-operands anyof-instances)
(loop (+ i 1))))))))
*UNSPECIFIED*
; All arguments are in raw (non-evaluated) form.
; The result is the parsed object or #f if insn isn't for selected mach(s).
-(define (-insn-parse context name comment attrs syntax fmt ifield-assertion
+(define (/insn-parse context name comment attrs syntax fmt ifield-assertion
semantics timing)
(logit 2 "Processing insn " name " ...\n")
(semantics (if (not (null? semantics))
semantics
#f))
- (format (-parse-insn-format (context-append context " format")
+ (format (/parse-insn-format (context-append context " format")
fmt))
(comment (parse-comment context comment))
; If there are no semantics, mark this as an alias.
; This is also used to create virtual insns by apps like simulators.
; CONTEXT is a <context> object for error messages.
; ARG-LIST is an associative list of field name and field value.
-; -insn-parse is invoked to create the <insn> object.
+; /insn-parse is invoked to create the <insn> object.
(define (insn-read context . arg-list)
(let (
(loop (cdr arg-list)))))
; Now that we've identified the elements, build the object.
- (-insn-parse context name comment attrs syntax fmt ifield-assertion
+ (/insn-parse context name comment attrs syntax fmt ifield-assertion
semantics timing))
)
(define (define-full-insn name comment attrs syntax fmt ifield-assertion
semantics timing)
- (let ((i (-insn-parse (make-current-context "define-full-insn")
+ (let ((i (/insn-parse (make-current-context "define-full-insn")
name comment attrs
syntax fmt ifield-assertion
semantics timing)))
(else (parse-error context "improper syntax" syntax)))
)
-; Subroutine of -parse-insn-format to parse a symbol ifield spec.
+; Subroutine of /parse-insn-format to parse a symbol ifield spec.
-(define (-parse-insn-format-symbol context sym)
+(define (/parse-insn-format-symbol context sym)
;(debug-repl-env sym)
(let ((op (current-op-lookup sym)))
(if op
(parse-error context "bad format element, expecting symbol to be operand or insn enum" sym)))))
)
-; Subroutine of -parse-insn-format to parse an (ifield-name value) ifield spec.
+; Subroutine of /parse-insn-format to parse an (ifield-name value) ifield spec.
;
; The last element is the ifield's value. It must be an integer.
; ??? Whether it can be negative is still unspecified.
;
; ??? Error messages need improvement, but that's generally true of cgen.
-(define (-parse-insn-format-ifield-spec context ifld ifld-spec)
+(define (/parse-insn-format-ifield-spec context ifld ifld-spec)
(if (!= (length ifld-spec) 2)
(parse-error context "bad ifield format, should be (ifield-name value)" ifld-spec))
(parse-error context "ifield value not an integer or enum" ifld-spec))))
)
-; Subroutine of -parse-insn-format to parse an
+; Subroutine of /parse-insn-format to parse an
; (ifield-name value) ifield spec.
; ??? There is room for growth in the specification syntax here.
; Possibilities are (ifield-name|operand-name [options] [value]).
-(define (-parse-insn-format-list context spec)
+(define (/parse-insn-format-list context spec)
(let ((ifld (current-ifld-lookup (car spec))))
(if ifld
- (-parse-insn-format-ifield-spec context ifld spec)
+ (/parse-insn-format-ifield-spec context ifld spec)
(parse-error context "unknown ifield" spec)))
)
; It's called for each instruction, and is one of the more expensive routines
; in insn parsing.
-(define (-parse-insn-format context fld-list)
+(define (/parse-insn-format context fld-list)
(if (null? fld-list)
nil ; field list unspecified
(case (car fld-list)
(string->symbol fld)
fld)))
(cond ((symbol? f)
- (-parse-insn-format-symbol context f))
+ (/parse-insn-format-symbol context f))
((and (list? f)
; ??? This use to allow <ifield> objects
; in the `car' position. Checked for below.
(symbol? (car f)))
- (-parse-insn-format-list context f))
+ (/parse-insn-format-list context f))
(else
(if (and (list? f)
(ifield? (car f)))
;; Helper functions for getting the values of certain mep-specific gcc
;; attributes. In each case INSN is a cgen instruction (not an md-insn).
-(define (-may-trap-attribute insn)
+(define (/may-trap-attribute insn)
(if (obj-has-attr? insn 'MAY_TRAP) "yes" "no"))
-(define (-slot-attribute insn)
+(define (/slot-attribute insn)
(if (exists? (lambda (isa)
(or (equal? isa 'mep)
(equal? (string-take 8 (st isa)) "ext_core")))
"core"
"cop"))
-(define (-latency-attribute insn)
+(define (/latency-attribute insn)
(if (obj-attr-value insn 'LATENCY)
(st (obj-attr-value insn 'LATENCY))
"0"))
-(define (-length-attribute insn)
+(define (/length-attribute insn)
(st (/ (insn-length insn) 8)))
-(define (-stall-attribute insn)
+(define (/stall-attribute insn)
(string-downcase (st (obj-attr-value insn 'STALL))))
-(define (-slots-attribute insn)
+(define (/slots-attribute insn)
(let ((slots (obj-attr-value insn 'SLOTS)))
(if slots
(string-downcase (gen-c-symbol (st slots)))
;; pairs.
(define (target:attributes insn)
(let ((cgen-insn (md-insn:cgen-insn insn)))
- (list (cons 'may_trap (-may-trap-attribute cgen-insn))
- (cons 'latency (-latency-attribute cgen-insn))
- (cons 'length (-length-attribute cgen-insn))
- (cons 'slot (-slot-attribute cgen-insn))
- (cons 'slots (-slots-attribute cgen-insn))
+ (list (cons 'may_trap (/may-trap-attribute cgen-insn))
+ (cons 'latency (/latency-attribute cgen-insn))
+ (cons 'length (/length-attribute cgen-insn))
+ (cons 'slot (/slot-attribute cgen-insn))
+ (cons 'slots (/slots-attribute cgen-insn))
(if (eq? (obj-attr-value cgen-insn 'STALL) 'SHIFTI)
(cons 'shiftop "operand2")
- (cons 'stall (-stall-attribute cgen-insn))))))
+ (cons 'stall (/stall-attribute cgen-insn))))))
;; Define target-specific fields of cgen_insn. In the MeP case, we want
;; to record how long the intruction is.
;; Initialize the fields described above.
(define (target:initialize-fields insn)
(comma-line-break)
- (string-write (-length-attribute (md-insn:cgen-insn insn))))
+ (string-write (/length-attribute (md-insn:cgen-insn insn))))
;; Use WELL-KNOWN-INTRINSIC to define the names of builtins that
;; gcc might treat specially.
; ??? All elements should really be assumed to be a black-box table.
(define (arch-ifld-list arch)
- (-ident-object-table->list (arch-ifld-table arch))
+ (/ident-object-table->list (arch-ifld-table arch))
)
(define (arch-op-list arch)
- (-ident-object-table->list (arch-op-table arch))
+ (/ident-object-table->list (arch-op-table arch))
)
(define (arch-insn-list arch)
- (-ident-object-table->list (arch-insn-table arch))
+ (/ident-object-table->list (arch-insn-table arch))
)
(define (arch-minsn-list arch)
- (-ident-object-table->list (arch-minsn-table arch))
+ (/ident-object-table->list (arch-minsn-table arch))
)
;; Get the next ordinal and increment it for the next time.
-(define (-get-next-ordinal! arch)
+(define (/get-next-ordinal! arch)
(let ((ordinal (arch-next-ordinal arch)))
(arch-set-next-ordinal! arch (+ ordinal 1))
ordinal)
;; FIXME: temp hack for current-ifld-lookup, current-op-lookup.
;; Return the element of list L with the lowest ordinal.
-(define (-get-lowest-ordinal l)
+(define (/get-lowest-ordinal l)
(let ((lowest-obj #f)
- (lowest-ord (-get-next-ordinal! CURRENT-ARCH)))
+ (lowest-ord (/get-next-ordinal! CURRENT-ARCH)))
(for-each (lambda (elm)
(if (< (obj-ordinal elm) lowest-ord)
(begin
;; This relies on the ordinal element of <source-ident> objects to build the
;; ordered list.
-(define (-make-ident-object-table hash-size)
+(define (/make-ident-object-table hash-size)
(cons (make-hash-table hash-size) #f)
)
;; integer and (integer . integer) where the latter is a pair of
;; major-ordinal-number and minor-ordinal-number.
-(define (-ident-object-table->list iot)
+(define (/ident-object-table->list iot)
(if (cdr iot)
(cdr iot)
(let ((unsorted (hash-fold (lambda (key value prior)
;; Add an entry to an ident-object-table.
-(define (-ident-object-table-add! arch iot key object)
+(define (/ident-object-table-add! arch iot key object)
;; Give OBJECT an ordinal if it doesn't have one already.
(if (not (obj-ordinal object))
- (obj-set-ordinal! object (-get-next-ordinal! arch)))
+ (obj-set-ordinal! object (/get-next-ordinal! arch)))
;; Remember: Elements in the hash table are lists of objects, this is because
;; multiple objects can have the same key if they come from different isas.
;; Look up KEY in an ident-object-table.
-(define (-ident-object-table-lookup iot key)
+(define (/ident-object-table-lookup iot key)
(hashq-ref iot key)
)
; Instruction fields.
(define (current-ifld-list)
- (-ident-object-table->list (arch-ifld-table CURRENT-ARCH))
+ (/ident-object-table->list (arch-ifld-table CURRENT-ARCH))
)
(define (current-ifld-add! f)
- (if (-ifld-already-defined? f)
+ (if (/ifld-already-defined? f)
(parse-error (make-obj-context f "define-ifield")
"ifield already defined" (obj:name f)))
- (-ident-object-table-add! CURRENT-ARCH (arch-ifld-table CURRENT-ARCH)
+ (/ident-object-table-add! CURRENT-ARCH (arch-ifld-table CURRENT-ARCH)
(obj:name f) f)
*UNSPECIFIED*
)
(define (current-ifld-lookup x)
(if (ifield? x)
x
- (let ((f-list (-ident-object-table-lookup (car (arch-ifld-table CURRENT-ARCH))
+ (let ((f-list (/ident-object-table-lookup (car (arch-ifld-table CURRENT-ARCH))
x)))
(if f-list
(if (= (length f-list) 1)
;; FIXME: For now just return the first one,
;; same behaviour as before.
;; Here "first one" means "first defined".
- (-get-lowest-ordinal f-list))
+ (/get-lowest-ordinal f-list))
#f)))
)
; This is slightly complicated because multiple isas can have different
; ifields with the same name.
-(define (-ifld-already-defined? f)
- (let ((iflds (-ident-object-table-lookup (car (arch-ifld-table CURRENT-ARCH))
+(define (/ifld-already-defined? f)
+ (let ((iflds (/ident-object-table-lookup (car (arch-ifld-table CURRENT-ARCH))
(obj:name f))))
; We've got all the ifields with the same name,
; now see if any have the same ISA as F.
; Operands.
(define (current-op-list)
- (-ident-object-table->list (arch-op-table CURRENT-ARCH))
+ (/ident-object-table->list (arch-op-table CURRENT-ARCH))
)
(define (current-op-add! op)
- (if (-op-already-defined? op)
+ (if (/op-already-defined? op)
(parse-error (make-obj-context op "define-operand")
"operand already defined" (obj:name op)))
- (-ident-object-table-add! CURRENT-ARCH (arch-op-table CURRENT-ARCH)
+ (/ident-object-table-add! CURRENT-ARCH (arch-op-table CURRENT-ARCH)
(obj:name op) op)
*UNSPECIFIED*
)
; for different isas.
(define (current-op-lookup name)
- (let ((op-list (-ident-object-table-lookup (car (arch-op-table CURRENT-ARCH))
+ (let ((op-list (/ident-object-table-lookup (car (arch-op-table CURRENT-ARCH))
name)))
(if op-list
(if (= (length op-list) 1)
(car op-list)
;; FIXME: For now just return the first one, same behaviour as before.
;; Here "first one" means "first defined".
- (-get-lowest-ordinal op-list))
+ (/get-lowest-ordinal op-list))
#f))
)
; This is slightly complicated because multiple isas can have different
; operands with the same name.
-(define (-op-already-defined? op)
- (let ((ops (-ident-object-table-lookup (car (arch-op-table CURRENT-ARCH))
+(define (/op-already-defined? op)
+ (let ((ops (/ident-object-table-lookup (car (arch-op-table CURRENT-ARCH))
(obj:name op))))
; We've got all the operands with the same name,
; now see if any have the same ISA as OP.
; Instructions.
(define (current-insn-list)
- (-ident-object-table->list (arch-insn-table CURRENT-ARCH))
+ (/ident-object-table->list (arch-insn-table CURRENT-ARCH))
)
(define (current-insn-add! i)
- (if (-insn-already-defined? i)
+ (if (/insn-already-defined? i)
(parse-error (make-obj-context i "define-insn")
"insn already defined" (obj:name i)))
- (-ident-object-table-add! CURRENT-ARCH (arch-insn-table CURRENT-ARCH)
+ (/ident-object-table-add! CURRENT-ARCH (arch-insn-table CURRENT-ARCH)
(obj:name i) i)
*UNSPECIFIED*
)
; for different isas.
(define (current-insn-lookup name)
- (let ((i (-ident-object-table-lookup (car (arch-insn-table CURRENT-ARCH))
+ (let ((i (/ident-object-table-lookup (car (arch-insn-table CURRENT-ARCH))
name)))
(if i
(begin
; This is slightly complicated because multiple isas can have different
; insns with the same name.
-(define (-insn-already-defined? insn)
- (let ((insns (-ident-object-table-lookup (car (arch-insn-table CURRENT-ARCH))
+(define (/insn-already-defined? insn)
+ (let ((insns (/ident-object-table-lookup (car (arch-insn-table CURRENT-ARCH))
(obj:name insn))))
; We've got all the insns with the same name,
; now see if any have the same ISA as INSN.
; Macro instructions.
(define (current-minsn-list)
- (-ident-object-table->list (arch-minsn-table CURRENT-ARCH))
+ (/ident-object-table->list (arch-minsn-table CURRENT-ARCH))
)
(define (current-minsn-add! m)
- (if (-minsn-already-defined? m)
+ (if (/minsn-already-defined? m)
(parse-error (make-obj-context m "define-minsn")
"macro-insn already defined" (obj:name m)))
- (-ident-object-table-add! CURRENT-ARCH (arch-minsn-table CURRENT-ARCH)
+ (/ident-object-table-add! CURRENT-ARCH (arch-minsn-table CURRENT-ARCH)
(obj:name m) m)
*UNSPECIFIED*
)
; for different isas.
(define (current-minsn-lookup name)
- (let ((m (-ident-object-table-lookup (car (arch-minsn-table CURRENT-ARCH))
+ (let ((m (/ident-object-table-lookup (car (arch-minsn-table CURRENT-ARCH))
name)))
(if m
(begin
; This is slightly complicated because multiple isas can have different
; macro-insns with the same name.
-(define (-minsn-already-defined? m)
- (let ((minsns (-ident-object-table-lookup (car (arch-minsn-table CURRENT-ARCH))
+(define (/minsn-already-defined? m)
+ (let ((minsns (/ident-object-table-lookup (car (arch-minsn-table CURRENT-ARCH))
(obj:name m))))
; We've got all the macro-insns with the same name,
; now see if any have the same ISA as M.
; Parse an alignment spec.
-(define (-arch-parse-alignment context alignment)
+(define (/arch-parse-alignment context alignment)
(if (memq alignment '(aligned unaligned forced))
alignment
(parse-error context "invalid alignment" alignment))
; The value is a list of mach names or (mach-name sanitize-key) elements.
; The result is a list of (mach-name . sanitize-key) elements.
-(define (-arch-parse-machs context machs)
+(define (/arch-parse-machs context machs)
(for-each (lambda (m)
(if (or (symbol? m)
(and (list? m) (= (length m) 2)
; The value is a list of isa names or (isa-name sanitize-key) elements.
; The result is a list of (isa-name . sanitize-key) elements.
-(define (-arch-parse-isas context isas)
+(define (/arch-parse-isas context isas)
(for-each (lambda (m)
(if (or (symbol? m)
(and (list? m) (= (length m) 2)
; description in the .cpu file.
; All arguments are in raw (non-evaluated) form.
-(define (-arch-parse context name comment attrs
+(define (/arch-parse context name comment attrs
default-alignment insn-lsb0?
machs isas)
(logit 2 "Processing arch " name " ...\n")
(parse-name context name)
(parse-comment context comment)
(atlist-parse context attrs "arch")
- (-arch-parse-alignment context default-alignment)
+ (/arch-parse-alignment context default-alignment)
(parse-boolean context insn-lsb0?)
- (-arch-parse-machs context machs)
- (-arch-parse-isas context isas))
+ (/arch-parse-machs context machs)
+ (/arch-parse-isas context isas))
)
; Read an architecture description.
; ARG-LIST is an associative list of field name and field value.
; parse-arch is invoked to create the `arch' object.
-(define -arch-read
+(define /arch-read
(lambda arg-list
(let ((context "arch-read")
; <arch-data> object members and default values
(if (not isas)
(parse-error context "missing isas spec"))
; Now that we've identified the elements, build the object.
- (-arch-parse context name comment attrs default-alignment insn-lsb0?
+ (/arch-parse context name comment attrs default-alignment insn-lsb0?
machs isas)
)
)
(define define-arch
(lambda arg-list
- (let ((a (apply -arch-read arg-list)))
+ (let ((a (apply /arch-read arg-list)))
(arch-set-data! CURRENT-ARCH a)
(def-mach-attr! (adata-machs a))
(keep-mach-validate!)
; FIXME: All possible values must be specified. Need an `else' clause.
; Ranges would also be useful.
-(define (-isa-parse-decode-split context spec)
+(define (/isa-parse-decode-split context spec)
(if (!= (length spec) 3)
(parse-error context "decode-split spec is (ifield-name constraint value-list)" spec))
; Parse a list of decode-split specs.
-(define (-isa-parse-decode-splits context spec-list)
+(define (/isa-parse-decode-splits context spec-list)
(map (lambda (spec)
- (-isa-parse-decode-split context spec))
+ (/isa-parse-decode-split context spec))
spec-list)
)
; `condition' here refers to the condition performed by architectures like
; ARM and ARC before each insn.
-(define (-isa-parse-condition context spec)
+(define (/isa-parse-condition context spec)
(if (null? spec)
#f
(begin
; Parse a setup-semantics spec.
-(define (-isa-parse-setup-semantics context spec)
+(define (/isa-parse-setup-semantics context spec)
(if (not (null? spec))
spec
#f)
; The result is the <isa> object.
; All arguments are in raw (non-evaluated) form.
-(define (-isa-parse context name comment attrs
+(define (/isa-parse context name comment attrs
base-insn-bitsize default-insn-bitsize default-insn-word-bitsize
decode-assist liw-insns parallel-insns condition
setup-semantics decode-splits)
decode-assist
liw-insns
parallel-insns
- (-isa-parse-condition context condition)
- (-isa-parse-setup-semantics context setup-semantics)
- (-isa-parse-decode-splits context decode-splits)
+ (/isa-parse-condition context condition)
+ (/isa-parse-setup-semantics context setup-semantics)
+ (/isa-parse-decode-splits context decode-splits)
))
)
; Read an isa entry.
; ARG-LIST is an associative list of field name and field value.
-(define (-isa-read context . arg-list)
+(define (/isa-read context . arg-list)
(let (
(name #f)
(attrs nil)
(loop (cdr arg-list)))))
;; Now that we've identified the elements, build the object.
- (-isa-parse context name comment attrs
+ (/isa-parse context name comment attrs
base-insn-bitsize
(if default-insn-word-bitsize
default-insn-word-bitsize
(define define-isa
(lambda arg-list
- (let ((i (apply -isa-read (cons (make-current-context "define-isa")
+ (let ((i (apply /isa-read (cons (make-current-context "define-isa")
arg-list))))
(if i
(current-isa-add! i))
; Subroutine of modify-isa to process one add-decode-split spec.
-(define (-isa-add-decode-split! context isa spec)
- (let ((decode-split (-isa-parse-decode-split context spec)))
+(define (/isa-add-decode-split! context isa spec)
+ (let ((decode-split (/isa-parse-decode-split context spec)))
(isa-set-decode-splits! (cons decode-split (isa-decode-splits isa)))
*UNSPECIFIED*)
)
(case (car arg-spec)
((name) #f) ; ignore, already processed
((add-decode-split)
- (-isa-add-decode-split! context isa (cdr arg-spec)))
+ (/isa-add-decode-split! context isa (cdr arg-spec)))
(else
(parse-error context "invalid/unsupported option" (car arg-spec))))
(loop (cdr args)))))))
; description in the .cpu file.
; All arguments are in raw (non-evaluated) form.
-(define (-cpu-parse context name comment attrs
+(define (/cpu-parse context name comment attrs
endian insn-endian data-endian float-endian
word-bitsize insn-chunk-bitsize file-transform parallel-insns)
(logit 2 "Processing cpu family " name " ...\n")
; This is the main routine for analyzing a cpu description in the .cpu file.
; CONTEXT is a <context> object for error messages.
; ARG-LIST is an associative list of field name and field value.
-; -cpu-parse is invoked to create the <cpu> object.
+; /cpu-parse is invoked to create the <cpu> object.
-(define (-cpu-read context . arg-list)
+(define (/cpu-read context . arg-list)
(let (
(name nil)
(comment nil)
(loop (cdr arg-list)))))
;; Now that we've identified the elements, build the object.
- (-cpu-parse context name comment attrs
+ (/cpu-parse context name comment attrs
endian insn-endian data-endian float-endian
word-bitsize insn-chunk-bitsize file-transform parallel-insns-))
)
(define define-cpu
(lambda arg-list
- (let ((c (apply -cpu-read (cons (make-current-context "define-cpu")
+ (let ((c (apply /cpu-read (cons (make-current-context "define-cpu")
arg-list))))
(if c
(begin
; The result is a <mach> object or #f if the mach isn't to be kept.
; All arguments are in raw (non-evaluated) form.
-(define (-mach-parse context name comment attrs cpu bfd-name isas)
+(define (/mach-parse context name comment attrs cpu bfd-name isas)
(logit 2 "Processing mach " name " ...\n")
;; Pick out name first to augment the error context.
; CONTEXT is a <context> object for error messages.
; ARG-LIST is an associative list of field name and field value.
-(define (-mach-read context . arg-list)
+(define (/mach-read context . arg-list)
(let (
(name nil)
(attrs nil)
(loop (cdr arg-list)))))
;; Now that we've identified the elements, build the object.
- (-mach-parse context name comment attrs cpu
+ (/mach-parse context name comment attrs cpu
;; Default bfd-name is same as object's name.
(if bfd-name bfd-name (symbol->string name))
;; Default isa is the first one.
(define define-mach
(lambda arg-list
- (let ((m (apply -mach-read (cons (make-current-context "define-mach")
+ (let ((m (apply /mach-read (cons (make-current-context "define-mach")
arg-list))))
(if m
(current-mach-add! m))
; computation.
; Often this data isn't needed so we only computed it if we have to.
-(define (-adata-set-derived! arch)
+(define (/adata-set-derived! arch)
; Don't compute this data unless we need to.
(arch-set-derived!
arch
(define (mach-init!)
(let ((arch CURRENT-ARCH))
- (arch-set-ifld-table! arch (-make-ident-object-table 127))
- (arch-set-op-table! arch (-make-ident-object-table 127))
- (arch-set-insn-table! arch (-make-ident-object-table 509))
- (arch-set-minsn-table! arch (-make-ident-object-table 127))
+ (arch-set-ifld-table! arch (/make-ident-object-table 127))
+ (arch-set-op-table! arch (/make-ident-object-table 127))
+ (arch-set-insn-table! arch (/make-ident-object-table 509))
+ (arch-set-minsn-table! arch (/make-ident-object-table 127))
)
(reader-add-command! 'define-mach
; Called after .cpu file is read in.
(define (mach-finish!)
- (-adata-set-derived! CURRENT-ARCH)
+ (/adata-set-derived! CURRENT-ARCH)
*UNSPECIFIED*
)
; Parse a macro-insn expansion description.
; ??? At present we only support unconditional simple expansion.
-(define (-minsn-parse-expansion context expn)
+(define (/minsn-parse-expansion context expn)
(if (not (form? expn))
(parse-error context "invalid macro expansion" expn))
(if (not (eq? 'emit (car expn)))
; All arguments are in raw (non-evaluated) form.
; The result is the parsed object or #f if object isn't for selected mach(s).
-(define (-minsn-parse context name comment attrs syntax expansions)
+(define (/minsn-parse context name comment attrs syntax expansions)
(logit 2 "Processing macro-insn " name " ...\n")
(if (not (list? expansions))
(parse-comment context comment)
atlist-obj
(parse-syntax context syntax)
- (map (lambda (e) (-minsn-parse-expansion context e))
+ (map (lambda (e) (/minsn-parse-expansion context e))
expansions))))
result)
; This is the main routine for analyzing macro-insns in the .cpu file.
; CONTEXT is a <context> object for error messages.
; ARG-LIST is an associative list of field name and field value.
-; -minsn-parse is invoked to create the `macro-insn' object.
+; /minsn-parse is invoked to create the `macro-insn' object.
-(define (-minsn-read context . arg-list)
+(define (/minsn-read context . arg-list)
(let (
(name nil)
(comment "")
(loop (cdr arg-list)))))
; Now that we've identified the elements, build the object.
- (-minsn-parse context name comment attrs syntax expansions))
+ (/minsn-parse context name comment attrs syntax expansions))
)
; Define a macro-insn object, name/value pair list version.
(lambda arg-list
(if (eq? APPLICATION 'SIMULATOR)
#f ; don't waste time if simulator
- (let ((m (apply -minsn-read (cons (make-current-context "define-minsn")
+ (let ((m (apply /minsn-read (cons (make-current-context "define-minsn")
arg-list))))
(if m
(current-minsn-add! m))
(define (define-full-minsn name comment attrs syntax expansion)
(if (eq? APPLICATION 'SIMULATOR)
#f ; don't waste time if simulator
- (let ((m (-minsn-parse (make-current-context "define-full-minsn")
+ (let ((m (/minsn-parse (make-current-context "define-full-minsn")
name comment
(cons 'ALIAS attrs)
syntax (list expansion))))
; This involves making a copy of REAL-INSN's ifield list and assigning
; known quantities to operands that have fixed values in the macro-insn.
-(define (-minsn-compute-iflds context minsn-iflds real-insn)
+(define (/minsn-compute-iflds context minsn-iflds real-insn)
(let* ((iflds (list-copy (insn-iflds real-insn)))
; List of "free variables", i.e. operands.
(ifld-ops (find ifld-operand? iflds))
(obj:comment minsn)
(obj-atlist minsn)
(minsn-syntax minsn)
- (-minsn-compute-iflds (context-append context
+ (/minsn-compute-iflds (context-append context
(string-append ": " (obj:str-name minsn)))
(cddr expn) alias-of)
#f ; ifield-assertion
; This is the main routine for building a mode object.
; All arguments are in raw (non-evaluated) form.
-(define (-mode-parse context name comment attrs class bits bytes
+(define (/mode-parse context name comment attrs class bits bytes
non-mode-c-type printf-type sem-mode ptr-to host?)
(logit 2 "Processing mode " name " ...\n")
(define (define-full-mode name comment attrs class bits bytes
non-mode-c-type printf-type sem-mode ptr-to host?)
- (let ((m (-mode-parse (make-current-context "define-full-mode")
+ (let ((m (/mode-parse (make-current-context "define-full-mode")
name comment attrs
class bits bytes
non-mode-c-type printf-type sem-mode ptr-to host?)))
; Kind of word size handling wanted.
; BIGGEST: pick the largest word size
; IDENTICAL: all word sizes must be identical
-(define -mode-word-sizes-kind #f)
+(define /mode-word-sizes-kind #f)
; Called when a cpu-family is read in to set the word sizes.
; Enforce word size kind.
(if (!= current-word-bitsize 0)
; word size already set
- (case -mode-word-sizes-kind
+ (case /mode-word-sizes-kind
((IDENTICAL)
(if (!= current-word-bitsize (mode:bits word-mode))
(error "app requires all selected cpu families to have same word size"))
; Must be called before loading .cpu files.
(define (mode-set-identical-word-bitsizes!)
- (set! -mode-word-sizes-kind 'IDENTICAL)
+ (set! /mode-word-sizes-kind 'IDENTICAL)
)
; Called by apps to indicate using the biggest cpu:word-bitsize of all
; Must be called before loading .cpu files.
(define (mode-set-biggest-word-bitsizes!)
- (set! -mode-word-sizes-kind 'BIGGEST)
+ (set! /mode-word-sizes-kind 'BIGGEST)
)
; Ensure word sizes have been defined.
(define UINT #f)
(define (mode-init!)
- (set! -mode-word-sizes-kind 'IDENTICAL)
+ (set! /mode-word-sizes-kind 'IDENTICAL)
(reader-add-command! 'define-full-mode
"\
\f
; Parse a `prefetch' spec.
-(define (-prefetch-parse context expr)
+(define (/prefetch-parse context expr)
nil
)
; Parse a `retire' spec.
-(define (-retire-parse context expr)
+(define (/retire-parse context expr)
nil
)
; ??? Perhaps we should also use name/value pairs here, but that's an
; unnecessary complication at this point in time.
-(define (-pipeline-parse context model-name spec) ; name comments attrs elements)
+(define (/pipeline-parse context model-name spec) ; name comments attrs elements)
(if (not (= (length spec) 4))
(parse-error context "pipeline spec not `name comment attrs elements'" spec))
(apply make (cons <pipeline> spec))
; ??? Perhaps we should also use name/value pairs here, but that's an
; unnecessary complication at this point in time.
-(define (-unit-parse context model-name spec) ; name comments attrs elements)
+(define (/unit-parse context model-name spec) ; name comments attrs elements)
(if (not (= (length spec) 9))
(parse-error context "unit spec not `name comment attrs issue done state inputs outputs profile'" spec))
(apply make (append (cons <unit> spec) (list model-name)))
; description in the .cpu file.
; All arguments are in raw (non-evaluated) form.
-(define (-model-parse context name comment attrs mach-name prefetch retire pipelines state units)
+(define (/model-parse context name comment attrs mach-name prefetch retire pipelines state units)
(logit 2 "Processing model " name " ...\n")
;; Pick out name first to augment the error context.
(parse-comment context comment)
(atlist-parse context attrs "cpu")
mach
- (-prefetch-parse context prefetch)
- (-retire-parse context retire)
- (map (lambda (p) (-pipeline-parse context name p)) pipelines)
+ (/prefetch-parse context prefetch)
+ (/retire-parse context retire)
+ (map (lambda (p) (/pipeline-parse context name p)) pipelines)
state
- (map (lambda (u) (-unit-parse context name u)) units))))
+ (map (lambda (u) (/unit-parse context name u)) units))))
model-obj)
(begin
; This is the main routine for analyzing models in the .cpu file.
; CONTEXT is a <context> object for error messages.
; ARG-LIST is an associative list of field name and field value.
-; -model-parse is invoked to create the `model' object.
+; /model-parse is invoked to create the `model' object.
-(define (-model-read context . arg-list)
+(define (/model-read context . arg-list)
(let (
(name nil) ; name of model
(comment nil) ; description of model
(loop (cdr arg-list)))))
; Now that we've identified the elements, build the object.
- (-model-parse context name comment attrs mach prefetch retire pipelines state units))
+ (/model-parse context name comment attrs mach prefetch retire pipelines state units))
)
; Define a cpu model object, name/value pair list version.
(define define-model
(lambda arg-list
- (let ((m (apply -model-read (cons (make-current-context "define-model")
+ (let ((m (apply /model-read (cons (make-current-context "define-model")
arg-list))))
(if m
(current-model-add! m))
; Subroutine of parse-insn-timing to parse the timing spec for MODEL.
; The result is a <timing> object.
-(define (-insn-timing-parse-model context model spec)
+(define (/insn-timing-parse-model context model spec)
(make <timing> model
(map (lambda (unit-timing-desc)
(let ((type (car unit-timing-desc))
(model (current-model-lookup model-name)))
(cons model-name
(if model
- (-insn-timing-parse-model context model
+ (/insn-timing-parse-model context model
(cdr model-timing-desc))
'()))))
insn-timing-desc)
; Assembler support.
-(define (-gen-parse-switch)
+(define (/gen-parse-switch)
(logit 2 "Generating parse switch ...\n")
(string-list
"\
; Assembler initialization C code
; Code is appended during processing.
-(define -asm-init-code "")
+(define /asm-init-code "")
(define (add-asm-init code)
- (set! -asm-init-code (string-append -asm-init-code code))
+ (set! /asm-init-code (string-append /asm-init-code code))
)
; Return C code to define the assembler init function.
; This is called after opcode_open.
-(define (-gen-init-asm-fn)
+(define (/gen-init-asm-fn)
(string-append
"\
void
CGEN_ASM_INIT_HOOK
#endif
"
- -asm-init-code
+ /asm-init-code
"}\n\n"
)
)
"\n"
(lambda () (gen-extra-asm.c (opc-file-path) (current-arch-name)))
"\n"
- -gen-parse-switch
+ /gen-parse-switch
(lambda () (gen-handler-table "parse" opc-parse-handlers))
- -gen-init-asm-fn
+ /gen-init-asm-fn
)
)
\f
; Disassembler support.
-(define (-gen-print-switch)
+(define (/gen-print-switch)
(logit 2 "Generating print switch ...\n")
(string-list
"\
; Disassembler initialization C code.
; Code is appended during processing.
-(define -dis-init-code "")
+(define /dis-init-code "")
(define (add-dis-init code)
- (set! -dis-init-code (string-append -dis-init-code code))
+ (set! /dis-init-code (string-append /dis-init-code code))
)
; Return C code to define the disassembler init function.
-(define (-gen-init-dis-fn)
+(define (/gen-init-dis-fn)
(string-append
"
void
cd->print_handlers = & @arch@_cgen_print_handlers[0];
cd->print_operand = @arch@_cgen_print_operand;
"
- -dis-init-code
+ /dis-init-code
"}\n\n"
)
)
"\n"
(lambda () (gen-extra-dis.c (opc-file-path) (current-arch-name)))
"\n"
- -gen-print-switch
+ /gen-print-switch
(lambda () (gen-handler-table "print" opc-print-handlers))
- -gen-init-dis-fn
+ /gen-init-dis-fn
)
)
; Instruction field support.
-(define (-gen-fget-switch)
+(define (/gen-fget-switch)
(logit 2 "Generating field get switch ...\n")
(string-list
"\
\n")
)
-(define (-gen-fset-switch)
+(define (/gen-fset-switch)
(logit 2 "Generating field set switch ...\n")
(string-list
"\
\f
; Generate the C code for dealing with operands.
-(define (-gen-insert-switch)
+(define (/gen-insert-switch)
(logit 2 "Generating insert switch ...\n")
(string-list
"\
}\n\n")
)
-(define (-gen-extract-switch)
+(define (/gen-extract-switch)
(logit 2 "Generating extract switch ...\n")
(string-list
"\
; Emit a function to call to initialize the ibld tables.
-(define (-gen-ibld-init-fn)
+(define (/gen-ibld-init-fn)
(string-write
"\
/* Function to call before using the instruction builder tables. */
(string-write
; No need for copyright, appended to file with one.
"\n"
- -gen-insert-switch
- -gen-extract-switch
+ /gen-insert-switch
+ /gen-extract-switch
(lambda () (gen-handler-table "insert" opc-insert-handlers))
(lambda () (gen-handler-table "extract" opc-extract-handlers))
- -gen-fget-switch
- -gen-fset-switch
- -gen-ibld-init-fn
+ /gen-fget-switch
+ /gen-fset-switch
+ /gen-ibld-init-fn
)
)
; Define CGEN_INIT_{PARSE,INSERT,EXTRACT,PRINT} macros.
; ??? These were early escape hatches. Not currently used.
-(define (-gen-init-macros)
+(define (/gen-init-macros)
(logit 2 "Generating init macros ...\n")
(string-append
"#define CGEN_INIT_PARSE(od) \\
; Return C code to declare various ifield types,decls.
-(define (-gen-ifield-decls)
+(define (/gen-ifield-decls)
(logit 2 "Generating instruction field decls ...\n")
(string-append
"/* This struct records data prior to insertion or after extraction. */\n"
; Return the table for IFMT, an <iformat> object.
-(define (-gen-ifmt-table-1 ifmt)
+(define (/gen-ifmt-table-1 ifmt)
(gen-obj-sanitize
(ifmt-eg-insn ifmt) ; sanitize based on the example insn
(string-list
; Generate the insn format table.
-(define (-gen-ifmt-table)
+(define (/gen-ifmt-table)
(string-write
"/* Instruction formats. */\n\n"
(gen-define-with-symcat "F(f) & @arch@_cgen_ifld_table[@ARCH@_" "f]")
- (string-list-map -gen-ifmt-table-1 (current-ifmt-list))
+ (string-list-map /gen-ifmt-table-1 (current-ifmt-list))
"#undef F\n\n"
)
)
; Return a declaration of an enum for all insns.
-(define (-gen-insn-enum)
+(define (/gen-insn-enum)
(logit 2 "Generating instruction enum ...\n")
(let ((insns (gen-obj-list-enums (non-multi-insns (current-insn-list)))))
(string-list
; ALL-ATTRS is a list of all instruction attributes.
; NUM-NON-BOOLS is the number of non-boolean insn attributes.
-(define (-gen-insn-opcode-entry insn all-attrs num-non-bools)
+(define (/gen-insn-opcode-entry insn all-attrs num-non-bools)
(gen-obj-sanitize
insn
(string-list
; Generate insn table.
-(define (-gen-insn-opcode-table)
+(define (/gen-insn-opcode-table)
(logit 2 "Generating instruction opcode table ...\n")
(let* ((all-attrs (current-insn-attr-list))
(num-non-bools (attr-count-non-bools all-attrs)))
(lambda ()
(string-write-map (lambda (insn)
(logit 3 "Generating insn opcode entry for " (obj:name insn) " ...\n")
- (-gen-insn-opcode-entry insn all-attrs
+ (/gen-insn-opcode-entry insn all-attrs
num-non-bools))
(non-multi-insns (current-insn-list))))
\f
; Return assembly/disassembly hashing support.
-(define (-gen-hash-fns)
+(define (/gen-hash-fns)
(string-list
"\
#ifndef CGEN_ASM_HASH_P
; Hash support decls.
-(define (-gen-hash-decls)
+(define (/gen-hash-decls)
(string-list
"\
/* The hash functions are recorded here to help keep assembler code out of
; Return a macro-insn expansion entry.
-(define (-gen-miexpn-entry entry)
+(define (/gen-miexpn-entry entry)
; FIXME: wip
"0, "
)
; Return a macro-insn table entry.
; ??? wip, not currently used.
-(define (-gen-minsn-table-entry minsn all-attrs num-non-bools)
+(define (/gen-minsn-table-entry minsn all-attrs num-non-bools)
(gen-obj-sanitize
minsn
(string-list
; Return a macro-insn opcode table entry.
; ??? wip, not currently used.
-(define (-gen-minsn-opcode-entry minsn all-attrs num-non-bools)
+(define (/gen-minsn-opcode-entry minsn all-attrs num-non-bools)
(gen-obj-sanitize
minsn
(string-list
; expanding to text, the macro-expansion could invoke the builder for each
; expanded-to insn.
-(define (-gen-macro-insn-table)
+(define (/gen-macro-insn-table)
(logit 2 "Generating macro-instruction table ...\n")
(let* ((minsn-list (map (lambda (minsn)
(if (has-attr? minsn 'ALIAS)
"/* Formats for ALIAS macro-insns. */\n\n"
(gen-define-with-symcat "F(f) & @arch@_cgen_ifld_table[@ARCH@_" "f]")
(lambda ()
- (string-write-map -gen-ifmt-table-1
+ (string-write-map /gen-ifmt-table-1
(map insn-ifmt (find (lambda (minsn)
(has-attr? minsn 'ALIAS))
minsn-list))))
(string-append
"static const CGEN_MINSN_EXPANSION macro_" (gen-sym minsn) "_expansions[] =\n"
"{\n"
- (string-map -gen-miexpn-entry
+ (string-map /gen-miexpn-entry
(minsn-expansions minsn))
" { 0, 0 }\n};\n\n")))
minsn-list))
; Simple macro-insns are emitted as aliases of real insns.
(if (has-attr? minsn 'ALIAS)
(gen-insn-table-entry minsn all-attrs num-non-bools)
- (-gen-minsn-table-entry minsn all-attrs num-non-bools)))
+ (/gen-minsn-table-entry minsn all-attrs num-non-bools)))
minsn-list))
"\
};
(logit 3 "Generating macro-insn table entry for " (obj:name minsn) " ...\n")
; Simple macro-insns are emitted as aliases of real insns.
(if (has-attr? minsn 'ALIAS)
- (-gen-insn-opcode-entry minsn all-attrs num-non-bools)
- (-gen-minsn-opcode-entry minsn all-attrs num-non-bools)))
+ (/gen-insn-opcode-entry minsn all-attrs num-non-bools)
+ (/gen-minsn-opcode-entry minsn all-attrs num-non-bools)))
minsn-list))
"\
};
\f
; Emit a function to call to initialize the opcode table.
-(define (-gen-opcode-init-fn)
+(define (/gen-opcode-init-fn)
(string-write
"\
/* Set the recorded length of the insn in the CGEN_FIELDS struct. */
"
(lambda () (gen-extra-opc.h (opc-file-path) (current-arch-name)))
- -gen-insn-enum
- -gen-ifield-decls
- -gen-init-macros
+ /gen-insn-enum
+ /gen-ifield-decls
+ /gen-init-macros
"
#endif /* @ARCH@_OPC_H */
#include \"libiberty.h\"
\n"
(lambda () (gen-extra-opc.c (opc-file-path) (current-arch-name)))
- -gen-hash-decls
- -gen-ifmt-table
- -gen-insn-opcode-table
- -gen-macro-insn-table
- -gen-hash-fns
- -gen-opcode-init-fn
+ /gen-hash-decls
+ /gen-ifmt-table
+ /gen-insn-opcode-table
+ /gen-macro-insn-table
+ /gen-hash-fns
+ /gen-opcode-init-fn
)
)
; Return C code to define one instance of operand object OP.
; TYPE is one of "INPUT" or "OUTPUT".
-(define (-gen-operand-instance op type)
+(define (/gen-operand-instance op type)
(let ((index (op:index op)))
(string-append " { "
type ", "
; which register(s) the next instruction operates on), this will need
; additional support.
-(define (-gen-operand-instance-table sfmt)
+(define (/gen-operand-instance-table sfmt)
(let ((ins (sfmt-in-ops sfmt))
(outs (sfmt-out-ops sfmt)))
; This used to exclude outputing anything if there were no ins or outs.
(string-append
"static const CGEN_OPINST "
(gen-sym sfmt) "_ops[] ATTRIBUTE_UNUSED = {\n"
- (string-map (lambda (op) (-gen-operand-instance op "INPUT"))
+ (string-map (lambda (op) (/gen-operand-instance op "INPUT"))
ins)
- (string-map (lambda (op) (-gen-operand-instance op "OUTPUT"))
+ (string-map (lambda (op) (/gen-operand-instance op "OUTPUT"))
outs)
" { END, (const char *)0, (enum cgen_hw_type)0, (enum cgen_mode)0, (enum cgen_operand_type)0, 0, 0 }\n};\n\n")))
)
-(define (-gen-operand-instance-tables)
+(define (/gen-operand-instance-tables)
(string-write
"\
/* Operand references. */
#define COND_REF CGEN_OPINST_COND_REF
"
- (lambda () (string-write-map -gen-operand-instance-table (current-sfmt-list)))
+ (lambda () (string-write-map /gen-operand-instance-table (current-sfmt-list)))
"\
#undef OP_ENT
#undef INPUT
; Return C code to define a table to lookup an insn's operand instance table.
-(define (-gen-insn-opinst-lookup-table)
+(define (/gen-insn-opinst-lookup-table)
(string-list
"/* Operand instance lookup table. */\n\n"
"static const CGEN_OPINST *@arch@_cgen_opinst_table[MAX_INSNS] = {\n"
; If not generating the operand instance table, use a heuristic.
(define (max-operand-instances)
- (if -opcodes-build-operand-instance-table?
+ (if /opcodes-build-operand-instance-table?
(apply max
(map (lambda (insn)
(+ (length (sfmt-in-ops (insn-sfmt insn)))
(logit 1 "Doing so now ...\n")
(arch-analyze-insns! CURRENT-ARCH
#t ; include aliases
- #t) ; -opcodes-build-operand-instance-table?
+ #t) ; /opcodes-build-operand-instance-table?
))
(string-write
#include \"@prefix@-desc.h\"
#include \"@prefix@-opc.h\"
\n"
- -gen-operand-instance-tables
- -gen-insn-opinst-lookup-table
+ /gen-operand-instance-tables
+ /gen-insn-opinst-lookup-table
)
)
(set! APPLICATION 'OPCODES)
; Records the -OPC arg which specifies the path to the .opc file.
-(define -opc-file-path #f)
+(define /opc-file-path #f)
(define (opc-file-path)
- (if -opc-file-path
- -opc-file-path
+ (if /opc-file-path
+ /opc-file-path
(error ".opc file unspecified, missing -OPC argument"))
)
(define (set-opc-file-path! path)
- (set! -opc-file-path path)
+ (set! /opc-file-path path)
)
; Return #t if the -OPC parameter was specified.
(define (opc-file-provided?)
- (and -opc-file-path #t)
+ (and /opc-file-path #t)
)
; Boolean indicating if we're to build the operand instance table.
; ??? Simulator tracing support could use it.
; ??? Might be lazily built at runtime by parsing the semantic code
; (which would be recorded in the insn table).
-(define -opcodes-build-operand-instance-table? #f)
+; FIXME: Referenced outside this file in opc-opinst.scm.
+(define /opcodes-build-operand-instance-table? #f)
; String containing copyright text.
(define CURRENT-COPYRIGHT #f)
; Initialize the options.
(define (option-init!)
- (set! -opcodes-build-operand-instance-table? #f)
+ (set! /opcodes-build-operand-instance-table? #f)
(set! CURRENT-COPYRIGHT copyright-fsf)
(set! CURRENT-PACKAGE package-gnu-binutils-gdb)
*UNSPECIFIED*
(define (option-set! name value)
(case name
- ((opinst) (set! -opcodes-build-operand-instance-table? #t))
+ ((opinst) (set! /opcodes-build-operand-instance-table? #t))
((copyright) (cond ((equal? value '("fsf"))
(set! CURRENT-COPYRIGHT copyright-fsf))
((equal? value '("redhat"))
; PARSE-FN is the name of the function to call or #f to use the default.
; OP-ENUM is the enum of the operand.
-(define (-gen-parse-number mode parse-fn op-enum result-var-name)
+(define (/gen-parse-number mode parse-fn op-enum result-var-name)
(string-append
" errmsg = "
; Use operand's special parse function if there is one, otherwise compute
; PARSE-FN is the name of the function to call or #f to use the default.
; OP-ENUM is the enum of the operand.
-(define (-gen-parse-address parse-fn op-enum result-var-name)
+(define (/gen-parse-address parse-fn op-enum result-var-name)
(string-append
" {\n"
" bfd_vma value = 0;\n"
((ifield) (gen-operand-result-var (op-ifield operand)))
(else "junk"))))
(if (address? (op:type operand))
- (-gen-parse-address (send operand 'gen-function-name 'parse)
+ (/gen-parse-address (send operand 'gen-function-name 'parse)
(op-enum operand)
result-var)
- (-gen-parse-number mode (send operand 'gen-function-name 'parse)
+ (/gen-parse-number mode (send operand 'gen-function-name 'parse)
(op-enum operand)
result-var))))
)
; Still need to traverse the semantics to derive machine computed attributes.
(arch-analyze-insns! CURRENT-ARCH
#t ; include aliases
- -opcodes-build-operand-instance-table?)
+ /opcodes-build-operand-instance-table?)
*UNSPECIFIED*
)
\f
; Parsing support.
-; Utility of -operand-parse-[gs]etter to build the expected syntax,
+; Utility of /operand-parse-[gs]etter to build the expected syntax,
; for use in error messages.
-(define (-operand-g/setter-syntax rank setter?)
+(define (/operand-g/setter-syntax rank setter?)
(string-append "("
(string-drop1
(numbers->string (iota rank) " index"))
; Omit `index-names' for scalar objects.
; {rank} is the required number of elements in {index-names}.
-(define (-operand-parse-getter context getter rank)
+(define (/operand-parse-getter context getter rank)
(if (null? getter)
#f ; use default
(let ()
(= (length (car getter)) rank))))
(parse-error context
(string-append "invalid getter, should be "
- (-operand-g/setter-syntax rank #f))
+ (/operand-g/setter-syntax rank #f))
getter))
(if (not (rtx? (cadr getter)))
(parse-error context "invalid rtx expression" getter))
; Omit `index-names' for scalar objects.
; {rank} is the required number of elements in {index-names}.
-(define (-operand-parse-setter context setter rank)
+(define (/operand-parse-setter context setter rank)
(if (null? setter)
#f ; use default
(let ()
(= (+ 1 (length (car setter)) rank)))))
(parse-error context
(string-append "invalid setter, should be "
- (-operand-g/setter-syntax rank #t))
+ (/operand-g/setter-syntax rank #t))
setter))
(if (not (rtx? (cadr setter)))
(parse-error context "invalid rtx expression" setter))
; ??? This only takes insn fields as the index. May need another proc (or an
; enhancement of this one) that takes other kinds of indices.
-(define (-operand-parse context name comment attrs hw mode ifld handlers getter setter)
+(define (/operand-parse context name comment attrs hw mode ifld handlers getter setter)
(logit 2 "Processing operand " name " ...\n")
;; Pick out name first to augment the error context.
mode ; ditto, this is a name, not an object
hw-index
(parse-handlers context '(parse print) handlers)
- (-operand-parse-getter context getter (if scalar? 0 1))
- (-operand-parse-setter context setter (if scalar? 0 1))
+ (/operand-parse-getter context getter (if scalar? 0 1))
+ (/operand-parse-setter context setter (if scalar? 0 1))
)))
(begin
; This is the main routine for analyzing operands in the .cpu file.
; CONTEXT is a <context> object for error messages.
; ARG-LIST is an associative list of field name and field value.
-; -operand-parse is invoked to create the <operand> object.
+; /operand-parse is invoked to create the <operand> object.
-(define (-operand-read context . arg-list)
+(define (/operand-read context . arg-list)
(let (
(name nil)
(comment nil)
(loop (cdr arg-list)))))
; Now that we've identified the elements, build the object.
- (-operand-parse context name comment attrs type mode index handlers
+ (/operand-parse context name comment attrs type mode index handlers
getter setter))
)
(define define-operand
(lambda arg-list
- (let ((op (apply -operand-read (cons (make-current-context "define-operand")
+ (let ((op (apply /operand-read (cons (make-current-context "define-operand")
arg-list))))
(if op
(current-op-add! op))
; Define an operand object, all arguments specified.
(define (define-full-operand name comment attrs type mode index handlers getter setter)
- (let ((op (-operand-parse (make-current-context "define-full-operand")
+ (let ((op (/operand-parse (make-current-context "define-full-operand")
name comment attrs
type mode index handlers getter setter)))
(if op
\f
; Derived/Anyof parsing support.
-; Subroutine of -derived-operand-parse to parse the encoding.
+; Subroutine of /derived-operand-parse to parse the encoding.
; The result is a <derived-ifield> object.
; The {owner} member still needs to be set!
-(define (-derived-parse-encoding context operand-name encoding)
+(define (/derived-parse-encoding context operand-name encoding)
(if (or (null? encoding)
(not (list? encoding)))
(parse-error context "encoding not a list" encoding))
(if (not (eq? (car encoding) '+))
(parse-error context "encoding must begin with `+'" encoding))
- ; ??? Calling -parse-insn-format is a quick hack.
+ ; ??? Calling /parse-insn-format is a quick hack.
; It's an internal routine of some other file.
- (let ((iflds (-parse-insn-format context encoding)))
+ (let ((iflds (/parse-insn-format context encoding)))
(make <derived-ifield>
operand-name
'derived-ifield ; (string-append "<derived-ifield> for " operand-name)
))
)
-; Subroutine of -derived-operand-parse to parse the ifield assertion.
+; Subroutine of /derived-operand-parse to parse the ifield assertion.
; The ifield assertion is either () or an RTL expression asserting something
; about the ifield values of the containing insn.
; Operands are specified by name, but what is used is their indices (there's
; an implicit `index-of' going on).
-(define (-derived-parse-ifield-assertion context args ifield-assertion)
+(define (/derived-parse-ifield-assertion context args ifield-assertion)
; FIXME: for now
(if (null? ifield-assertion)
#f
; ??? Currently no support for handlers(,???) found in normal operands.
; Later, when necessary.
-(define (-derived-operand-parse context name comment attrs mode
+(define (/derived-operand-parse context name comment attrs mode
args syntax
base-ifield encoding ifield-assertion
getter setter)
(if (keep-atlist? atlist-obj #f)
(let ((mode-obj (parse-mode-name context mode))
- (parsed-encoding (-derived-parse-encoding context name encoding)))
+ (parsed-encoding (/derived-parse-encoding context name encoding)))
(if (not mode-obj)
(parse-error context "unknown mode" mode))
syntax
base-ifield ; FIXME: validate
parsed-encoding
- (-derived-parse-ifield-assertion context args ifield-assertion)
+ (/derived-parse-ifield-assertion context args ifield-assertion)
(if (null? getter)
#f
- (-operand-parse-getter context
+ (/operand-parse-getter context
(list args
(rtx-canonicalize context getter))
(length args)))
(if (null? setter)
#f
- (-operand-parse-setter context
+ (/operand-parse-setter context
(list (append args '(newval))
(rtx-canonicalize context setter))
(length args)))
; This is the main routine for analyzing derived operands in the .cpu file.
; CONTEXT is a <context> object for error messages.
; ARG-LIST is an associative list of field name and field value.
-; -derived-operand-parse is invoked to create the <derived-operand> object.
+; /derived-operand-parse is invoked to create the <derived-operand> object.
-(define (-derived-operand-read context . arg-list)
+(define (/derived-operand-read context . arg-list)
(let (
(name nil)
(comment nil)
(loop (cdr arg-list)))))
; Now that we've identified the elements, build the object.
- (-derived-operand-parse context name comment attrs mode args
+ (/derived-operand-parse context name comment attrs mode args
syntax base-ifield encoding ifield-assertion
getter setter))
)
(define define-derived-operand
(lambda arg-list
- (let ((op (apply -derived-operand-read
+ (let ((op (apply /derived-operand-read
(cons (make-current-context "define-derived-operand")
arg-list))))
(if op
; ??? Not supported (yet).
;
;(define (define-full-derived-operand name comment attrs mode ...)
-; (let ((op (-derived-operand-parse (make-current-context "define-full-derived-operand")
+; (let ((op (/derived-operand-parse (make-current-context "define-full-derived-operand")
; name comment attrs
; mode ...)))
; (if op
; Parse an "anyof" choice, which is a derived-operand name.
; The result is {choice} unchanged.
-(define (-anyof-parse-choice context choice)
+(define (/anyof-parse-choice context choice)
(if (not (symbol? choice))
(parse-error context "anyof choice not a symbol" choice))
(let ((op (current-op-lookup choice)))
; ??? Currently no support for handlers(,???) found in normal operands.
; Later, when necessary.
-(define (-anyof-operand-parse context name comment attrs mode
+(define (/anyof-operand-parse context name comment attrs mode
base-ifield choices)
(logit 2 "Processing anyof operand " name " ...\n")
mode
base-ifield
(map (lambda (c)
- (-anyof-parse-choice context c))
+ (/anyof-parse-choice context c))
choices)))
(begin
; This is the main routine for analyzing anyof operands in the .cpu file.
; CONTEXT is a <context> object for error messages.
; ARG-LIST is an associative list of field name and field value.
-;
-anyof-operand-parse is invoked to create the <anyof-operand> object.
+;
/anyof-operand-parse is invoked to create the <anyof-operand> object.
-(define (-anyof-operand-read context . arg-list)
+(define (/anyof-operand-read context . arg-list)
(let (
(name nil)
(comment nil)
(loop (cdr arg-list)))))
; Now that we've identified the elements, build the object.
- (-anyof-operand-parse context name comment attrs mode base-ifield choices))
+ (/anyof-operand-parse context name comment attrs mode base-ifield choices))
)
; Define an anyof operand object, name/value pair list version.
(define define-anyof-operand
(lambda arg-list
- (let ((op (apply -anyof-operand-read
+ (let ((op (apply /anyof-operand-read
(cons (make-current-context "define-anyof-operand")
arg-list))))
(if op
; Return initial list of known ifield values in {anyof-instance}.
-(define (-anyof-initial-known anyof-instance)
+(define (/anyof-initial-known anyof-instance)
(assert (derived-operand? anyof-instance))
(let ((encoding (derived-encoding anyof-instance)))
(assert (derived-ifield? encoding))
#t))
)
-; Subroutine of -anyof-merge-subchoices.
+; Subroutine of /anyof-merge-subchoices.
; Merge syntaxes of VALUE-NAMES/VALUES into SYNTAX.
;
; Example:
; If SYNTAX is "$a+$b", and VALUE-NAMES is (b), and VALUES is
; ("$c+$d"-object), then return "$a+$c+$d".
-(define (-anyof-syntax anyof-instance)
+(define (/anyof-syntax anyof-instance)
(elm-get anyof-instance 'syntax)
)
-(define (-anyof-name anyof-instance)
+(define (/anyof-name anyof-instance)
(elm-get anyof-instance 'name)
)
-(define (-anyof-merge-syntax syntax value-names values)
+(define (/anyof-merge-syntax syntax value-names values)
(let ((syntax-elements (syntax-break-out syntax)))
(syntax-make (map (lambda (e)
(if (anyof-operand? e)
(if (not indx)
(error "Name " name " not one of " values)
)
- (-anyof-syntax (list-ref values indx)))
+ (/anyof-syntax (list-ref values indx)))
e))
syntax-elements)))
)
-; Subroutine of -anyof-merge-subchoices.
+; Subroutine of /anyof-merge-subchoices.
; Merge syntaxes of {value-names}/{values} into <derived-ifield> {encoding}.
; The result is a new <derived-ifield> object with subfields matching
; {value-names} replaced with {values}.
; is (b), and {values} is (c-choice-of-b-object), then return
; (a-ifield-object c-choice-of-b-ifield-object).
-(define (-anyof-merge-encoding container encoding value-names values)
+(define (/anyof-merge-encoding container encoding value-names values)
(assert (derived-ifield? encoding))
(let ((subfields (derived-ifield-subfields encoding))
(result (object-copy-top encoding)))
result)
)
-; Subroutine of -anyof-merge-subchoices.
+; Subroutine of /anyof-merge-subchoices.
; Merge semantics of VALUE-NAMES/VALUES into GETTER.
;
; Example:
; If GETTER is (mem QI foo), and VALUE-NAMES is (foo), and VALUES is
; ((add a b)-object), then return (mem QI (add a b)).
-(define (-anyof-merge-getter getter value-names values)
+(define (/anyof-merge-getter getter value-names values)
;(debug-repl-env getter value-names values)
; ??? This implementation is a quick hack, intended to evolve or be replaced.
(cond ((not getter)
(op:getter (list-ref values indx))
e)))
((pair? e) ; pair? -> cheap non-null-list?
- (-anyof-merge-getter e value-names values))
+ (/anyof-merge-getter e value-names values))
(else
e)))
getter)))
)
-; Subroutine of -anyof-merge-subchoices.
+; Subroutine of /anyof-merge-subchoices.
; Merge semantics of VALUE-NAMES/VALUES into SETTER.
;
; Example:
;
; ??? `newval' in this context is a reserved word.
-(define (-anyof-merge-setter setter value-names values)
+(define (/anyof-merge-setter setter value-names values)
;(debug-repl-env setter value-names values)
; ??? This implementation is a quick hack, intended to evolve or be replaced.
(cond ((not setter)
(if (rtx-kind 'mem dest)
(set! dest
(rtx-change-address dest
- (-anyof-merge-getter
+ (/anyof-merge-getter
(rtx-mem-addr dest)
value-names values))))
- (set! src (-anyof-merge-getter src value-names values))
+ (set! src (/anyof-merge-getter src value-names values))
(rtx-make 'set options mode dest src)))
(else
- (error "-anyof-merge-setter: unsupported form" (car setter))))
+ (error "/anyof-merge-setter: unsupported form" (car setter))))
)
; Subroutine of -sub-insn-make!.
(cond ((symbol? e)
(let ((indx (element-lookup-index e value-names 0)))
(if indx
- (-anyof-name (list-ref values indx))
+ (/anyof-name (list-ref values indx))
; (op:sem-name (list-ref values indx))
e)))
((pair? e) ; pair? -> cheap non-null-list?
result)
)
-; Subroutine of -anyof-merge-subchoices.
+; Subroutine of /anyof-merge-subchoices.
; Merge assertion of VALUE-NAMES/VALUES into ASSERTION.
;
; Example:
; FIXME: Perform simplification pass, based on combined set of known
; ifield values.
-(define (-anyof-merge-ifield-assertion assertion value-names values)
+(define (/anyof-merge-ifield-assertion assertion value-names values)
(let ((assertions (find identity
(cons assertion
(map derived-ifield-assertion values)))))
(rtx-combine 'andif assertions)))
)
-; Subroutine of -anyof-all-subchoices.
+; Subroutine of /anyof-all-subchoices.
; Return a copy of <derived-operand> CHOICE with NEW-ARGS from ANYOF-ARGS
; merged in. This is for when a derived operand is itself composed of
; anyof operands.
; element in ANYOF-ARGS.
; CONTAINER is the <anyof-operand> containing CHOICE.
-(define (-anyof-merge-subchoices container choice anyof-args new-args)
+(define (/anyof-merge-subchoices container choice anyof-args new-args)
(assert (all-true? (map anyof-operand? anyof-args)))
(assert (all-true? (map derived-operand? new-args)))
(let* ((arg-names (map obj:name anyof-args))
- (encoding (-anyof-merge-encoding container (derived-encoding choice)
+ (encoding (/anyof-merge-encoding container (derived-encoding choice)
arg-names new-args))
(result
(make <anyof-instance>
(obj-atlist choice)
(op:mode choice)
(derived-args choice)
- (-anyof-merge-syntax (derived-syntax choice)
+ (/anyof-merge-syntax (derived-syntax choice)
arg-names new-args)
(derived-base-ifield choice)
encoding
- (-anyof-merge-ifield-assertion (derived-ifield-assertion choice)
+ (/anyof-merge-ifield-assertion (derived-ifield-assertion choice)
anyof-args new-args)
- (-anyof-merge-getter (op:getter choice)
+ (/anyof-merge-getter (op:getter choice)
arg-names new-args)
- (-anyof-merge-setter (op:setter choice)
+ (/anyof-merge-setter (op:setter choice)
arg-names new-args)
container)))
result)
)
-; Subroutine of -anyof-all-choices-1.
+; Subroutine of /anyof-all-choices-1.
; Return a list of all possible subchoices of <derived-operand> ANYOF-CHOICE,
; known to use <anyof-operand>'s itself.
; CONTAINER is the containing <anyof-operand>.
-(define (-anyof-all-subchoices container anyof-choice)
+(define (/anyof-all-subchoices container anyof-choice)
; Split args into anyof and non-anyof elements.
(let* ((args (derived-args anyof-choice))
(anyof-args (find anyof-operand? args)))
; ((1 a B) (1 a C) (2 a B) (2 a C) (3 a B) (3 a C)).
;
; Note that some of these values may be derived from nested
- ; <anyof-operand>'s which is why we recursively call -anyof-all-choices-1.
- ; ??? -anyof-all-choices-1 should cache the results.
+ ; <anyof-operand>'s which is why we recursively call /anyof-all-choices-1.
+ ; ??? /anyof-all-choices-1 should cache the results.
- (let* ((todo (map -anyof-all-choices-1 anyof-args))
+ (let* ((todo (map /anyof-all-choices-1 anyof-args))
(lengths (map length todo))
(total (apply * lengths))
(result nil))
;(display (map obj:name new-args) (current-error-port))
;(newline (current-error-port))
(set! result
- (cons (-anyof-merge-subchoices container
+ (cons (/anyof-merge-subchoices container
anyof-choice
anyof-args
new-args)
; Return an <anyof-instance> object from <derived-operand> {derop}, which is a
; choice of {anyof-operand}.
-(define (-anyof-instance-from-derived anyof-operand derop)
+(define (/anyof-instance-from-derived anyof-operand derop)
(let* ((encoding (object-copy-top (derived-encoding derop)))
(result
(make <anyof-instance>
; Derived operands are the first cut at it. They'll evolve or be replaced
; (and it's the implementation of them that will evolve first).
-(define (-anyof-all-choices-1 anyof-operand)
+(define (/anyof-all-choices-1 anyof-operand)
(assert (anyof-operand? anyof-operand))
(let ((result nil))
; This operand has "anyof" operands so we need to turn this
; choice into a list of all possible subchoices.
- (let ((subchoices (-anyof-all-subchoices anyof-operand this)))
+ (let ((subchoices (/anyof-all-subchoices anyof-operand this)))
(set! result
(append subchoices result)))
; No <anyof-operand> arguments.
(set! result
- (cons (-anyof-instance-from-derived anyof-operand this)
+ (cons (/anyof-instance-from-derived anyof-operand this)
result)))
(loop (cdr choices)))))
result)
)
-; Cover fn of -anyof-all-choices-1.
+; Cover fn of /anyof-all-choices-1.
; Return list of <anyof-instance> objects, one for each possible variant of
; ANYOF-OPERAND.
; We want to delete choices that fail their ifield assertions, but since
-; -anyof-all-choices-1 can recursively call itself, assertion checking is
+; /anyof-all-choices-1 can recursively call itself, assertion checking is
; defered until it returns.
(define (anyof-all-choices anyof-operand)
- (let ((all-choices (-anyof-all-choices-1 anyof-operand)))
+ (let ((all-choices (/anyof-all-choices-1 anyof-operand)))
; Delete ones that fail their ifield assertions.
; Sometimes there isn't enough information yet to completely do this.
; However, it is our responsibility to assert as much as we can.
(find (lambda (op)
(anyof-satisfies-assertions? op
- (-anyof-initial-known op)))
+ (/anyof-initial-known op)))
all-choices))
)
\f
; pmacro-debug - expand all pmacros in an expression,
; printing various debugging messages.
-; This does not process .exec.
+; This does not process $exec.
;
; (pmacro-debug expression)
; Builtin pmacros:
;
-; (.sym symbol1 symbol2 ...) - symbolstr-append
-; (.str string1 string2 ...) - stringsym-append
-; (.hex number [width]) - convert to hex string
-; (.upcase string)
-; (.downcase string)
-; (.substring string start end) - get part of a string
-; (.splice a b (.unsplice c) d e ...) - splice list into another list
-; (.iota count [start [increment]]) - number generator
-; (.map pmacro arg1 . arg-rest)
-; (.for-each pmacro arg1 . arg-rest)
-; (.eval expr) - expand (or evaluate it) expr
-; (.exec expr) - execute expr immediately
-; (.apply pmacro-name arg)
-; (.pmacro (arg-list) expansion) - akin go lambda in Scheme
-; (.pmacro? arg)
-; (.let (var-list) expr1 . expr-rest) - akin to let in Scheme
-; (.let* (var-list) expr1 . expr-rest) - akin to let* in Scheme
-; (.if expr then [else])
-; (.case expr ((case-list1) stmt) [case-expr-stmt-list] [(else stmt)])
-; (.cond (expr stmt) [(cond-expr-stmt-list)] [(else stmt)])
-; (.begin . stmt-list)
-; (.print . exprs) - for debugging messages
-; (.dump expr) - dump expr in readable format
-; (.error . message) - print error message and exit
-; (.list . exprs)
-; (.ref l n) - extract the n'th element of list l
-; (.length x) - length of symbol, string, or list
-; (.replicate n expr) - return list of expr replicated n times
-; (.find pred l) - return elements of list l matching pred
-; (.equal? x y) - deep comparison
-; (.andif expr . rest) - && in C
-; (.orif expr . rest) - || in C
-; (.not expr) - ! in C
-; (.eq x y)
-; (.ne x y)
-; (.lt x y)
-; (.gt x y)
-; (.le x y)
-; (.ge x y)
-; (.add x y)
-; (.sub x y)
-; (.mul x y)
-; (.div x y) - integer division
-; (.rem x y) - integer remainder
-; (.sll x n) - shift left logical
-; (.srl x n) - shift right logical
-; (.sra x n) - shift right arithmetic
-; (.and x y) - bitwise and
-; (.or x y) - bitwise or
-; (.xor x y) - bitwise xor
-; (.inv x) - bitwise invert
-; (.car l)
-; (.cdr l)
-; (.caar l)
-; (.cadr l)
-; (.cdar l)
-; (.cddr l)
-; (.internal-test expr) - testsuite internal use only
+; ($sym symbol1 symbol2 ...) - symbolstr-append
+; ($str string1 string2 ...) - stringsym-append
+; ($hex number [width]) - convert to hex string
+; ($upcase string)
+; ($downcase string)
+; ($substring string start end) - get part of a string
+; ($splice a b ($unsplice c) d e ...) - splice list into another list
+; ($iota count [start [increment]]) - number generator
+; ($map pmacro arg1 . arg-rest)
+; ($for-each pmacro arg1 . arg-rest)
+; ($eval expr) - expand (or evaluate it) expr
+; ($exec expr) - execute expr immediately
+; ($apply pmacro-name arg)
+; ($pmacro (arg-list) expansion) - akin go lambda in Scheme
+; ($pmacro? arg)
+; ($let (var-list) expr1 . expr-rest) - akin to let in Scheme
+; ($let* (var-list) expr1 . expr-rest) - akin to let* in Scheme
+; ($if expr then [else])
+; ($case expr ((case-list1) stmt) [case-expr-stmt-list] [(else stmt)])
+; ($cond (expr stmt) [(cond-expr-stmt-list)] [(else stmt)])
+; ($begin . stmt-list)
+; ($print . exprs) - for debugging messages
+; ($dump expr) - dump expr in readable format
+; ($error . message) - print error message and exit
+; ($list . exprs)
+; ($ref l n) - extract the n'th element of list l
+; ($length x) - length of symbol, string, or list
+; ($replicate n expr) - return list of expr replicated n times
+; ($find pred l) - return elements of list l matching pred
+; ($equal? x y) - deep comparison
+; ($andif expr . rest) - && in C
+; ($orif expr . rest) - || in C
+; ($not expr) - ! in C
+; ($eq x y)
+; ($ne x y)
+; ($lt x y)
+; ($gt x y)
+; ($le x y)
+; ($ge x y)
+; ($add x y)
+; ($sub x y)
+; ($mul x y)
+; ($div x y) - integer division
+; ($rem x y) - integer remainder
+; ($sll x n) - shift left logical
+; ($srl x n) - shift right logical
+; ($sra x n) - shift right arithmetic
+; ($and x y) - bitwise and
+; ($or x y) - bitwise or
+; ($xor x y) - bitwise xor
+; ($inv x) - bitwise invert
+; ($car l)
+; ($cdr l)
+; ($caar l)
+; ($cadr l)
+; ($cdar l)
+; ($cddr l)
+; ($internal-test expr) - testsuite internal use only
;
-; NOTE: .cons currently absent on purpose
+; NOTE: $cons currently absent on purpose
;
-; .sym and .str convert numbers to symbols/strings as necessary (base 10).
+; $sym and $str convert numbers to symbols/strings as necessary (base 10).
;
-; .pmacro is for constructing pmacros on-the-fly, like lambda, and is currently
-; only valid as arguments to other pmacros or assigned to a local in a {.let}
-; or {.let*}.
+; $pmacro is for constructing pmacros on-the-fly, like lambda, and is currently
+; only valid as arguments to other pmacros or assigned to a local in a {$let}
+; or {$let*}.
;
; NOTE: While Scheme requires tail recursion to be implemented as a loop,
; we do not. We might some day, but not today.
; to something else.
; True if doing pmacro expansion via pmacro-debug.
-(define -pmacro-debug? #f)
+(define /pmacro-debug? #f)
; True if doing pmacro expansion via pmacro-trace.
-(define -pmacro-trace? #f)
+(define /pmacro-trace? #f)
; The pmacro table.
-(define -pmacro-table #f)
-(define (-pmacro-lookup name) (hashq-ref -pmacro-table name))
-(define (-pmacro-set! name val) (hashq-set! -pmacro-table name val))
+(define /pmacro-table #f)
+(define (/pmacro-lookup name) (hashq-ref /pmacro-table name #f))
+(define (/pmacro-set! name val) (hashq-set! /pmacro-table name val))
; A copy of syntactic pmacros is kept separately.
-(define -smacro-table #f)
-(define (-smacro-lookup name) (hashq-ref -smacro-table name))
-(define (-smacro-set! name val) (hashq-set! -smacro-table name val))
+(define /smacro-table #f)
+(define (/smacro-lookup name) (hashq-ref /smacro-table name #f))
+(define (/smacro-set! name val) (hashq-set! /smacro-table name val))
; Marker to indicate a value is a pmacro.
; NOTE: Naming this "<pmacro>" is intentional. It makes them look like
; objects of class <pmacro>. However we don't use COS in part to avoid
; a dependency on COS and in part because displaying COS objects isn't well
; supported (displaying them in debugging dumps adds a lot of noise).
-(define
-pmacro-marker '<pmacro>)
+(define
/pmacro-marker '<pmacro>)
; Utilities to create and access pmacros.
-(define (-pmacro-make name arg-spec default-values
+(define (/pmacro-make name arg-spec default-values
syntactic-form? transformer comment)
- (vector -pmacro-marker name arg-spec default-values
+ (vector /pmacro-marker name arg-spec default-values
syntactic-form? transformer comment)
)
-(define (-pmacro? x) (and (vector? x) (eq? (vector-ref x 0) -pmacro-marker)))
-(define (-pmacro-name pmac) (vector-ref pmac 1))
-(define (-pmacro-arg-spec pmac) (vector-ref pmac 2))
-(define (-pmacro-default-values pmac) (vector-ref pmac 3))
-(define (-pmacro-syntactic-form? pmac) (vector-ref pmac 4))
-(define (-pmacro-transformer pmac) (vector-ref pmac 5))
-(define (-pmacro-comment pmac) (vector-ref pmac 6))
+(define (/pmacro? x) (and (vector? x) (eq? (vector-ref x 0) /pmacro-marker)))
+(define (/pmacro-name pmac) (vector-ref pmac 1))
+(define (/pmacro-arg-spec pmac) (vector-ref pmac 2))
+(define (/pmacro-default-values pmac) (vector-ref pmac 3))
+(define (/pmacro-syntactic-form? pmac) (vector-ref pmac 4))
+(define (/pmacro-transformer pmac) (vector-ref pmac 5))
+(define (/pmacro-comment pmac) (vector-ref pmac 6))
; Cover functions to manage an "environment" in case a need or desire for
; another method arises.
-(define (-pmacro-env-make prev-env names values)
+(define (/pmacro-env-make prev-env names values)
(append! (map cons names values) prev-env)
)
-(define (-pmacro-env-ref env name) (assq name env))
+(define (/pmacro-env-ref env name) (assq name env))
; Error message generator.
-(define (-pmacro-error msg expr)
+(define (/pmacro-error msg expr)
(error (string-append
(or (port-filename (current-input-port)) "<input>")
":"
; Issue an error where a number was expected.
-(define (-pmacro-expected-number op n)
- (-pmacro-error (string-append "invalid arg for " op ", expected number") n)
+(define (/pmacro-expected-number op n)
+ (/pmacro-error (string-append "invalid arg for " op ", expected number") n)
)
; Verify N is a number.
-(define (-pmacro-verify-number op n)
+(define (/pmacro-verify-number op n)
(if (not (number? n))
- (-pmacro-expected-number op n))
+ (/pmacro-expected-number op n))
)
; Issue an error where an integer was expected.
-(define (-pmacro-expected-integer op n)
- (-pmacro-error (string-append "invalid arg for " op ", expected integer") n)
+(define (/pmacro-expected-integer op n)
+ (/pmacro-error (string-append "invalid arg for " op ", expected integer") n)
)
; Verify N is an integer.
-(define (-pmacro-verify-integer op n)
+(define (/pmacro-verify-integer op n)
(if (not (integer? n))
- (-pmacro-expected-integer op n))
+ (/pmacro-expected-integer op n))
)
; Issue an error where a non-negative integer was expected.
-(define (-pmacro-expected-non-negative-integer op n)
- (-pmacro-error (string-append "invalid arg for " op ", expected non-negative integer") n)
+(define (/pmacro-expected-non-negative-integer op n)
+ (/pmacro-error (string-append "invalid arg for " op ", expected non-negative integer") n)
)
; Verify N is a non-negative integer.
-(define (-pmacro-verify-non-negative-integer op n)
+(define (/pmacro-verify-non-negative-integer op n)
(if (or (not (integer? n))
(< n 0))
- (-pmacro-expected-non-negative-integer op n))
+ (/pmacro-expected-non-negative-integer op n))
)
; Expand a list of expressions, in order.
; The result is the value of the last one.
-(define (-pmacro-expand-expr-list exprs env loc)
+(define (/pmacro-expand-expr-list exprs env loc)
(let ((result nil))
(for-each (lambda (expr)
- (set! result (-pmacro-expand expr env loc)))
+ (set! result (/pmacro-expand expr env loc)))
exprs)
result)
)
; Process list of keyword/value specified arguments.
-(define (-pmacro-process-keyworded-args arg-spec default-values args)
+(define (/pmacro-process-keyworded-args arg-spec default-values args)
; Build a list of default values, then override ones specified in ARGS,
(let ((result-alist (alist-copy default-values)))
(let loop ((args args))
((and (pair? args) (keyword? (car args)))
(let ((elm (assq (car args) result-alist)))
(if (not elm)
- (-pmacro-error "not an argument name" (car args)))
+ (/pmacro-error "not an argument name" (car args)))
(if (null? (cdr args))
- (-pmacro-error "missing argument to #:keyword" (car args)))
+ (/pmacro-error "missing argument to #:keyword" (car args)))
(set-cdr! elm (cadr args))
(loop (cddr args))))
(else
- (-pmacro-error "bad keyword/value argument list" args))))
+ (/pmacro-error "bad keyword/value argument list" args))))
; Ensure each element has a value.
(let loop ((to-scan result-alist))
#f ; done
(begin
(if (not (cdar to-scan))
- (-pmacro-error "argument value not specified" (caar to-scan)))
+ (/pmacro-error "argument value not specified" (caar to-scan)))
(loop (cdr to-scan)))))
; If varargs pmacro, adjust result.
; or is a list of keyword/value pairs with missing values coming from
; DEFAULT-VALUES.
-(define (-pmacro-process-args-1 arg-spec default-values args)
+(define (/pmacro-process-args-1 arg-spec default-values args)
(if (and (pair? args) (keyword? (car args)))
- (-pmacro-process-keyworded-args arg-spec default-values args)
+ (/pmacro-process-keyworded-args arg-spec default-values args)
args)
)
-; Subroutine of -pmacro-apply/-smacro-apply to simplify them.
+; Subroutine of /pmacro-apply,/smacro-apply to simplify them.
; Process the arguments, verify the correct number is present.
-(define (-pmacro-process-args macro args)
- (let ((arg-spec (-pmacro-arg-spec macro))
- (default-values (-pmacro-default-values macro)))
- (let ((processed-args (-pmacro-process-args-1 arg-spec default-values args)))
+(define (/pmacro-process-args macro args)
+ (let ((arg-spec (/pmacro-arg-spec macro))
+ (default-values (/pmacro-default-values macro)))
+ (let ((processed-args (/pmacro-process-args-1 arg-spec default-values args)))
(if (not (num-args-ok? (length processed-args) arg-spec))
- (-pmacro-error (string-append
+ (/pmacro-error (string-append
"wrong number of arguments to pmacro "
(with-output-to-string
(lambda ()
- (write (cons (-pmacro-name macro)
- (-pmacro-arg-spec macro))))))
+ (write (cons (/pmacro-name macro)
+ (/pmacro-arg-spec macro))))))
args))
processed-args))
)
; Invoke a pmacro.
-(define (-pmacro-apply macro args)
- (apply (-pmacro-transformer macro)
- (-pmacro-process-args macro args))
+(define (/pmacro-apply macro args)
+ (apply (/pmacro-transformer macro)
+ (/pmacro-process-args macro args))
)
; Invoke a syntactic-form pmacro.
-; ENV, LOC are handed down from -pmacro-expand.
+; ENV, LOC are handed down from /pmacro-expand.
-(define (-smacro-apply macro args env loc)
- (apply (-pmacro-transformer macro)
- (cons loc (cons env (-pmacro-process-args macro args))))
+(define (/smacro-apply macro args env loc)
+ (apply (/pmacro-transformer macro)
+ (cons loc (cons env (/pmacro-process-args macro args))))
)
;; Expand expression EXP using ENV, an alist of variable assignments.
;; LOC is the location stack thus far.
-(define (-pmacro-expand exp env loc)
+(define (/pmacro-expand exp env loc)
(define cep (current-error-port))
;; Otherwise return the symbol unchanged.
(define (scan-symbol sym)
- (let ((val (-pmacro-env-ref env sym)))
+ (let ((val (/pmacro-env-ref env sym)))
(if val
(cdr val) ;; cdr is value of (name . value) pair
- (let ((val (-pmacro-lookup sym)))
+ (let ((val (/pmacro-lookup sym)))
(if val
;; Symbol is a pmacro.
;; If this is a procedural pmacro, let caller perform expansion.
;; Otherwise, return the pmacro's value.
- (if (procedure? (-pmacro-transformer val))
+ (if (procedure? (/pmacro-transformer val))
val
- (-pmacro-transformer val))
+ (/pmacro-transformer val))
;; Return symbol unchanged.
sym)))))
;; Return pmacro or #f.
(define (check-pmacro exp)
- (if -pmacro-debug?
+ (if /pmacro-debug?
(begin
(display "Checking for pmacro: " cep)
(write exp cep)
(newline cep)))
- (and (-pmacro? (car exp)) (car exp)))
+ (and (/pmacro? (car exp)) (car exp)))
;; Subroutine of scan-list to simplify it.
;; Macro expand EXP which is known to be a non-null list.
;; routine to evaluate the arguments.
;; Note that we also don't support passing syntactic form functions
;; as arguments: We look up (car exp) here, not its expansion.
- (let ((sform (-smacro-lookup (car exp))))
+ (let ((sform (/smacro-lookup (car exp))))
(if sform
(begin
;; ??? Is it useful to trace these?
- (-smacro-apply sform (cdr exp) env loc))
+ (/smacro-apply sform (cdr exp) env loc))
;; Not a syntactic form.
;; See if we have a pmacro. Do this before evaluating all the
;; arguments (even though we will eventually evaluate all the
;; legible (we print the expression we're about to evaluate *before*
;; we evaluate its arguments).
(let ((scanned-car (scan (car exp) loc)))
- (if (-pmacro? scanned-car)
+ (if (/pmacro? scanned-car)
(begin
;; Trace expansion here, we know we have a pmacro.
- (if -pmacro-trace?
+ (if /pmacro-trace?
(let ((src-props (source-properties exp))
(indent (spaces (* 2 (length (location-list loc))))))
;; We use `write' to display `exp' to see strings quoted.
;; Evaluate all the arguments before invoking the pmacro.
(let* ((scanned-args (map (lambda (e) (scan e loc))
(cdr exp)))
- (result (if (procedure? (-pmacro-transformer scanned-car))
- (-pmacro-apply scanned-car scanned-args)
- (cons (-pmacro-transformer scanned-car) scanned-args))))
- (if -pmacro-trace?
+ (result (if (procedure? (/pmacro-transformer scanned-car))
+ (/pmacro-apply scanned-car scanned-args)
+ (cons (/pmacro-transformer scanned-car) scanned-args))))
+ (if /pmacro-trace?
(let ((indent (spaces (* 2 (length (location-list loc))))))
(display indent cep)
(display " result: " cep)
(else
exp))))
;; Re-examining `result' to see if it is another pmacro invocation
- ;; allows doing things like ((.sym a b c) arg1 arg2)
+ ;; allows doing things like (($sym a b c) arg1 arg2)
;; where `abc' is a pmacro. Scheme doesn't work this way, but then
;; this is CGEN.
(if (symbol? result) (scan-symbol result) result)))
; elements. For varargs pmacros, ARGS must be an improper list
; (e.g. (a b . c)) with the last element being a symbol.
-(define (-pmacro-get-arg-spec args)
+(define (/pmacro-get-arg-spec args)
(let ((parse-arg
(lambda (arg)
(cond ((symbol? arg)
((and (pair? arg) (symbol? (car arg)))
(car arg))
(else
- (-pmacro-error "argument not `symbol' or `(symbol . default-value)'"
+ (/pmacro-error "argument not `symbol' or `(symbol . default-value)'"
arg))))))
(if (list? args)
(map parse-arg args)
(cons (parse-arg (car args))
(parse-improper-list (cdr args))))
(else
- (-pmacro-error "argument not `symbol' or `(symbol . default-value)'"
+ (/pmacro-error "argument not `symbol' or `(symbol . default-value)'"
args))))))
(parse-improper-list args))))
)
; (e.g. (a b . c)) with the last element being a symbol.
; Unspecified default values are recorded as #f.
-(define (-pmacro-get-default-values args)
+(define (/pmacro-get-default-values args)
(let ((parse-arg
(lambda (arg)
(cond ((symbol? arg)
((and (pair? arg) (symbol? (car arg)))
(cons (symbol->keyword (car arg)) (cdr arg)))
(else
- (-pmacro-error "argument not `symbol' or `(symbol . default-value)'"
+ (/pmacro-error "argument not `symbol' or `(symbol . default-value)'"
arg))))))
(if (list? args)
(map parse-arg args)
(cons (parse-arg (car args))
(parse-improper-list (cdr args))))
(else
- (-pmacro-error "argument not `symbol' or `(symbol . default-value)'"
+ (/pmacro-error "argument not `symbol' or `(symbol . default-value)'"
args))))))
(parse-improper-list args))))
)
; Earlier version, doesn't work with LOC as a <location> object,
; COS objects don't pass through eval1.
-;(define (-pmacro-build-lambda prev-env params expansion)
+;(define (/pmacro-build-lambda prev-env params expansion)
; (eval1 `(lambda ,params
-; (-pmacro-expand ',expansion
-; (-pmacro-env-make ',prev-env
+; (/pmacro-expand ',expansion
+; (/pmacro-env-make ',prev-env
; ',params (list ,@params))))
;)
-(define (-pmacro-build-lambda loc prev-env params expansion)
+(define (/pmacro-build-lambda loc prev-env params expansion)
(lambda args
- (-pmacro-expand expansion
- (-pmacro-env-make prev-env params args)
+ (/pmacro-expand expansion
+ (/pmacro-env-make prev-env params args)
loc))
)
(define (define-pmacro header arg1 . arg-rest)
(if (and (not (symbol? header))
(not (list? header)))
- (-pmacro-error "invalid pmacro header" header))
+ (/pmacro-error "invalid pmacro header" header))
(let ((name (if (symbol? header) header (car header)))
- (arg-spec (if (symbol? header) #f (-pmacro-get-arg-spec (cdr header))))
- (default-values (if (symbol? header) #f (-pmacro-get-default-values (cdr header))))
+ (arg-spec (if (symbol? header) #f (/pmacro-get-arg-spec (cdr header))))
+ (default-values (if (symbol? header) #f (/pmacro-get-default-values (cdr header))))
(comment (if (null? arg-rest) "" arg1))
(expansion (if (null? arg-rest) arg1 (car arg-rest))))
;;(if (> (length arg-rest) 1)
- ;;(-pmacro-error "extraneous arguments to define-pmacro" (cdr arg-rest)))
+ ;;(/pmacro-error "extraneous arguments to define-pmacro" (cdr arg-rest)))
;;(if (not (string? comment))
- ;;(-pmacro-error "invalid pmacro comment, expected string" comment))
+ ;;(/pmacro-error "invalid pmacro comment, expected string" comment))
(if (symbol? header)
(if (symbol? expansion)
- (let ((maybe-pmacro (-pmacro-lookup expansion)))
+ (let ((maybe-pmacro (/pmacro-lookup expansion)))
(if maybe-pmacro
- (-pmacro-set! name
- (-pmacro-make name
- (-pmacro-arg-spec maybe-pmacro)
- (-pmacro-default-values maybe-pmacro)
+ (/pmacro-set! name
+ (/pmacro-make name
+ (/pmacro-arg-spec maybe-pmacro)
+ (/pmacro-default-values maybe-pmacro)
#f ; syntactic-form?
- (-pmacro-transformer maybe-pmacro)
+ (/pmacro-transformer maybe-pmacro)
comment))
- (-pmacro-set! name (-pmacro-make name #f #f #f expansion comment))))
- (-pmacro-set! name (-pmacro-make name #f #f #f expansion comment)))
- (-pmacro-set! name
- (-pmacro-make name arg-spec default-values #f
- (-pmacro-build-lambda (current-reader-location)
+ (/pmacro-set! name (/pmacro-make name #f #f #f expansion comment))))
+ (/pmacro-set! name (/pmacro-make name #f #f #f expansion comment)))
+ (/pmacro-set! name
+ (/pmacro-make name arg-spec default-values #f
+ (/pmacro-build-lambda (current-reader-location)
nil
arg-spec
expansion)
; LOC is the <location> of EXPR.
(define (pmacro-expand expr loc)
- (-pmacro-expand expr '() loc)
+ (/pmacro-expand expr '() loc)
)
; Debugging routine to trace pmacro expansion.
(define (pmacro-trace expr loc)
; FIXME: Need unwind protection.
- (let ((old-trace -pmacro-trace?)
+ (let ((old-trace /pmacro-trace?)
(src-props (and (pair? expr) (source-properties expr)))
(cep (current-error-port)))
- (set! -pmacro-trace? #t)
+ (set! /pmacro-trace? #t)
;; We use `write' to display `expr' to see strings quoted.
(display "Pmacro expanding: " cep) (write expr cep) (newline cep)
;;(display "Top level env: " cep) (display nil cep) (newline cep)
(display (source-properties-location->string src-props) cep)
(display (single-location->string (location-top loc)) cep))
(newline cep)
- (let ((result (-pmacro-expand expr '() loc)))
+ (let ((result (/pmacro-expand expr '() loc)))
(display "Pmacro result: " cep) (write result cep) (newline cep)
- (set! -pmacro-trace? old-trace)
+ (set! /pmacro-trace? old-trace)
result))
)
; Debugging utility to expand a pmacro, with no initial source location.
(define (pmacro-dump expr)
- (-pmacro-expand expr '() (unspecified-location))
+ (/pmacro-expand expr '() (unspecified-location))
)
; Expand any pmacros in EXPR, printing various debugging messages.
-; This does not process .exec.
+; This does not process $exec.
(define (pmacro-debug expr)
; FIXME: Need unwind protection.
- (let ((old-debug -pmacro-debug?))
- (set! -pmacro-debug? #t)
+ (let ((old-debug /pmacro-debug?))
+ (set! /pmacro-debug? #t)
(let ((result (pmacro-trace expr (unspecified-location))))
- (set! -pmacro-debug? old-debug)
+ (set! /pmacro-debug? old-debug)
result))
)
\f
; Builtin pmacros.
-; (.sym symbol1 symbol2 ...) - symbol-append, auto-convert numbers
+; ($sym symbol1 symbol2 ...) - symbol-append, auto-convert numbers
-(define -pmacro-builtin-sym
+(define /pmacro-builtin-sym
(lambda args
(string->symbol
(apply string-append
((symbol? elm) (symbol->string elm))
((string? elm) elm)
(else
- (-pmacro-error "invalid argument to .str" elm))))
+ (/pmacro-error "invalid argument to $sym" elm))))
args))))
)
-; (.str string1 string2 ...) - string-append, auto-convert numbers
+; ($str string1 string2 ...) - string-append, auto-convert numbers
-(define -pmacro-builtin-str
+(define /pmacro-builtin-str
(lambda args
(apply string-append
(map (lambda (elm)
((symbol? elm) (symbol->string elm))
((string? elm) elm)
(else
- (-pmacro-error "invalid argument to .str" elm))))
+ (/pmacro-error "invalid argument to $str" elm))))
args)))
)
-; (.hex number [width]) - convert number to hex string
+; ($hex number [width]) - convert number to hex string
; WIDTH, if present, is the number of characters in the result, beginning
; from the least significant digit.
-(define (-pmacro-builtin-hex num . width)
+(define (/pmacro-builtin-hex num . width)
(if (> (length width) 1)
- (-pmacro-error "wrong number of arguments to .hex"
- (cons '.hex (cons num width))))
+ (/pmacro-error "wrong number of arguments to $hex"
+ (cons '$hex (cons num width))))
(let ((str (number->string num 16)))
(if (null? width)
str
len (+ len (car width))))))
)
-; (.upcase string) - convert a string or symbol to uppercase
+; ($upcase string) - convert a string or symbol to uppercase
-(define (-pmacro-builtin-upcase str)
+(define (/pmacro-builtin-upcase str)
(cond
((string? str) (string-upcase str))
((symbol? str) (string->symbol (string-upcase (symbol->string str))))
- (else (-pmacro-error "invalid argument to .upcase" str)))
+ (else (/pmacro-error "invalid argument to $upcase" str)))
)
-; (.downcase string) - convert a string or symbol to lowercase
+; ($downcase string) - convert a string or symbol to lowercase
-(define (-pmacro-builtin-downcase str)
+(define (/pmacro-builtin-downcase str)
(cond
((string? str) (string-downcase str))
((symbol? str) (string->symbol (string-downcase (symbol->string str))))
- (else (-pmacro-error "invalid argument to .downcase" str)))
+ (else (/pmacro-error "invalid argument to $downcase" str)))
)
-; (.substring string start end) - get part of a string
+; ($substring string start end) - get part of a string
; `end' can be the symbol `end'.
-(define (-pmacro-builtin-substring str start end)
+(define (/pmacro-builtin-substring str start end)
(if (not (integer? start)) ;; FIXME: non-negative-integer
- (-pmacro-error "start not an integer" start))
+ (/pmacro-error "start not an integer" start))
(if (and (not (integer? end))
(not (eq? end 'end)))
- (-pmacro-error "end not an integer nor symbol `end'" end))
+ (/pmacro-error "end not an integer nor symbol `end'" end))
(cond ((string? str)
(if (eq? end 'end)
(substring str start)
(string->symbol (substring (symbol->string str) start))
(string->symbol (substring (symbol->string str) start end))))
(else
- (-pmacro-error "invalid argument to .substring" str)))
+ (/pmacro-error "invalid argument to $substring" str)))
)
-; .splice - splicing support
+; $splice - splicing support
; Splice lists into the outer list.
;
-; E.g. (define-pmacro '(splice-test a b c) '(.splice a (.unsplice b) c))
+; E.g. (define-pmacro '(splice-test a b c) '($splice a ($unsplice b) c))
; (pmacro-expand '(splice-test (1 (2) 3))) --> (1 2 3)
;
; Similar to `(1 ,@'(2) 3) in Scheme, though the terminology is slightly
; [??? Some may want a quoting facility, but I'd like to defer adding it as
; long as possible (and ideally never add it).]
;
-; NOTE: The implementation relies on .unsplice being undefined so that
-; (.unsplice (42)) is expanded unchanged.
+; NOTE: The implementation relies on $unsplice being undefined so that
+; ($unsplice (42)) is expanded unchanged.
-(define -pmacro-builtin-splice
+(define /pmacro-builtin-splice
(lambda arg-list
; ??? Not the most efficient implementation.
- (let loop ((arg-list arg-list) (result '()))
- (cond ((null? arg-list) result)
- ((and (pair? (car arg-list)) (eq? '.unsplice (caar arg-list)))
- (if (= (length (car arg-list)) 2)
- (if (list? (cadar arg-list))
- (loop (cdr arg-list) (append result (cadar arg-list)))
- (-pmacro-error "argument to .unsplice must be a list"
- (car arg-list)))
- (-pmacro-error "wrong number of arguments to .unsplice"
- (car arg-list))))
- (else
- (loop (cdr arg-list) (append result (list (car arg-list))))))))
-)
-
-; .iota
+ (let* ((unsplice-str (if (rtl-version-at-least? 0 9) "$unsplice" ".unsplice"))
+ (unsplice-sym (string->symbol unsplice-str)))
+ (let loop ((arg-list arg-list) (result '()))
+ (cond ((null? arg-list) result)
+ ((and (pair? (car arg-list)) (eq? unsplice-sym (caar arg-list)))
+ (if (= (length (car arg-list)) 2)
+ (if (list? (cadar arg-list))
+ (loop (cdr arg-list) (append result (cadar arg-list)))
+ (/pmacro-error (string-append "argument to " unsplice-str " must be a list")
+ (car arg-list)))
+ (/pmacro-error (string-append "wrong number of arguments to " unsplice-str)
+ (car arg-list))))
+ (else
+ (loop (cdr arg-list) (append result (list (car arg-list)))))))))
+)
+
+; $iota
; Usage:
-; (.iota count) ; start=0, incr=1
-; (.iota count start) ; incr=1
-; (.iota count start incr)
+; ($iota count) ; start=0, incr=1
+; ($iota count start) ; incr=1
+; ($iota count start incr)
-(define (-pmacro-builtin-iota count . start-incr)
+(define (/pmacro-builtin-iota count . start-incr)
(if (> (length start-incr) 2)
- (-pmacro-error "wrong number of arguments to .iota"
- (cons '.iota (cons count start-incr))))
+ (/pmacro-error "wrong number of arguments to $iota"
+ (cons '$iota (cons count start-incr))))
(if (< count 0)
- (-pmacro-error "count must be non-negative"
- (cons '.iota (cons count start-incr))))
+ (/pmacro-error "count must be non-negative"
+ (cons '$iota (cons count start-incr))))
(let ((start (if (pair? start-incr) (car start-incr) 0))
(incr (if (= (length start-incr) 2) (cadr start-incr) 1)))
(let loop ((i start) (count count) (result '()))
(loop (+ i incr) (- count 1) (cons i result)))))
)
-; (.map pmacro arg1 . arg-rest)
+; ($map pmacro arg1 . arg-rest)
-(define (-pmacro-builtin-map pmacro arg1 . arg-rest)
- (if (not (-pmacro? pmacro))
- (-pmacro-error "not a pmacro" pmacro))
- (let ((transformer (-pmacro-transformer pmacro)))
+(define (/pmacro-builtin-map pmacro arg1 . arg-rest)
+ (if (not (/pmacro? pmacro))
+ (/pmacro-error "not a pmacro" pmacro))
+ (let ((transformer (/pmacro-transformer pmacro)))
(if (not (procedure? transformer))
- (-pmacro-error "not a procedural pmacro" pmacro))
+ (/pmacro-error "not a procedural pmacro" pmacro))
(apply map (cons transformer (cons arg1 arg-rest))))
)
-; (.for-each pmacro arg1 . arg-rest)
+; ($for-each pmacro arg1 . arg-rest)
-(define (-pmacro-builtin-for-each pmacro arg1 . arg-rest)
- (if (not (-pmacro? pmacro))
- (-pmacro-error "not a pmacro" pmacro))
- (let ((transformer (-pmacro-transformer pmacro)))
+(define (/pmacro-builtin-for-each pmacro arg1 . arg-rest)
+ (if (not (/pmacro? pmacro))
+ (/pmacro-error "not a pmacro" pmacro))
+ (let ((transformer (/pmacro-transformer pmacro)))
(if (not (procedure? transformer))
- (-pmacro-error "not a procedural pmacro" pmacro))
+ (/pmacro-error "not a procedural pmacro" pmacro))
(apply for-each (cons transformer (cons arg1 arg-rest)))
nil) ; need to return something the reader will accept and ignore
)
-; (.eval expr)
+; ($eval expr)
; NOTE: This is implemented as a syntactic form in order to get ENV and LOC.
; That's an implementation detail, and this is not really a syntactic form.
;
-; ??? I debated whether to call this .expand, .eval has been a source of
+; ??? I debated whether to call this $expand, $eval has been a source of
; confusion/headaches.
-(define (-pmacro-builtin-eval loc env expr)
- ;; -pmacro-expand is invoked twice because we're implemented as a syntactic
+(define (/pmacro-builtin-eval loc env expr)
+ ;; /pmacro-expand is invoked twice because we're implemented as a syntactic
;; form: We *want* to be passed an evaluated expression, and then we
;; re-evaluate it. But syntactic forms pass parameters unevaluated, so we
;; have to do the first one ourselves.
- (-pmacro-expand (-pmacro-expand expr env loc) env loc)
+ (/pmacro-expand (/pmacro-expand expr env loc) env loc)
)
-; (.exec expr)
+; ($exec expr)
-(define (-pmacro-builtin-exec expr)
+(define (/pmacro-builtin-exec expr)
;; If we're expanding pmacros for debugging purposes, don't execute,
;; just return unchanged.
- (if -pmacro-debug?
- (list '.exec expr)
+ (if /pmacro-debug?
+ (list '$exec expr)
(begin
(reader-process-expanded! expr)
nil)) ;; need to return something the reader will accept and ignore
)
-; (.apply pmacro-name arg)
+; ($apply pmacro-name arg)
-(define (-pmacro-builtin-apply pmacro arg-list)
- (if (not (-pmacro? pmacro))
- (-pmacro-error "not a pmacro" pmacro))
- (let ((transformer (-pmacro-transformer pmacro)))
+(define (/pmacro-builtin-apply pmacro arg-list)
+ (if (not (/pmacro? pmacro))
+ (/pmacro-error "not a pmacro" pmacro))
+ (let ((transformer (/pmacro-transformer pmacro)))
(if (not (procedure? transformer))
- (-pmacro-error "not a procedural pmacro" pmacro))
+ (/pmacro-error "not a procedural pmacro" pmacro))
(apply transformer arg-list))
)
-; (.pmacro (arg-list) expansion)
+; ($pmacro (arg-list) expansion)
; NOTE: syntactic form
-(define (-pmacro-builtin-pmacro loc env params expansion)
+(define (/pmacro-builtin-pmacro loc env params expansion)
;; ??? Prohibiting improper lists seems unnecessarily restrictive here.
;; e.g. (define (foo bar . baz) ...)
(if (not (list? params))
- (-pmacro-error ".pmacro parameter-spec is not a list" params))
- (-pmacro-make '.anonymous params #f #f
- (-pmacro-build-lambda loc env params expansion) "")
+ (/pmacro-error "$pmacro parameter-spec is not a list" params))
+ (/pmacro-make '$anonymous params #f #f
+ (/pmacro-build-lambda loc env params expansion) "")
)
-; (.pmacro? arg)
+; ($pmacro? arg)
-(define (-pmacro-builtin-pmacro? arg)
- (-pmacro? arg)
+(define (/pmacro-builtin-pmacro? arg)
+ (/pmacro? arg)
)
-; (.let (var-list) expr1 . expr-rest)
+; ($let (var-list) expr1 . expr-rest)
; NOTE: syntactic form
-(define (-pmacro-builtin-let loc env locals expr1 . expr-rest)
+(define (/pmacro-builtin-let loc env locals expr1 . expr-rest)
(if (not (list? locals))
- (-pmacro-error "locals is not a list" locals))
+ (/pmacro-error "locals is not a list" locals))
(if (not (all-true? (map (lambda (l)
(and (list? l)
(= (length l) 2)
(symbol? (car l))))
locals)))
- (-pmacro-error "syntax error in locals list" locals))
+ (/pmacro-error "syntax error in locals list" locals))
(let* ((evald-locals (map (lambda (l)
- (cons (car l) (-pmacro-expand (cadr l) env loc)))
+ (cons (car l) (/pmacro-expand (cadr l) env loc)))
locals))
(new-env (append! evald-locals env)))
- (-pmacro-expand-expr-list (cons expr1 expr-rest) new-env loc))
+ (/pmacro-expand-expr-list (cons expr1 expr-rest) new-env loc))
)
-; (.let* (var-list) expr1 . expr-rest)
+; ($let* (var-list) expr1 . expr-rest)
; NOTE: syntactic form
-(define (-pmacro-builtin-let* loc env locals expr1 . expr-rest)
+(define (/pmacro-builtin-let* loc env locals expr1 . expr-rest)
(if (not (list? locals))
- (-pmacro-error "locals is not a list" locals))
+ (/pmacro-error "locals is not a list" locals))
(if (not (all-true? (map (lambda (l)
(and (list? l)
(= (length l) 2)
(symbol? (car l))))
locals)))
- (-pmacro-error "syntax error in locals list" locals))
+ (/pmacro-error "syntax error in locals list" locals))
(let loop ((locals locals) (new-env env))
(if (null? locals)
- (-pmacro-expand-expr-list (cons expr1 expr-rest) new-env loc)
+ (/pmacro-expand-expr-list (cons expr1 expr-rest) new-env loc)
(loop (cdr locals) (acons (caar locals)
- (-pmacro-expand (cadar locals) new-env loc)
+ (/pmacro-expand (cadar locals) new-env loc)
new-env))))
)
-; (.if expr then [else])
+; ($if expr then [else])
; NOTE: syntactic form
-(define (-pmacro-builtin-if loc env expr then-clause . else-clause)
+(define (/pmacro-builtin-if loc env expr then-clause . else-clause)
(case (length else-clause)
- ((0) (if (-pmacro-expand expr env loc)
- (-pmacro-expand then-clause env loc)
+ ((0) (if (/pmacro-expand expr env loc)
+ (/pmacro-expand then-clause env loc)
nil))
- ((1) (if (-pmacro-expand expr env loc)
- (-pmacro-expand then-clause env loc)
- (-pmacro-expand (car else-clause) env loc)))
- (else (-pmacro-error "too many elements in else-clause, expecting 0 or 1" else-clause)))
+ ((1) (if (/pmacro-expand expr env loc)
+ (/pmacro-expand then-clause env loc)
+ (/pmacro-expand (car else-clause) env loc)))
+ (else (/pmacro-error "too many elements in else-clause, expecting 0 or 1" else-clause)))
)
-; (.case expr ((case-list1) stmt) [case-expr-stmt-list] [(else stmt)])
+; ($case expr ((case-list1) stmt) [case-expr-stmt-list] [(else stmt)])
; NOTE: syntactic form
; NOTE: this uses "member" for case comparison (Scheme uses memq I think)
-(define (-pmacro-builtin-case loc env expr case1 . rest)
- (let ((evald-expr (-pmacro-expand expr env loc)))
+(define (/pmacro-builtin-case loc env expr case1 . rest)
+ (let ((evald-expr (/pmacro-expand expr env loc)))
(let loop ((cases (cons case1 rest)))
(if (null? cases)
nil
(begin
(if (not (list? (car cases)))
- (-pmacro-error "case statement not a list" (car cases)))
+ (/pmacro-error "case statement not a list" (car cases)))
(if (= (length (car cases)) 1)
- (-pmacro-error "case statement has case but no expr" (car cases)))
+ (/pmacro-error "case statement has case but no expr" (car cases)))
(if (and (not (eq? (caar cases) 'else))
(not (list? (caar cases))))
- (-pmacro-error "case must be \"else\" or list of choices" (caar cases)))
+ (/pmacro-error "case must be \"else\" or list of choices" (caar cases)))
(cond ((eq? (caar cases) 'else)
- (-pmacro-expand-expr-list (cdar cases) env loc))
+ (/pmacro-expand-expr-list (cdar cases) env loc))
((member evald-expr (caar cases))
- (-pmacro-expand-expr-list (cdar cases) env loc))
+ (/pmacro-expand-expr-list (cdar cases) env loc))
(else
(loop (cdr cases))))))))
)
-; (.cond (expr stmt) [(cond-expr-stmt-list)] [(else stmt)])
+; ($cond (expr stmt) [(cond-expr-stmt-list)] [(else stmt)])
; NOTE: syntactic form
-(define (-pmacro-builtin-cond loc env expr1 . rest)
+(define (/pmacro-builtin-cond loc env expr1 . rest)
(let loop ((exprs (cons expr1 rest)))
(cond ((null? exprs)
nil)
((eq? (car exprs) 'else)
- (-pmacro-expand-expr-list (cdar exprs) env loc))
+ (/pmacro-expand-expr-list (cdar exprs) env loc))
(else
- (let ((evald-expr (-pmacro-expand (caar exprs) env loc)))
+ (let ((evald-expr (/pmacro-expand (caar exprs) env loc)))
(if evald-expr
- (-pmacro-expand-expr-list (cdar exprs) env loc)
+ (/pmacro-expand-expr-list (cdar exprs) env loc)
(loop (cdr exprs)))))))
)
-; (.begin . stmt-list)
+; ($begin . stmt-list)
; NOTE: syntactic form
-(define (-pmacro-builtin-begin loc env . rest)
- (-pmacro-expand-expr-list rest env loc)
+(define (/pmacro-builtin-begin loc env . rest)
+ (/pmacro-expand-expr-list rest env loc)
)
-; (.print . expr)
+; ($print . expr)
; Strings have quotes removed.
-(define (-pmacro-builtin-print . exprs)
+(define (/pmacro-builtin-print . exprs)
(apply message exprs)
nil ; need to return something the reader will accept and ignore
)
-; (.dump expr)
+; ($dump expr)
; Strings do not have quotes removed.
-(define (-pmacro-builtin-dump expr)
+(define (/pmacro-builtin-dump expr)
(write expr (current-error-port))
nil ; need to return something the reader will accept and ignore
)
-; (.error . expr)
+; ($error . expr)
-(define (-pmacro-builtin-error . exprs)
+(define (/pmacro-builtin-error . exprs)
(apply error exprs)
)
-; (.list expr1 ...)
+; ($list expr1 ...)
-(define (-pmacro-builtin-list . exprs)
+(define (/pmacro-builtin-list . exprs)
exprs
)
-; (.ref expr index)
+; ($ref expr index)
-(define (-pmacro-builtin-ref l n)
+(define (/pmacro-builtin-ref l n)
(if (not (list? l))
- (-pmacro-error "invalid arg for .ref, expected list" l))
+ (/pmacro-error "invalid arg for $ref, expected list" l))
(if (not (integer? n)) ;; FIXME: call non-negative-integer?
- (-pmacro-error "invalid arg for .ref, expected non-negative integer" n))
+ (/pmacro-error "invalid arg for $ref, expected non-negative integer" n))
(list-ref l n)
)
-; (.length x)
+; ($length x)
-(define (-pmacro-builtin-length x)
+(define (/pmacro-builtin-length x)
(cond ((symbol? x) (string-length (symbol->string x)))
((string? x) (string-length x))
((list? x) (length x))
(else
- (-pmacro-error "invalid arg for .length, expected symbol, string, or list" x)))
+ (/pmacro-error "invalid arg for $length, expected symbol, string, or list" x)))
)
-; (.replicate n expr)
+; ($replicate n expr)
-(define (-pmacro-builtin-replicate n expr)
+(define (/pmacro-builtin-replicate n expr)
(if (not (integer? n)) ;; FIXME: call non-negative-integer?
- (-pmacro-error "invalid arg for .replicate, expected non-negative integer" n))
+ (/pmacro-error "invalid arg for $replicate, expected non-negative integer" n))
(make-list n expr)
)
-; (.find pred l)
+; ($find pred l)
-(define (-pmacro-builtin-find pred l)
- (if (not (-pmacro? pred))
- (-pmacro-error "not a pmacro" pred))
+(define (/pmacro-builtin-find pred l)
+ (if (not (/pmacro? pred))
+ (/pmacro-error "not a pmacro" pred))
(if (not (list? l))
- (-pmacro-error "not a list" l))
- (let ((transformer (-pmacro-transformer pred)))
+ (/pmacro-error "not a list" l))
+ (let ((transformer (/pmacro-transformer pred)))
(if (not (procedure? transformer))
- (-pmacro-error "not a procedural macro" pred))
+ (/pmacro-error "not a procedural macro" pred))
(find transformer l))
)
-; (.equal? x y)
+; ($equal? x y)
-(define (-pmacro-builtin-equal? x y)
+(define (/pmacro-builtin-equal? x y)
(equal? x y)
)
-; (.andif . rest)
+; ($andif . rest)
; NOTE: syntactic form
; Elements of EXPRS are evaluated one at a time.
; Unprocessed elements are not evaluated.
-(define (-pmacro-builtin-andif loc env . exprs)
+(define (/pmacro-builtin-andif loc env . exprs)
(if (null? exprs)
#t
(let loop ((exprs exprs))
- (let ((evald-expr (-pmacro-expand (car exprs) env loc)))
+ (let ((evald-expr (/pmacro-expand (car exprs) env loc)))
(cond ((null? (cdr exprs)) evald-expr)
(evald-expr (loop (cdr exprs)))
(else #f)))))
)
-; (.orif . rest)
+; ($orif . rest)
; NOTE: syntactic form
; Elements of EXPRS are evaluated one at a time.
; Unprocessed elements are not evaluated.
-(define (-pmacro-builtin-orif loc env . exprs)
+(define (/pmacro-builtin-orif loc env . exprs)
(let loop ((exprs exprs))
(if (null? exprs)
#f
- (let ((evald-expr (-pmacro-expand (car exprs) env loc)))
+ (let ((evald-expr (/pmacro-expand (car exprs) env loc)))
(if evald-expr
evald-expr
(loop (cdr exprs))))))
)
-; (.not expr)
+; ($not expr)
-(define (-pmacro-builtin-not x)
+(define (/pmacro-builtin-not x)
(not x)
)
; Verify x,y are compatible for eq/ne comparisons.
-(define (-pmacro-compatible-for-equality x y)
+(define (/pmacro-compatible-for-equality x y)
(or (and (symbol? x) (symbol? y))
(and (string? x) (string? y))
(and (number? x) (number? y)))
)
-; (.eq expr)
+; ($eq expr)
-(define (-pmacro-builtin-eq x y)
+(define (/pmacro-builtin-eq x y)
(cond ((symbol? x)
(if (symbol? y)
(eq? x y)
- (-pmacro-error "incompatible args for .eq, expected symbol" y)))
+ (/pmacro-error "incompatible args for $eq, expected symbol" y)))
((string? x)
(if (string? y)
(string=? x y)
- (-pmacro-error "incompatible args for .eq, expected string" y)))
+ (/pmacro-error "incompatible args for $eq, expected string" y)))
((number? x)
(if (number? y)
(= x y)
- (-pmacro-error "incompatible args for .eq, expected number" y)))
+ (/pmacro-error "incompatible args for $eq, expected number" y)))
(else
- (-pmacro-error "unsupported args for .eq" (list x y))))
+ (/pmacro-error "unsupported args for $eq" (list x y))))
)
-; (.ne expr)
+; ($ne expr)
-(define (-pmacro-builtin-ne x y)
+(define (/pmacro-builtin-ne x y)
(cond ((symbol? x)
(if (symbol? y)
(not (eq? x y))
- (-pmacro-error "incompatible args for .ne, expected symbol" y)))
+ (/pmacro-error "incompatible args for $ne, expected symbol" y)))
((string? x)
(if (string? y)
(not (string=? x y))
- (-pmacro-error "incompatible args for .ne, expected string" y)))
+ (/pmacro-error "incompatible args for $ne, expected string" y)))
((number? x)
(if (number? y)
(not (= x y))
- (-pmacro-error "incompatible args for .ne, expected number" y)))
+ (/pmacro-error "incompatible args for $ne, expected number" y)))
(else
- (-pmacro-error "unsupported args for .ne" (list x y))))
+ (/pmacro-error "unsupported args for $ne" (list x y))))
)
-; (.lt expr)
+; ($lt expr)
-(define (-pmacro-builtin-lt x y)
- (-pmacro-verify-number ".lt" x)
- (-pmacro-verify-number ".lt" y)
+(define (/pmacro-builtin-lt x y)
+ (/pmacro-verify-number "$lt" x)
+ (/pmacro-verify-number "$lt" y)
(< x y)
)
-; (.gt expr)
+; ($gt expr)
-(define (-pmacro-builtin-gt x y)
- (-pmacro-verify-number ".gt" x)
- (-pmacro-verify-number ".gt" y)
+(define (/pmacro-builtin-gt x y)
+ (/pmacro-verify-number "$gt" x)
+ (/pmacro-verify-number "$gt" y)
(> x y)
)
-; (.le expr)
+; ($le expr)
-(define (-pmacro-builtin-le x y)
- (-pmacro-verify-number ".le" x)
- (-pmacro-verify-number ".le" y)
+(define (/pmacro-builtin-le x y)
+ (/pmacro-verify-number "$le" x)
+ (/pmacro-verify-number "$le" y)
(<= x y)
)
-; (.ge expr)
+; ($ge expr)
-(define (-pmacro-builtin-ge x y)
- (-pmacro-verify-number ".ge" x)
- (-pmacro-verify-number ".ge" y)
+(define (/pmacro-builtin-ge x y)
+ (/pmacro-verify-number "$ge" x)
+ (/pmacro-verify-number "$ge" y)
(>= x y)
)
-; (.add x y)
+; ($add x y)
-(define (-pmacro-builtin-add x y)
- (-pmacro-verify-number ".add" x)
- (-pmacro-verify-number ".add" y)
+(define (/pmacro-builtin-add x y)
+ (/pmacro-verify-number "$add" x)
+ (/pmacro-verify-number "$add" y)
(+ x y)
)
-; (.sub x y)
+; ($sub x y)
-(define (-pmacro-builtin-sub x y)
- (-pmacro-verify-number ".sub" x)
- (-pmacro-verify-number ".sub" y)
+(define (/pmacro-builtin-sub x y)
+ (/pmacro-verify-number "$sub" x)
+ (/pmacro-verify-number "$sub" y)
(- x y)
)
-; (.mul x y)
+; ($mul x y)
-(define (-pmacro-builtin-mul x y)
- (-pmacro-verify-number ".mul" x)
- (-pmacro-verify-number ".mul" y)
+(define (/pmacro-builtin-mul x y)
+ (/pmacro-verify-number "$mul" x)
+ (/pmacro-verify-number "$mul" y)
(* x y)
)
-; (.div x y) - integer division
+; ($div x y) - integer division
-(define (-pmacro-builtin-div x y)
- (-pmacro-verify-integer ".div" x)
- (-pmacro-verify-integer ".div" y)
+(define (/pmacro-builtin-div x y)
+ (/pmacro-verify-integer "$div" x)
+ (/pmacro-verify-integer "$div" y)
(quotient x y)
)
-; (.rem x y) - integer remainder
+; ($rem x y) - integer remainder
; ??? Need to decide behavior.
-(define (-pmacro-builtin-rem x y)
- (-pmacro-verify-integer ".rem" x)
- (-pmacro-verify-integer ".rem" y)
+(define (/pmacro-builtin-rem x y)
+ (/pmacro-verify-integer "$rem" x)
+ (/pmacro-verify-integer "$rem" y)
(remainder x y)
)
-; (.sll x n) - shift left logical
+; ($sll x n) - shift left logical
-(define (-pmacro-builtin-sll x n)
- (-pmacro-verify-integer ".sll" x)
- (-pmacro-verify-non-negative-integer ".sll" n)
+(define (/pmacro-builtin-sll x n)
+ (/pmacro-verify-integer "$sll" x)
+ (/pmacro-verify-non-negative-integer "$sll" n)
(ash x n)
)
-; (.srl x n) - shift right logical
+; ($srl x n) - shift right logical
; X must be non-negative, otherwise behavior is undefined.
; [Unless we introduce a size argument: How do you logical shift right
; an arbitrary precision negative number?]
-(define (-pmacro-builtin-srl x n)
- (-pmacro-verify-non-negative-integer ".srl" x)
- (-pmacro-verify-non-negative-integer ".srl" n)
+(define (/pmacro-builtin-srl x n)
+ (/pmacro-verify-non-negative-integer "$srl" x)
+ (/pmacro-verify-non-negative-integer "$srl" n)
(ash x (- n))
)
-; (.sra x n) - shift right arithmetic
+; ($sra x n) - shift right arithmetic
-(define (-pmacro-builtin-sra x n)
- (-pmacro-verify-integer ".sra" x)
- (-pmacro-verify-non-negative-integer ".sra" n)
+(define (/pmacro-builtin-sra x n)
+ (/pmacro-verify-integer "$sra" x)
+ (/pmacro-verify-non-negative-integer "$sra" n)
(ash x (- n))
)
-; (.and x y) - bitwise and
+; ($and x y) - bitwise and
-(define (-pmacro-builtin-and x y)
- (-pmacro-verify-integer ".and" x)
- (-pmacro-verify-integer ".and" y)
+(define (/pmacro-builtin-and x y)
+ (/pmacro-verify-integer "$and" x)
+ (/pmacro-verify-integer "$and" y)
(logand x y)
)
-; (.or x y) - bitwise or
+; ($or x y) - bitwise or
-(define (-pmacro-builtin-or x y)
- (-pmacro-verify-integer ".or" x)
- (-pmacro-verify-integer ".or" y)
+(define (/pmacro-builtin-or x y)
+ (/pmacro-verify-integer "$or" x)
+ (/pmacro-verify-integer "$or" y)
(logior x y)
)
-; (.xor x y) - bitwise xor
+; ($xor x y) - bitwise xor
-(define (-pmacro-builtin-xor x y)
- (-pmacro-verify-integer ".xor" x)
- (-pmacro-verify-integer ".xor" y)
+(define (/pmacro-builtin-xor x y)
+ (/pmacro-verify-integer "$xor" x)
+ (/pmacro-verify-integer "$xor" y)
(logxor x y)
)
-; (.inv x) - bitwise invert
+; ($inv x) - bitwise invert
-(define (-pmacro-builtin-inv x)
- (-pmacro-verify-integer ".inv" x)
+(define (/pmacro-builtin-inv x)
+ (/pmacro-verify-integer "$inv" x)
(lognot x)
)
-; (.car expr)
+; ($car expr)
-(define (-pmacro-builtin-car l)
+(define (/pmacro-builtin-car l)
(if (pair? l)
(car l)
- (-pmacro-error "invalid arg for .car, expected pair" l))
+ (/pmacro-error "invalid arg for $car, expected pair" l))
)
-; (.cdr expr)
+; ($cdr expr)
-(define (-pmacro-builtin-cdr l)
+(define (/pmacro-builtin-cdr l)
(if (pair? l)
(cdr l)
- (-pmacro-error "invalid arg for .cdr, expected pair" l))
+ (/pmacro-error "invalid arg for $cdr, expected pair" l))
)
-; (.caar expr)
+; ($caar expr)
-(define (-pmacro-builtin-caar l)
+(define (/pmacro-builtin-caar l)
(if (and (pair? l) (pair? (car l)))
(caar l)
- (-pmacro-error "invalid arg for .caar" l))
+ (/pmacro-error "invalid arg for $caar" l))
)
-; (.cadr expr)
+; ($cadr expr)
-(define (-pmacro-builtin-cadr l)
+(define (/pmacro-builtin-cadr l)
(if (and (pair? l) (pair? (cdr l)))
(cadr l)
- (-pmacro-error "invalid arg for .cadr" l))
+ (/pmacro-error "invalid arg for $cadr" l))
)
-; (.cdar expr)
+; ($cdar expr)
-(define (-pmacro-builtin-cdar l)
+(define (/pmacro-builtin-cdar l)
(if (and (pair? l) (pair? (car l)))
(cdar l)
- (-pmacro-error "invalid arg for .cdar" l))
+ (/pmacro-error "invalid arg for $cdar" l))
)
-; (.cddr expr)
+; ($cddr expr)
-(define (-pmacro-builtin-cddr l)
+(define (/pmacro-builtin-cddr l)
(if (and (pair? l) (pair? (cdr l)))
(cddr l)
- (-pmacro-error "invalid arg for .cddr" l))
+ (/pmacro-error "invalid arg for $cddr" l))
)
-; (.internal-test expr)
+; ($internal-test expr)
; This is an internal builtin for use by the testsuite.
; EXPR is a Scheme expression that is executed to verify proper
; behaviour of something. It must return #f for FAIL, non-#f for PASS.
; The result is #f for FAIL, #t for PASS.
; This must be used in an expression, it is not sufficient to do
-; (.internal-test mumble) because the reader will see #f or #t and complain.
+; ($internal-test mumble) because the reader will see #f or #t and complain.
-(define (-pmacro-builtin-internal-test expr)
+(define (/pmacro-builtin-internal-test expr)
(and (eval1 expr) #t)
)
\f
; Initialization.
(define (pmacros-init!)
- (set! -pmacro-table (make-hash-table 127))
- (set! -smacro-table (make-hash-table 41))
+ (set! /pmacro-table (make-hash-table 127))
+ (set! /smacro-table (make-hash-table 41))
; Some "predefined" pmacros.
(let ((macros
;; name arg-spec syntactic? function description
(list
- (list '.sym 'symbols #f -pmacro-builtin-sym "symbol-append")
- (list '.str 'strings #f -pmacro-builtin-str "string-append")
- (list '.hex '(number . width) #f -pmacro-builtin-hex "convert to -hex, with optional width")
- (list '.upcase '(string) #f -pmacro-builtin-upcase "string-upcase")
- (list '.downcase '(string) #f -pmacro-builtin-downcase "string-downcase")
- (list '.substring '(string start end) #f -pmacro-builtin-substring "get start of a string")
- (list '.splice 'arg-list #f -pmacro-builtin-splice "splice lists into the outer list")
- (list '.iota '(count . start-incr) #f -pmacro-builtin-iota "iota number generator")
- (list '.map '(pmacro list1 . rest) #f -pmacro-builtin-map "map a pmacro over a list of arguments")
- (list '.for-each '(pmacro list1 . rest) #f -pmacro-builtin-for-each "execute a pmacro over a list of arguments")
- (list '.eval '(expr) #t -pmacro-builtin-eval "expand(evaluate) expr")
- (list '.exec '(expr) #f -pmacro-builtin-exec "execute expr immediately")
- (list '.apply '(pmacro arg-list) #f -pmacro-builtin-apply "apply a pmacro to a list of arguments")
- (list '.pmacro '(params expansion) #t -pmacro-builtin-pmacro "create a pmacro on-the-fly")
- (list '.pmacro? '(arg) #f -pmacro-builtin-pmacro? "return true if arg is a pmacro")
- (list '.let '(locals expr1 . rest) #t -pmacro-builtin-let "create a binding context, let-style")
- (list '.let* '(locals expr1 . rest) #t -pmacro-builtin-let* "create a binding context, let*-style")
- (list '.if '(expr then . else) #t -pmacro-builtin-if "if expr is true, process then, else else")
- (list '.case '(expr case1 . rest) #t -pmacro-builtin-case "process statement that matches expr")
- (list '.cond '(expr1 . rest) #t -pmacro-builtin-cond "process first statement whose expr succeeds")
- (list '.begin 'rest #t -pmacro-builtin-begin "process a sequence of statements")
- (list '.print 'exprs #f -pmacro-builtin-print "print exprs, for debugging purposes")
- (list '.dump '(expr) #f-pmacro-builtin-dump "dump expr, for debugging purposes")
- (list '.error 'message #f -pmacro-builtin-error "print error message and exit")
- (list '.list 'exprs #f -pmacro-builtin-list "return a list of exprs")
- (list '.ref '(l n) #f -pmacro-builtin-ref "return n'th element of list l")
- (list '.length '(x) #f -pmacro-builtin-length "return length of symbol, string, or list")
- (list '.replicate '(n expr) #f -pmacro-builtin-replicate "return list of expr replicated n times")
- (list '.find '(pred l) #f -pmacro-builtin-find "return elements of list l matching pred")
- (list '.equal? '(x y) #f -pmacro-builtin-equal? "deep comparison of x and y")
- (list '.andif 'rest #t -pmacro-builtin-andif "return first #f element, otherwise return last element")
- (list '.orif 'rest #t -pmacro-builtin-orif "return first non-#f element found, otherwise #f")
- (list '.not '(x) #f -pmacro-builtin-not "return !x")
- (list '.eq '(x y) #f -pmacro-builtin-eq "return true if x == y")
- (list '.ne '(x y) #f -pmacro-builtin-ne "return true if x != y")
- (list '.lt '(x y) #f -pmacro-builtin-lt "return true if x < y")
- (list '.gt '(x y) #f -pmacro-builtin-gt "return true if x > y")
- (list '.le '(x y) #f -pmacro-builtin-le "return true if x <= y")
- (list '.ge '(x y) #f -pmacro-builtin-ge "return true if x >= y")
- (list '.add '(x y) #f -pmacro-builtin-add "return x + y")
- (list '.sub '(x y) #f -pmacro-builtin-sub "return x - y")
- (list '.mul '(x y) #f -pmacro-builtin-mul "return x * y")
- (list '.div '(x y) #f -pmacro-builtin-div "return x / y")
- (list '.rem '(x y) #f -pmacro-builtin-rem "return x % y")
- (list '.sll '(x n) #f -pmacro-builtin-sll "return logical x << n")
- (list '.srl '(x n) #f -pmacro-builtin-srl "return logical x >> n")
- (list '.sra '(x n) #f -pmacro-builtin-sra "return arithmetic x >> n")
- (list '.and '(x y) #f -pmacro-builtin-and "return x & y")
- (list '.or '(x y) #f -pmacro-builtin-or "return x | y")
- (list '.xor '(x y) #f -pmacro-builtin-xor "return x ^ y")
- (list '.inv '(x) #f -pmacro-builtin-inv "return ~x")
- (list '.car '(x) #f -pmacro-builtin-car "return (car x)")
- (list '.cdr '(x) #f -pmacro-builtin-cdr "return (cdr x)")
- (list '.caar '(x) #f -pmacro-builtin-caar "return (caar x)")
- (list '.cadr '(x) #f -pmacro-builtin-cadr "return (cadr x)")
- (list '.cdar '(x) #f -pmacro-builtin-cdar "return (cdar x)")
- (list '.cddr '(x) #f -pmacro-builtin-cddr "return (cddr x)")
- (list '.internal-test '(expr) #f -pmacro-builtin-internal-test "testsuite use only")
+ (list 'sym 'symbols #f /pmacro-builtin-sym "symbol-append")
+ (list 'str 'strings #f /pmacro-builtin-str "string-append")
+ (list 'hex '(number . width) #f /pmacro-builtin-hex "convert to -hex, with optional width")
+ (list 'upcase '(string) #f /pmacro-builtin-upcase "string-upcase")
+ (list 'downcase '(string) #f /pmacro-builtin-downcase "string-downcase")
+ (list 'substring '(string start end) #f /pmacro-builtin-substring "get start of a string")
+ (list 'splice 'arg-list #f /pmacro-builtin-splice "splice lists into the outer list")
+ (list 'iota '(count . start-incr) #f /pmacro-builtin-iota "iota number generator")
+ (list 'map '(pmacro list1 . rest) #f /pmacro-builtin-map "map a pmacro over a list of arguments")
+ (list 'for-each '(pmacro list1 . rest) #f /pmacro-builtin-for-each "execute a pmacro over a list of arguments")
+ (list 'eval '(expr) #t /pmacro-builtin-eval "expand(evaluate) expr")
+ (list 'exec '(expr) #f /pmacro-builtin-exec "execute expr immediately")
+ (list 'apply '(pmacro arg-list) #f /pmacro-builtin-apply "apply a pmacro to a list of arguments")
+ (list 'pmacro '(params expansion) #t /pmacro-builtin-pmacro "create a pmacro on-the-fly")
+ (list 'pmacro? '(arg) #f /pmacro-builtin-pmacro? "return true if arg is a pmacro")
+ (list 'let '(locals expr1 . rest) #t /pmacro-builtin-let "create a binding context, let-style")
+ (list 'let* '(locals expr1 . rest) #t /pmacro-builtin-let* "create a binding context, let*-style")
+ (list 'if '(expr then . else) #t /pmacro-builtin-if "if expr is true, process then, else else")
+ (list 'case '(expr case1 . rest) #t /pmacro-builtin-case "process statement that matches expr")
+ (list 'cond '(expr1 . rest) #t /pmacro-builtin-cond "process first statement whose expr succeeds")
+ (list 'begin 'rest #t /pmacro-builtin-begin "process a sequence of statements")
+ (list 'print 'exprs #f /pmacro-builtin-print "print exprs, for debugging purposes")
+ (list 'dump '(expr) #f/pmacro-builtin-dump "dump expr, for debugging purposes")
+ (list 'error 'message #f /pmacro-builtin-error "print error message and exit")
+ (list 'list 'exprs #f /pmacro-builtin-list "return a list of exprs")
+ (list 'ref '(l n) #f /pmacro-builtin-ref "return n'th element of list l")
+ (list 'length '(x) #f /pmacro-builtin-length "return length of symbol, string, or list")
+ (list 'replicate '(n expr) #f /pmacro-builtin-replicate "return list of expr replicated n times")
+ (list 'find '(pred l) #f /pmacro-builtin-find "return elements of list l matching pred")
+ (list 'equal? '(x y) #f /pmacro-builtin-equal? "deep comparison of x and y")
+ (list 'andif 'rest #t /pmacro-builtin-andif "return first #f element, otherwise return last element")
+ (list 'orif 'rest #t /pmacro-builtin-orif "return first non-#f element found, otherwise #f")
+ (list 'not '(x) #f /pmacro-builtin-not "return !x")
+ (list 'eq '(x y) #f /pmacro-builtin-eq "return true if x == y")
+ (list 'ne '(x y) #f /pmacro-builtin-ne "return true if x != y")
+ (list 'lt '(x y) #f /pmacro-builtin-lt "return true if x < y")
+ (list 'gt '(x y) #f /pmacro-builtin-gt "return true if x > y")
+ (list 'le '(x y) #f /pmacro-builtin-le "return true if x <= y")
+ (list 'ge '(x y) #f /pmacro-builtin-ge "return true if x >= y")
+ (list 'add '(x y) #f /pmacro-builtin-add "return x + y")
+ (list 'sub '(x y) #f /pmacro-builtin-sub "return x - y")
+ (list 'mul '(x y) #f /pmacro-builtin-mul "return x * y")
+ (list 'div '(x y) #f /pmacro-builtin-div "return x / y")
+ (list 'rem '(x y) #f /pmacro-builtin-rem "return x % y")
+ (list 'sll '(x n) #f /pmacro-builtin-sll "return logical x << n")
+ (list 'srl '(x n) #f /pmacro-builtin-srl "return logical x >> n")
+ (list 'sra '(x n) #f /pmacro-builtin-sra "return arithmetic x >> n")
+ (list 'and '(x y) #f /pmacro-builtin-and "return x & y")
+ (list 'or '(x y) #f /pmacro-builtin-or "return x | y")
+ (list 'xor '(x y) #f /pmacro-builtin-xor "return x ^ y")
+ (list 'inv '(x) #f /pmacro-builtin-inv "return ~x")
+ (list 'car '(x) #f /pmacro-builtin-car "return (car x)")
+ (list 'cdr '(x) #f /pmacro-builtin-cdr "return (cdr x)")
+ (list 'caar '(x) #f /pmacro-builtin-caar "return (caar x)")
+ (list 'cadr '(x) #f /pmacro-builtin-cadr "return (cadr x)")
+ (list 'cdar '(x) #f /pmacro-builtin-cdar "return (cdar x)")
+ (list 'cddr '(x) #f /pmacro-builtin-cddr "return (cddr x)")
+ (list 'internal-test '(expr) #f /pmacro-builtin-internal-test "testsuite use only")
)))
(for-each (lambda (x)
- (let ((name (list-ref x 0))
+ (let ((name (string->symbol (string-append "." (symbol->string (list-ref x 0)))))
(arg-spec (list-ref x 1))
(syntactic? (list-ref x 2))
(pmacro (list-ref x 3))
(comment (list-ref x 4)))
- (-pmacro-set! name
- (-pmacro-make name arg-spec #f syntactic? pmacro comment))
+ (/pmacro-set! name
+ (/pmacro-make name arg-spec #f syntactic? pmacro comment))
(if syntactic?
- (-smacro-set! name
- (-pmacro-make name arg-spec #f syntactic? pmacro comment)))))
+ (/smacro-set! name
+ (/pmacro-make name arg-spec #f syntactic? pmacro comment)))))
macros))
)
; A list of three numbers designating the cgen version: major minor fixlevel.
; The "50" is a generic indicator that we're between 1.1 and 1.2.
-(define -CGEN-VERSION '(1 1 50))
-(define (cgen-major) (car -CGEN-VERSION))
-(define (cgen-minor) (cadr -CGEN-VERSION))
-(define (cgen-fixlevel) (caddr -CGEN-VERSION))
+(define /CGEN-VERSION '(1 1 50))
+(define (cgen-major) (car /CGEN-VERSION))
+(define (cgen-minor) (cadr /CGEN-VERSION))
+(define (cgen-fixlevel) (caddr /CGEN-VERSION))
; A list of two numbers designating the description language version.
-; Note that this is different from -CGEN-VERSION.
+; Note that this is different from /CGEN-VERSION.
; See section "RTL Versions" of the docs.
-(define -CGEN-RTL-VERSION '(0 7))
-(define (cgen-rtl-version) -CGEN-RTL-VERSION)
-(define (cgen-rtl-major) (car -CGEN-RTL-VERSION))
-(define (cgen-rtl-minor) (cadr -CGEN-RTL-VERSION))
+(define /CGEN-RTL-VERSION '(0 7))
+(define (cgen-rtl-version) /CGEN-RTL-VERSION)
+(define (cgen-rtl-major) (car /CGEN-RTL-VERSION))
+(define (cgen-rtl-minor) (cadr /CGEN-RTL-VERSION))
+
+;; Utilities for testing the rtl version.
+(define (rtl-version-equal? major minor)
+ (equal? (cgen-rtl-version) (list major minor))
+)
+(define (rtl-version-at-least? major minor)
+ (let ((rmajor (cgen-rtl-major))
+ (rminor (cgen-rtl-major)))
+ (or (> rmajor major)
+ (and (= rmajor major)
+ (>= rminor minor))))
+)
+(define (rtl-version-older? major minor)
+ (not (rtl-version-at-least? major minor))
+)
;; List of supported versions
-(define -supported-rtl-versions '((0 7) (0 8)))
+(define /supported-rtl-versions '((0 7) (0 8)))
-(define (-cmd-define-rtl-version major minor)
+(define (/cmd-define-rtl-version major minor)
(if (not (non-negative-integer? major))
(parse-error #f "Invalid major version number" major))
(if (not (non-negative-integer? minor))
(parse-error #f "Invalid minor version number" minor))
(let ((new-version (list major minor)))
- (if (not (member new-version -supported-rtl-versions))
+ (if (not (member new-version /supported-rtl-versions))
(parse-error #f "Unsupported/invalid rtl version" new-version))
(logit 1 "Setting RTL version to " major "." minor " ...\n")
- (set! -CGEN-RTL-VERSION new-version))
+ (set! /CGEN-RTL-VERSION new-version))
)
; Which application is in use (UNKNOWN, DESC, OPCODES, SIMULATOR, ???).
; List of loaded files.
-(if (not (defined? '-loaded-file-list))
- (define -loaded-file-list '()))
+(if (not (defined? '/loaded-file-list))
+ (define /loaded-file-list '()))
; Return non-zero if FILE was loaded last time through.
-(define (-loaded-file? file)
- (->bool (memq (string->symbol file) -loaded-file-list))
+(define (/loaded-file? file)
+ (->bool (memq (string->symbol file) /loaded-file-list))
)
; Record FILE as compiled in.
-(define (-loaded-file-record! file)
+(define (/loaded-file-record! file)
(let ((file (string->symbol file)))
- (if (not (memq file -loaded-file-list))
- (set! -loaded-file-list (cons file -loaded-file-list))))
+ (if (not (memq file /loaded-file-list))
+ (set! /loaded-file-list (cons file /loaded-file-list))))
)
; Load FILE if SYM is not compiled in.
(display (string-append "Skipping " file ", dynamically loaded.\n")))
((or (not CHECK-LOADED?)
(not (defined? sym))
- (-loaded-file? file))
- (-loaded-file-record! file)
+ (/loaded-file? file))
+ (/loaded-file-record! file)
(load file))
(else
(display (string-append "Skipping " file ", already loaded.\n")))))
; A pair of two lists: machs to keep, machs to drop.
; The default is "keep all machs", "drop none".
-(define -keep-all-machs '((all)))
+(define /keep-all-machs '((all)))
; Main reader state class.
; variants in the architecture, it is the default value of the
; MACH attribute. If `all' is present the drop list is still
; processed.
- (cons 'keep-mach -keep-all-machs)
+ (cons 'keep-mach /keep-all-machs)
; Selected isas to keep or `all'.
'(keep-isa . (all))
(reader-commands CURRENT-READER)))
)
-(define (-reader-lookup-command name)
+(define (/reader-lookup-command name)
(assq-ref (reader-commands CURRENT-READER) name)
)
; Return the current source location in readable form.
; FIXME: Currently unused, keep for reference for awhile.
-(define (-readable-current-location)
+(define (/readable-current-location)
(let ((loc (current-reader-location)))
(if loc
(location->string loc)
; Process a macro-expanded entry.
-(define (-reader-process-expanded-1! entry)
+(define (/reader-process-expanded-1! entry)
(let ((location (location-property entry)))
;; Set the current source location for better diagnostics.
"\n"
(with-output-to-string (lambda () (pretty-print entry)))))
- (let ((command (-reader-lookup-command (car entry)))
+ (let ((command (/reader-lookup-command (car entry)))
(context (make-current-context #f)))
(if command
;; ENTRY is expected to have a location-property object property.
;; NOTE: This is "public" so the .eval pmacro can use it.
-;; This is also used by -cmd-if.
+;; This is also used by /cmd-if.
(define (reader-process-expanded! entry)
;; () is used to indicate a no-op
(for-each reader-process-expanded!
(cdr entry)))
(else
- (-reader-process-expanded-1! entry)))
+ (/reader-process-expanded-1! entry)))
*UNSPECIFIED*
)
; Process file entry ENTRY.
; LOC is a <location> object for ENTRY.
-(define (-reader-process! entry loc)
+(define (/reader-process! entry loc)
(if (not (form? entry))
(parse-error loc "improperly formed entry" entry))
;; location (it's easier).
;; ??? Use source-properties of entry, and only if
;; not present fall back on current-input-location.
- (-reader-process! entry (current-input-location #t))
+ (/reader-process! entry (current-input-location #t))
(loop (read)))))))
)
; MACH-NAME-LIST is a comma separated string of machines to keep and drop
; (if prefixed with !).
-(define (-keep-mach-set! mach-name-list)
+(define (/keep-mach-set! mach-name-list)
(let* ((mach-name-list (string-cut mach-name-list #\,))
(keep (find (lambda (name) (not (char=? (string-ref name 0) #\!)))
mach-name-list))
; Return a boolean indicating if everything is kept.
(define (keep-all?)
- (equal? (reader-keep-mach CURRENT-READER) -keep-all-machs)
+ (equal? (reader-keep-mach CURRENT-READER) /keep-all-machs)
)
; Ensure all cpu families were kept, necessary for generating files that
; has to remember. On the other hand, !drop support is moderately complicated,
; and it can be added in an upward compatible manner later.
-(define (-keep-isa-set! isa-name-list)
+(define (/keep-isa-set! isa-name-list)
(let ((isa-name-list (map string->symbol (string-cut isa-name-list #\,))))
(reader-set-keep-isa! CURRENT-READER isa-name-list)
)
;;; [If we later need to support disabling some tracing, one way is to
;;; recognize an "-" in front of an option.]
-(define (-set-trace-options! trace-options)
+(define (/set-trace-options! trace-options)
(let ((all (list "commands" "pmacros"))
(requests (string-cut trace-options #\,)))
(if (member "all" requests)
; ??? Class local variables would provide a more efficient way to do this.
; Assuming one wants to continue on this route.
-(define -cpu-new-class-list nil)
+(define /cpu-new-class-list nil)
(define (set-for-new! parent child)
- (set! -cpu-new-class-list (acons parent child -cpu-new-class-list))
+ (set! /cpu-new-class-list (acons parent child /cpu-new-class-list))
)
; Lookup the class registered with set-for-new!
; If none registered, return PARENT.
(define (lookup-for-new parent)
- (let ((child (assq-ref -cpu-new-class-list parent)))
+ (let ((child (assq-ref /cpu-new-class-list parent)))
(if child
child
parent))
;; hardware, etc.) to add their own.
;; The "result" is stored in global CURRENT-READER.
-(define (-init-reader!)
+(define (/init-reader!)
(set! CURRENT-READER (new <reader>))
(reader-add-command! 'define-rtl-version
"Specify the RTL version being used.\n"
- nil '(major minor) -cmd-define-rtl-version)
+ nil '(major minor) /cmd-define-rtl-version)
(reader-add-command! 'include
"Include a file.\n"
- nil '(file) -cmd-include)
+ nil '(file) /cmd-include)
(reader-add-command! 'if
"(if test then . else)\n"
- nil '(test then . else) -cmd-if)
+ nil '(test then . else) /cmd-if)
; Rather than add cgen-internal specific stuff to pmacros.scm, we create
; the pmacro commands here.
; OPTIONS is a list of options to control code generation.
; The values are application dependent.
-(define (-init-parse-cpu! keep-mach keep-isa options)
- (set! -cpu-new-class-list nil)
+(define (/init-parse-cpu! keep-mach keep-isa options)
+ (set! /cpu-new-class-list nil)
(set! CURRENT-ARCH (new <arch>))
- (-keep-mach-set! keep-mach)
- (-keep-isa-set! keep-isa)
+ (/keep-mach-set! keep-mach)
+ (/keep-isa-set! keep-isa)
(set-cgen-options! options)
; The order here is important.
; The lists get cons'd in reverse order. One thing this does is change them
; back to file order, it makes things easier for the human viewer.
-(define (-finish-parse-cpu!)
+(define (/finish-parse-cpu!)
; The order here is generally the reverse of init-parse-cpu!.
(rtl-finish!)
(minsn-finish!)
; Perform a global error checking pass after the .cpu file has been read in.
-(define (-global-error-checks)
+(define (/global-error-checks)
; ??? None yet.
; TODO:
; - all hardware elements with same name must have same rank and
; .cpu file include mechanism
-(define (-cmd-include file)
+(define (/cmd-include file)
(logit 1 "Including file " (string-append arch-path "/" file) " ...\n")
(reader-read-file! (string-append arch-path "/" file))
(logit 2 "Resuming previous file ...\n")
; This is a work-in-progress. Its presence in the description file is ok,
; but the implementation will need to evolve.
-(define (-cmd-if test then . else)
+(define (/cmd-if test then . else)
(if (> (length else) 1)
(parse-error #f
"wrong number of arguments to `if'"
(define (cpu-load file keep-mach keep-isa options trace-options
app-initer! app-finisher! analyzer!)
- (-init-reader!)
- (-init-parse-cpu! keep-mach keep-isa options)
- (-set-trace-options! trace-options)
+ (/init-reader!)
+ (/init-parse-cpu! keep-mach keep-isa options)
+ (/set-trace-options! trace-options)
(app-initer!)
(logit 1 "Loading cpu description " file " ...\n")
(set! arch-path (dirname file))
(reader-read-file! file)
(logit 2 "Processing cpu description " file " ...\n")
- (-finish-parse-cpu!)
+ (/finish-parse-cpu!)
(app-finisher!)
- (-global-error-checks)
+ (/global-error-checks)
(analyzer!)
*UNSPECIFIED*
)
; `help-text' is a string that is printed with the usage information.
; Elements beyond `help-text' are ignored.
-(define (-getopt argv opt-spec)
+(define (/getopt argv opt-spec)
(if (null? argv)
(cons (cons #f #f) #f)
(let ((opt (assoc (car argv) opt-spec)))
; OPTION-HANDLER is either (lambda () ...) or (lambda (arg) ...) and
; processes the option.
-(define -cgen
+(define /cgen
(lambda args
(let ((app-name "unknown")
(opt-spec nil)
)
(let loop ((argv (cdr argv)))
- (let* ((new-argv (-getopt argv opt-spec))
+ (let* ((new-argv (/getopt argv opt-spec))
(opt (caar new-argv))
(arg (cdar new-argv)))
(case opt
(define cgen
(lambda args
- (cgen-debugging-stack-start -cgen args))
+ (cgen-debugging-stack-start /cgen args))
)
; rtl->c configuration parameters
; #t -> emit calls to rtl cover fns, otherwise emit plain C where possible.
-(define -rtl-c-rtl-cover-fns? #f)
+(define /rtl-c-rtl-cover-fns? #f)
; Called before emitting code to configure the generator.
; ??? I think this can go away now (since cover-fn specification is also
; done at each call to rtl-c).
(define (rtl-c-config! . args)
- (set! -rtl-c-rtl-cover-fns? #f)
+ (set! /rtl-c-rtl-cover-fns? #f)
(let loop ((args args))
(if (null? args)
#f ; done
(begin
(case (car args)
((#:rtl-cover-fns?)
- (set! -rtl-c-rtl-cover-fns? (cadr args)))
+ (set! /rtl-c-rtl-cover-fns? (cadr args)))
(else (error "rtl-c-config: unknown option:" (car args))))
(loop (cddr args)))))
*UNSPECIFIED*
#f ; FIXME: context
#f ; FIXME: owner
extra-vars-alist
- -rtl-c-rtl-cover-fns?
+ /rtl-c-rtl-cover-fns?
#f ; macro?
overrides)
)
#f ; FIXME: context
#f ; FIXME: owner
extra-vars-alist
- -rtl-c-rtl-cover-fns?
+ /rtl-c-rtl-cover-fns?
#f ; macro?
(cons #:output-language (cons "c++" overrides)))
)
;
; ??? mode compatibility checks are wip
-(define (-rtl-c-get estate mode src)
+(define (/rtl-c-get estate mode src)
(let ((mode (mode:lookup mode)))
(cond ((c-expr? src)
(mode:eq? 'DFLT mode)
(mode:eq? (cx:mode src) mode))
src)
- ((-rtx-mode-compatible? mode (cx:mode src))
+ ((rtx-mode-compatible? mode (cx:mode src))
(cx-new-mode mode src))
(else
(estate-error
": ")
(obj:name mode)))))
- ; The recursive call to -rtl-c-get is in case the result of rtx-eval
+ ; The recursive call to /rtl-c-get is in case the result of rtx-eval
; is a hardware object, rtx-func object, or another rtl expression.
((rtx? src)
(let ((evald-src (rtx-eval-with-estate src mode estate)))
; There must have been some change, otherwise we'll loop forever.
(assert (not (eq? src evald-src)))
- (-rtl-c-get estate mode evald-src)))
+ (/rtl-c-get estate mode evald-src)))
((or (and (symbol? src) (current-op-lookup src))
(operand? src))
; FIXME: If we fetch the mode here, operands can assume
; they never get called with "default mode".
(send src 'cxmake-get estate mode #f #f))
- ((-rtx-mode-compatible? mode (op:mode src))
- (let ((mode (-rtx-lazy-sem-mode mode)))
+ ((rtx-mode-compatible? mode (op:mode src))
+ (let ((mode (rtx-lazy-sem-mode mode)))
(send src 'cxmake-get estate mode #f #f)))
(else
(estate-error
(set! src (rtx-temp-lookup (estate-env estate) src)))
(cond ((mode:eq? 'DFLT mode)
(send src 'cxmake-get estate (rtx-temp-mode src) #f #f))
- ((-rtx-mode-compatible? mode (rtx-temp-mode src))
- (let ((mode (-rtx-lazy-sem-mode mode)))
+ ((rtx-mode-compatible? mode (rtx-temp-mode src))
+ (let ((mode (rtx-lazy-sem-mode mode)))
(send src 'cxmake-get estate mode #f #f)))
(else (estate-error
estate
(cx:make INT src)
(cx:make mode src)))
- (else (estate-error estate "-rtl-c-get: invalid argument:" src))))
+ (else (estate-error estate "/rtl-c-get: invalid argument:" src))))
)
(define (rtl-c-get estate mode src)
(logit 4 (spaces (estate-depth estate))
"(rtl-c-get " (mode-real-name mode) " " (rtx-strdump src) ")\n")
- (let ((result (-rtl-c-get estate mode src)))
+ (let ((result (/rtl-c-get estate mode src)))
(logit 4 (spaces (estate-depth estate))
"(rtl-c-get " (mode-real-name mode) " " (rtx-strdump src) ") => "
(cx:c result) "\n")
(if (not (object? xdest))
(estate-error estate "rtl-c-set-quiet: invalid dest:" dest))
(let ((mode (if (mode:eq? 'DFLT mode)
- (-rtx-obj-mode xdest)
- (-rtx-lazy-sem-mode mode))))
+ (rtx-obj-mode xdest)
+ (rtx-lazy-sem-mode mode))))
(assert (mode? mode))
(cx:make VOID (send xdest 'gen-set-quiet
estate mode #f #f
(if (not (object? xdest))
(estate-error estate "rtl-c-set-trace: invalid dest:" dest))
(let ((mode (if (mode:eq? 'DFLT mode)
- (-rtx-obj-mode xdest) ; FIXME: internal routines
- (-rtx-lazy-sem-mode mode))))
+ (rtx-obj-mode xdest)
+ (rtx-lazy-sem-mode mode))))
(assert (mode? mode))
(cx:make VOID (send xdest 'gen-set-trace
estate mode #f #f
; Table mapping rtx function to C generator.
-(define -rtl-c-gen-table #f)
+(define /rtl-c-gen-table #f)
; Return the C generator for <rtx-func> F.
(define (rtl-c-generator f)
- (vector-ref -rtl-c-gen-table (rtx-num f))
+ (vector-ref /rtl-c-gen-table (rtx-num f))
)
\f
; Support for explicit C/C++ code.
; C-OP is a string containing the C operation or #f if there is none.
; MODE is the mode of the operation.
-(define (-rtx-use-sem-fn? estate c-op mode)
+(define (/rtx-use-sem-fn? estate c-op mode)
; If no C operation has been provided, use a macro, or
; if this is the simulator and MODE is not a host mode, use a macro.
; (or (not c-op)
(let* ((val (rtl-c-get estate mode src))
; Refetch mode in case it was DFLT and ensure unsigned->signed.
(mode (cx:mode val))
- (sem-mode (-rtx-sem-mode mode)))
+ (sem-mode (rtx-sem-mode mode)))
; FIXME: Argument checking.
- (if (-rtx-use-sem-fn? estate c-op mode)
+ (if (/rtx-use-sem-fn? estate c-op mode)
(if (mode-float? mode)
(cx:make sem-mode
(string-append "CGEN_CPU_FPU (current_cpu)->ops->"
(let* ((val1 (rtl-c-get estate mode src1))
; Refetch mode in case it was DFLT and ensure unsigned->signed.
(mode (cx:mode val1))
- (sem-mode (-rtx-sem-mode mode))
+ (sem-mode (rtx-sem-mode mode))
(val2 (rtl-c-get estate mode src2)))
; FIXME: Argument checking.
- (if (-rtx-use-sem-fn? estate c-op mode)
+ (if (/rtx-use-sem-fn? estate c-op mode)
(if (mode-float? mode)
(cx:make sem-mode
(string-append "CGEN_CPU_FPU (current_cpu)->ops->"
(define (s-binop-with-bit estate name mode src1 src2 src3)
(let* ((val1 (rtl-c-get estate mode src1))
; Refetch mode in case it was DFLT and ensure unsigned->signed.
- (mode (-rtx-sem-mode (cx:mode val1)))
+ (mode (rtx-sem-mode (cx:mode val1)))
(val2 (rtl-c-get estate mode src2))
(val3 (rtl-c-get estate 'BI src3)))
; FIXME: Argument checking.
; Refetch mode in case it was DFLT and ensure unsigned->signed
; [sign of operation is determined from operation name, not mode].
(mode (cx:mode val1))
- (sem-mode (-rtx-sem-mode mode))
+ (sem-mode (rtx-sem-mode mode))
(val2 (rtl-c-get estate mode src2)))
; FIXME: Argument checking.
- (if (-rtx-use-sem-fn? estate c-op mode)
+ (if (/rtx-use-sem-fn? estate c-op mode)
(cx:make sem-mode
(string-append name (obj:str-name sem-mode)
" (" (cx:c val1) ", "
(cx:make mode
(string-append "CGEN_CPU_FPU (current_cpu)->ops->"
(string-downcase name)
- (string-downcase (obj:str-name (-rtx-sem-mode (cx:mode s))))
- (string-downcase (obj:str-name (-rtx-sem-mode mode)))
+ (string-downcase (obj:str-name (rtx-sem-mode (cx:mode s))))
+ (string-downcase (obj:str-name (rtx-sem-mode mode)))
" (CGEN_CPU_FPU (current_cpu), "
(cx:c s) ")"))
(cx:make mode
(string-append name
- (obj:str-name (-rtx-sem-mode (cx:mode s)))
- (obj:str-name (-rtx-sem-mode mode))
+ (obj:str-name (rtx-sem-mode (cx:mode s)))
+ (obj:str-name (rtx-sem-mode mode))
" (" (cx:c s) ")")))))
)
; If no C operation has been provided, use a macro, or
; if this is the simulator and MODE is not a host mode, use a macro.
- (if (-rtx-use-sem-fn? estate c-op mode)
+ (if (/rtx-use-sem-fn? estate c-op mode)
(if (mode-float? mode)
(cx:make (mode:lookup 'BI)
(string-append "CGEN_CPU_FPU (current_cpu)->ops->"
(string-downcase (symbol->string name))
- (string-downcase (obj:str-name (-rtx-sem-mode mode)))
+ (string-downcase (obj:str-name (rtx-sem-mode mode)))
" (CGEN_CPU_FPU (current_cpu), "
(cx:c val1) ", "
(cx:c val2) ")"))
(cx:make (mode:lookup 'BI)
(string-append (string-upcase (symbol->string name))
(if (memq name '(eq ne))
- (obj:str-name (-rtx-sem-mode mode))
+ (obj:str-name (rtx-sem-mode mode))
(obj:str-name mode))
" (" (cx:c val1) ", "
(cx:c val2) ")")))
; Utility of s-case to print a case prefix (for lack of a better term).
-(define (-gen-case-prefix val)
+(define (/gen-case-prefix val)
(string-append " case "
(cond ((number? val)
(number->string val))
(code (cdr case-entry)))
(string-append
(cond ((list? caseval)
- (string-map -gen-case-prefix caseval))
+ (string-map /gen-case-prefix caseval))
((eq? 'else caseval)
(string-append " default : "))
(else
- (-gen-case-prefix caseval)))
+ (/gen-case-prefix caseval)))
(cx:c (apply s-sequence
(cons estate (cons VOID (cons nil code)))))
" break;\n")))
; Utility of s-case-non-vm to generate code to perform the test.
-(define (-gen-non-vm-case-test estate mode test cases)
+(define (/gen-non-vm-case-test estate mode test cases)
(assert (not (null? cases)))
(let loop ((result "") (cases cases))
(if (null? cases)
(let loop ((result
(string-append
if-part
- (-gen-non-vm-case-test estate mode test (caar case-list))
+ (/gen-non-vm-case-test estate mode test (caar case-list))
then-part
(cx:c (apply s-sequence
(cons estate
(else (loop (string-append
result
elseif-part
- (-gen-non-vm-case-test estate mode test (caar cl))
+ (/gen-non-vm-case-test estate mode test (caar cl))
then-part
(cx:c (apply s-sequence
(cons estate
; Temps for `parallel' are recorded differently than for `sequence'.
; ??? I believe this is because there was an interaction between the two.
-(define -par-temp-list nil)
+(define /par-temp-list nil)
; Record a temporary needed for a parallel in mode MODE.
; We just need to record the mode with a unique name so we use a <c-expr>
; object where the "expression" is the variable's name.
-(define (-par-new-temp! mode)
- (set! -par-temp-list
+(define (/par-new-temp! mode)
+ (set! /par-temp-list
(cons (cx:make mode (string-append "temp"
(number->string
- (length -par-temp-list))))
- -par-temp-list))
- (car -par-temp-list)
+ (length /par-temp-list))))
+ /par-temp-list))
+ (car /par-temp-list)
)
; Return the next temp from the list, and leave the list pointing to the
; next one.
-(define (-par-next-temp!)
- (let ((result (car -par-temp-list)))
- (set! -par-temp-list (cdr -par-temp-list))
+(define (/par-next-temp!)
+ (let ((result (car /par-temp-list)))
+ (set! /par-temp-list (cdr /par-temp-list))
result)
)
-(define (-gen-par-temp-defns temp-list)
+(define (/gen-par-temp-defns temp-list)
;(display temp-list) (newline)
(string-append
" "
; How about disallowing if's and jump's inside parallels?
; One can still put a parallel inside an `if' however.
-(define (-par-replace-set-dests estate exprs)
+(define (/par-replace-set-dests estate exprs)
(let ((sets (list 'set 'set-quiet
(rtx-lookup 'set) (rtx-lookup 'set-quiet))))
(letrec ((replace
(list name
options
mode
- (-par-new-temp! ; replace dest with temp
+ (/par-new-temp! ; replace dest with temp
(if (mode:eq? 'DFLT mode)
(rtx-lvalue-mode-name estate (rtx-set-dest expr))
mode))
(map replace exprs)))
)
-; This must process expressions in the same order as -par-replace-set-dests!
+; This must process expressions in the same order as /par-replace-set-dests!
-(define (-par-replace-set-srcs estate exprs)
+(define (/par-replace-set-srcs estate exprs)
(let ((sets (list 'set 'set-quiet
(rtx-lookup 'set) (rtx-lookup 'set-quiet))))
(letrec ((replace
options
mode
(rtx-set-dest expr)
- (-par-next-temp!)) ; the source's temp
+ (/par-next-temp!)) ; the source's temp
(cons name
(cons options
(cons mode (replace (cddr expr)))))))))
(define (s-parallel estate . exprs)
(begin
- ; Initialize -par-temp-list for -par-replace-set-dests.
- (set! -par-temp-list nil)
+ ; Initialize /par-temp-list for /par-replace-set-dests.
+ (set! /par-temp-list nil)
(let* ((set-dests (string-map (lambda (e)
(rtl-c-with-estate estate VOID e))
- (-par-replace-set-dests estate exprs)))
- (temps (reverse! -par-temp-list)))
- ; Initialize -par-temp-list for -par-replace-set-srcs.
- (set! -par-temp-list temps)
+ (/par-replace-set-dests estate exprs)))
+ (temps (reverse! /par-temp-list)))
+ ; Initialize /par-temp-list for /par-replace-set-srcs.
+ (set! /par-temp-list temps)
(cx:make VOID
(string-append
; FIXME: do {} while (0); doesn't get "optimized out"
; big files and can cause gcc to require *lots* of memory.
; So let's try just {} ...
"{\n"
- (-gen-par-temp-defns temps)
+ (/gen-par-temp-defns temps)
set-dests
(string-map (lambda (e)
(rtl-c-with-estate estate VOID e))
- (-par-replace-set-srcs estate exprs))
+ (/par-replace-set-srcs estate exprs))
"}\n")
)))
)
)
(define (rtl-c-init!)
- (set! -rtl-c-gen-table (rtl-c-build-table))
+ (set! /rtl-c-gen-table (rtl-c-build-table))
*UNSPECIFIED*
)
; Set to #t to debug rtx traversal.
-(define -rtx-traverse-debug? #f)
+(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
; Return a boolean indicating if X is a mode.
-(define (-rtx-any-mode? x)
+(define (/rtx-any-mode? x)
(->bool (mode:lookup x))
)
; Return a boolean indicating if X is a symbol or rtx.
-(define (-rtx-symornum? x)
+(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)
+(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-traverse rtx 'RTX mode expr op-num tstate appstuff))
rtx-list)
)
; of operand OP-NUM.
; RTL-EXPR must be an rtl expression.
-(define (-rtx-traverse-error tstate errmsg rtl-expr op-num)
+(define (/rtx-traverse-error tstate errmsg rtl-expr op-num)
(tstate-error tstate
(string-append errmsg ", operand #" (number->string op-num))
(rtx-strdump rtl-expr))
; 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)
+(define (/rtx-traverse-options val mode expr op-num tstate appstuff)
#f
)
-(define (-rtx-traverse-anymode val mode expr op-num tstate appstuff)
+(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"
+ (/rtx-traverse-error tstate "expecting a mode"
expr op-num))
#f)
)
-(define (-rtx-traverse-intmode val mode expr op-num tstate appstuff)
+(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"
+ (/rtx-traverse-error tstate "expecting an integer mode"
expr op-num)))
)
-(define (-rtx-traverse-floatmode val mode expr op-num tstate appstuff)
+(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"
+ (/rtx-traverse-error tstate "expecting a float mode"
expr op-num)))
)
-(define (-rtx-traverse-nummode val mode expr op-num tstate appstuff)
+(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"
+ (/rtx-traverse-error tstate "expecting a numeric mode"
expr op-num)))
)
-(define (-rtx-traverse-explnummode val mode expr op-num tstate appstuff)
+(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"
+ (/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"
+ (/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)
+(define (/rtx-traverse-nonvoidmode val mode expr op-num tstate appstuff)
(if (eq? val 'VOID)
- (-rtx-traverse-error tstate "mode can't be 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)
+(define (/rtx-traverse-voidmode val mode expr op-num tstate appstuff)
(if (memq val '(DFLT VOID))
#f
- (-rtx-traverse-error tstate "expecting mode VOID"
+ (/rtx-traverse-error tstate "expecting mode VOID"
expr op-num))
)
-(define (-rtx-traverse-dfltmode val mode expr op-num tstate appstuff)
+(define (/rtx-traverse-dfltmode val mode expr op-num tstate appstuff)
(if (eq? val 'DFLT)
#f
- (-rtx-traverse-error tstate "expecting mode DFLT"
+ (/rtx-traverse-error tstate "expecting mode DFLT"
expr op-num))
)
-(define (-rtx-traverse-rtx val mode expr op-num tstate appstuff)
+(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"
+; (/rtx-traverse-error tstate "expecting an rtx"
; expr op-num))
- (cons (-rtx-traverse val 'RTX mode expr op-num tstate appstuff)
+ (cons (/rtx-traverse val 'RTX mode expr op-num tstate appstuff)
tstate)
)
-(define (-rtx-traverse-setrtx val mode expr op-num tstate appstuff)
+(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"
+; (/rtx-traverse-error tstate "expecting an rtx"
; expr op-num))
- (cons (-rtx-traverse val 'SETRTX mode 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)
+(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"
+; (/rtx-traverse-error tstate "expecting an rtx"
; expr op-num))
- (cons (-rtx-traverse val 'RTX mode expr op-num tstate appstuff)
+ (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)
+(define (/rtx-traverse-condrtx val mode expr op-num tstate appstuff)
(if (not (pair? val))
- (-rtx-traverse-error tstate "expecting an expression"
+ (/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
+ (/rtx-traverse-error tstate
"`else' clause not last"
expr op-num))
(cons (cons 'else
- (-rtx-traverse-rtx-list
+ (/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
+ (/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)
+(define (/rtx-traverse-casertx val mode expr op-num tstate appstuff)
(if (or (not (list? val))
(< (length val) 2))
- (-rtx-traverse-error tstate
+ (/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?
+ (all-true? (map /rtx-symornum?
(car val))))))
- (-rtx-traverse-error tstate
+ (/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"
+ (/rtx-traverse-error tstate "`else' clause not last"
expr op-num))
(cons (cons (car val)
- (-rtx-traverse-rtx-list
+ (/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)
+(define (/rtx-traverse-locals val mode expr op-num tstate appstuff)
(if (not (list? val))
- (-rtx-traverse-error tstate "bad locals list"
+ (/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 (/rtx-any-mode? (car var)))
(not (symbol? (cadr var))))
- (-rtx-traverse-error tstate
+ (/rtx-traverse-error tstate
"bad locals list"
expr op-num)))
val)
(cons val (tstate-push-env tstate env)))
)
-(define (-rtx-traverse-iteration val mode expr op-num tstate appstuff)
+(define (/rtx-traverse-iteration val mode expr op-num tstate appstuff)
(if (not (symbol? val))
- (-rtx-traverse-error tstate "bad iteration variable name"
+ (/rtx-traverse-error tstate "bad iteration variable name"
expr op-num))
(let ((env (rtx-env-make-iteration-locals val)))
(cons val (tstate-push-env tstate env)))
)
-(define (-rtx-traverse-env val mode expr op-num tstate appstuff)
+(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"
+ (/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)
+(define (/rtx-traverse-attrs val mode expr op-num tstate appstuff)
; (cons val ; (atlist-source-form (atlist-parse (make-prefix-context "with-attr") val ""))
; tstate)
#f
)
-(define (-rtx-traverse-symbol val mode expr op-num tstate appstuff)
+(define (/rtx-traverse-symbol val mode expr op-num tstate appstuff)
(if (not (symbol? val))
- (-rtx-traverse-error tstate "expecting a symbol"
+ (/rtx-traverse-error tstate "expecting a symbol"
expr op-num))
#f
)
-(define (-rtx-traverse-string val mode expr op-num tstate appstuff)
+(define (/rtx-traverse-string val mode expr op-num tstate appstuff)
(if (not (string? val))
- (-rtx-traverse-error tstate "expecting a string"
+ (/rtx-traverse-error tstate "expecting a string"
expr op-num))
#f
)
-(define (-rtx-traverse-number val mode expr op-num tstate appstuff)
+(define (/rtx-traverse-number val mode expr op-num tstate appstuff)
(if (not (number? val))
- (-rtx-traverse-error tstate "expecting a number"
+ (/rtx-traverse-error tstate "expecting a number"
expr op-num))
#f
)
-(define (-rtx-traverse-symornum val mode expr op-num tstate appstuff)
+(define (/rtx-traverse-symornum val mode expr op-num tstate appstuff)
(if (not (or (symbol? val) (number? val)))
- (-rtx-traverse-error tstate
+ (/rtx-traverse-error tstate
"expecting a symbol or number"
expr op-num))
#f
)
-(define (-rtx-traverse-object val mode expr op-num tstate appstuff)
+(define (/rtx-traverse-object val mode expr op-num tstate appstuff)
#f
)
; This is a vector of size rtx-max-num.
; Each entry is a list of (arg-type-name . traverser) elements
; for rtx-arg-types.
+; FIXME: Initialized in rtl.scm (i.e. outside this file).
-(define -rtx-traverser-table #f)
+(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)
+(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 'NONVOIDMODE (/fastcall-make -rtx-traverse-nonvoidmode))
- (cons 'VOIDMODE (/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 'ITERATION (/fastcall-make -rtx-traverse-iteration))
- (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))
+ (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 'NONVOIDMODE (/fastcall-make /rtx-traverse-nonvoidmode))
+ (cons 'VOIDMODE (/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 'ITERATION (/fastcall-make /rtx-traverse-iteration))
+ (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)
)
; Traverse the operands of EXPR, a canonicalized RTL expression.
-; Here "canonicalized" means that -rtx-munge-mode&options has been called to
+; 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.
; Note that this means that, yes, the options and mode are "traversed" too.
-(define (-rtx-traverse-operands rtx-obj expr tstate appstuff)
- (if -rtx-traverse-debug?
+(define (/rtx-traverse-operands rtx-obj expr tstate appstuff)
+ (if /rtx-traverse-debug?
(begin
(display (spaces (* 4 (tstate-depth tstate))))
(display "Traversing operands of: ")
(let loop ((operands (cdr expr))
(op-num 0)
- (arg-types (vector-ref -rtx-traverser-table (rtx-num rtx-obj)))
+ (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?
+ (if /rtx-traverse-debug?
(begin
(display (spaces (* 4 (tstate-depth tstate))))
(if (null? operands)
(cons val result)))))))
)
-; Publically accessible version of -rtx-traverse-operands as EXPR-FN may
+; Publically accessible version of /rtx-traverse-operands as EXPR-FN may
; need to call it.
-(define rtx-traverse-operands -rtx-traverse-operands)
+(define rtx-traverse-operands /rtx-traverse-operands)
-; Subroutine of -rtx-munge-mode&options.
+; Subroutine of /rtx-munge-mode&options.
; Return boolean indicating if X is an rtx option.
-(define (-rtx-option? x)
+(define (/rtx-option? x)
(and (symbol? x)
(char=? (string-ref (symbol->string x) 0) #\:))
)
-; Subroutine of -rtx-munge-mode&options.
+; Subroutine of /rtx-munge-mode&options.
; Return boolean indicating if X is an rtx option list.
-(define (-rtx-option-list? x)
+(define (/rtx-option-list? x)
(or (null? x)
(and (pair? x)
- (-rtx-option? (car x))))
+ (/rtx-option? (car x))))
)
-; Subroutine of -rtx-traverse-expr to fill in the mode if absent and to
+; 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
; 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)
+(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))
+ (/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)))
(cons options (cons mode-name args)))
)
-; Subroutine of -rtx-traverse to traverse an expression.
+; Subroutine of /rtx-traverse to traverse an expression.
;
; RTX-OBJ is the <rtx-func> object of the (outer) expression being traversed.
;
; This is for semantic-compile's sake and all traversal handlers are
; required to do this if the expr-fn returns #f.
-(define (-rtx-traverse-expr rtx-obj expr mode parent-expr op-pos tstate appstuff)
+(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))))
+ (/rtx-munge-mode&options (cdr expr))))
(fn (fastcall7 (tstate-expr-fn tstate)
rtx-obj expr2 mode parent-expr op-pos tstate appstuff)))
(if 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)))
+ (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)))
+ (let ((operands (/rtx-traverse-operands rtx-obj expr2 tstate appstuff)))
(cons (car expr2) operands))))
)
; - 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?
+(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: ")
(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))))
+ (/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)
+ (/rtx-traverse (/rtx-macro-expand expr rtx-evaluator)
expected mode parent-expr op-pos tstate appstuff)
(tstate-error tstate "unknown rtx function" expr))))))
(tstate-decr-depth! tstate)
(cond ((symbol? expr)
(cond ((current-op-lookup expr)
- (-rtx-traverse
+ (/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-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-traverse
(rtx-make-ifield expr)
expected mode parent-expr op-pos tstate appstuff))
((enum-lookup-val expr)
;; ??? If enums could have modes other than INT,
;; we'd want to propagate that mode here.
- (-rtx-traverse
+ (/rtx-traverse
(rtx-make-enum 'INT expr)
expected mode parent-expr op-pos tstate appstuff))
(else
(tstate-error tstate "unknown operand" expr))))
((integer? expr)
- (-rtx-traverse (rtx-make-const 'INT expr)
+ (/rtx-traverse (rtx-make-const 'INT expr)
expected mode parent-expr op-pos tstate appstuff))
(else
(tstate-error tstate "unexpected operand" expr)))
)
; User visible procedures to traverse an rtl expression.
-; These calls -rtx-traverse to do most of the work.
+; These calls /rtx-traverse to do most of the work.
; See tstate-make for explanations of OWNER, 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
+ (/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
+ (/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))
; Set to #t to debug rtx evaluation.
-(define -rtx-eval-debug? #f)
+(define /rtx-eval-debug? #f)
; RTX expression evaluator.
;
; ESTATE is the current evaluation state.
(define (rtx-eval-with-estate expr mode estate)
- (if -rtx-eval-debug?
+ (if /rtx-eval-debug?
(begin
(display "Traversing ")
(display expr)
; (if (rtx-style-syntax? rtx-obj)
; (apply fn (cons estate (cdr expr)))
; (let ((operands
-; (-rtx-eval-operands rtx-obj expr estate)))
+; (/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)))
+; (/rtx-traverse-operands rtx-obj expr estate)))
; (cons rtx-obj operands))))
; EXPR is not a list
\f
;; rtx-simplify (and supporting cast)
-; Subroutine of -rtx-simplify-expr-fn to compare two values for equality.
+; Subroutine of /rtx-simplify-expr-fn to compare two values for equality.
; If both are constants and they're equal return #f/#t.
; INVERT? = #f -> return #t if equal, #t -> return #f if equal.
; Returns 'unknown if either argument is not a constant.
-(define (-rtx-const-equal arg0 arg1 invert?)
+(define (/rtx-const-equal arg0 arg1 invert?)
(if (and (rtx-constant? arg0)
(rtx-constant? arg1))
(if invert?
'unknown)
)
-; Subroutine of -rtx-simplify-expr-fn to see if MAYBE-CONST is
+; Subroutine of /rtx-simplify-expr-fn to see if MAYBE-CONST is
; an element of NUMBER-LIST.
; NUMBER-LIST is a `number-list' rtx.
; INVERT? is #t if looking for non-membership.
; - return 'member if MAYBE-CONST is in NUMBER-LIST and it has many members
; - otherwise return 'unknown
-(define (-rtx-const-list-equal maybe-const number-list invert?)
+(define (/rtx-const-list-equal maybe-const number-list invert?)
(assert (rtx-kind? 'number-list number-list))
(if (rtx-constant? maybe-const)
(let ((values (rtx-number-list-values number-list)))
'unknown)
)
-; Subroutine of -rtx-simplify-expr-fn to simplify an eq-attr of (current-mach).
+; Subroutine of /rtx-simplify-expr-fn to simplify an eq-attr of (current-mach).
; CONTEXT is a <context> object or #f if there is none.
-(define (-rtx-simplify-eq-attr-mach rtx context)
+(define (/rtx-simplify-eq-attr-mach rtx context)
(let ((attr (rtx-eq-attr-attr rtx))
(value (rtx-eq-attr-value rtx)))
; If all currently selected machs will yield the same value
rtx)))
)
-; Subroutine of -rtx-simplify-expr-fn to simplify an eq-attr of (current-insn).
+; Subroutine of /rtx-simplify-expr-fn to simplify an eq-attr of (current-insn).
-(define (-rtx-simplify-eq-attr-insn rtx insn context)
+(define (/rtx-simplify-eq-attr-insn rtx insn context)
(let ((attr (rtx-eq-attr-attr rtx))
(value (rtx-eq-attr-value rtx)))
(if (not (insn? insn))
; Subroutine of rtx-simplify.
; This is the EXPR-FN argument to rtx-traverse.
-(define (-rtx-simplify-expr-fn rtx-obj expr mode parent-expr op-pos
+(define (/rtx-simplify-expr-fn rtx-obj expr mode parent-expr op-pos
tstate appstuff)
;(display "Processing ") (display (rtx-dump expr)) (newline)
(case (rtx-name expr)
((not)
- (let* ((arg (-rtx-traverse (rtx-alu-op-arg expr 0)
+ (let* ((arg (/rtx-traverse (rtx-alu-op-arg expr 0)
'RTX
(rtx-alu-op-mode expr)
expr 1 tstate appstuff))
(else (rtx-make 'not (rtx-alu-op-mode expr) arg)))))
((orif)
- (let ((arg0 (-rtx-traverse (rtx-boolif-op-arg expr 0)
+ (let ((arg0 (/rtx-traverse (rtx-boolif-op-arg expr 0)
'RTX 'DFLT expr 0 tstate appstuff))
- (arg1 (-rtx-traverse (rtx-boolif-op-arg expr 1)
+ (arg1 (/rtx-traverse (rtx-boolif-op-arg expr 1)
'RTX 'DFLT expr 1 tstate appstuff)))
(let ((no-side-effects-0? (not (rtx-side-effects? arg0)))
(no-side-effects-1? (not (rtx-side-effects? arg1))))
(rtx-make 'orif arg0 arg1))))))
((andif)
- (let ((arg0 (-rtx-traverse (rtx-boolif-op-arg expr 0)
+ (let ((arg0 (/rtx-traverse (rtx-boolif-op-arg expr 0)
'RTX 'DFLT expr 0 tstate appstuff))
- (arg1 (-rtx-traverse (rtx-boolif-op-arg expr 1)
+ (arg1 (/rtx-traverse (rtx-boolif-op-arg expr 1)
'RTX 'DFLT expr 1 tstate appstuff)))
(let ((no-side-effects-0? (not (rtx-side-effects? arg0)))
(no-side-effects-1? (not (rtx-side-effects? arg1))))
; ??? Was this but that calls rtx-traverse again which
; resets the temp stack!
; (rtx-simplify context (caddr expr))))
- (-rtx-traverse (rtx-if-test expr) 'RTX 'DFLT expr 1 tstate appstuff)))
+ (/rtx-traverse (rtx-if-test expr) 'RTX 'DFLT expr 1 tstate appstuff)))
(cond ((rtx-true? test)
- (-rtx-traverse (rtx-if-then expr) 'RTX mode expr 2 tstate appstuff))
+ (/rtx-traverse (rtx-if-then expr) 'RTX mode expr 2 tstate appstuff))
((rtx-false? test)
(if (rtx-if-else expr)
- (-rtx-traverse (rtx-if-else expr) 'RTX mode expr 3 tstate appstuff)
+ (/rtx-traverse (rtx-if-else expr) 'RTX mode expr 3 tstate appstuff)
; Sanity check, mode must be VOID.
(if (or (mode:eq? 'DFLT (rtx-mode expr))
(mode:eq? 'VOID (rtx-mode expr)))
((eq ne)
(let ((name (rtx-name expr))
(cmp-mode (rtx-cmp-op-mode expr))
- (arg0 (-rtx-traverse (rtx-cmp-op-arg expr 0) 'RTX
+ (arg0 (/rtx-traverse (rtx-cmp-op-arg expr 0) 'RTX
(rtx-cmp-op-mode expr)
expr 1 tstate appstuff))
- (arg1 (-rtx-traverse (rtx-cmp-op-arg expr 1) 'RTX
+ (arg1 (/rtx-traverse (rtx-cmp-op-arg expr 1) 'RTX
(rtx-cmp-op-mode expr)
expr 2 tstate appstuff)))
(if (or (rtx-side-effects? arg0) (rtx-side-effects? arg1))
(rtx-make name cmp-mode arg0 arg1)
- (case (-rtx-const-equal arg0 arg1 (rtx-kind? 'ne expr))
+ (case (/rtx-const-equal arg0 arg1 (rtx-kind? 'ne expr))
((#f) (rtx-false))
((#t) (rtx-true))
(else
(let ((known-val (tstate-known-lookup tstate
(rtx-ifield-name arg0))))
(if (and known-val (rtx-kind? 'number-list known-val))
- (case (-rtx-const-list-equal arg1 known-val (rtx-kind? 'ne expr))
+ (case (/rtx-const-list-equal arg1 known-val (rtx-kind? 'ne expr))
((#f) (rtx-false))
((#t) (rtx-true))
(else
(let ((known-val (tstate-known-lookup tstate
(rtx-operand-name arg0))))
(if (and known-val (rtx-kind? 'number-list known-val))
- (case (-rtx-const-list-equal arg1 known-val (rtx-kind? 'ne expr))
+ (case (/rtx-const-list-equal arg1 known-val (rtx-kind? 'ne expr))
((#f) (rtx-false))
((#t) (rtx-true))
(else
; Recognize attribute requests of current-insn, current-mach.
((eq-attr)
(cond ((rtx-kind? 'current-mach (rtx-eq-attr-owner expr))
- (-rtx-simplify-eq-attr-mach expr (tstate-context tstate)))
+ (/rtx-simplify-eq-attr-mach expr (tstate-context tstate)))
((rtx-kind? 'current-insn (rtx-eq-attr-owner expr))
- (-rtx-simplify-eq-attr-insn expr (tstate-owner tstate) (tstate-context tstate)))
+ (/rtx-simplify-eq-attr-insn expr (tstate-owner tstate) (tstate-context tstate)))
(else expr)))
((ifield)
; ??? Will become more intelligent as needed.
(define (rtx-simplify context owner expr known)
- (-rtx-traverse expr #f 'DFLT #f 0
+ (/rtx-traverse expr #f 'DFLT #f 0
(tstate-make context owner
- (/fastcall-make -rtx-simplify-expr-fn)
+ (/fastcall-make /rtx-simplify-expr-fn)
(rtx-env-empty-stack)
#f #f known 0)
#f)
; Subroutine of rtx-solve.
; This is the EXPR-FN argument to rtx-traverse.
-(define (-solve-expr-fn rtx-obj expr mode parent-expr op-pos tstate appstuff)
+(define (/solve-expr-fn rtx-obj expr mode parent-expr op-pos tstate appstuff)
#f ; wip
)
(let* ((simplified-expr (rtx-simplify context owner expr known))
(maybe-solved-expr
simplified-expr) ; FIXME: for now
-; (-rtx-traverse simplified-expr #f 'DFLT #f 0
+; (/rtx-traverse simplified-expr #f 'DFLT #f 0
; (tstate-make context owner
-; (/fastcall-make -solve-expr-fn)
+; (/fastcall-make /solve-expr-fn)
; (rtx-env-empty-stack)
; #f #f known 0)
; #f))
; It is used for error message.
; RTX-OBJ is the <rtx-func> object of (car expr).
-(define (-rtx-canonicalize-expr context rtx-obj expr)
+(define (/rtx-canonicalize-expr context rtx-obj expr)
#f
)
; ??? 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)
+(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)
; parent-expr op-pos tstate))
; (else
(cons (car expr) ; rtx-obj
- (-rtx-traverse-operands rtx-obj expr tstate appstuff))
+ (/rtx-traverse-operands rtx-obj expr tstate appstuff))
)
(define (rtx-compile context expr extra-vars-alist)
- (-rtx-traverse expr #f 'DFLT #f 0
+ (/rtx-traverse expr #f 'DFLT #f 0
(tstate-make context #f
- (/fastcall-make -compile-expr-fn)
+ (/fastcall-make /compile-expr-fn)
(rtx-env-init-stack1 extra-vars-alist)
#f #f nil 0)
#f)
; RTX trimming (removing fluff not normally needed for the human viewer).
-; Subroutine of -rtx-trim-for-doc to simplify it.
+; Subroutine of /rtx-trim-for-doc to simplify it.
; Trim all the arguments of rtx NAME.
-(define (-rtx-trim-args name args)
+(define (/rtx-trim-args name args)
(let* ((rtx-obj (rtx-lookup name))
(arg-types (rtx-arg-types rtx-obj)))
#f) ; leave arg untouched
((RTX SETRTX TESTRTX)
- (set! new-arg (-rtx-trim-for-doc arg)))
+ (set! new-arg (/rtx-trim-for-doc arg)))
((CONDRTX)
(assert (= (length arg) 2))
(if (eq? (car arg) 'else)
- (set! new-arg (cons 'else (-rtx-trim-for-doc (cadr arg))))
- (set! new-arg (list (-rtx-trim-for-doc (car arg))
- (-rtx-trim-for-doc (cadr arg)))))
+ (set! new-arg (cons 'else (/rtx-trim-for-doc (cadr arg))))
+ (set! new-arg (list (/rtx-trim-for-doc (car arg))
+ (/rtx-trim-for-doc (cadr arg)))))
)
((CASERTX)
(assert (= (length arg) 2))
- (set! new-arg (list (car arg) (-rtx-trim-for-doc (cadr arg))))
+ (set! new-arg (list (car arg) (/rtx-trim-for-doc (cadr arg))))
)
((LOCALS)
; it isn't. You need to keep separate the notions of simplifying "1+1" to "2"
; and trimming the clutter from "(const () BI 0)" yielding "0".
-(define (-rtx-trim-for-doc rtx)
+(define (/rtx-trim-for-doc rtx)
(if (pair? rtx) ; ??? cheap rtx?
(let ((name (car rtx))
(options (cadr rtx))
((sequence parallel)
; No special support is needed, except it's nice to remove nop
; statements. These can be created when an `if' get simplified.
- (let ((trimmed-args (-rtx-trim-args name rest))
+ (let ((trimmed-args (/rtx-trim-args name rest))
(result nil))
(for-each (lambda (rtx)
(if (equal? rtx '(nop))
(cons name (cons options (cons mode (reverse result)))))))
(else
- (let ((trimmed-args (-rtx-trim-args name rest)))
+ (let ((trimmed-args (/rtx-trim-args name rest)))
(if (null? options)
(if (eq? mode 'DFLT)
(cons name trimmed-args)
)
(define (rtx-trim-for-doc rtx)
- (-rtx-trim-for-doc rtx)
+ (/rtx-trim-for-doc rtx)
)
; List of mode types for arg-types.
-(define -rtx-valid-mode-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
+(define /rtx-valid-types
(append
'(OPTIONS)
- -rtx-valid-mode-types
+ /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.
-(define -rtx-valid-matches
+(define /rtx-valid-matches
'(ANY NA OP0 MATCH1 MATCH2)
)
; List of all defined rtx names. This can be map'd over without having
-; to know the innards of -rtx-func-table (which is a hash table).
+; to know the innards of /rtx-func-table (which is a hash table).
-(define -rtx-name-list nil)
-(define (rtx-name-list) -rtx-name-list)
+(define /rtx-name-list nil)
+(define (rtx-name-list) /rtx-name-list)
; Table of rtx function objects.
; This is set in rtl-init!.
-(define -rtx-func-table nil)
+(define /rtx-func-table nil)
; Look up the <rtx-func> object for RTX-KIND.
; Returns the object or #f if not found.
(define (rtx-lookup rtx-kind)
(cond ((symbol? rtx-kind)
- (hashq-ref -rtx-func-table rtx-kind))
+ (hashq-ref /rtx-func-table rtx-kind))
((rtx-func? rtx-kind)
rtx-kind)
(else #f))
; Table of rtx macro objects.
; This is set in rtl-init!.
-(define -rtx-macro-table nil)
+(define /rtx-macro-table nil)
; Table of operands, modes, and other non-functional aspects of RTL.
; This is defined in rtl-finish!, after all operands have been read in.
-(define -rtx-operand-table nil)
+(define /rtx-operand-table nil)
; Number of next rtx to be defined.
-(define -rtx-num-next #f)
+(define /rtx-num-next #f)
; Return the number of rtx's.
(define (rtx-max-num)
- -rtx-num-next
+ /rtx-num-next
)
\f
; Define Rtx Node
; NAME-ARGS is a list of the operation name and arguments.
; The mode of the result must be the first element in `args' (if there are
; any arguments).
-; ARG-TYPES is a list of argument types (-rtx-valid-types).
-; ARG-MODES is a list of mode matchers (-rtx-valid-matches).
+; ARG-TYPES is a list of argument types (/rtx-valid-types).
+; ARG-MODES is a list of mode matchers (/rtx-valid-matches).
; CLASS is the class of the rtx to be created.
; ACTION is a list of Scheme expressions to perform the operation.
;
(if action
(eval1 (list 'lambda (cons '*estate* args) action))
#f)
- -rtx-num-next)))
+ /rtx-num-next)))
; Add it to the table of rtx handlers.
- (hashq-set! -rtx-func-table name rtx)
- (set! -rtx-num-next (+ -rtx-num-next 1))
- (set! -rtx-name-list (cons name -rtx-name-list))
+ (hashq-set! /rtx-func-table name rtx)
+ (set! /rtx-num-next (+ /rtx-num-next 1))
+ (set! /rtx-name-list (cons name /rtx-name-list))
*UNSPECIFIED*))
)
(if action
(eval1 (list 'lambda (cons '*estate* args) action))
#f)
- -rtx-num-next)))
+ /rtx-num-next)))
; Add it to the table of rtx handlers.
- (hashq-set! -rtx-func-table name rtx)
- (set! -rtx-num-next (+ -rtx-num-next 1))
- (set! -rtx-name-list (cons name -rtx-name-list))
+ (hashq-set! /rtx-func-table name rtx)
+ (set! /rtx-num-next (+ /rtx-num-next 1))
+ (set! /rtx-name-list (cons name /rtx-name-list))
*UNSPECIFIED*))
)
class
'operand
(eval1 (list 'lambda (cons '*estate* args) action))
- -rtx-num-next)))
+ /rtx-num-next)))
; Add it to the table of rtx handlers.
- (hashq-set! -rtx-func-table name rtx)
- (set! -rtx-num-next (+ -rtx-num-next 1))
- (set! -rtx-name-list (cons name -rtx-name-list))
+ (hashq-set! /rtx-func-table name rtx)
+ (set! /rtx-num-next (+ /rtx-num-next 1))
+ (set! /rtx-name-list (cons name /rtx-name-list))
*UNSPECIFIED*))
)
#f ; class
'macro
(eval1 (list 'lambda args action))
- -rtx-num-next)))
+ /rtx-num-next)))
; Add it to the table of rtx macros.
- (hashq-set! -rtx-macro-table name rtx)
- (set! -rtx-num-next (+ -rtx-num-next 1))
- (set! -rtx-name-list (cons name -rtx-name-list))
+ (hashq-set! /rtx-macro-table name rtx)
+ (set! /rtx-num-next (+ /rtx-num-next 1))
+ (set! /rtx-name-list (cons name /rtx-name-list))
*UNSPECIFIED*))
)
; Lookup MACRO-NAME and return its <rtx-func> object or #f if not found.
-(define (-rtx-macro-lookup macro-name)
- (hashq-ref -rtx-macro-table macro-name)
+(define (/rtx-macro-lookup macro-name)
+ (hashq-ref /rtx-macro-table macro-name)
)
; Lookup (car exp) and return the macro's lambda if it is one or #f.
-(define (-rtx-macro-check exp fn-getter)
- (let ((macro (hashq-ref -rtx-macro-table (car exp))))
+(define (/rtx-macro-check exp fn-getter)
+ (let ((macro (hashq-ref /rtx-macro-table (car exp))))
(if macro
(fn-getter macro)
#f))
; Expand a list.
-(define (-rtx-macro-expand-list exp fn-getter)
- (let ((macro (-rtx-macro-check exp fn-getter)))
+(define (/rtx-macro-expand-list exp fn-getter)
+ (let ((macro (/rtx-macro-check exp fn-getter)))
(if macro
- (apply macro (map (lambda (x) (-rtx-macro-expand x fn-getter))
+ (apply macro (map (lambda (x) (/rtx-macro-expand x fn-getter))
(cdr exp)))
- (map (lambda (x) (-rtx-macro-expand x fn-getter))
+ (map (lambda (x) (/rtx-macro-expand x fn-getter))
exp)))
)
; Main entry point to expand a macro invocation.
-(define (-rtx-macro-expand exp fn-getter)
+(define (/rtx-macro-expand exp fn-getter)
(if (pair? exp) ; pair? -> cheap (and (not (null? exp)) (list? exp))
- (let ((result (-rtx-macro-expand-list exp fn-getter)))
+ (let ((result (/rtx-macro-expand-list exp fn-getter)))
; If the result is a new macro invocation, recurse.
(if (pair? result)
- (let ((macro (-rtx-macro-check result fn-getter)))
+ (let ((macro (/rtx-macro-check result fn-getter)))
(if macro
- (-rtx-macro-expand (apply macro (cdr result)) fn-getter)
+ (/rtx-macro-expand (apply macro (cdr result)) fn-getter)
result))
result))
exp)
; Publically accessible version.
-(define rtx-macro-expand -rtx-macro-expand)
+(define rtx-macro-expand /rtx-macro-expand)
\f
; RTX mode support.
; comfortable, though I liked bringing unsigned modes out into the open
; even if it doubled the number of semantic operations.
-(define (-rtx-sem-mode m) (or (mode:sem-mode m) m))
+(define (rtx-sem-mode m) (or (mode:sem-mode m) m))
; MODE is a mode name or <mode> object.
-(define (-rtx-lazy-sem-mode mode) (-rtx-sem-mode (mode:lookup mode)))
+
+(define (rtx-lazy-sem-mode mode) (rtx-sem-mode (mode:lookup mode)))
; Return the mode of object OBJ.
-(define (-rtx-obj-mode obj) (send obj 'get-mode))
+(define (rtx-obj-mode obj) (send obj 'get-mode))
; Return a boolean indicating of modes M1,M2 are compatible.
-(define (-rtx-mode-compatible? m1 m2)
- (let ((mode1 (-rtx-lazy-sem-mode m1))
- (mode2 (-rtx-lazy-sem-mode m2)))
+(define (rtx-mode-compatible? m1 m2)
+ (let ((mode1 (rtx-lazy-sem-mode m1))
+ (mode2 (rtx-lazy-sem-mode m2)))
;(eq? (obj:name mode1) (obj:name mode2)))
; ??? This is more permissive than is perhaps proper.
(mode-compatible? 'sameclass mode1 mode2))
; Create a "closure" of EXPR using the current temp stack.
-(define (-rtx-closure-make estate expr)
+(define (/rtx-closure-make estate expr)
(rtx-make 'closure expr (estate-env estate))
)
; that much.
(define (rtx-make kind . args)
- (cons kind (-rtx-munge-mode&options args))
+ (cons kind (/rtx-munge-mode&options args))
)
(define rtx-name car)
(define (rtx? x)
(->bool
(and (pair? x) ; pair? -> cheap non-null-list?
- (or (hashq-ref -rtx-func-table (car x))
- (hashq-ref -rtx-macro-table (car x)))))
+ (or (hashq-ref /rtx-func-table (car x))
+ (hashq-ref /rtx-macro-table (car x)))))
)
\f
; Instruction field support.
; We make some attempt to make the name pretty as it appears in generated
; files.
-(define (-rtx-hw-name hw hw-name index-arg)
+(define (/rtx-hw-name hw hw-name index-arg)
(cond ((hw-scalar? hw)
hw-name)
((rtx? index-arg)
(make <hw-index> 'anonymous 'constant UINT
(rtx-constant-value index-arg))
(make <hw-index> 'anonymous 'rtx DFLT
- (-rtx-closure-make estate index-arg))))
+ (/rtx-closure-make estate index-arg))))
(else (parse-error (estate-context estate)
"invalid index" index-arg))))
; 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-with-mode 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))
; Subroutines.
; ??? Not sure this should live here.
-(define (-subr-read context . arg-list)
+(define (/subr-read context . arg-list)
#f
)
(define define-subr
(lambda arg-list
- (let ((s (apply -subr-read (cons "define-subr" arg-list))))
+ (let ((s (apply /subr-read (cons "define-subr" arg-list))))
(if s
(current-subr-add! s))
s))
; Called before a .cpu file is read in.
(define (rtl-init!)
- (set! -rtx-func-table (make-hash-table 127))
- (set! -rtx-macro-table (make-hash-table 127))
- (set! -rtx-num-next 0)
+ (set! /rtx-func-table (make-hash-table 127))
+ (set! /rtx-macro-table (make-hash-table 127))
+ (set! /rtx-num-next 0)
(def-rtx-funcs)
; Sanity checks.
#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)))))
+ (assert (memq (cadr (rtx-arg-types rtx)) /rtx-valid-mode-types)))))
#f) ; else a macro
))
- -rtx-name-list)
+ /rtx-name-list)
(reader-add-command! 'define-subr
"\
(set! s-pc pc)
; Table of traversers for the various rtx elements.
- (let ((hash-table (-rtx-make-traverser-table)))
- (set! -rtx-traverser-table (make-vector (rtx-max-num) #f))
+ (let ((hash-table (/rtx-make-traverser-table)))
+ (set! /rtx-traverser-table (make-vector (rtx-max-num) #f))
(for-each (lambda (rtx-name)
(let ((rtx (rtx-lookup rtx-name)))
(if rtx
- (vector-set! -rtx-traverser-table (rtx-num rtx)
+ (vector-set! /rtx-traverser-table (rtx-num rtx)
(map1-improper
(lambda (arg-type)
(cons arg-type
(rtx-name-list)))
; Initialize the operand hash table.
- (set! -rtx-operand-table (make-hash-table 127))
+ (set! /rtx-operand-table (make-hash-table 127))
; Add the operands to the eval symbol table.
(for-each (lambda (op)
- (hashq-set! -rtx-operand-table (obj:name op) op))
+ (hashq-set! /rtx-operand-table (obj:name op) op))
(current-op-list))
; Add ifields to the eval symbol table.
(for-each (lambda (f)
- (hashq-set! -rtx-operand-table (obj:name f) f))
+ (hashq-set! /rtx-operand-table (obj:name f) f))
(non-derived-ifields (current-ifld-list)))
*UNSPECIFIED*
; Set to #t to collect various statistics.
-(define -stmt-stats? #f)
+(define /stmt-stats? #f)
-; Collection of computed stats. Only set if -stmt-stats? = #t.
+; Collection of computed stats. Only set if /stmt-stats? = #t.
-(define -stmt-stats #f)
+(define /stmt-stats #f)
-; Collection of computed statement data. Only set if -stmt-stats? = #t.
+; Collection of computed statement data. Only set if /stmt-stats? = #t.
-(define -stmt-stats-data #f)
+(define /stmt-stats-data #f)
; Create a structure recording data of all statements.
; A pair of (next-ordinal . table).
-(define (-stmt-data-make hash-size)
+(define (/stmt-data-make hash-size)
(cons 0 (make-vector hash-size nil))
)
; Accessors.
-(define (-stmt-data-table data) (cdr data))
-(define (-stmt-data-next-num data) (car data))
-(define (-stmt-data-set-next-num! data newval) (set-car! data newval))
-(define (-stmt-data-hash-size data) (vector-length (cdr data)))
+(define (/stmt-data-table data) (cdr data))
+(define (/stmt-data-next-num data) (car data))
+(define (/stmt-data-set-next-num! data newval) (set-car! data newval))
+(define (/stmt-data-hash-size data) (vector-length (cdr data)))
; A single statement.
; INSN semantics either consist of a single statement or a sequence of them.
;
; The user list is set to nil.
-(define (-stmt-make expr locals num speed-cost size-cost)
+(define (/stmt-make expr locals num speed-cost size-cost)
(make <statement> expr locals num speed-cost size-cost nil)
)
; Add a user of STMT.
-(define (-stmt-add-user! stmt user-num user-obj)
+(define (/stmt-add-user! stmt user-num user-obj)
(-stmt-set-users! stmt (cons (cons user-num user-obj) (-stmt-users stmt)))
*UNSPECIFIED*
)
; CHAIN-NUM is an argument so it need only be computed once.
; The result is the found <statement> object or #f.
-(define (-frag-lookup-stmt data chain-num stmt)
- (let ((table (-stmt-data-table data)))
+(define (/frag-lookup-stmt data chain-num stmt)
+ (let ((table (/stmt-data-table data)))
(let loop ((stmts (vector-ref table chain-num)))
(cond ((null? stmts)
#f)
; Hash a statement.
; Computed hash value.
-; Global 'cus -frag-hash-compute! is defined globally so we can use
+; Global 'cus /frag-hash-compute! is defined globally so we can use
; /fastcall (FIXME: Need /fastcall to work on non-global procs).
-(define -frag-hash-value-tmp 0)
+(define /frag-hash-value-tmp 0)
-(define (-frag-hash-string str)
+(define (/frag-hash-string str)
(let loop ((chars (map char->integer (string->list str))) (result 0))
(if (null? chars)
result
(loop (cdr chars) (modulo (+ (* result 7) (car chars)) #xfffffff))))
)
-(define (-frag-hash-compute! rtx-obj expr mode parent-expr op-pos tstate appstuff)
+(define (/frag-hash-compute! rtx-obj expr mode parent-expr op-pos tstate appstuff)
(let ((h 0))
(case (rtx-name expr)
((operand)
- (set! h (-frag-hash-string (symbol->string (rtx-operand-name expr)))))
+ (set! h (/frag-hash-string (symbol->string (rtx-operand-name expr)))))
((local)
- (set! h (-frag-hash-string (symbol->string (rtx-local-name expr)))))
+ (set! h (/frag-hash-string (symbol->string (rtx-local-name expr)))))
((const)
(set! h (rtx-const-value expr)))
(else
(set! h (rtx-num rtx-obj))))
- (set! -frag-hash-value-tmp
+ (set! /frag-hash-value-tmp
; Keep number small.
- (modulo (+ (* -frag-hash-value-tmp 3) h op-pos)
+ (modulo (+ (* /frag-hash-value-tmp 3) h op-pos)
#xfffffff)))
; #f -> "continue with normal traversing"
#f
)
-(define (-frag-hash-stmt stmt locals size)
- (set! -frag-hash-value-tmp 0)
- (rtx-traverse-with-locals #f #f stmt -frag-hash-compute! locals #f) ; FIXME: (/fastcall-make -frag-hash-compute!))
- (modulo -frag-hash-value-tmp size)
+(define (/frag-hash-stmt stmt locals size)
+ (set! /frag-hash-value-tmp 0)
+ (rtx-traverse-with-locals #f #f stmt /frag-hash-compute! locals #f) ; FIXME: (/fastcall-make /frag-hash-compute!))
+ (modulo /frag-hash-value-tmp size)
)
; Compute the speed/size costs of a statement.
; Compute speed/size costs.
-; Global 'cus -frag-cost-compute! is defined globally so we can use
+; Global 'cus /frag-cost-compute! is defined globally so we can use
; /fastcall (FIXME: Need /fastcall to work on non-global procs).
-(define -frag-speed-cost-tmp 0)
-(define -frag-size-cost-tmp 0)
+(define /frag-speed-cost-tmp 0)
+(define /frag-size-cost-tmp 0)
-(define (-frag-cost-compute! rtx-obj expr mode parent-expr op-pos tstate appstuff)
+(define (/frag-cost-compute! rtx-obj expr mode parent-expr op-pos tstate appstuff)
; FIXME: wip
(let ((speed 0)
(size 0))
(else
(set! speed 4)
(set! size 4)))
- (set! -frag-speed-cost-tmp (+ -frag-speed-cost-tmp speed))
- (set! -frag-size-cost-tmp (+ -frag-size-cost-tmp size)))
+ (set! /frag-speed-cost-tmp (+ /frag-speed-cost-tmp speed))
+ (set! /frag-size-cost-tmp (+ /frag-size-cost-tmp size)))
; #f -> "continue with normal traversing"
#f
)
-(define (-frag-stmt-cost stmt locals)
- (set! -frag-speed-cost-tmp 0)
- (set! -frag-size-cost-tmp 0)
- (rtx-traverse-with-locals #f #f stmt -frag-cost-compute! locals #f) ; FIXME: (/fastcall-make -frag-cost-compute!))
- (cons -frag-speed-cost-tmp -frag-size-cost-tmp)
+(define (/frag-stmt-cost stmt locals)
+ (set! /frag-speed-cost-tmp 0)
+ (set! /frag-size-cost-tmp 0)
+ (rtx-traverse-with-locals #f #f stmt /frag-cost-compute! locals #f) ; FIXME: (/fastcall-make /frag-cost-compute!))
+ (cons /frag-speed-cost-tmp /frag-size-cost-tmp)
)
; Add STMT to statement table DATA.
; CHAIN-NUM is the chain in the hash table to add STMT to.
-; {SPEED,SIZE}-COST are passed through to -stmt-make.
+; {SPEED,SIZE}-COST are passed through to /stmt-make.
; The result is the newly created <statement> object.
-(define (-frag-add-stmt! data chain-num stmt locals speed-cost size-cost)
- (let ((stmt (-stmt-make stmt locals (-stmt-data-next-num data) speed-cost size-cost))
- (table (-stmt-data-table data)))
+(define (/frag-add-stmt! data chain-num stmt locals speed-cost size-cost)
+ (let ((stmt (/stmt-make stmt locals (/stmt-data-next-num data) speed-cost size-cost))
+ (table (/stmt-data-table data)))
(vector-set! table chain-num (cons stmt (vector-ref table chain-num)))
- (-stmt-data-set-next-num! data (+ 1 (-stmt-data-next-num data)))
+ (/stmt-data-set-next-num! data (+ 1 (/stmt-data-next-num data)))
stmt)
)
; Otherwise, return nil.
; The result is in assq'able form.
-(define (-frag-expr-locals expr)
+(define (/frag-expr-locals expr)
(if (rtx-kind? 'sequence expr)
(rtx-sequence-assq-locals expr)
nil)
; If a sequence, return the sequence's expressions.
; Otherwise, return (list expr).
-(define (-frag-expr-stmts expr)
+(define (/frag-expr-stmts expr)
(if (rtx-kind? 'sequence expr)
(rtx-sequence-exprs expr)
(list expr))
; USAGE-INDEX is the index of USAGE-TABLE to use.
; OWNER is the object of the owner of the statement.
-(define (-frag-analyze-expr-stmt! locals stmt stmt-data usage-table expr-num owner)
+(define (/frag-analyze-expr-stmt! locals stmt stmt-data usage-table expr-num owner)
(logit 3 "Analyzing statement: " (rtx-strdump stmt) "\n")
(let* ((chain-num
- (-frag-hash-stmt stmt locals (-stmt-data-hash-size stmt-data)))
- (stmt-obj (-frag-lookup-stmt stmt-data chain-num stmt)))
+ (/frag-hash-stmt stmt locals (/stmt-data-hash-size stmt-data)))
+ (stmt-obj (/frag-lookup-stmt stmt-data chain-num stmt)))
(logit 3 " chain #" chain-num "\n")
(if (not stmt-obj)
- (let* ((costs (-frag-stmt-cost stmt locals))
+ (let* ((costs (/frag-stmt-cost stmt locals))
(speed-cost (car costs))
(size-cost (cdr costs)))
- (set! stmt-obj (-frag-add-stmt! stmt-data chain-num stmt locals
+ (set! stmt-obj (/frag-add-stmt! stmt-data chain-num stmt locals
speed-cost size-cost))
(logit 3 " new statement, #" (-stmt-num stmt-obj) "\n"))
(logit 3 " existing statement, #" (-stmt-num stmt-obj) "\n"))
- (-stmt-add-user! stmt-obj expr-num owner)
+ (/stmt-add-user! stmt-obj expr-num owner)
; If first entry, initialize list, otherwise append to existing list.
(if (null? (vector-ref usage-table expr-num))
; USAGE-INDEX is the index of the USAGE-TABLE entry to use.
; As each statement's ordinal is computed it is added to the usage list.
-(define (-frag-analyze-expr! expr owner stmt-data usage-table usage-index)
+(define (/frag-analyze-expr! expr owner stmt-data usage-table usage-index)
(logit 3 "Analyzing " (obj:name owner) ": " (rtx-strdump expr) "\n")
- (let ((locals (-frag-expr-locals expr))
- (stmt-list (-frag-expr-stmts expr)))
+ (let ((locals (/frag-expr-locals expr))
+ (stmt-list (/frag-expr-stmts expr)))
(for-each (lambda (stmt)
- (-frag-analyze-expr-stmt! locals stmt stmt-data
+ (/frag-analyze-expr-stmt! locals stmt stmt-data
usage-table usage-index owner))
stmt-list))
*UNSPECIFIED*
; - vector of statements (the statement table of the previous item)
; - each element is a <statement> object
-(define (-frag-compute-statements exprs owners)
+(define (/frag-compute-statements exprs owners)
(logit 2 "Computing statement table ...\n")
(let* ((num-exprs (length exprs))
(hash-size
(else 127))))
(let (; Hash table of expressions.
- (stmt-data (-stmt-data-make hash-size))
+ (stmt-data (/stmt-data-make hash-size))
; Statement index lists for each expression.
(usage-table (make-vector num-exprs nil)))
(if (not (null? exprs))
(let ((expr (car exprs))
(owner (vector-ref owners exprnum)))
- (-frag-analyze-expr! expr owner stmt-data usage-table exprnum)
+ (/frag-analyze-expr! expr owner stmt-data usage-table exprnum)
(loop (cdr exprs) (+ exprnum 1)))))
; Convert statement hash table to vector.
- (let ((stmt-hash-table (-stmt-data-table stmt-data))
- (end (vector-length (-stmt-data-table stmt-data)))
- (stmt-table (make-vector (-stmt-data-next-num stmt-data) #f)))
+ (let ((stmt-hash-table (/stmt-data-table stmt-data))
+ (end (vector-length (/stmt-data-table stmt-data)))
+ (stmt-table (make-vector (/stmt-data-next-num stmt-data) #f)))
(let loop ((i 0))
(if (< i end)
(begin
(loop (+ i 1)))))
; All done. Compute stats if asked to.
- (if -stmt-stats?
+ (if /stmt-stats?
(begin
; See how well the hashing worked.
- (set! -stmt-stats-data stmt-data)
- (set! -stmt-stats
+ (set! /stmt-stats-data stmt-data)
+ (set! /stmt-stats
(make-vector (vector-length stmt-hash-table) #f))
(let loop ((i 0))
(if (< i end)
(begin
- (vector-set! -stmt-stats i
+ (vector-set! /stmt-stats i
(length (vector-ref stmt-hash-table i)))
(loop (+ i 1)))))))
; List of statement numbers that make up `semantics'.
; Each element is an index into the stmt-table arg of
- ; -frag-pick-best.
+ ; /frag-pick-best.
; This is #f if the sfrag wasn't derived from some set of
; statements.
stmt-numbers
; Sorter to merge common fragments together.
; A and B are lists of statement numbers.
-(define (-frag-sort a b)
+(define (/frag-sort a b)
(cond ((null? a)
(not (null? b)))
((null? b)
((> (car a) (car b))
#f)
(else ; =
- (-frag-sort (cdr a) (cdr b))))
+ (/frag-sort (cdr a) (cdr b))))
)
; Return a boolean indicating if L1,L2 match in the first LEN elements.
; Each element is an integer.
-(define (-frag-list-match? l1 l2 len)
+(define (/frag-list-match? l1 l2 len)
(cond ((= len 0)
#t)
((or (null? l1) (null? l2))
#f)
((= (car l1) (car l2))
- (-frag-list-match? (cdr l1) (cdr l2) (- len 1)))
+ (/frag-list-match? (cdr l1) (cdr l2) (- len 1)))
(else
#f))
)
; Return the number of expressions that match in the first LEN statements.
-(define (-frag-find-matching expr-table indices stmt-list len)
+(define (/frag-find-matching expr-table indices stmt-list len)
(let loop ((num-exprs 0) (indices indices))
(cond ((null? indices)
num-exprs)
- ((-frag-list-match? stmt-list
+ ((/frag-list-match? stmt-list
(vector-ref expr-table (car indices)) len)
(loop (+ num-exprs 1) (cdr indices)))
(else
; STMT-LIST is a list of statement numbers, indices into STMT-TABLE.
; NUM-EXPRS is the number of expressions with STMT-LIST in common.
-(define (-frag-merge-profitable? stmt-table stmt-list num-exprs)
+(define (/frag-merge-profitable? stmt-table stmt-list num-exprs)
; FIXME: wip
(and (>= num-exprs 2)
(or ; No need to include speed costs yet.
- ;(>= (-frag-list-speed-cost stmt-table stmt-list) 10)
- (>= (-frag-list-size-cost stmt-table stmt-list) 4)))
+ ;(>= (/frag-list-speed-cost stmt-table stmt-list) 10)
+ (>= (/frag-list-size-cost stmt-table stmt-list) 4)))
)
; Return the cost of executing STMT-LIST.
; FIXME: The yardstick to use is wip. Currently we measure things relative
; to a simple add insn which is given the value 1.
-(define (-frag-list-speed-cost stmt-table stmt-list)
+(define (/frag-list-speed-cost stmt-table stmt-list)
; FIXME: wip
(apply + (map (lambda (stmt-num)
(-stmt-speed-cost (vector-ref stmt-table stmt-num)))
stmt-list))
)
-(define (-frag-list-size-cost stmt-table stmt-list)
+(define (/frag-list-size-cost stmt-table stmt-list)
; FIXME: wip
(apply + (map (lambda (stmt-num)
(-stmt-size-cost (vector-ref stmt-table stmt-num)))
; FIXME: Choosing a statement list should depend on whether there are existing
; chosen statement lists only slightly shorter.
-(define (-frag-longest-desired stmt-table stmt-usage-table indices)
+(define (/frag-longest-desired stmt-table stmt-usage-table indices)
; STMT-LIST is the list of statements in the first expression.
(let ((stmt-list (vector-ref stmt-usage-table (car indices))))
(let loop ((len 1) (prev-num-exprs 0))
; See how many subsequent expressions match at length LEN.
- (let ((num-exprs (-frag-find-matching stmt-usage-table (cdr indices)
+ (let ((num-exprs (/frag-find-matching stmt-usage-table (cdr indices)
stmt-list len)))
; If there aren't any, we're done.
; If LEN-1 is usable, return that.
(if (= num-exprs 0)
(let ((matching-stmt-list (list-take (- len 1) stmt-list)))
- (if (-frag-merge-profitable? stmt-table matching-stmt-list
+ (if (/frag-merge-profitable? stmt-table matching-stmt-list
prev-num-exprs)
(cons prev-num-exprs matching-stmt-list)
#f))
; Insns are also distinguished by being a CTI insn vs a non-CTI insn.
; CTI insns require special handling in the semantics.
-(define (-frag-split-by-sbuf user-list)
+(define (/frag-split-by-sbuf user-list)
; Sanity check.
(if (not (elm-bound? (cdar user-list) 'sfmt))
(error "sformats not computed"))
; This works for trailing fragments too as we do the computation based on the
; reversed statement lists.
-(define (-frag-compute-desired-frags stmt-table stmt-usage-table owner-table kind)
+(define (/frag-compute-desired-frags stmt-table stmt-usage-table owner-table kind)
(logit 2 "Computing desired " kind " frags ...\n")
(let* (
(map reverse (vector->list stmt-usage-table))))
; Sort STMT-USAGE-TABLE. That will bring exprs with common fragments
; together.
- (sorted-indices (sort-grade stmt-usage-list -frag-sort))
+ (sorted-indices (sort-grade stmt-usage-list /frag-sort))
; List of statement lists that together yield the fragment to create,
; plus associated users.
(desired-frags nil)
(let loop ((indices sorted-indices) (iteration 1))
(logit 3 "Iteration " iteration "\n")
(if (not (null? indices))
- (let ((longest (-frag-longest-desired stmt-table stmt-usage-table indices)))
+ (let ((longest (/frag-longest-desired stmt-table stmt-usage-table indices)))
(if longest
(picked-indices (list-take num-exprs indices))
; Need one copy of the frag for each sbuf, as structure
; offsets will be different in generated C/C++ code.
- (sfmt-users (-frag-split-by-sbuf
+ (sfmt-users (/frag-split-by-sbuf
(map (lambda (expr-num)
(cons expr-num
(vector-ref owner-table
; It's kept as one big function so we can compute each expression's sfrag list
; as we go. Though it's not much extra expense to not do this.
-(define (-frag-pick-best stmt-table stmt-usage-table owner-table)
+(define (/frag-pick-best stmt-table stmt-usage-table owner-table)
(let (
(num-stmts (vector-length stmt-table))
(num-exprs (vector-length stmt-usage-table))
; Compute desired headers.
(set! desired-header-frags
- (-frag-compute-desired-frags stmt-table stmt-usage-table owner-table
+ (/frag-compute-desired-frags stmt-table stmt-usage-table owner-table
'header))
; Compute the header used by each expression.
(let ((expr-hdrs (vector->list expr-hdrs-v)))
(set! desired-trailer-frags
- (-frag-compute-desired-frags
+ (/frag-compute-desired-frags
stmt-table
; FIXME: Shouldn't have to use list->vector.
; [still pass a vector, but use vector-map here instead of map]
; ??? This can be done later, with an appropriate enhancement to rtx-equal?
; ??? cse can be improved by ignoring local variable name (of course).
-(define (-frag-compute-locals! expr-list)
+(define (/frag-compute-locals! expr-list)
(logit 2 "Computing common locals ...\n")
(let ((result nil)
(lookup-local (lambda (local local-list)
(mode:eq? (cadr l1) (cadr l2)))))
)
(for-each (lambda (expr)
- (let ((locals (-frag-expr-locals expr)))
+ (let ((locals (/frag-expr-locals expr)))
(for-each (lambda (local)
(let ((entry (lookup-local local result)))
(if (and entry
;
; The result is a vector of six elements:
; - sfrag usage table for each owner #(header middle trailer)
-; - statement table (vector of all statements, made with -stmt-make)
+; - statement table (vector of all statements, made with /stmt-make)
; - list of sequence locals used by header sfrags
; - these locals are defined at the top level so that all fragments have
; access to them
; - trailer sfrags
; - middle sfrags
-(define (-sem-find-common-frags-1 exprs owners)
+(define (/sem-find-common-frags-1 exprs owners)
; Sanity check.
(if (not (elm-bound? (car owners) 'sfmt))
(error "sformats not computed"))
; A simple procedure that calls, in order:
- ; -frag-compute-locals!
- ; -frag-compute-statements
- ; -frag-pick-best
+ ; /frag-compute-locals!
+ ; /frag-compute-statements
+ ; /frag-pick-best
; The rest is shuffling of results.
; Internally it's easier if OWNERS is a vector.
(let ((owners (list->vector owners))
- (locals (-frag-compute-locals! exprs)))
+ (locals (/frag-compute-locals! exprs)))
; Collect statement usage data.
- (let ((stmt-usage (-frag-compute-statements exprs owners)))
+ (let ((stmt-usage (/frag-compute-statements exprs owners)))
(let ((stmt-usage-table (car stmt-usage))
(stmt-table (cdr stmt-usage)))
; Compute the frags we want to create.
; These are in general sequences of statements.
(let ((desired-frags
- (-frag-pick-best stmt-table stmt-usage-table owners)))
+ (/frag-pick-best stmt-table stmt-usage-table owners)))
(let (
(expr-sfrags (vector-ref desired-frags 0))
(headers (vector-ref desired-frags 1))
headers trailers middles))))))
)
-; Cover proc of -sem-find-common-frags-1.
+; Cover proc of /sem-find-common-frags-1.
; See its documentation.
(define (sem-find-common-frags insn-list)
- (-sem-find-common-frags-1
+ (/sem-find-common-frags-1
(begin
(logit 2 "Simplifying/canonicalizing rtl ...\n")
(map (lambda (insn)
; Try to use the middle fragment if present. Otherwise,
; use the x-header,x-trailer virtual insns.
-(define (-sfrag-compute-frag-list! insn frag-usage frag-table num-headers num-trailers x-header-relnum x-trailer-relnum)
+(define (/sfrag-compute-frag-list! insn frag-usage frag-table num-headers num-trailers x-header-relnum x-trailer-relnum)
; `(list #f)' is so append! works. The #f is deleted before returning.
(let ((result (list #f))
(header (vector-ref frag-usage 0))
; Subroutine of sfrag-create-cse-mapping to find the fragment number of the
; x-header/x-trailer virtual frags.
-(define (-frag-lookup-virtual frag-list name)
+(define (/frag-lookup-virtual frag-list name)
(let loop ((i 0) (frag-list frag-list))
(if (null? frag-list)
(assert (not "expected virtual insn not present"))
(let ((frag-table (list->vector (append header-list
trailer-list
middle-list)))
- (x-header-relnum (-frag-lookup-virtual header-list 'x-header))
- (x-trailer-relnum (-frag-lookup-virtual trailer-list 'x-trailer))
+ (x-header-relnum (/frag-lookup-virtual header-list 'x-header))
+ (x-trailer-relnum (/frag-lookup-virtual trailer-list 'x-trailer))
)
; Convert sfrag-usage-table to one that refers to the one big
; sfrag table.
(logit 2 "Computing insn frag usage ...\n")
(let ((insn-frags
(map (lambda (insn frag-usage)
- (-sfrag-compute-frag-list! insn frag-usage
+ (/sfrag-compute-frag-list! insn frag-usage
frag-table
num-headers num-trailers
x-header-relnum
\f
; Data analysis interface.
-(define -sim-sfrag-init? #f)
-(define (sim-sfrag-init?) -sim-sfrag-init?)
+(define /sim-sfrag-init? #f)
+(define (sim-sfrag-init?) /sim-sfrag-init?)
; Keep in globals for now, simplifies debugging.
; evil globals, blah blah blah.
-(define -sim-sfrag-insn-list #f)
-(define -sim-sfrag-frag-table #f)
-(define -sim-sfrag-usage-table #f)
-(define -sim-sfrag-locals-list #f)
+(define /sim-sfrag-insn-list #f)
+(define /sim-sfrag-frag-table #f)
+(define /sim-sfrag-usage-table #f)
+(define /sim-sfrag-locals-list #f)
(define (sim-sfrag-insn-list)
- (assert -sim-sfrag-init?)
- -sim-sfrag-insn-list
+ (assert /sim-sfrag-init?)
+ /sim-sfrag-insn-list
)
(define (sim-sfrag-frag-table)
- (assert -sim-sfrag-init?)
- -sim-sfrag-frag-table
+ (assert /sim-sfrag-init?)
+ /sim-sfrag-frag-table
)
(define (sim-sfrag-usage-table)
- (assert -sim-sfrag-init?)
- -sim-sfrag-usage-table
+ (assert /sim-sfrag-init?)
+ /sim-sfrag-usage-table
)
(define (sim-sfrag-locals-list)
- (assert -sim-sfrag-init?)
- -sim-sfrag-locals-list
+ (assert /sim-sfrag-init?)
+ /sim-sfrag-locals-list
)
(define (sim-sfrag-init!)
- (set! -sim-sfrag-init? #f)
- (set! -sim-sfrag-insn-list #f)
- (set! -sim-sfrag-frag-table #f)
- (set! -sim-sfrag-usage-table #f)
- (set! -sim-sfrag-locals-list #f)
+ (set! /sim-sfrag-init? #f)
+ (set! /sim-sfrag-insn-list #f)
+ (set! /sim-sfrag-frag-table #f)
+ (set! /sim-sfrag-usage-table #f)
+ (set! /sim-sfrag-locals-list #f)
)
(define (sim-sfrag-analyze-insns!)
- (if (not -sim-sfrag-init?)
+ (if (not /sim-sfrag-init?)
(begin
- (set! -sim-sfrag-insn-list (non-multi-insns (non-alias-insns (current-insn-list))))
- (let ((frag-data (sfrag-create-cse-mapping -sim-sfrag-insn-list)))
- (set! -sim-sfrag-frag-table (vector-ref frag-data 0))
- (set! -sim-sfrag-usage-table (vector-ref frag-data 1))
- (set! -sim-sfrag-locals-list (vector-ref frag-data 2)))
- (set! -sim-sfrag-init? #t)))
+ (set! /sim-sfrag-insn-list (non-multi-insns (non-alias-insns (current-insn-list))))
+ (let ((frag-data (sfrag-create-cse-mapping /sim-sfrag-insn-list)))
+ (set! /sim-sfrag-frag-table (vector-ref frag-data 0))
+ (set! /sim-sfrag-usage-table (vector-ref frag-data 1))
+ (set! /sim-sfrag-locals-list (vector-ref frag-data 2)))
+ (set! /sim-sfrag-init? #t)))
*UNSPECIFIED*
)
\f
; Testing support.
-(define (-frag-small-test-data)
+(define (/frag-small-test-data)
'(
(a . (sequence VOID ((SI tmp)) (set DFLT tmp rm) (set DFLT rd rm)))
(b . (sequence VOID ((SI tmp)) (set DFLT tmp rm) (set DFLT rd rm)))
)
)
-(define (-frag-test-data)
+(define (/frag-test-data)
(cons
(map (lambda (insn)
(rtx-simplify-insn #f insn))
(define test-middle-list #f)
(define (frag-test-run)
- (let* ((test-data (-frag-test-data))
+ (let* ((test-data (/frag-test-data))
(frag-data (sem-find-common-frags (car test-data) (cdr test-data))))
(set! test-sfrag-table (vector-ref frag-data 0))
(set! test-stmt-table (vector-ref frag-data 1))
; Two modes are equivalent if they're equal, or if their sem-mode fields
; are equal.
-(define (-rtx-mode-equiv? m1 m2)
+(define (/rtx-mode-equiv? m1 m2)
(or (eq? m1 m2)
(let ((mode1 (mode:lookup m1))
(mode2 (mode:lookup m2)))
; TYPE is one of -op- reg mem.
; EXPR is the constructed `xop' rtx expression for the operand,
; ignored in the search.
-; MODE must match, as defined by -rtx-mode-equiv?.
+; MODE must match, as defined by /rtx-mode-equiv?.
; NAME is the hardware element name, ifield name, or '-op-'.
; INDX-SEL must match if present in either.
;
; ??? Does this need to take "conditionally-referenced" into account?
-(define (-rtx-find-op op op-list)
+(define (/rtx-find-op op op-list)
(let ((type (car op))
(mode (caddr op))
(name (cadddr op))
((eq? type (caar op-list))
(let ((try (car op-list)))
(if (and (eq? name (cadddr try))
- (-rtx-mode-equiv? mode (caddr try))
+ (/rtx-mode-equiv? mode (caddr try))
(equal? indx-sel (car (cddddr try))))
try
(loop (cdr op-list)))))
; The result is one of 'use, 'set, 'set-quiet.
; "use" means "input operand".
-(define (-rtx-ref-type expr op-pos)
+(define (/rtx-ref-type expr op-pos)
; operand 0 is the option list, operand 1 is the mode
; (if you want to complain, fine, it's not like it would be unexpected)
(if (= op-pos 2)
; REF-TYPE is one of 'use, 'set, 'set-quiet.
; Adds COND-CTI/UNCOND-CTI to SEM-ATTRS if the operand is a set of the pc.
-(define (-build-operand! op-name op mode tstate ref-type op-list sem-attrs)
+(define (/build-operand! op-name op mode tstate ref-type op-list sem-attrs)
;(display (list op-name mode ref-type)) (newline) (force-output)
(let* ((mode (mode-real-name (if (eq? mode 'DFLT)
(op:mode op)
mode)))
; The first #f is a placeholder for the object.
(try (list '-op- #f mode op-name #f))
- (existing-op (-rtx-find-op try op-list)))
+ (existing-op (/rtx-find-op try op-list)))
(if (and (pc? op)
(memq ref-type '(set set-quiet)))
; Subroutine of semantic-compile:process-expr!, to simplify it.
-(define (-build-reg-operand! expr tstate op-list)
+(define (/build-reg-operand! expr tstate op-list)
(let* ((hw-name (rtx-reg-name expr))
(hw (current-hw-sem-lookup-1 hw-name)))
(indx-sel (rtx-reg-index-sel expr))
; #f is a place-holder for the object (filled in later)
(try (list 'reg #f mode hw-name indx-sel))
- (existing-op (-rtx-find-op try op-list)))
+ (existing-op (/rtx-find-op try op-list)))
; If already present, return the object, otherwise add it.
(if existing-op
; Subroutine of semantic-compile:process-expr!, to simplify it.
-(define (-build-mem-operand! expr tstate op-list)
+(define (/build-mem-operand! expr tstate op-list)
(let ((mode (rtx-mode expr))
(indx-sel (rtx-mem-index-sel expr)))
"memory must have explicit mode" expr))
(let* ((try (list 'mem #f mode 'h-memory indx-sel))
- (existing-op (-rtx-find-op try op-list)))
+ (existing-op (/rtx-find-op try op-list)))
; If already present, return the object, otherwise add it.
(if existing-op
; Subroutine of semantic-compile:process-expr!, to simplify it.
-(define (-build-ifield-operand! expr tstate op-list)
+(define (/build-ifield-operand! expr tstate op-list)
(let* ((f-name (rtx-ifield-name expr))
(f (current-ifld-lookup f-name)))
(let* ((mode (obj:name (ifld-mode f)))
(try (list '-op- #f mode f-name #f))
- (existing-op (-rtx-find-op try op-list)))
+ (existing-op (/rtx-find-op try op-list)))
; If already present, return the object, otherwise add it.
(if existing-op
; spent in semantic code) that can be done on code that uses index-of
; (see i960's movq insn). Later.
-(define (-build-index-of-operand! expr tstate op-list)
+(define (/build-index-of-operand! expr tstate op-list)
(if (not (and (rtx? (rtx-index-of-value expr))
(rtx-kind? 'operand (rtx-index-of-value expr))))
(parse-error (tstate-context tstate)
expr))
(let* ((f (hw-index:value indx))
(f-name (obj:name f)))
- ; The rest of this is identical to -build-ifield-operand!.
+ ; The rest of this is identical to /build-ifield-operand!.
(let* ((mode (obj:name (ifld-mode f)))
(try (list '-op- #f mode f-name #f))
- (existing-op (-rtx-find-op try op-list)))
+ (existing-op (/rtx-find-op try op-list)))
; If already present, return the object, otherwise add it.
(if existing-op
(case (car expr)
; Registers.
- ((reg) (let ((ref-type (-rtx-ref-type parent-expr op-pos))
+ ((reg) (let ((ref-type (/rtx-ref-type parent-expr op-pos))
; ??? could verify reg is a scalar
(regno (or (rtx-reg-number expr) 0)))
; The register number is either a number or an
(else (parse-error (tstate-context tstate)
"invalid register number"
regno)))
- (-build-reg-operand! expr tstate
+ (/build-reg-operand! expr tstate
(if (eq? ref-type 'use)
in-ops
out-ops))))
; Memory.
- ((mem) (let ((ref-type (-rtx-ref-type parent-expr op-pos)))
+ ((mem) (let ((ref-type (/rtx-ref-type parent-expr op-pos)))
(rtx-traverse-operands rtx-obj expr tstate appstuff)
- (-build-mem-operand! expr tstate
+ (/build-mem-operand! expr tstate
(if (eq? ref-type 'use)
in-ops
out-ops))))
; Operands.
((operand) (let ((op (rtx-operand-obj expr))
- (ref-type (-rtx-ref-type parent-expr op-pos)))
- (-build-operand! (obj:name op) op mode tstate ref-type
+ (ref-type (/rtx-ref-type parent-expr op-pos)))
+ (/build-operand! (obj:name op) op mode tstate ref-type
(if (eq? ref-type 'use)
in-ops
out-ops)
sem-attrs)))
; Give operand new name.
- ((name) (let ((result (-rtx-traverse (caddr expr) 'RTX mode
+ ((name) (let ((result (/rtx-traverse (caddr expr) 'RTX mode
parent-expr op-pos tstate appstuff)))
(if (not (operand? result))
(error "name: invalid argument:" expr result))
((local) expr) ; nothing to do
; Instruction fields.
- ((ifield) (let ((ref-type (-rtx-ref-type parent-expr op-pos)))
+ ((ifield) (let ((ref-type (/rtx-ref-type parent-expr op-pos)))
(if (not (eq? ref-type 'use))
(parse-error (tstate-context tstate)
"can't set an `ifield'" expr))
- (-build-ifield-operand! expr tstate in-ops)))
+ (/build-ifield-operand! expr tstate in-ops)))
; Hardware indices.
; For registers this is the register number.
; For memory this is the address.
; For constants, this is the constant.
- ((index-of) (let ((ref-type (-rtx-ref-type parent-expr op-pos)))
+ ((index-of) (let ((ref-type (/rtx-ref-type parent-expr op-pos)))
(if (not (eq? ref-type 'use))
(parse-error (tstate-context tstate)
"can't set an `index-of'" expr))
- (-build-index-of-operand! expr tstate in-ops)))
+ (/build-index-of-operand! expr tstate in-ops)))
; Machine generate the SKIP-CTI attribute.
((skip) (append! sem-attrs (list 'SKIP-CTI)) #f)
(case (car expr)
((operand) (if (and (eq? 'pc (obj:name (rtx-operand-obj expr)))
- (memq (-rtx-ref-type parent-expr op-pos)
+ (memq (/rtx-ref-type parent-expr op-pos)
'(set set-quiet)))
(append! sem-attrs
(if (tstate-cond? tstate)
; ***********
; cgen-desc.h
-(define (-last-insn)
+(define (/last-insn)
(string-upcase (gen-c-symbol (caar (list-take -1
(gen-obj-list-enums (non-multi-insns (current-insn-list))))))))
; Declare the attributes.
-(define (-gen-attr-decls)
+(define (/gen-attr-decls)
(string-list
"// Insn attribute indices.\n\n"
(gen-attr-enum-decl "cgen_insn" (current-insn-attr-list))
; Generate class to hold an instruction's attributes.
-(define (-gen-insn-attr-decls)
+(define (/gen-insn-attr-decls)
(let ((attrs (current-insn-attr-list)))
(string-append
"// Insn attributes.\n\n"
; Emit a macro that specifies the word-bitsize for each machine.
-(define (-gen-mach-params)
+(define (/gen-mach-params)
(string-map (lambda (mach)
(string-append
"#define MACH_" (string-upcase (gen-sym mach)) "_INSN_CHUNK_BITSIZE "
"// Enums.\n\n"
(lambda () (string-map gen-decl (current-enum-list)))
- -gen-attr-decls
- -gen-insn-attr-decls
- -gen-mach-params
+ /gen-attr-decls
+ /gen-insn-attr-decls
+ /gen-mach-params
"
} // end @arch@ namespace
; Get/set fns for hardware element HW.
-(define (-gen-reg-access-defns hw)
+(define (/gen-reg-access-defns hw)
(let ((scalar? (hw-scalar? hw))
(name (obj:name hw))
(getter (hw-getter hw))
(and (register? hw) (hw-used-in-delay-rtl? hw))
)
-; Subroutine of -gen-hardware-types to generate the struct containing
+; Subroutine of /gen-hardware-types to generate the struct containing
; hardware elements of one isa.
-(define (-gen-hardware-struct prefix hw-list)
+(define (/gen-hardware-struct prefix hw-list)
(if (null? hw-list)
; If struct is empty, leave it out to simplify generated code.
""
; Return C type declarations of all of the hardware elements.
; The name of the type is prepended with the cpu family name.
-(define (-gen-hardware-types)
+(define (/gen-hardware-types)
(string-list
"// CPU state information.\n\n"
- (-gen-hardware-struct #f (find hw-need-storage? (current-hw-list))))
+ (/gen-hardware-struct #f (find hw-need-storage? (current-hw-list))))
)
-(define (-gen-hw-stream-and-destream-fns)
+(define (/gen-hw-stream-and-destream-fns)
(let* ((sa string-append)
(regs (find hw-need-storage? (current-hw-list)))
(stack-regs (find hw-need-write-stack? (current-hw-list)))
(reg-dim (lambda (r)
- (let ((dims (-hw-vector-dims r)))
+ (let ((dims (/hw-vector-dims r)))
(if (equal? 0 (length dims))
"0"
(number->string (car dims))))))
public:
\n"
- -gen-hardware-types
+ /gen-hardware-types
- -gen-hw-stream-and-destream-fns
+ /gen-hw-stream-and-destream-fns
" // C++ register access function templates\n"
"#define current_cpu this\n\n"
(lambda ()
- (string-list-map -gen-reg-access-defns
+ (string-list-map /gen-reg-access-defns
(find register? (current-hw-list))))
"#undef current_cpu\n\n"
)
; A "cpu family" here is a collection of variants of a particular architecture
; that share sufficient commonality that they can be handled together.
-(define (-gen-cpu-defines)
+(define (/gen-cpu-defines)
(string-append
"\
/* Maximum number of instructions that are fetched at a time.
; Generate type of struct holding model state while executing.
-(define (-gen-model-decls)
+(define (/gen-model-decls)
(logit 2 "Generating model decls ...\n")
(string-list
(string-list-map
(define write-stack-memory-mode-names '())
-(define (-calculated-memory-write-buffer-size)
+(define (/calculated-memory-write-buffer-size)
(let* ((is-mem? (lambda (op) (eq? (hw-sem-name (op:type op)) 'h-memory)))
(count-mem-writes
(lambda (sfmt) (length (find is-mem? (sfmt-out-ops sfmt))))))
;; note: this doesn't really correctly approximate the worst case. user-supplied functions
;; might rewrite the pipeline extensively while it's running.
-;(define (-worst-case-number-of-writes-to hw-name)
+;(define (/worst-case-number-of-writes-to hw-name)
; (let* ((sfmts (current-sfmt-list))
; (out-ops (map sfmt-out-ops sfmts))
; (pred (lambda (op) (equal? hw-name (gen-c-symbol (obj:name (op:type op))))))
; (filtered-ops (map (lambda (ops) (find pred ops)) out-ops)))
; (apply max (cons 0 (map (lambda (ops) (length ops)) filtered-ops)))))
-(define (-hw-gen-write-stack-decl nm mode)
+(define (/hw-gen-write-stack-decl nm mode)
(let* (
; for the time being, we're disabling this size-estimation stuff and just
; requiring the user to supply a parameter WRITE_BUF_SZ before they include -defs.h
; (pipe-sz (+ 1 (max-delay (cpu-max-delay (current-cpu)))))
-; (sz (* pipe-sz (-worst-case-number-of-writes-to nm))))
+; (sz (* pipe-sz (/worst-case-number-of-writes-to nm))))
(mode-pad (spaces (- 4 (string-length (symbol->string mode)))))
(stack-name (string-append nm "_writes")))
" write_stack< write<" (symbol->string mode) "> >" mode-pad "\t" stack-name "\t[pipe_sz];\n")))
-(define (-hw-gen-write-struct-decl)
- (let* ((dims (-worst-case-index-dims))
+(define (/hw-gen-write-struct-decl)
+ (let* ((dims (/worst-case-index-dims))
(sa string-append)
(ns number->string)
(idxs (iota dims))
" write() {}\n"
" };\n" )))
-(define (-hw-vector-dims hw) (elm-get (hw-type hw) 'dimensions))
-(define (-worst-case-index-dims)
+(define (/hw-vector-dims hw) (elm-get (hw-type hw) 'dimensions))
+(define (/worst-case-index-dims)
(apply max
(append '(1) ; for memory accesses
- (map (lambda (hw) (length (-hw-vector-dims hw)))
+ (map (lambda (hw) (length (/hw-vector-dims hw)))
(find (lambda (hw) (not (scalar? hw))) (current-hw-list))))))
-(define (-gen-writestacks)
+(define (/gen-writestacks)
(let* ((hw (find hw-need-write-stack? (current-hw-list)))
(modes write-stack-memory-mode-names)
(hw-pairs (map (lambda (h) (list (gen-c-symbol (obj:name h))
"\n void reset ();"))
(zz "\n\n }; // end struct @prefix@::write_stacks \n\n"))
(string-append
- (-hw-gen-write-struct-decl)
- (foldl (lambda (s pair) (string-append s (apply -hw-gen-write-stack-decl pair))) h1 all-pairs)
+ (/hw-gen-write-struct-decl)
+ (foldl (lambda (s pair) (string-append s (apply /hw-gen-write-stack-decl pair))) h1 all-pairs)
wb
zz)))
; for use during parallel execution.
(define (gen-write-stack-structure)
- (let ((membuf-sz (-calculated-memory-write-buffer-size))
+ (let ((membuf-sz (/calculated-memory-write-buffer-size))
(max-delay (cpu-max-delay (current-cpu))))
(logit 2 "Generating write stack structure ...\n")
(string-append
"
- (-gen-writestacks)
+ (/gen-writestacks)
)))
; Generate the TRACE_RECORD struct definition.
-(define (-gen-trace-record-type)
+(define (/gen-trace-record-type)
(string-list
"\
/* Collection of various things for the trace handler to use. */
; Generate <cpu>-write.cxx.
-(define (-gen-register-writer nm mode dims)
+(define (/gen-register-writer nm mode dims)
(let* ((pad " ")
(sa string-append)
(mode (symbol->string mode))
pad " " nm "_writes[tick].pop();\n"
pad "}\n\n")))
-(define (-gen-memory-writer nm mode dims)
+(define (/gen-memory-writer nm mode dims)
(let* ((pad " ")
(sa string-append)
(mode (symbol->string mode))
pad "}\n\n")))
-(define (-gen-reset-fn)
+(define (/gen-reset-fn)
(let* ((sa string-append)
(objs (append (map (lambda (h) (gen-c-symbol (obj:name h)))
(find hw-need-write-stack? (current-hw-list)))
(string-map clr objs)
" }")))
-(define (-gen-unified-write-fn)
+(define (/gen-unified-write-fn)
(let* ((hw (find hw-need-write-stack? (current-hw-list)))
(modes write-stack-memory-mode-names)
(hw-triples (map (lambda (h) (list (gen-c-symbol (obj:name h))
(obj:name (hw-mode h))
- (length (-hw-vector-dims h))))
+ (length (/hw-vector-dims h))))
hw))
(mem-triples (map (lambda (m) (list (string-append (symbol->string m)
"_memory")
{
"
"\n // register writeback loops\n"
- (string-map (lambda (t) (apply -gen-register-writer t)) hw-triples)
+ (string-map (lambda (t) (apply /gen-register-writer t)) hw-triples)
"\n // memory writeback loops\n"
- (string-map (lambda (t) (apply -gen-memory-writer t)) mem-triples)
+ (string-map (lambda (t) (apply /gen-memory-writer t)) mem-triples)
"
}
")))
#include \"@cpu@.h\"
"
- -gen-reset-fn
- -gen-unified-write-fn
+ /gen-reset-fn
+ /gen-unified-write-fn
)
)
\f
; Return definition of C function to perform INSN.
; This version handles the with-scache case.
-(define (-gen-scache-semantic-fn insn)
+(define (/gen-scache-semantic-fn insn)
(logit 2 "Processing semantics for " (obj:name insn) ": \"" (insn-syntax insn) "\" ...\n")
- (set! -with-profile? -with-profile-fn?)
+ (set! /with-profile? /with-profile-fn?)
(let ((cti? (insn-cti? insn))
(insn-len (insn-length-bytes insn)))
(string-list
; Otherwise we know they're all written so there's no point in
; keeping track.
(if (or (with-profile?) (with-parallel-write?))
- (if (-any-cond-written? (insn-sfmt insn))
+ (if (/any-cond-written? (insn-sfmt insn))
" abuf->written = written;\n"
"")
"")
))
)
-(define (-gen-all-semantic-fns)
+(define (/gen-all-semantic-fns)
(logit 2 "Processing semantics ...\n")
(let ((insns (scache-engine-insns)))
(if (with-scache?)
- (string-write-map -gen-scache-semantic-fn insns)
+ (string-write-map /gen-scache-semantic-fn insns)
(error "must specify `with-scache'")))
)
\n"
- -gen-all-semantic-fns
+ /gen-all-semantic-fns
)
)
\f
; The semantic switch engine has two flavors: one case per insn, and one
; case per "frag" (where each insn is split into one or more fragments).
-; Utility of -gen-sem-case to return the mask of operands always written
+; Utility of /gen-sem-case to return the mask of operands always written
; to in <sformat> SFMT.
; ??? Not currently used.
-(define (-uncond-written-mask sfmt)
+(define (/uncond-written-mask sfmt)
(apply + (map (lambda (op)
(if (op:cond? op)
0
(sfmt-out-ops sfmt)))
)
-; Utility of -gen-sem-case to return #t if any operand in <sformat> SFMT is
+; Utility of /gen-sem-case to return #t if any operand in <sformat> SFMT is
; conditionally written to.
-(define (-any-cond-written? sfmt)
+(define (/any-cond-written? sfmt)
(any-true? (map op:cond? (sfmt-out-ops sfmt)))
)
\f
; Generate a switch case to perform INSN.
-(define (-gen-sem-case insn parallel?)
+(define (/gen-sem-case insn parallel?)
(logit 2 "Processing "
(if parallel? "parallel " "")
"semantic switch case for \"" (insn-syntax insn) "\" ...\n")
- (set! -with-profile? -with-profile-sw?)
+ (set! /with-profile? /with-profile-sw?)
(let ((cti? (insn-cti? insn))
(insn-len (insn-length-bytes insn)))
(string-list
; Otherwise we know they're all written so there's no point in
; keeping track.
(if (or (with-profile?) (with-parallel-write?))
- (if (-any-cond-written? (insn-sfmt insn))
+ (if (/any-cond-written? (insn-sfmt insn))
" abuf->written = written;\n"
"")
"")
))
)
-(define (-gen-sem-switch)
+(define (/gen-sem-switch)
(logit 2 "Processing semantic switch ...\n")
; Turn parallel execution support off.
(set-with-parallel?! #f)
- (string-write-map (lambda (insn) (-gen-sem-case insn #f))
+ (string-write-map (lambda (insn) (/gen-sem-case insn #f))
(non-multi-insns (non-alias-insns (current-insn-list))))
)
; reduces the amount of code, though it is believed that in this particular
; instance the win isn't big enough.
-(define (-gen-parallel-sem-switch)
+(define (/gen-parallel-sem-switch)
(logit 2 "Processing parallel insn semantic switch ...\n")
; Turn parallel execution support on.
(set-with-parallel?! #t)
(string-write-map (lambda (insn)
- (string-list (-gen-sem-case insn #t)
- (-gen-write-case (insn-sfmt insn) insn)))
+ (string-list (/gen-sem-case insn #t)
+ (/gen-write-case (insn-sfmt insn) insn)))
(parallel-insns (current-insn-list)))
)
; Return computed-goto engine.
-(define (-gen-sem-switch-engine)
+(define (/gen-sem-switch-engine)
(string-write
"\
void
@prefix@_idesc::idesc_table[labels[i].insn].cgoto.label = labels[i].label;
// confirm that table is all filled up
- for (int i = 0; i <= @PREFIX@_INSN_" (-last-insn) "; i++)
+ for (int i = 0; i <= @PREFIX@_INSN_" (/last-insn) "; i++)
assert (@prefix@_idesc::idesc_table[i].cgoto.label != 0);
// Initialize the compiler virtual insn.
{
"
- -gen-sem-switch
+ /gen-sem-switch
(if (state-parallel-exec?)
- -gen-parallel-sem-switch
+ /gen-parallel-sem-switch
"")
"
; Return declaration of frag enum.
-(define (-gen-sfrag-enum-decl frag-list)
+(define (/gen-sfrag-enum-decl frag-list)
(gen-enum-decl "@prefix@_frag_type"
"semantic fragments in cpu family @prefix@"
"@PREFIX@_FRAG_"
; Return header file decls for semantic frag threaded engine.
-(define (-gen-sfrag-engine-decls)
+(define (/gen-sfrag-engine-decls)
(string-write
"namespace @cpu@ {\n\n"
; FIXME: vector->list
- (-gen-sfrag-enum-decl (vector->list (sim-sfrag-frag-table)))
+ (/gen-sfrag-enum-decl (vector->list (sim-sfrag-frag-table)))
"\
struct @prefix@_insn_frag {
; LOCALS is a list of sequence locals made global to all frags.
; Each element is (symbol <mode> "c-var-name").
-(define (-gen-sfrag-code frag locals)
+(define (/gen-sfrag-code frag locals)
; Indicate generating code for FRAG.
; Use the compiled form if available.
; The case when they're not available is for virtual insns.
; LOCALS is a list of sequence locals made global to all frags.
; Each element is (symbol <mode> "c-var-name").
-(define (-gen-sfrag-case frag locals)
- (set! -with-profile? -with-profile-sw?)
+(define (/gen-sfrag-case frag locals)
+ (set! /with-profile? /with-profile-sw?)
(let ((cti? (sfmt-cti? (sfrag-sfmt frag)))
(parallel? (sfrag-parallel? frag)))
(logit 2 "Processing "
#:owner #f))
"")
"\n"
- (-gen-sfrag-code frag locals)
+ (/gen-sfrag-code frag locals)
"\n"
; Only update what's been written if some are conditionally written.
; Otherwise we know they're all written so there's no point in
; keeping track.
(if (or (with-profile?) (with-parallel-write?))
- (if (-any-cond-written? (sfrag-sfmt frag))
+ (if (/any-cond-written? (sfrag-sfmt frag))
" abuf->written = written;\n"
"")
"")
)
; Convert locals from form computed by sem-find-common-frags to that needed by
-; -gen-sfrag-engine-code (and ultimately rtl-c++).
+; /gen-sfrag-engine-code (and ultimately rtl-c++).
-(define (-frag-convert-c-locals locals)
+(define (/frag-convert-c-locals locals)
(map (lambda (local)
(list (car local) (mode:lookup (cadr local))
(gen-c-symbol (car local))))
; Return definition of insn frag usage table.
-(define (-gen-sfrag-engine-frag-table insn-list frag-table frag-usage)
+(define (/gen-sfrag-engine-frag-table insn-list frag-table frag-usage)
(string-write
"\
// Table of frags used by each insn.
; LOCALS is a list of sequence locals made global to all frags.
; Each element is (symbol <mode> "c-var-name").
-(define (-gen-sfrag-engine-fn frag-table locals)
+(define (/gen-sfrag-engine-fn frag-table locals)
(string-write
"\
void
// Allocate frag label table and point idesc table entries at it.
// FIXME: Temporary hack, to be redone.
static void** frag_label_table;
- int max_insns = @PREFIX@_INSN_" (-last-insn) " + 1;
+ int max_insns = @PREFIX@_INSN_" (/last-insn) " + 1;
int tabsize = max_insns * 4;
frag_label_table = new void* [tabsize];
memset (frag_label_table, 0, sizeof (void*) * tabsize);
; ??? Still needed?
(set-with-parallel?! #f)
(string-write-map (lambda (frag)
- (-gen-sfrag-case frag locals))
+ (/gen-sfrag-case frag locals))
; FIXME: vector->list
(vector->list frag-table)))
\n")
)
-(define (-gen-sfrag-engine)
+(define (/gen-sfrag-engine)
(string-write
(lambda ()
- (-gen-sfrag-engine-frag-table (sim-sfrag-insn-list)
+ (/gen-sfrag-engine-frag-table (sim-sfrag-insn-list)
(sim-sfrag-frag-table)
(sim-sfrag-usage-table)))
(lambda ()
- (-gen-sfrag-engine-fn (sim-sfrag-frag-table)
- (-frag-convert-c-locals (sim-sfrag-locals-list))))
+ (/gen-sfrag-engine-fn (sim-sfrag-frag-table)
+ (/frag-convert-c-locals (sim-sfrag-locals-list))))
)
)
\f
\n"
(if (with-sem-frags?)
- -gen-sfrag-engine-decls
+ /gen-sfrag-engine-decls
"")
(if (with-sem-frags?)
- -gen-sfrag-engine
- -gen-sem-switch-engine)
+ /gen-sfrag-engine
+ /gen-sem-switch-engine)
)
)
; big array. It doesn't matter too much (yet). Generating one big array is
; simpler.
-(define (-gen-decode-insn-globals insn-list)
+(define (/gen-decode-insn-globals insn-list)
; Print the higher detailed stuff at higher verbosity.
(logit 2 "Processing decode insn globals ...\n")
(if (with-scache?)
(if pbb?
"0, "
- (string-append (-gen-sem-fn-name insn) ", "))
+ (string-append (/gen-sem-fn-name insn) ", "))
"")
"\"" (string-upcase name) "\", "
(gen-cpu-insn-enum (current-cpu) insn)
; Return a function that lookups up virtual insns.
-(define (-gen-virtual-insn-finder)
+(define (/gen-virtual-insn-finder)
(string-list
"\
// Given a canonical virtual insn id, return the target specific one.
\f
; Return enum name of format FMT.
-(define (-gen-fmt-enum fmt)
+(define (/gen-fmt-enum fmt)
(string-upcase (gen-sym fmt))
)
; Return names of semantic fns for INSN.
; ??? Make global, call from gen-semantic-fn, blah blah blah.
-(define (-gen-sem-fn-name insn)
+(define (/gen-sem-fn-name insn)
(string-append "@prefix@_sem_" (gen-sym insn))
)
; Return decls of each semantic fn.
-(define (-gen-sem-fn-decls)
+(define (/gen-sem-fn-decls)
(string-write
"// Decls of each semantic fn.\n\n"
"using @cpu@::@prefix@_sem_fn;\n"
(string-list-map (lambda (insn)
(string-list "extern @prefix@_sem_fn "
- (-gen-sem-fn-name insn)
+ (/gen-sem-fn-name insn)
";\n"))
(scache-engine-insns))
"\n"
; Generate decls for the insn descriptor table type IDESC.
-(define (-gen-idesc-decls)
+(define (/gen-idesc-decls)
(string-append
"
// Forward decls.
")
)
-; Utility of -gen-argbuf-fields-union to generate the definition for
+; Utility of /gen-argbuf-fields-union to generate the definition for
; <sformat-abuf> SBUF.
-(define (-gen-argbuf-elm sbuf)
+(define (/gen-argbuf-elm sbuf)
(logit 2 "Processing sbuf format " (obj:name sbuf) " ...\n")
(string-list
" struct { /* " (obj:comment sbuf) " */\n"
" } " (gen-sym sbuf) ";\n")
)
-; Utility of -gen-scache-decls to generate the union of extracted ifields.
+; Utility of /gen-scache-decls to generate the union of extracted ifields.
-(define (-gen-argbuf-fields-union)
+(define (/gen-argbuf-fields-union)
(string-list
"\
// Instruction argument buffer.
union @prefix@_sem_fields {\n"
- (string-list-map -gen-argbuf-elm (current-sbuf-list))
+ (string-list-map /gen-argbuf-elm (current-sbuf-list))
"\
// This one is for chain/cti-chain virtual insns.
struct {
)
)
-(define (-gen-scache-decls)
+(define (/gen-scache-decls)
(string-list
- (-gen-argbuf-fields-union)
+ (/gen-argbuf-fields-union)
"\
// Simulator instruction cache.
; Return C code to record <ifield> F for the semantic handler
; in a local variable rather than an ARGBUF struct.
-(define (-gen-record-argbuf-ifld f sfmt)
+(define (/gen-record-argbuf-ifld f sfmt)
(string-append " " (gen-ifld-argbuf-ref f)
" = " (gen-extracted-ifld-value f) ";\n")
)
; string argument to fprintf, character indicating type of third arg, value.
; The type is one of: x.
-(define (-gen-trace-argbuf-ifld f sfmt)
+(define (/gen-trace-argbuf-ifld f sfmt)
(string-append
; FIXME: Add method to return fprintf format string.
", \"" (gen-sym f) " 0x%x\""
; the ARGBUF struct.
; ??? Later allow target to provide an `extract' expression.
-(define (-gen-op-extract op sfmt local?)
+(define (/gen-op-extract op sfmt local?)
(send (op:type op) 'gen-extract op sfmt local?)
)
; string argument to fprintf, character indicating type of third arg, value.
; The type is one of: x.
-(define (-gen-op-trace-extract op sfmt)
+(define (/gen-op-trace-extract op sfmt)
(send (op:type op) 'gen-trace-extract op sfmt)
)
(define (gen-sfmt-op-argbuf-assigns sfmt)
(let ((operands (sfmt-extracted-operands sfmt)))
(string-list-map (lambda (op)
- (-gen-op-extract op sfmt #t))
+ (/gen-op-extract op sfmt #t))
operands))
)
\f
; Return C code to record insn field data for <sformat> SFMT.
; This is used when with-scache.
-(define (-gen-record-args sfmt)
+(define (/gen-record-args sfmt)
(let ((operands (sfmt-extracted-operands sfmt))
(iflds (sfmt-needed-iflds sfmt)))
(string-list
" /* Record the fields for the semantic handler. */\n"
- (string-list-map (lambda (f) (-gen-record-argbuf-ifld f sfmt))
+ (string-list-map (lambda (f) (/gen-record-argbuf-ifld f sfmt))
iflds)
- (string-list-map (lambda (op) (-gen-op-extract op sfmt #f))
+ (string-list-map (lambda (op) (/gen-op-extract op sfmt #f))
operands)
" if (UNLIKELY(current_cpu->trace_extract_p))\n"
" {\n"
; is kept to the extraction phase. If someone wants to put forth some real
; data, this might then be changed (or at least noted).
-(define (-gen-record-profile-args sfmt)
+(define (/gen-record-profile-args sfmt)
(let ((in-ops (find op-profilable? (sfmt-in-ops sfmt)))
(out-ops (find op-profilable? (sfmt-out-ops sfmt)))
)
; by the semantic code. This is currently done by recording this information
; with the format.
-(define (-gen-extract-fn sfmt)
+(define (/gen-extract-fn sfmt)
(logit 2 "Processing extractor for \"" (sfmt-key sfmt) "\" ...\n")
(string-list
"void
"\n"
(gen-extract-ifields (sfmt-iflds sfmt) (sfmt-length sfmt) " " #f)
"\n"
- (-gen-record-args sfmt)
+ (/gen-record-args sfmt)
"\n"
- (-gen-record-profile-args sfmt)
+ (/gen-record-profile-args sfmt)
(gen-undef-field-macro sfmt)
"}\n\n"
)
; For each format, return its extraction function.
-(define (-define-all-extractor-fns)
+(define (/define-all-extractor-fns)
(logit 2 "Processing extractor fn bodies ...\n")
- (string-list-map -gen-extract-fn (current-sfmt-list))
+ (string-list-map /gen-extract-fn (current-sfmt-list))
)
-(define (-declare-all-extractor-fns)
+(define (/declare-all-extractor-fns)
(logit 2 "Processing extractor fn declarations ...\n")
(string-map (lambda (sfmt)
(string-append "
; ourselves.
; LSB0? is non-#f if bit number 0 is the least significant bit.
-(define (-gen-decode-fn insn-list initial-bitnums lsb0?)
+(define (/gen-decode-fn insn-list initial-bitnums lsb0?)
(assert (with-scache?))
; Compute the initial DECODE-BITSIZE as the minimum of all insn lengths.
"
// Declare extractor functions
"
- -declare-all-extractor-fns
+ /declare-all-extractor-fns
"
"
- -define-all-extractor-fns
+ /define-all-extractor-fns
)))
)
\f
"
(lambda () (gen-cpu-insn-enum-decl (current-cpu)
(non-multi-insns (non-alias-insns (current-insn-list)))))
- -gen-idesc-decls
- -gen-scache-decls
+ /gen-idesc-decls
+ /gen-scache-decls
"\
} // end @cpu@ namespace
; ??? The semantic functions could go in the cpu's namespace.
; There's no pressing need for it though.
(if (with-scache?)
- -gen-sem-fn-decls
+ /gen-sem-fn-decls
"")
"\
using namespace @cpu@; // FIXME: namespace organization still wip
\n"
- (lambda () (-gen-decode-insn-globals (non-multi-insns (non-alias-insns (current-insn-list)))))
- -gen-virtual-insn-finder
- (lambda () (-gen-decode-fn (non-multi-insns (real-insns (current-insn-list)))
+ (lambda () (/gen-decode-insn-globals (non-multi-insns (non-alias-insns (current-insn-list)))))
+ /gen-virtual-insn-finder
+ (lambda () (/gen-decode-fn (non-multi-insns (real-insns (current-insn-list)))
(state-decode-assist)
(current-arch-insn-lsb0?)))
)
; Return C code to define cpu implementation properties.
-(define (-gen-cpu-imp-properties)
+(define (/gen-cpu-imp-properties)
(string-list
"\
/* The properties of this cpu's implementation. */
; Generate code to profile hardware elements.
; ??? Not currently used.
-(define (-gen-hw-profile-code)
+(define (/gen-hw-profile-code)
; Fetch profilable input and output operands of the semantic code.
(let ((in-ops (find op-profilable? (sfmt-in-ops (insn-sfmt insn))))
(out-ops (find op-profilable? (sfmt-out-ops (insn-sfmt insn)))))
; Return decls of hardware element profilers.
; ??? Not currently used.
-(define (-gen-hw-profile-decls)
+(define (/gen-hw-profile-decls)
(string-list
"/* Hardware profiling handlers. */\n\n"
(string-list-map (lambda (hw)
; Return name of profile handler for INSN, MODEL.
-(define (-gen-model-insn-fn-name model insn when)
+(define (/gen-model-insn-fn-name model insn when)
(string-append "model_" (gen-sym insn) "_" (symbol->string when))
)
-(define (-gen-model-insn-qualified-fn-name model insn when)
- (string-append (gen-model-class-name model) "::" (-gen-model-insn-fn-name model insn when))
+(define (/gen-model-insn-qualified-fn-name model insn when)
+ (string-append (gen-model-class-name model) "::" (/gen-model-insn-fn-name model insn when))
)
; Return declaration of function to model INSN.
-(define (-gen-model-insn-fn-decl model insn when)
+(define (/gen-model-insn-fn-decl model insn when)
(string-list
"UINT "
- (-gen-model-insn-fn-name model insn when)
+ (/gen-model-insn-fn-name model insn when)
" (@cpu@_cpu *current_cpu, @prefix@_scache *sem);\n"
)
)
-(define (-gen-model-insn-fn-decls model)
+(define (/gen-model-insn-fn-decls model)
(string-list
" // These methods call the appropriate unit modeller(s) for each insn.\n"
(string-list-map
(lambda (insn)
(string-list
- " " (-gen-model-insn-fn-decl model insn 'before)
- " " (-gen-model-insn-fn-decl model insn 'after)))
+ " " (/gen-model-insn-fn-decl model insn 'before)
+ " " (/gen-model-insn-fn-decl model insn 'after)))
(non-multi-insns (real-insns (current-insn-list))))
)
)
; Return function to model INSN.
-(define (-gen-model-insn-fn model insn when)
+(define (/gen-model-insn-fn model insn when)
(logit 2 "Processing modeling for " (obj:name insn) ": \"" (insn-syntax insn) "\" ...\n")
(let ((sfmt (insn-sfmt insn)))
(string-list
"UINT\n"
- (-gen-model-insn-qualified-fn-name model insn when)
+ (/gen-model-insn-qualified-fn-name model insn when)
" (@cpu@_cpu *current_cpu, @prefix@_scache *sem)\n"
"{\n"
(if (with-scache?)
; ??? Modelling of insns could be table driven, but that puts constraints on
; generality.
-(define (-gen-model-insn-fns)
+(define (/gen-model-insn-fns)
(string-write
"/* Model handlers for each insn. */\n\n"
(lambda () (string-write-map
(string-write-map
(lambda (insn)
(string-list
- (-gen-model-insn-fn model insn 'before)
- (-gen-model-insn-fn model insn 'after)))
+ (/gen-model-insn-fn model insn 'before)
+ (/gen-model-insn-fn model insn 'after)))
(non-multi-insns (real-insns (current-insn-list)))))
(current-model-list)))
)
)
-(define (-gen-model-class-decls model)
+(define (/gen-model-class-decls model)
(string-append
"\n"
" "
protected:
"
- (-gen-model-insn-fn-decls model)
- (-gen-model-class-decls model)
+ (/gen-model-insn-fn-decls model)
+ (/gen-model-class-decls model)
"\
typedef UINT (" (gen-model-class-name model) "::*model_function) (@cpu@_cpu* current_cpu, @prefix@_scache* sem);
; U is a <unit> object.
; ARGS is a list of overriding arguments from INSN.
-(define (-gen-insn-unit-timing model insn u args)
+(define (/gen-insn-unit-timing model insn u args)
(string-append
"{ "
(gen-model-class-name model) "::" (unit:enum u) ", "
; Generate timing table entry for MODEL for INSN.
-(define (-gen-insn-timing model insn)
+(define (/gen-insn-timing model insn)
; Instruction timing is stored as an associative list based on the model.
(let ((timing (assq (obj:name model) (insn-timing insn))))
;(display timing) (newline)
(if (obj-has-attr? insn 'VIRTUAL)
"0, 0"
(string-append
- "& " (-gen-model-insn-qualified-fn-name model insn 'before) ", "
- "& " (-gen-model-insn-qualified-fn-name model insn 'after)))
+ "& " (/gen-model-insn-qualified-fn-name model insn 'before) ", "
+ "& " (/gen-model-insn-qualified-fn-name model insn 'after)))
", { "
(string-drop
-2
(if (not timing)
- (-gen-insn-unit-timing model insn (model-default-unit model) nil)
+ (/gen-insn-unit-timing model insn (model-default-unit model) nil)
(let ((units (timing:units (cdr timing))))
(string-map (lambda (iunit)
- (-gen-insn-unit-timing model insn
+ (/gen-insn-unit-timing model insn
(iunit:unit iunit)
(iunit:args iunit)))
units))))
; Generate model timing table for MODEL.
-(define (-gen-model-timing-table model)
+(define (/gen-model-timing-table model)
(string-write
"/* Model timing data for `" (obj:name model) "'. */\n\n"
"const " (gen-model-class-name model) "::insn_timing " (gen-model-class-name model) "::timing[] = {\n"
- (lambda () (string-write-map (lambda (insn) (-gen-insn-timing model insn))
+ (lambda () (string-write-map (lambda (insn) (/gen-insn-timing model insn))
(non-multi-insns (non-alias-insns (current-insn-list)))))
"};\n\n"
)
; Return C code to define model profiling support stuff.
-(define (-gen-model-profile-data)
+(define (/gen-model-profile-data)
(string-write
"/* We assume UNIT_NONE == 0 because the tables don't always terminate\n"
" entries with it. */\n\n"
- (lambda () (string-write-map -gen-model-timing-table (current-model-list)))
+ (lambda () (string-write-map /gen-model-timing-table (current-model-list)))
)
)
; Return C code to define the model table for MACH.
-(define (-gen-mach-model-table mach)
+(define (/gen-mach-model-table mach)
(string-list
"\
static const MODEL " (gen-sym mach) "_models[] =\n{\n"
; Return C code to define model init fn.
-(define (-gen-model-init-fn model)
+(define (/gen-model-init-fn model)
(string-list "\
static void\n"
(gen-sym model) "_model_init (@cpu@_cpu *cpu)
; Return C code to define model data and support fns.
-(define (-gen-model-defns)
+(define (/gen-model-defns)
(string-write
- (lambda () (string-write-map -gen-model-init-fn (current-model-list)))
+ (lambda () (string-write-map /gen-model-init-fn (current-model-list)))
"#if WITH_PROFILE_MODEL_P
#define TIMING_DATA(td) td
#else
#define TIMING_DATA(td) 0
#endif\n\n"
- (lambda () (string-write-map -gen-mach-model-table (current-mach-list)))
+ (lambda () (string-write-map /gen-mach-model-table (current-mach-list)))
)
)
; Return C definitions for this cpu family variant.
-(define (-gen-cpu-defns)
+(define (/gen-cpu-defns)
""
)
; Return C code to define the machine data.
-(define (-gen-mach-defns)
+(define (/gen-mach-defns)
(string-list-map
(lambda (mach)
(gen-obj-sanitize
mechanism. After all, this is information for profiling. */
"
- -gen-model-insn-fns
- -gen-model-profile-data
+ /gen-model-insn-fns
+ /gen-model-profile-data
; not adapted for sid yet
-; -gen-model-defns
-; -gen-cpu-imp-properties
-; -gen-cpu-defns
-; -gen-mach-defns
+; /gen-model-defns
+; /gen-cpu-imp-properties
+; /gen-cpu-defns
+; /gen-mach-defns
)
)
; indicate the software package
; #t if the scache is being used
-(define -with-scache? #f)
-(define (with-scache?) -with-scache?)
+(define /with-scache? #f)
+(define (with-scache?) /with-scache?)
; #t if we're generating profiling code
; Each of the function and switch semantic code can have profiling.
-; The options as passed are stored in -with-profile-{fn,sw}?, and
-; -with-profile? is set at code generation time.
-(define -with-profile-fn? #f)
-(define -with-profile-sw? #f)
-(define -with-profile? #f)
-(define (with-profile?) -with-profile?)
-(define (with-any-profile?) (or -with-profile-fn? -with-profile-sw?))
+; The options as passed are stored in /with-profile-{fn,sw}?, and
+; /with-profile? is set at code generation time.
+(define /with-profile-fn? #f)
+(define /with-profile-sw? #f)
+(define /with-profile? #f)
+(define (with-profile?) /with-profile?)
+(define (with-any-profile?) (or /with-profile-fn? /with-profile-sw?))
; #t if multiple isa support is enabled
-(define -with-multiple-isa? #f)
-(define (with-multiple-isa?) -with-multiple-isa?)
+(define /with-multiple-isa? #f)
+(define (with-multiple-isa?) /with-multiple-isa?)
; #t if semantics are generated as pbb computed-goto engine
-(define -with-pbb? #f)
-(define (with-pbb?) -with-pbb?)
+(define /with-pbb? #f)
+(define (with-pbb?) /with-pbb?)
; #t if the semantic fragment engine is to be used.
; This involves combining common fragments of each insn into one.
-(define -with-sem-frags? #f)
-(define (with-sem-frags?) -with-sem-frags?)
+(define /with-sem-frags? #f)
+(define (with-sem-frags?) /with-sem-frags?)
; String containing copyright text.
(define CURRENT-COPYRIGHT #f)
; Initialize the options.
(define (option-init!)
- (set! -with-scache? #f)
- (set! -with-pbb? #f)
- (set! -with-sem-frags? #f)
- (set! -with-profile-fn? #f)
- (set! -with-profile-sw? #f)
- (set! -with-multiple-isa? #f)
+ (set! /with-scache? #f)
+ (set! /with-pbb? #f)
+ (set! /with-sem-frags? #f)
+ (set! /with-profile-fn? #f)
+ (set! /with-profile-sw? #f)
+ (set! /with-multiple-isa? #f)
(set! CURRENT-COPYRIGHT copyright-fsf)
(set! CURRENT-PACKAGE package-gnu-simulators)
*UNSPECIFIED*
(define (option-set! name value)
(case name
- ((with-scache) (set! -with-scache? #t))
- ((with-pbb) (set! -with-pbb? #t))
- ((with-sem-frags) (set! -with-sem-frags? #t))
+ ((with-scache) (set! /with-scache? #t))
+ ((with-pbb) (set! /with-pbb? #t))
+ ((with-sem-frags) (set! /with-sem-frags? #t))
((with-profile) (cond ((equal? value '("fn"))
- (set! -with-profile-fn? #t))
+ (set! /with-profile-fn? #t))
((equal? value '("sw"))
- (set! -with-profile-sw? #t))
+ (set! /with-profile-sw? #t))
(else (error "invalid with-profile value" value))))
- ((with-multiple-isa) (set! -with-multiple-isa? #t))
+ ((with-multiple-isa) (set! /with-multiple-isa? #t))
((copyright) (cond ((equal? value '("fsf"))
(set! CURRENT-COPYRIGHT copyright-fsf))
((equal? value '("redhat"))
)
; #t if we're currently generating a pbb engine.
-(define -current-pbb-engine? #f)
-(define (current-pbb-engine?) -current-pbb-engine?)
-(define (set-current-pbb-engine?! flag) (set! -current-pbb-engine? flag))
+(define /current-pbb-engine? #f)
+(define (current-pbb-engine?) /current-pbb-engine?)
+(define (set-current-pbb-engine?! flag) (set! /current-pbb-engine? flag))
; #t if the cpu can execute insns parallely.
; This one isn't passed on the command line, but we follow the convention
; While processing operand reading (or writing), parallel execution support
; needs to be turned off, so it is up to the appropriate cgen-foo.c proc to
; set-with-parallel?! appropriately.
-(define -with-parallel? #f)
-(define (with-parallel?) -with-parallel?)
-(define (set-with-parallel?! flag) (set! -with-parallel? flag))
+(define /with-parallel? #f)
+(define (with-parallel?) /with-parallel?)
+(define (set-with-parallel?! flag) (set! /with-parallel? flag))
; Kind of parallel support.
; If 'read, read pre-processing is done.
; ??? At present we always use write post-processing, though the previous
; version used read pre-processing. Not sure supporting both is useful
; in the long run.
-(define -with-parallel-kind 'write)
+(define /with-parallel-kind 'write)
; #t if parallel support is provided by read pre-processing.
(define (with-parallel-read?)
- (and -with-parallel? (eq? -with-parallel-kind 'read))
+ (and /with-parallel? (eq? /with-parallel-kind 'read))
)
; #t if parallel support is provided by write post-processing.
(define (with-parallel-write?)
- (and -with-parallel? (eq? -with-parallel-kind 'write))
+ (and /with-parallel? (eq? /with-parallel-kind 'write))
)
\f
; Cover functions for various methods.
; Return a <c-expr> object of the value of an ifield.
-(define (-cxmake-ifld-val mode f)
+(define (/cxmake-ifld-val mode f)
(if (with-scache?)
; ??? Perhaps a better way would be to defer evaluating the src of a
; set until the method processing the dest.
(lambda (self sym index estate)
(let ((gen-index1 (lambda (idx)
(string-append "["
- (-gen-hw-index idx estate)
+ (/gen-hw-index idx estate)
"]"))))
(string-append sym
(cond ((list? index) (string-map gen-index1 index))
(lambda (self estate mode index selector)
;(if (not (eq? 'ifield (hw-index:type index)))
; (error "not an ifield hw-index" index))
- (-cxmake-ifld-val mode (hw-index:value index)))
+ (/cxmake-ifld-val mode (hw-index:value index)))
)
\f
; PC support
; of rtx: that takes a variable number of named arguments.
; ??? Another way to get #:direct might be (raw-reg h-pc).
-(define (-hw-gen-set-quiet-pc self estate mode index selector newval . options)
+(define (/hw-gen-set-quiet-pc self estate mode index selector newval . options)
(if (not (send self 'pc?)) (error "Not a PC:" self))
(cond ((memq #:direct options)
- (-hw-gen-set-quiet self estate mode index selector newval))
+ (/hw-gen-set-quiet self estate mode index selector newval))
((current-pbb-engine?)
(string-append "npc = " (cx:c newval) ";"
(if (obj-has-attr? newval 'CACHED)
(string-append "current_cpu->branch (" (cx:c newval) ", npc, status);\n")))
)
-(method-make! <hw-pc> 'gen-set-quiet -hw-gen-set-quiet-pc)
+(method-make! <hw-pc> 'gen-set-quiet /hw-gen-set-quiet-pc)
; Handle updates of the pc during parallel execution.
; This is done in a post-processing pass after semantic evaluation.
<hw-register> 'gen-record-profile
(lambda (self index sfmt estate)
; FIXME: Need to handle scalars.
- (-gen-hw-index-raw index estate)
+ (/gen-hw-index-raw index estate)
;(send index 'gen-extracted-field-value)
)
)
; Utilities to generate register accesses via cover functions.
-(define (-hw-gen-fun-get reg estate mode index)
+(define (/hw-gen-fun-get reg estate mode index)
(let ((scalar? (hw-scalar? reg))
- (c-index (-gen-hw-index index estate)))
+ (c-index (/gen-hw-index index estate)))
(string-append "current_cpu->"
(gen-reg-get-fun-name reg)
" ("
")"))
)
-(define (-hw-gen-fun-set reg estate mode index newval)
+(define (/hw-gen-fun-set reg estate mode index newval)
(let ((scalar? (hw-scalar? reg))
- (c-index (-gen-hw-index index estate)))
+ (c-index (/gen-hw-index index estate)))
(string-append "current_cpu->"
(gen-reg-set-fun-name reg)
" ("
; Utility to build a <c-expr> object to fetch the value of a register.
-(define (-hw-cxmake-get hw estate mode index selector)
+(define (/hw-cxmake-get hw estate mode index selector)
(let ((mode (if (mode:eq? 'DFLT mode)
(send hw 'get-mode)
mode)))
(cx:make mode
(cond ((or (hw-getter hw)
(obj-has-attr? hw 'FUN-GET))
- (-hw-gen-fun-get hw estate mode index))
+ (/hw-gen-fun-get hw estate mode index))
((and (hw-cache-addr? hw) ; FIXME: redo test
(eq? 'ifield (hw-index:type index)))
(string-append
(gen-sym hw) index estate))))))
)
-(method-make! <hw-register> 'cxmake-get -hw-cxmake-get)
+(method-make! <hw-register> 'cxmake-get /hw-cxmake-get)
; raw-reg: support
; ??? raw-reg: support is wip
; Utilities to generate C code to assign a variable to a register.
-(define (-hw-gen-set-quiet hw estate mode index selector newval)
+(define (/hw-gen-set-quiet hw estate mode index selector newval)
(cond ((or (hw-setter hw)
(obj-has-attr? hw 'FUN-SET))
- (-hw-gen-fun-set hw estate mode index newval))
+ (/hw-gen-fun-set hw estate mode index newval))
((and (hw-cache-addr? hw) ; FIXME: redo test
(eq? 'ifield (hw-index:type index)))
(string-append "* "
" = " (cx:c newval) ";\n")))
)
-(method-make! <hw-register> 'gen-set-quiet -hw-gen-set-quiet)
+(method-make! <hw-register> 'gen-set-quiet /hw-gen-set-quiet)
; raw-reg: support
; ??? wip
(if default-selector? "" "ASI")
" ("
"pc, "
- (-gen-hw-index index estate)
+ (/gen-hw-index index estate)
(if default-selector?
""
(string-append ", "
- (-gen-hw-selector selector)))
+ (/gen-hw-selector selector)))
")"))))
)
(if default-selector? "" "ASI")
" ("
"pc, "
- (-gen-hw-index index estate)
+ (/gen-hw-index index estate)
(if default-selector?
""
(string-append ", "
- (-gen-hw-selector selector)))
+ (/gen-hw-selector selector)))
", " (cx:c newval) ");\n")))
)
(let ((index-mode (send hw 'get-index-mode)))
(if index-mode
(make <hw-index> 'anonymous 'str-expr index-mode
- (string-append access-macro " (" (-op-index-name op) ")"))
+ (string-append access-macro " (" (/op-index-name op) ")"))
(hw-index-scalar)))))
)
; Return the name of the PAREXEC structure member holding a hardware index
; for operand OP.
-(define (-op-index-name op)
+(define (/op-index-name op)
(string-append (gen-sym op) "_idx")
)
; The result is a string of C code.
; FIXME:wip
-(define (-gen-hw-index-raw index estate)
+(define (/gen-hw-index-raw index estate)
(let ((type (hw-index:type index))
(mode (hw-index:mode index))
(value (hw-index:value index)))
(gen-extracted-ifld-value value)))
((operand) (cx:c (send value 'cxmake-get estate mode (op:index value)
(op:selector value) #f)))
- (else (error "-gen-hw-index-raw: invalid index:" index))))
+ (else (error "/gen-hw-index-raw: invalid index:" index))))
)
-; Same as -gen-hw-index-raw except used where speedups are possible.
+; Same as /gen-hw-index-raw except used where speedups are possible.
; e.g. doing array index calcs at extraction time.
-(define (-gen-hw-index index estate)
+(define (/gen-hw-index index estate)
(let ((type (hw-index:type index))
(mode (hw-index:mode index))
(value (hw-index:value index)))
((rtx) (rtl-c-with-estate estate mode value))
((ifield) (if (= (ifld-length value) 0)
""
- (cx:c (-cxmake-ifld-val mode value))))
+ (cx:c (/cxmake-ifld-val mode value))))
((operand) (cx:c (send value 'cxmake-get estate mode (op:index value)
(op:selector value))))
- (else (error "-gen-hw-index: invalid index:" index))))
+ (else (error "/gen-hw-index: invalid index:" index))))
)
; Return a <c-expr> object of the value of a hardware index.
(obj-cons-attr! xmode (bool-attr-make 'FORCE-C #t))
xmode)
mode)
- (-gen-hw-index self estate))))
+ (/gen-hw-index self estate))))
)
\f
; Hardware selector support code.
; Generate C code for SEL.
-(define (-gen-hw-selector sel)
+(define (/gen-hw-selector sel)
(rtl-c++ 'INT sel nil)
)
\f
mode))
(hw (op:type self))
(index (if index index (op:index self)))
- (idx (if index (-gen-hw-index index estate) ""))
+ (idx (if index (/gen-hw-index index estate) ""))
(idx-args (if (equal? idx "") "" (string-append ", " idx)))
(selector (if selector selector (op:selector self)))
(delayval (op:delay self))
; Utilities to implement gen-set-quiet/gen-set-trace.
-(define (-op-gen-set-quiet op estate mode index selector newval)
+(define (/op-gen-set-quiet op estate mode index selector newval)
(send (op:type op) 'gen-set-quiet estate mode index selector newval)
)
-(define (-op-gen-delayed-set-quiet op estate mode index selector newval)
- (-op-gen-delayed-set-maybe-trace op estate mode index selector newval #f))
+(define (/op-gen-delayed-set-quiet op estate mode index selector newval)
+ (/op-gen-delayed-set-maybe-trace op estate mode index selector newval #f))
-(define (-op-gen-set-trace op estate mode index selector newval)
+(define (/op-gen-set-trace op estate mode index selector newval)
(string-append
" {\n"
" " (mode:c-type mode) " opval = " (cx:c newval) ";\n"
(if (string=? (send op 'gen-pretty-name mode) "\"memory\"")
" \"0x\" << hex << (UDI) "
"")
- (-gen-hw-index index estate)
+ (/gen-hw-index index estate)
(if (string=? (send op 'gen-pretty-name mode) "\"memory\"")
" << dec"
"")
" }\n")
)
-(define (-op-gen-delayed-set-trace op estate mode index selector newval)
- (-op-gen-delayed-set-maybe-trace op estate mode index selector newval #t))
+(define (/op-gen-delayed-set-trace op estate mode index selector newval)
+ (/op-gen-delayed-set-maybe-trace op estate mode index selector newval #t))
-(define (-op-gen-delayed-set-maybe-trace op estate mode index selector newval do-trace?)
+(define (/op-gen-delayed-set-maybe-trace op estate mode index selector newval do-trace?)
(let* ((pad " ")
(hw (op:type op))
(delayval (op:delay op))
(string-append md "_memory")
(gen-c-symbol (obj:name hw))))
(val (cx:c newval))
- (idx (if index (-gen-hw-index index estate) ""))
+ (idx (if index (/gen-hw-index index estate) ""))
(idx-args (if (equal? idx "") "" (string-append ", " idx)))
)
") % @prefix@::pipe_sz].push (@prefix@::write<" md ">(pc, opval" idx-args "));\n")
;; else, uh, we should never have been called!
- (error "-op-gen-delayed-set-maybe-trace called on non-delayed operand"))
+ (error "/op-gen-delayed-set-maybe-trace called on non-delayed operand"))
(if do-trace?
(if (string=? (send op 'gen-pretty-name mode) "\"memory\"")
" \"0x\" << hex << (UDI) "
"")
- (-gen-hw-index index estate)
+ (/gen-hw-index index estate)
(if (string=? (send op 'gen-pretty-name mode) "\"memory\"")
" << dec"
"")
(cond ((obj-has-attr? self 'RAW)
(send (op:type self) 'gen-set-quiet-raw estate mode index selector newval))
((op:delay self)
- (-op-gen-delayed-set-quiet self estate mode index selector newval))
+ (/op-gen-delayed-set-quiet self estate mode index selector newval))
(else
- (-op-gen-set-quiet self estate mode index selector newval)))))
+ (/op-gen-set-quiet self estate mode index selector newval)))))
)
; Return C code to set the value of an operand and print TRACE_RESULT message.
(cond ((obj-has-attr? self 'RAW)
(send (op:type self) 'gen-set-quiet-raw estate mode index selector newval))
((op:delay self)
- (-op-gen-delayed-set-trace self estate mode index selector newval))
+ (/op-gen-delayed-set-trace self estate mode index selector newval))
(else
- (-op-gen-set-trace self estate mode index selector newval)))))
+ (/op-gen-set-trace self estate mode index selector newval)))))
)
\f
; Return C code to declare the machine data.
-(define (-gen-mach-decls)
+(define (/gen-mach-decls)
(string-append
(string-map (lambda (mach)
(gen-obj-sanitize mach
; Return C code to define the machine data.
-(define (-gen-mach-data)
+(define (/gen-mach-data)
(string-append
"const MACH *sim_machs[] =\n{\n"
(string-map (lambda (mach)
; Return C declarations of cpu model support stuff.
; ??? This goes in arch.h but a better place is each cpu.h.
-(define (-gen-arch-model-decls)
+(define (/gen-arch-model-decls)
(string-append
(gen-enum-decl 'model_type "model types"
"MODEL_"
(non-multi-insns (real-insns (current-insn-list)))
)
-;; Subroutine of -create-virtual-insns!.
+;; Subroutine of /create-virtual-insns!.
;; Add virtual insn INSN to the database.
;; We put virtual insns ahead of normal insns because they're kind of special,
;; and it helps to see them first in lists.
;; ORDINAL is a used to place the insn ahead of normal insns;
;; it is a pair so we can do the update for the next virtual insn here.
-(define (-virtual-insn-add! ordinal insn)
+(define (/virtual-insn-add! ordinal insn)
(obj-set-ordinal! insn (cdr ordinal))
(current-insn-add! insn)
(set-cdr! ordinal (- (cdr ordinal) 1))
; Create the virtual insns.
-(define (-create-virtual-insns! isa)
+(define (/create-virtual-insns! isa)
(let ((isa-name (obj:name isa))
(context (make-prefix-context "virtual insns"))
- ;; Record as a pair so -virtual-insn-add! can update it.
+ ;; Record as a pair so /virtual-insn-add! can update it.
(ordinal (cons #f -1)))
- (-virtual-insn-add!
+ (/virtual-insn-add!
ordinal
(insn-read context
'(name x-invalid)
(if (with-pbb?)
(begin
- (-virtual-insn-add!
+ (/virtual-insn-add!
ordinal
(insn-read context
'(name x-begin)
"))
))
- (-virtual-insn-add!
+ (/virtual-insn-add!
ordinal
(insn-read context
'(name x-chain)
"))
))
- (-virtual-insn-add!
+ (/virtual-insn-add!
ordinal
(insn-read context
'(name x-cti-chain)
"))
))
- (-virtual-insn-add!
+ (/virtual-insn-add!
ordinal
(insn-read context
'(name x-before)
"))
))
- (-virtual-insn-add!
+ (/virtual-insn-add!
ordinal
(insn-read context
'(name x-after)
; insn to handle that.
(if (and (with-pbb?)
(isa-conditional-exec? isa))
- (-virtual-insn-add!
+ (/virtual-insn-add!
ordinal
(insn-read context
'(name x-cond)
; Return a boolean indicating if INSN should be split.
-(define (-decode-split-insn? insn isa)
+(define (/decode-split-insn? insn isa)
(let loop ((split-specs (isa-decode-splits isa)))
(cond ((null? split-specs)
#f)
(else (loop (cdr split-specs)))))
)
-; Subroutine of -decode-split-insn-1.
+; Subroutine of /decode-split-insn-1.
; Build the ifield-assertion for ifield F-NAME.
; VALUE is either a number or a non-empty list of numbers.
-(define (-decode-split-build-assertion f-name value)
+(define (/decode-split-build-assertion f-name value)
(if (number? value)
(rtx-make 'eq 'INT (rtx-make 'ifield f-name) (rtx-make 'const 'INT value))
(rtx-make 'member (rtx-make 'ifield f-name)
(apply rtx-make (cons 'number-list (cons 'INT value)))))
)
-; Subroutine of -decode-split-insn.
+; Subroutine of /decode-split-insn.
; Specialize INSN according to <decode-split> dspec.
-(define (-decode-split-insn-1 insn dspec)
+(define (/decode-split-insn-1 insn dspec)
(let ((f-name (decode-split-name dspec))
(values (decode-split-values dspec)))
(let ((result (map object-copy-top (make-list (length values) insn))))
(obj-cons-attr! insn-copy (bool-attr-make 'DECODE-SPLIT #t))
(let ((existing-assertion (insn-ifield-assertion insn-copy))
(split-assertion
- (-decode-split-build-assertion f-name (cadr value))))
+ (/decode-split-build-assertion f-name (cadr value))))
(insn-set-ifield-assertion!
insn-copy
(if existing-assertion
; Split INSN.
; The result is a list of the split copies of INSN.
-(define (-decode-split-insn insn isa)
+(define (/decode-split-insn insn isa)
(logit 3 "Splitting " (obj:name insn) " ...\n")
(let loop ((splits (isa-decode-splits isa)) (result nil))
(cond ((null? splits)
; At each iteration, split the result of the previous.
(loop (cdr splits)
(if (null? result)
- (-decode-split-insn-1 insn (car splits))
+ (/decode-split-insn-1 insn (car splits))
(apply append
(map (lambda (insn)
- (-decode-split-insn-1 insn (car splits)))
+ (/decode-split-insn-1 insn (car splits)))
result)))))
(else
(loop (cdr splits) result))))
; ??? better phrase needed? Possible confusion with gcc's define-split.
; The original insns are then marked as aliases so the simulator ignores them.
-(define (-fill-sim-insn-list!)
+(define (/fill-sim-insn-list!)
(let ((isa (current-isa)))
(if (not (null? (isa-decode-splits isa)))
(for-each (lambda (insn)
(if (and (insn-real? insn)
(insn-semantics insn)
- (-decode-split-insn? insn isa))
+ (/decode-split-insn? insn isa))
(let ((ord (obj-ordinal insn))
(sub-ord 1))
(for-each (lambda (new-insn)
(cons ord sub-ord))
(current-insn-add! new-insn)
(set! sub-ord (+ sub-ord 1)))
- (-decode-split-insn insn isa))
+ (/decode-split-insn insn isa))
(obj-cons-attr! insn (bool-attr-make 'ALIAS #t)))))
(current-insn-list))
(logit 1 "Done splitting.\n"))
; .cpu file loading support
; Only run sim-analyze-insns! once.
-(define -sim-insns-analyzed? #f)
+(define /sim-insns-analyzed? #f)
; List of computed sformat argument buffers.
-(define -sim-sformat-argbuf-list #f)
-(define (current-sbuf-list) -sim-sformat-argbuf-list)
+(define /sim-sformat-argbuf-list #f)
+(define (current-sbuf-list) /sim-sformat-argbuf-list)
; Called before the .cpu file has been read in.
(define (sim-init!)
- (set! -sim-insns-analyzed? #f)
- (set! -sim-sformat-argbuf-list #f)
+ (set! /sim-insns-analyzed? #f)
+ (set! /sim-sformat-argbuf-list #f)
(if (with-sem-frags?)
(sim-sfrag-init!))
*UNSPECIFIED*
; If we're building files for an isa, create the virtual insns.
(if (not (keep-isa-multiple?))
- (-create-virtual-insns! (current-isa)))
+ (/create-virtual-insns! (current-isa)))
*UNSPECIFIED*
)
; This can only be done if one isa and one cpu family is being kept.
(assert-keep-one)
- (if (not -sim-insns-analyzed?)
+ (if (not /sim-insns-analyzed?)
(begin
- (-fill-sim-insn-list!)
+ (/fill-sim-insn-list!)
(arch-analyze-insns! CURRENT-ARCH
#f ; don't include aliases
#t) ; do analyze the semantics
; Compute the set of sformat argument buffers.
- (set! -sim-sformat-argbuf-list
+ (set! /sim-sformat-argbuf-list
(compute-sformat-argbufs! (current-sfmt-list)))
- (set! -sim-insns-analyzed? #t)
+ (set! /sim-insns-analyzed? #t)
))
; Do our own error checking.
; Return C macro definitions of the various supported cpus.
-(define (-gen-cpuall-defines)
+(define (/gen-cpuall-defines)
"" ; nothing yet
)
; ??? Modes are now defined in sim/common/cgen-types.h but we will need
; target specific modes.
-(define (-gen-support-decls)
+(define (/gen-support-decls)
(string-append
; (gen-enum-decl 'mode_type "mode types"
; "MODE_"
\f
; Utilities of cgen-cpuall.h.
-; Subroutine of -gen-cpuall-includes.
+; Subroutine of /gen-cpuall-includes.
-(define (-gen-cpu-header cpu prefix)
+(define (/gen-cpu-header cpu prefix)
(string-append "#include \"" prefix (cpu-file-transform cpu) ".h\"\n")
)
; Return C code to include all the relevant headers for each cpu family,
; conditioned on ifdef WANT_CPU_@CPU@.
-(define (-gen-cpuall-includes)
+(define (/gen-cpuall-includes)
(string-list
"/* Include files for each cpu family. */\n\n"
(string-list-map (lambda (cpu)
(let* ((cpu-name (gen-sym cpu))
(CPU-NAME (string-upcase cpu-name)))
(string-list "#ifdef WANT_CPU_" CPU-NAME "\n"
- (-gen-cpu-header cpu "eng")
+ (/gen-cpu-header cpu "eng")
"#include \"cgen-engine.h\"\n"
- (-gen-cpu-header cpu "cpu")
+ (/gen-cpu-header cpu "cpu")
; FIXME: Shorten "decode" to "dec".
- (-gen-cpu-header cpu "decode")
+ (/gen-cpu-header cpu "decode")
"#endif\n\n")))
(current-cpu-list))
)
)
-; Subroutine of -gen-cpuall-decls to generate cpu-specific structure entries.
+; Subroutine of /gen-cpuall-decls to generate cpu-specific structure entries.
; The result is "struct <cpu>_<type-name> <member-name>;".
; INDENT is the amount to indent by.
; CPU is the cpu object.
-(define (-gen-cpu-specific-decl indent cpu type-name member-name)
+(define (/gen-cpu-specific-decl indent cpu type-name member-name)
(let* ((cpu-name (gen-sym cpu))
(CPU-NAME (string-upcase cpu-name)))
(string-append
; just the baseclass. In cpu-specific files, the baseclass is augmented
; with the cpu-specific data.
-(define (-gen-cpuall-decls)
+(define (/gen-cpuall-decls)
(string-list
(gen-argbuf-type #f)
(gen-scache-type #f)
;"#define WI SI\n"
;"#define UWI USI\n"
;"#define AI USI\n\n"
- -gen-cpuall-defines
- -gen-support-decls
- -gen-arch-model-decls
+ /gen-cpuall-defines
+ /gen-support-decls
+ /gen-arch-model-decls
"#endif /* @ARCH@_ARCH_H */\n"
)
)
#include \"bfd.h\"
"
- -gen-mach-data
+ /gen-mach-data
)
)
"#ifndef @ARCH@_CPUALL_H\n"
"#define @ARCH@_CPUALL_H\n"
"\n"
- -gen-cpuall-includes
- -gen-mach-decls
- -gen-cpuall-decls
+ /gen-cpuall-includes
+ /gen-mach-decls
+ /gen-cpuall-decls
"#endif /* @ARCH@_CPUALL_H */\n"
)
)
; A "cpu family" here is a collection of variants of a particular architecture
; that share sufficient commonality that they can be handled together.
-(define (-gen-cpu-defines)
+(define (/gen-cpu-defines)
(string-append
"\
/* Maximum number of instructions that are fetched at a time.
(and (register? hw) (not (obj-has-attr? hw 'VIRTUAL)))
)
-; Subroutine of -gen-hardware-types to generate the struct containing
+; Subroutine of /gen-hardware-types to generate the struct containing
; hardware elements of one isa.
-(define (-gen-hardware-struct hw-list)
+(define (/gen-hardware-struct hw-list)
(if (null? hw-list)
; If struct is empty, leave it out to simplify generated code.
""
; Return C type declarations of all of the hardware elements.
; The name of the type is prepended with the cpu family name.
-(define (-gen-hardware-types)
+(define (/gen-hardware-types)
(string-list
"/* CPU state information. */\n"
"typedef struct {\n"
" /* Hardware elements. */\n"
" struct {\n"
- (-gen-hardware-struct
+ (/gen-hardware-struct
(find (lambda (hw)
(or (not (with-multiple-isa?))
(>= (count-common
; Return the declaration of register access functions.
-(define (-gen-cpu-reg-access-decls)
+(define (/gen-cpu-reg-access-decls)
(string-list
"/* Cover fns for register access. */\n"
(string-list-map (lambda (hw)
; Generate type of struct holding model state while executing.
-(define (-gen-model-decls)
+(define (/gen-model-decls)
(logit 2 "Generating model decls ...\n")
(string-list
(string-list-map
)
)
-; Utility of -gen-extract-macros to generate a macro to define the local
+; Utility of /gen-extract-macros to generate a macro to define the local
; vars to contain extracted field values and the code to assign them
; for <iformat> IFMT.
-(define (-gen-extract-ifmt-macro ifmt)
+(define (/gen-extract-ifmt-macro ifmt)
(logit 2 "Processing format " (obj:name ifmt) " ...\n")
(string-list
(gen-define-ifmt-ifields ifmt "" #t #f)
; Generate macros to extract instruction fields.
-(define (-gen-extract-macros)
+(define (/gen-extract-macros)
(logit 2 "Generating extraction macros ...\n")
(string-list
"\
/* Macros to simplify extraction, reading and semantic code.
These define and assign the local vars that contain the insn's fields. */
\n"
- (string-list-map -gen-extract-ifmt-macro (current-ifmt-list))
+ (string-list-map /gen-extract-ifmt-macro (current-ifmt-list))
)
)
-; Utility of -gen-parallel-exec-type to generate the definition of one
+; Utility of /gen-parallel-exec-type to generate the definition of one
; structure in PAREXEC.
; SFMT is an <sformat> object.
-(define (-gen-parallel-exec-elm sfmt)
+(define (/gen-parallel-exec-elm sfmt)
(string-append
" struct { /* " (obj:comment sfmt) " */\n"
(let ((sem-ops
; The fetched/queued values are stored in an array of PAREXEC structs, one
; element per instruction.
-(define (-gen-parallel-exec-type)
+(define (/gen-parallel-exec-type)
(logit 2 "Generating PAREXEC type ...\n")
(string-append
(if (with-parallel-write?)
struct parexec {
union {\n"
- (string-map -gen-parallel-exec-elm (current-sfmt-list))
+ (string-map /gen-parallel-exec-elm (current-sfmt-list))
"\
} operands;
/* For conditionally written operands, bitmask of which ones were. */
; semantic code. Then the fast/full distinction needn't use conditionals to
; discard/include the tracing/profiling code.
-(define (-gen-trace-record-type)
+(define (/gen-trace-record-type)
(string-list
"\
/* Collection of various things for the trace handler to use. */
; Get/set fns for every register.
-(define (-gen-cpu-reg-access-defns)
+(define (/gen-cpu-reg-access-defns)
(string-list-map
(lambda (hw)
(let ((scalar? (hw-scalar? hw))
; Generate a function to record trace results in a trace record.
-(define (-gen-cpu-record-results)
+(define (/gen-cpu-record-results)
(string-list
"\
/* Record trace results for INSN. */
; Return C code to fetch and save all input operands to instructions with
; <sformat> SFMT.
-(define (-gen-read-args sfmt)
+(define (/gen-read-args sfmt)
(string-map (lambda (op) (op:read op sfmt))
(sfmt-in-ops sfmt))
)
-; Utility of -gen-read-switch to generate a switch case for <sformat> SFMT.
+; Utility of /gen-read-switch to generate a switch case for <sformat> SFMT.
-(define (-gen-read-case sfmt)
+(define (/gen-read-case sfmt)
(logit 2 "Processing read switch case for \"" (obj:name sfmt) "\" ...\n")
(string-list
" CASE (read, READ_" (string-upcase (gen-sym sfmt)) ") : "
(gen-define-parallel-operand-macro sfmt)
(gen-define-ifields (sfmt-iflds sfmt) (sfmt-length sfmt) " " #f)
(gen-extract-ifields (sfmt-iflds sfmt) (sfmt-length sfmt) " " #f)
- (-gen-read-args sfmt)
+ (/gen-read-args sfmt)
(gen-undef-parallel-operand-macro sfmt)
(gen-undef-field-macro sfmt)
" }\n"
; Generate the guts of a C switch statement to read insn operands.
; The switch is based on instruction formats.
-(define (-gen-read-switch)
+(define (/gen-read-switch)
(logit 2 "Processing readers ...\n")
- (string-write-map -gen-read-case (current-sfmt-list))
+ (string-write-map /gen-read-case (current-sfmt-list))
)
\f
; Utilities of cgen-write.c.
; Return C code to fetch and save all output operands to instructions with
; <sformat> SFMT.
-(define (-gen-write-args sfmt)
+(define (/gen-write-args sfmt)
(string-map (lambda (op) (op:write op sfmt))
(sfmt-out-ops sfmt))
)
; the case is named after the insn not the format. This is done because
; current sem-switch support emits one handler per insn instead of per sfmt.
-(define (-gen-write-case sfmt insn)
+(define (/gen-write-case sfmt insn)
(logit 2 "Processing write switch case for \"" (obj:name sfmt) "\" ...\n")
(string-list
(if insn
"")
"\n"
(/indent-add 4)
- (-gen-write-args sfmt)
+ (/gen-write-args sfmt)
(/indent-add -4)
"\n"
(if (and insn (insn-cti? insn))
; E.g. on the m32r all 32 bit insns can't be executed in parallel.
; It's easier to generate the code anyway so we do.
-(define (-gen-write-switch)
+(define (/gen-write-switch)
(logit 2 "Processing writers ...\n")
(string-write-map (lambda (sfmt)
- (-gen-write-case sfmt #f))
+ (/gen-write-case sfmt #f))
(current-sfmt-list))
)
\f
; Return name of semantic fn for INSN.
-(define (-gen-sem-fn-name insn)
+(define (/gen-sem-fn-name insn)
;(string-append "sem_" (gen-sym insn))
(gen-sym insn)
)
; Return semantic fn table entry for INSN.
-(define (-gen-sem-fn-table-entry insn)
+(define (/gen-sem-fn-table-entry insn)
(string-list
" { "
"@PREFIX@_INSN_"
(string-upcase (gen-sym insn))
", "
- "SEM_FN_NAME (@prefix@," (-gen-sem-fn-name insn) ")"
+ "SEM_FN_NAME (@prefix@," (/gen-sem-fn-name insn) ")"
" },\n"
)
)
; Return C code to define a table of all semantic fns and a function to
; add the info to the insn descriptor table.
-(define (-gen-semantic-fn-table)
+(define (/gen-semantic-fn-table)
(string-write
"\
/* Table of all semantic fns. */
static const struct sem_fn_desc sem_fns[] = {\n"
(lambda ()
- (string-write-map -gen-sem-fn-table-entry
+ (string-write-map /gen-sem-fn-table-entry
(non-alias-insns (current-insn-list))))
"\
; Return definition of C function to perform INSN.
; This version handles the with-scache case.
-(define (-gen-scache-semantic-fn insn)
+(define (/gen-scache-semantic-fn insn)
(logit 2 "Processing semantics for " (obj:name insn) ": \"" (insn-syntax insn) "\" ...\n")
- (set! -with-profile? -with-profile-fn?)
+ (set! /with-profile? /with-profile-fn?)
(let ((profile? (and (with-profile?)
(not (obj-has-attr? insn 'VIRTUAL))))
(parallel? (with-parallel?))
; Only update what's been written if some are conditionally written.
; Otherwise we know they're all written so there's no point in
; keeping track.
- (if (-any-cond-written? (insn-sfmt insn))
+ (if (/any-cond-written? (insn-sfmt insn))
" abuf->written = written;\n"
"")
(if (and cti? (not parallel?))
; This version handles the without-scache case.
; ??? TODO: multiword insns.
-(define (-gen-no-scache-semantic-fn insn)
+(define (/gen-no-scache-semantic-fn insn)
(logit 2 "Processing semantics for " (obj:name insn) ": \"" (insn-syntax insn) "\" ...\n")
- (set! -with-profile? -with-profile-fn?)
+ (set! /with-profile? /with-profile-fn?)
(let ((profile? (and (with-profile?)
(not (obj-has-attr? insn 'VIRTUAL))))
(parallel? (with-parallel?))
; Only update what's been written if some are conditionally written.
; Otherwise we know they're all written so there's no point in
; keeping track.
- (if (-any-cond-written? (insn-sfmt insn))
+ (if (/any-cond-written? (insn-sfmt insn))
" abuf->written = written;\n"
"")
; SEM_{,N}BRANCH_FINI are user-supplied macros.
))
)
-(define (-gen-all-semantic-fns)
+(define (/gen-all-semantic-fns)
(logit 2 "Processing semantics ...\n")
(let ((insns (non-alias-insns (current-insn-list))))
(if (with-scache?)
- (string-write-map -gen-scache-semantic-fn insns)
- (string-write-map -gen-no-scache-semantic-fn insns)))
+ (string-write-map /gen-scache-semantic-fn insns)
+ (string-write-map /gen-no-scache-semantic-fn insns)))
)
-; Utility of -gen-sem-case to return the mask of operands always written
+; Utility of /gen-sem-case to return the mask of operands always written
; to in <sformat> SFMT.
; ??? Not currently used.
-(define (-uncond-written-mask sfmt)
+(define (/uncond-written-mask sfmt)
(apply + (map (lambda (op)
(if (op:cond? op)
0
(sfmt-out-ops sfmt)))
)
-; Utility of -gen-sem-case to return #t if any operand in <sformat> SFMT is
+; Utility of /gen-sem-case to return #t if any operand in <sformat> SFMT is
; conditionally written to.
-(define (-any-cond-written? sfmt)
+(define (/any-cond-written? sfmt)
(any-true? (map op:cond? (sfmt-out-ops sfmt)))
)
; Generate a switch case to perform INSN.
-(define (-gen-sem-case insn parallel?)
+(define (/gen-sem-case insn parallel?)
(logit 2 "Processing "
(if parallel? "parallel " "")
"semantic switch case for \"" (insn-syntax insn) "\" ...\n")
- (set! -with-profile? -with-profile-sw?)
+ (set! /with-profile? /with-profile-sw?)
(let ((cti? (insn-cti? insn))
(insn-len (insn-length-bytes insn)))
(string-list
; Only update what's been written if some are conditionally written.
; Otherwise we know they're all written so there's no point in
; keeping track.
- (if (-any-cond-written? (insn-sfmt insn))
+ (if (/any-cond-written? (insn-sfmt insn))
" abuf->written = written;\n"
"")
(if (and cti? (not parallel?))
))
)
-(define (-gen-sem-switch)
+(define (/gen-sem-switch)
(logit 2 "Processing semantic switch ...\n")
; Turn parallel execution support off.
(let ((orig-with-parallel? (with-parallel?)))
(set-with-parallel?! #f)
(let ((result
- (string-write-map (lambda (insn) (-gen-sem-case insn #f))
+ (string-write-map (lambda (insn) (/gen-sem-case insn #f))
(non-alias-insns (current-insn-list)))))
(set-with-parallel?! orig-with-parallel?)
result))
; reduces the amount of code, though it is believed that in this particular
; instance the win isn't big enough.
-(define (-gen-parallel-sem-switch)
+(define (/gen-parallel-sem-switch)
(logit 2 "Processing parallel insn semantic switch ...\n")
; Turn parallel execution support on.
(let ((orig-with-parallel? (with-parallel?)))
(set-with-parallel?! #t)
(let ((result
(string-write-map (lambda (insn)
- (string-list (-gen-sem-case insn #t)
- (-gen-write-case (insn-sfmt insn) insn)))
+ (string-list (/gen-sem-case insn #t)
+ (/gen-write-case (insn-sfmt insn) insn)))
(parallel-insns (current-insn-list)))))
(set-with-parallel?! orig-with-parallel?)
result))
#define CPU_@CPU@_H
"
- -gen-cpu-defines
- -gen-hardware-types
- -gen-cpu-reg-access-decls
- -gen-model-decls
+ /gen-cpu-defines
+ /gen-hardware-types
+ /gen-cpu-reg-access-decls
+ /gen-model-decls
(if (not (with-multiple-isa?))
(string-list
(lambda () (gen-argbuf-type #t))
(lambda () (gen-scache-type #t))
- -gen-extract-macros)
+ /gen-extract-macros)
"")
(if (and (with-parallel?) (not (with-generic-write?)))
- -gen-parallel-exec-type
+ /gen-parallel-exec-type
"")
- -gen-trace-record-type
+ /gen-trace-record-type
"#endif /* CPU_@CPU@_H */\n"
)
)
"
(lambda () (gen-argbuf-type #t))
(lambda () (gen-scache-type #t))
- -gen-extract-macros
+ /gen-extract-macros
"#endif /* DEFS_@PREFIX@_H */\n"
)
#include \"cgen-ops.h\"
"
- -gen-cpu-reg-access-defns
- -gen-cpu-record-results
+ /gen-cpu-reg-access-defns
+ /gen-cpu-record-results
)
)
"
- -gen-read-switch
+ /gen-read-switch
"\
}
\n"
;(/indent-add 8)
- -gen-write-switch
+ /gen-write-switch
;(/indent-add -8)
"\
#endif
\n"
- -gen-all-semantic-fns
+ /gen-all-semantic-fns
; Put the table at the end so we don't have to declare all the sem fns.
- -gen-semantic-fn-table
+ /gen-semantic-fn-table
)
)
"
- -gen-sem-switch
+ /gen-sem-switch
(if (state-parallel-exec?)
- -gen-parallel-sem-switch
+ /gen-parallel-sem-switch
"")
"
; big array. It doesn't matter too much (yet). Generating one big array is
; simpler.
-(define (-gen-decode-insn-globals insn-list)
+(define (/gen-decode-insn-globals insn-list)
; Print the higher detailed stuff at higher verbosity.
(logit 2 "Processing decode insn globals ...\n")
(string-append "VIRTUAL_INSN_" (string-upcase name) ", ")
(string-append "@ARCH@_INSN_" (string-upcase name) ", "))
(string-append "@PREFIX@_INSN_" (string-upcase name) ", ")
- "@PREFIX@_" (-gen-fmt-enum (insn-sfmt insn))
+ "@PREFIX@_" (/gen-fmt-enum (insn-sfmt insn))
(if (and (with-parallel?) (not (with-parallel-only?)))
(string-list
(if (insn-parallel? insn)
; Return enum name of format FMT.
-(define (-gen-fmt-enum fmt)
+(define (/gen-fmt-enum fmt)
(string-upcase (gen-sym fmt))
)
\f
; Generate decls for the insn descriptor table type IDESC.
-(define (-gen-idesc-decls)
+(define (/gen-idesc-decls)
(string-append "\
extern const IDESC *@prefix@_decode (SIM_CPU *, IADDR,
CGEN_INSN_INT,"
; @prefix@_init_idesc_table is defined here as it depends on with-parallel?
; and thus can't be defined in sim/common.
-(define (-gen-idesc-init-fn)
+(define (/gen-idesc-init-fn)
(string-append "\
/* Initialize an IDESC from the compile-time computable parts. */
; Return C code to record <ifield> F for the semantic handler
; in a local variable rather than an ARGBUF struct.
-(define (-gen-record-argbuf-ifld f sfmt)
+(define (/gen-record-argbuf-ifld f sfmt)
(string-append " " (gen-ifld-argbuf-ref f)
" = " (gen-extracted-ifld-value f) ";\n")
)
; string argument to fprintf, character indicating type of third arg, value.
; The type is one of: x.
-(define (-gen-trace-argbuf-ifld f sfmt)
+(define (/gen-trace-argbuf-ifld f sfmt)
(string-append
; FIXME: Add method to return fprintf format string.
", \"" (gen-sym f) " 0x%x\""
; the ARGBUF struct.
; ??? Later allow target to provide an `extract' expression.
-(define (-gen-op-extract op sfmt local?)
+(define (/gen-op-extract op sfmt local?)
(send (op:type op) 'gen-extract op sfmt local?)
)
; string argument to fprintf, character indicating type of third arg, value.
; The type is one of: x.
-(define (-gen-op-trace-extract op sfmt)
+(define (/gen-op-trace-extract op sfmt)
(send (op:type op) 'gen-trace-extract op sfmt)
)
(define (gen-sfmt-op-argbuf-assigns sfmt)
(let ((operands (sfmt-extracted-operands sfmt)))
(string-list-map (lambda (op)
- (-gen-op-extract op sfmt #t))
+ (/gen-op-extract op sfmt #t))
operands))
)
\f
; Return C code to record insn field data for <sformat> SFMT.
; This is used when with-scache.
-(define (-gen-record-args sfmt)
+(define (/gen-record-args sfmt)
(let ((operands (sfmt-extracted-operands sfmt))
(iflds (sfmt-needed-iflds sfmt)))
(string-list
" /* Record the fields for the semantic handler. */\n"
- (string-list-map (lambda (f) (-gen-record-argbuf-ifld f sfmt))
+ (string-list-map (lambda (f) (/gen-record-argbuf-ifld f sfmt))
iflds)
- (string-list-map (lambda (op) (-gen-op-extract op sfmt #f))
+ (string-list-map (lambda (op) (/gen-op-extract op sfmt #f))
operands)
" TRACE_EXTRACT (current_cpu, abuf, (current_cpu, pc, "
"\"" (gen-sym sfmt) "\""
- (string-list-map (lambda (f) (-gen-trace-argbuf-ifld f sfmt))
+ (string-list-map (lambda (f) (/gen-trace-argbuf-ifld f sfmt))
iflds)
- (string-list-map (lambda (op) (-gen-op-trace-extract op sfmt))
+ (string-list-map (lambda (op) (/gen-op-trace-extract op sfmt))
operands)
", (char *) 0));\n"
))
; is kept to the extraction phase. If someone wants to put forth some real
; data, this might then be changed (or at least noted).
-(define (-gen-record-profile-args sfmt)
+(define (/gen-record-profile-args sfmt)
(let ((in-ops (find op-profilable? (sfmt-in-ops sfmt)))
(out-ops (find op-profilable? (sfmt-out-ops sfmt)))
)
; by the semantic code. This is currently done by recording this information
; with the format.
-(define (-gen-extract-case sfmt)
+(define (/gen-extract-case sfmt)
(logit 2 "Processing extractor for \"" (sfmt-key sfmt) "\" ...\n")
(string-list
" extract_" (gen-sym sfmt) ":\n"
"\n"
(gen-extract-ifields (sfmt-iflds sfmt) (sfmt-length sfmt) " " #f)
"\n"
- (-gen-record-args sfmt)
+ (/gen-record-args sfmt)
"\n"
- (-gen-record-profile-args sfmt)
+ (/gen-record-profile-args sfmt)
(gen-undef-field-macro sfmt)
" return idesc;\n"
" }\n\n"
; For each format, return its extraction function.
-(define (-gen-all-extractors)
+(define (/gen-all-extractors)
(logit 2 "Processing extractors ...\n")
- (string-list-map -gen-extract-case (current-sfmt-list))
+ (string-list-map /gen-extract-case (current-sfmt-list))
)
\f
; Generate top level decoder.
; ourselves.
; LSB0? is non-#f if bit number 0 is the least significant bit.
-(define (-gen-decode-fn insn-list initial-bitnums lsb0?)
+(define (/gen-decode-fn insn-list initial-bitnums lsb0?)
; Compute the initial DECODE-BITSIZE as the minimum of all insn lengths.
; The caller of @prefix@_decode must fetch and pass exactly this number of bits
(if (with-scache?)
(string-list "\
/* The instruction has been decoded, now extract the fields. */\n\n"
- -gen-all-extractors)
+ /gen-all-extractors)
; Without the scache, extraction is defered until the semantic code.
(string-list "\
/* Extraction is defered until the semantic code. */
#define @PREFIX@_DECODE_H
"
- -gen-idesc-decls
+ /gen-idesc-decls
(lambda () (gen-cpu-insn-enum-decl (current-cpu)
(non-multi-insns (non-alias-insns (current-insn-list)))))
(lambda () (gen-sfmt-enum-decl (current-sfmt-list)))
#include \"sim-main.h\"
#include \"sim-assert.h\"\n\n"
- (lambda () (-gen-decode-insn-globals (non-multi-insns (non-alias-insns (current-insn-list)))))
- -gen-idesc-init-fn
- (lambda () (-gen-decode-fn (non-multi-insns (real-insns (current-insn-list)))
+ (lambda () (/gen-decode-insn-globals (non-multi-insns (non-alias-insns (current-insn-list)))))
+ /gen-idesc-init-fn
+ (lambda () (/gen-decode-fn (non-multi-insns (real-insns (current-insn-list)))
(state-decode-assist)
(current-arch-insn-lsb0?)))
)
(string-upcase (obj:str-name u))))
)
-(define (-gen-cpu-imp-properties)
+(define (/gen-cpu-imp-properties)
(string-list
"\
/* The properties of this cpu's implementation. */
; Generate code to profile hardware elements.
; ??? Not currently used.
-(define (-gen-hw-profile-code)
+(define (/gen-hw-profile-code)
; Fetch profilable input and output operands of the semantic code.
(let ((in-ops (find op-profilable? (sfmt-in-ops (insn-sfmt insn))))
(out-ops (find op-profilable? (sfmt-out-ops (insn-sfmt insn)))))
; Return decls of hardware element profilers.
; ??? Not currently used.
-(define (-gen-hw-profile-decls)
+(define (/gen-hw-profile-decls)
(string-list
"/* Hardware profiling handlers. */\n\n"
(string-list-map (lambda (hw)
)
(string-list
- ; -gen-hw-profile-decls
+ ; /gen-hw-profile-decls
"/* Function unit handlers (user written). */\n\n"
(string-list-map
(lambda (model)
; Return name of profile handler for INSN, MODEL.
-(define (-gen-model-insn-fn-name model insn)
+(define (/gen-model-insn-fn-name model insn)
(string-append "model_" (gen-sym model) "_" (gen-sym insn))
)
; Return function to model INSN.
-(define (-gen-model-insn-fn model insn)
+(define (/gen-model-insn-fn model insn)
(logit 2 "Processing modeling for " (obj:name insn) ": \"" (insn-syntax insn) "\" ...\n")
(string-list
"static int\n"
- (-gen-model-insn-fn-name model insn)
+ (/gen-model-insn-fn-name model insn)
; sem_arg is a void * to keep cgen specific stuff out of sim-model.h
" (SIM_CPU *current_cpu, void *sem_arg)\n"
"{\n"
; ??? Modelling of insns could be table driven, but that puts constraints on
; generality.
-(define (-gen-model-insn-fns)
+(define (/gen-model-insn-fns)
(string-write
"/* Model handlers for each insn. */\n\n"
(lambda () (string-write-map
(lambda (model)
(string-write-map
- (lambda (insn) (-gen-model-insn-fn model insn))
+ (lambda (insn) (/gen-model-insn-fn model insn))
(real-insns (current-insn-list))))
(current-model-list)))
)
; U is a <unit> object.
; ARGS is a list of overriding arguments from INSN.
-(define (-gen-insn-unit-timing model insn u args)
+(define (/gen-insn-unit-timing model insn u args)
(string-append
"{ "
"(int) " (unit:enum u) ", "
; Generate timing table entry for MODEL for INSN.
-(define (-gen-insn-timing model insn)
+(define (/gen-insn-timing model insn)
; Instruction timing is stored as an associative list based on the model.
(let ((timing (assq (obj:name model) (insn-timing insn))))
;(display timing) (newline)
", "
(if (obj-has-attr? insn 'VIRTUAL)
"0"
- (-gen-model-insn-fn-name model insn))
+ (/gen-model-insn-fn-name model insn))
", { "
(string-drop
-2
(if (not timing)
- (-gen-insn-unit-timing model insn (model-default-unit model) nil)
+ (/gen-insn-unit-timing model insn (model-default-unit model) nil)
(let ((units (timing:units (cdr timing))))
(string-map (lambda (iunit)
- (-gen-insn-unit-timing model insn
+ (/gen-insn-unit-timing model insn
(iunit:unit iunit)
(iunit:args iunit)))
units))))
; Generate model timing table for MODEL.
-(define (-gen-model-timing-table model)
+(define (/gen-model-timing-table model)
(string-write
"/* Model timing data for `" (obj:str-name model) "'. */\n\n"
"static const INSN_TIMING " (gen-sym model) "_timing[] = {\n"
- (lambda () (string-write-map (lambda (insn) (-gen-insn-timing model insn))
+ (lambda () (string-write-map (lambda (insn) (/gen-insn-timing model insn))
(non-alias-insns (current-insn-list))))
"};\n\n"
)
; Return C code to define model profiling support stuff.
-(define (-gen-model-profile-data)
+(define (/gen-model-profile-data)
(string-write
"/* We assume UNIT_NONE == 0 because the tables don't always terminate\n"
" entries with it. */\n\n"
- (lambda () (string-write-map -gen-model-timing-table (current-model-list)))
+ (lambda () (string-write-map /gen-model-timing-table (current-model-list)))
)
)
; Return C code to define the model table for MACH.
-(define (-gen-mach-model-table mach)
+(define (/gen-mach-model-table mach)
(string-list
"\
static const MODEL " (gen-sym mach) "_models[] =\n{\n"
; Return C code to define model init fn.
-(define (-gen-model-init-fn model)
+(define (/gen-model-init-fn model)
(string-list "\
static void\n"
(gen-sym model) "_model_init (SIM_CPU *cpu)
; Return C code to define model data and support fns.
-(define (-gen-model-defns)
+(define (/gen-model-defns)
(string-write
- (lambda () (string-write-map -gen-model-init-fn (current-model-list)))
+ (lambda () (string-write-map /gen-model-init-fn (current-model-list)))
"#if WITH_PROFILE_MODEL_P
#define TIMING_DATA(td) td
#else
#define TIMING_DATA(td) 0
#endif\n\n"
- (lambda () (string-write-map -gen-mach-model-table (current-mach-list)))
+ (lambda () (string-write-map /gen-mach-model-table (current-mach-list)))
)
)
; Return C definitions for this cpu family variant.
-(define (-gen-cpu-defns)
+(define (/gen-cpu-defns)
(string-list "\
static void
; Return C code to define the machine data.
-(define (-gen-mach-defns)
+(define (/gen-mach-defns)
(string-list-map
(lambda (mach)
(gen-obj-sanitize
#if WITH_PROFILE_MODEL_P
"
- -gen-model-insn-fns
- -gen-model-profile-data
+ /gen-model-insn-fns
+ /gen-model-profile-data
"#endif /* WITH_PROFILE_MODEL_P */\n\n"
- -gen-model-defns
- -gen-cpu-imp-properties
- -gen-cpu-defns
- -gen-mach-defns
+ /gen-model-defns
+ /gen-cpu-imp-properties
+ /gen-cpu-defns
+ /gen-mach-defns
)
)
; indicate the software package
; #t if the scache is being used
-(define -with-scache? #f)
-(define (with-scache?) -with-scache?)
+(define /with-scache? #f)
+(define (with-scache?) /with-scache?)
; #t if we're generating profiling code
; Each of the function and switch semantic code can have profiling.
-; The options as passed are stored in -with-profile-{fn,sw}?, and
-; -with-profile? is set at code generation time.
-(define -with-profile-fn? #f)
-(define -with-profile-sw? #f)
-(define -with-profile? #f)
-(define (with-profile?) -with-profile?)
-(define (with-any-profile?) (or -with-profile-fn? -with-profile-sw?))
+; The options as passed are stored in /with-profile-{fn,sw}?, and
+; /with-profile? is set at code generation time.
+(define /with-profile-fn? #f)
+(define /with-profile-sw? #f)
+(define /with-profile? #f)
+(define (with-profile?) /with-profile?)
+(define (with-any-profile?) (or /with-profile-fn? /with-profile-sw?))
; #t if multiple isa support is enabled
-(define -with-multiple-isa? #f)
-(define (with-multiple-isa?) -with-multiple-isa?)
+(define /with-multiple-isa? #f)
+(define (with-multiple-isa?) /with-multiple-isa?)
; Handle parallel execution with generic writeback pass.
-(define -with-generic-write? #f)
-(define (with-generic-write?) -with-generic-write?)
+(define /with-generic-write? #f)
+(define (with-generic-write?) /with-generic-write?)
; Only generate parallel versions of each insn.
-(define -with-parallel-only? #f)
-(define (with-parallel-only?) -with-parallel-only?)
+(define /with-parallel-only? #f)
+(define (with-parallel-only?) /with-parallel-only?)
; String containing copyright text.
(define CURRENT-COPYRIGHT #f)
; Initialize the options.
(define (option-init!)
- (set! -with-scache? #f)
- (set! -with-profile-fn? #f)
- (set! -with-profile-sw? #f)
- (set! -with-multiple-isa? #f)
- (set! -with-generic-write? #f)
- (set! -with-parallel-only? #f)
+ (set! /with-scache? #f)
+ (set! /with-profile-fn? #f)
+ (set! /with-profile-sw? #f)
+ (set! /with-multiple-isa? #f)
+ (set! /with-generic-write? #f)
+ (set! /with-parallel-only? #f)
(set! CURRENT-COPYRIGHT copyright-fsf)
(set! CURRENT-PACKAGE package-gnu-simulators)
*UNSPECIFIED*
(define (option-set! name value)
(case name
- ((with-scache) (set! -with-scache? #t))
+ ((with-scache) (set! /with-scache? #t))
((with-profile) (cond ((equal? value '("fn"))
- (set! -with-profile-fn? #t))
+ (set! /with-profile-fn? #t))
((equal? value '("sw"))
- (set! -with-profile-sw? #t))
+ (set! /with-profile-sw? #t))
(else (error "invalid with-profile value" value))))
- ((with-multiple-isa) (set! -with-multiple-isa? #t))
- ((with-generic-write) (set! -with-generic-write? #t))
- ((with-parallel-only) (set! -with-parallel-only? #t))
+ ((with-multiple-isa) (set! /with-multiple-isa? #t))
+ ((with-generic-write) (set! /with-generic-write? #t))
+ ((with-parallel-only) (set! /with-parallel-only? #t))
((copyright) (cond ((equal? value '("fsf"))
(set! CURRENT-COPYRIGHT copyright-fsf))
((equal? value '("redhat"))
; While processing operand reading (or writing), parallel execution support
; needs to be turned off, so it is up to the appropriate cgen-foo.c proc to
; set-with-parallel?! appropriately.
-(define -with-parallel? #f)
-(define (with-parallel?) -with-parallel?)
-(define (set-with-parallel?! flag) (set! -with-parallel? flag))
+(define /with-parallel? #f)
+(define (with-parallel?) /with-parallel?)
+(define (set-with-parallel?! flag) (set! /with-parallel? flag))
; Kind of parallel support.
; If 'read, read pre-processing is done.
; ??? At present we always use write post-processing, though the previous
; version used read pre-processing. Not sure supporting both is useful
; in the long run.
-(define -with-parallel-kind 'write)
+(define /with-parallel-kind 'write)
; #t if parallel support is provided by read pre-processing.
(define (with-parallel-read?)
- (and -with-parallel? (eq? -with-parallel-kind 'read))
+ (and /with-parallel? (eq? /with-parallel-kind 'read))
)
; #t if parallel support is provided by write post-processing.
(define (with-parallel-write?)
- (and -with-parallel? (eq? -with-parallel-kind 'write))
+ (and /with-parallel? (eq? /with-parallel-kind 'write))
)
\f
; Misc. utilities.
; Return a <c-expr> object of the value of an ifield.
-(define (-cxmake-ifld-val mode f)
+(define (/cxmake-ifld-val mode f)
(if (with-scache?)
; ??? Perhaps a better way would be to defer evaluating the src of a
; set until the method processing the dest.
(lambda (self sym index estate)
(let ((gen-index1 (lambda (idx)
(string-append "["
- (-gen-hw-index idx estate)
+ (/gen-hw-index idx estate)
"]"))))
(string-append sym
(cond ((list? index) (string-map gen-index1 index))
(lambda (self estate mode index selector)
(if (not (eq? 'ifield (hw-index:type index)))
(error "not an ifield hw-index" index))
- (-cxmake-ifld-val mode (hw-index:value index)))
+ (/cxmake-ifld-val mode (hw-index:value index)))
)
; Handle gen-get-macro/gen-set-macro.
; of rtx: that takes a variable number of named arguments.
; ??? Another way to get #:direct might be (raw-reg h-pc).
-(define (-hw-gen-set-quiet-pc self estate mode index selector newval . options)
+(define (/hw-gen-set-quiet-pc self estate mode index selector newval . options)
(if (not (send self 'pc?)) (error "Not a PC:" self))
(cond ((memq #:direct options)
- (-hw-gen-set-quiet self estate mode index selector newval))
+ (/hw-gen-set-quiet self estate mode index selector newval))
((has-attr? newval 'CACHED)
(string-append "SEM_BRANCH_VIA_CACHE (current_cpu, sem_arg, "
(cx:c newval)
", vpc);\n")))
)
-(method-make! <hw-pc> 'gen-set-quiet -hw-gen-set-quiet-pc)
+(method-make! <hw-pc> 'gen-set-quiet /hw-gen-set-quiet-pc)
; Handle updates of the pc during parallel execution.
; This is done in a post-processing pass after semantic evaluation.
<hw-register> 'gen-record-profile
(lambda (self index sfmt estate)
; FIXME: Need to handle scalars.
- (-gen-hw-index-raw index estate))
+ (/gen-hw-index-raw index estate))
)
(method-make!
; Utility to build a <c-expr> object to fetch the value of a register.
-(define (-hw-cxmake-get hw estate mode index selector)
+(define (/hw-cxmake-get hw estate mode index selector)
(let ((mode (if (mode:eq? 'DFLT mode)
(send hw 'get-mode)
mode))
(cx:make mode
(cond (getter
(let ((scalar? (hw-scalar? hw))
- (c-index (-gen-hw-index index estate)))
+ (c-index (/gen-hw-index index estate)))
(string-append "GET_"
(string-upcase (gen-sym hw))
" ("
(gen-sym hw) index estate))))))
)
-(method-make! <hw-register> 'cxmake-get -hw-cxmake-get)
+(method-make! <hw-register> 'cxmake-get /hw-cxmake-get)
; raw-reg: support
; ??? raw-reg: support is wip
; Utilities to generate C code to assign a variable to a register.
-(define (-hw-gen-set-quiet hw estate mode index selector newval)
+(define (/hw-gen-set-quiet hw estate mode index selector newval)
(let ((setter (hw-setter hw)))
(cond (setter
(let ((scalar? (hw-scalar? hw))
- (c-index (-gen-hw-index index estate)))
+ (c-index (/gen-hw-index index estate)))
(string-append "SET_"
(string-upcase (gen-sym hw))
" ("
" = " (cx:c newval) ";\n"))))
)
-(method-make! <hw-register> 'gen-set-quiet -hw-gen-set-quiet)
+(method-make! <hw-register> 'gen-set-quiet /hw-gen-set-quiet)
; raw-reg: support
; ??? wip
(if default-selector? "" "ASI")
" ("
"current_cpu, pc, "
- (-gen-hw-index index estate)
+ (/gen-hw-index index estate)
(if default-selector?
""
(string-append ", "
- (-gen-hw-selector selector)))
+ (/gen-hw-selector selector)))
")"))))
)
(if default-selector? "" "ASI")
" ("
"current_cpu, pc, "
- (-gen-hw-index index estate)
+ (/gen-hw-index index estate)
(if default-selector?
""
(string-append ", "
- (-gen-hw-selector selector)))
+ (/gen-hw-selector selector)))
", " (cx:c newval) ");\n")))
)
(let ((index-mode (send hw 'get-index-mode)))
(if index-mode
(make <hw-index> 'anonymous 'str-expr index-mode
- (string-append access-macro " (" (-op-index-name op) ")"))
+ (string-append access-macro " (" (/op-index-name op) ")"))
(hw-index-scalar)))))
)
; Return the name of the PAREXEC structure member holding a hardware index
; for operand OP.
-(define (-op-index-name op)
+(define (/op-index-name op)
(string-append (gen-sym op) "_idx")
)
; The result is a string of C code.
; FIXME:wip
-(define (-gen-hw-index-raw index estate)
+(define (/gen-hw-index-raw index estate)
(let ((type (hw-index:type index))
(mode (hw-index:mode index))
(value (hw-index:value index)))
(gen-extracted-ifld-value value)))
((operand) (cx:c (send value 'cxmake-get estate mode (op:index value)
(op:selector value) #f)))
- (else (error "-gen-hw-index-raw: invalid index:" index))))
+ (else (error "/gen-hw-index-raw: invalid index:" index))))
)
-; Same as -gen-hw-index-raw except used where speedups are possible.
+; Same as /gen-hw-index-raw except used where speedups are possible.
; e.g. doing array index calcs at extraction time.
-(define (-gen-hw-index index estate)
+(define (/gen-hw-index index estate)
(let ((type (hw-index:type index))
(mode (hw-index:mode index))
(value (hw-index:value index)))
((rtx) (rtl-c-with-estate estate mode value))
((ifield) (if (= (ifld-length value) 0)
""
- (cx:c (-cxmake-ifld-val mode value))))
+ (cx:c (/cxmake-ifld-val mode value))))
((operand) (cx:c (send value 'cxmake-get estate mode (op:index value)
(op:selector value))))
- (else (error "-gen-hw-index: invalid index:" index))))
+ (else (error "/gen-hw-index: invalid index:" index))))
)
; Return address where HW is stored.
-(define (-gen-hw-addr hw estate index)
+(define (/gen-hw-addr hw estate index)
(let ((setter (hw-setter hw)))
(cond ((and (hw-cache-addr? hw) ; FIXME: redo test
(eq? 'ifield (hw-index:type index)))
(obj-cons-attr! xmode (bool-attr-make 'FORCE-C #t))
xmode)
mode)
- (-gen-hw-index self estate))))
+ (/gen-hw-index self estate))))
)
\f
; Hardware selector support code.
; Generate C code for SEL.
-(define (-gen-hw-selector sel)
+(define (/gen-hw-selector sel)
(rtl-c 'INT sel nil)
)
\f
;(method-make!
; <pc> 'gen-set-quiet
; (lambda (self estate mode index selector newval)
-; (-op-gen-set-quiet self estate mode index selector newval)))
+; (/op-gen-set-quiet self estate mode index selector newval)))
;(method-make!
; <pc> 'gen-set-trace
; (lambda (self estate mode index selector newval)
-; (-op-gen-set-trace self estate mode index selector newval)))
+; (/op-gen-set-trace self estate mode index selector newval)))
; Name of C macro to access parallel execution operand support.
-(define -par-operand-macro "OPRND")
+(define /par-operand-macro "OPRND")
; Return C code to fetch an operand's value and save it away for the
; semantic handler. This is used to handle parallel execution of several
(define (op:read op sfmt)
(let ((estate (estate-make-for-normal-rtl-c nil nil)))
- (send op 'gen-read estate sfmt -par-operand-macro))
+ (send op 'gen-read estate sfmt /par-operand-macro))
)
; Return C code to write an operand's value.
(define (op:write op sfmt)
(let ((estate (estate-make-for-normal-rtl-c nil nil)))
- (send op 'gen-write estate sfmt -par-operand-macro))
+ (send op 'gen-write estate sfmt /par-operand-macro))
)
; Default gen-read method.
(send (op:type self) 'cxmake-get-raw estate mode index selector))
((with-parallel-read?)
(cx:make-with-atlist mode
- (string-append -par-operand-macro
+ (string-append /par-operand-macro
" (" (gen-sym self) ")")
nil)) ; FIXME: want CACHED attr if present
((op:getter self)
; Utilities to implement gen-set-quiet/gen-set-trace.
-(define (-op-gen-set-quiet op estate mode index selector newval)
+(define (/op-gen-set-quiet op estate mode index selector newval)
(send (op:type op) 'gen-set-quiet estate mode index selector newval)
)
; Return C code to call the appropriate queued-write handler.
; ??? wip
-(define (-op-gen-queued-write op estate mode index selector newval)
+(define (/op-gen-queued-write op estate mode index selector newval)
(let* ((hw (op:type op))
(setter (hw-setter hw))
(sem-mode (mode:sem-mode mode)))
(cond ((hw-scalar? hw)
"")
(setter
- (string-append ", " (-gen-hw-index index estate)))
+ (string-append ", " (/gen-hw-index index estate)))
((memory? hw)
- (string-append ", " (-gen-hw-index index estate)))
+ (string-append ", " (/gen-hw-index index estate)))
(else
- (string-append ", " (-gen-hw-addr (op:type op) estate index))))
+ (string-append ", " (/gen-hw-addr (op:type op) estate index))))
", "
newval
");\n"))
)
-(define (-op-gen-set-quiet-parallel op estate mode index selector newval)
+(define (/op-gen-set-quiet-parallel op estate mode index selector newval)
(if (with-generic-write?)
- (-op-gen-queued-write op estate mode index selector (cx:c newval))
+ (/op-gen-queued-write op estate mode index selector (cx:c newval))
(string-append
(if (op-save-index? op)
(string-append " "
- -par-operand-macro " (" (-op-index-name op) ")"
- " = " (-gen-hw-index index estate) ";\n")
+ /par-operand-macro " (" (/op-index-name op) ")"
+ " = " (/gen-hw-index index estate) ";\n")
"")
" "
- -par-operand-macro " (" (gen-sym op) ")"
+ /par-operand-macro " (" (gen-sym op) ")"
" = " (cx:c newval) ";\n"))
)
-(define (-op-gen-set-trace op estate mode index selector newval)
+(define (/op-gen-set-trace op estate mode index selector newval)
(string-append
" {\n"
" " (mode:c-type mode) " opval = " (cx:c newval) ";\n"
" }\n")
)
-(define (-op-gen-set-trace-parallel op estate mode index selector newval)
+(define (/op-gen-set-trace-parallel op estate mode index selector newval)
(string-append
" {\n"
" " (mode:c-type mode) " opval = " (cx:c newval) ";\n"
(if (with-generic-write?)
- (-op-gen-queued-write op estate mode index selector "opval")
+ (/op-gen-queued-write op estate mode index selector "opval")
(string-append
(if (op-save-index? op)
(string-append " "
- -par-operand-macro " (" (-op-index-name op) ")"
- " = " (-gen-hw-index index estate) ";\n")
+ /par-operand-macro " (" (/op-index-name op) ")"
+ " = " (/gen-hw-index index estate) ";\n")
"")
- " " -par-operand-macro " (" (gen-sym op) ")"
+ " " /par-operand-macro " (" (gen-sym op) ")"
" = opval;\n"))
(if (op:cond? op)
(string-append " written |= (1 << "
(cond ((obj-has-attr? self 'RAW)
(send (op:type self) 'gen-set-quiet-raw estate mode index selector newval))
((with-parallel-write?)
- (-op-gen-set-quiet-parallel self estate mode index selector newval))
+ (/op-gen-set-quiet-parallel self estate mode index selector newval))
(else
- (-op-gen-set-quiet self estate mode index selector newval)))))
+ (/op-gen-set-quiet self estate mode index selector newval)))))
)
; Return C code to set the value of an operand and print TRACE_RESULT message.
(cond ((obj-has-attr? self 'RAW)
(send (op:type self) 'gen-set-quiet-raw estate mode index selector newval))
((with-parallel-write?)
- (-op-gen-set-trace-parallel self estate mode index selector newval))
+ (/op-gen-set-trace-parallel self estate mode index selector newval))
(else
- (-op-gen-set-trace self estate mode index selector newval)))))
+ (/op-gen-set-trace self estate mode index selector newval)))))
)
; Define and undefine C macros to tuck away details of instruction format used
; similar thing done for extraction/semantic functions.
(define (gen-define-parallel-operand-macro sfmt)
- (string-append "#define " -par-operand-macro "(f) "
+ (string-append "#define " /par-operand-macro "(f) "
"par_exec->operands."
(gen-sym sfmt)
".f\n")
)
(define (gen-undef-parallel-operand-macro sfmt)
- (string-append "#undef " -par-operand-macro "\n")
+ (string-append "#undef " /par-operand-macro "\n")
)
\f
; Operand profiling and parallel execution support.
; Return C code to declare the machine data.
-(define (-gen-mach-decls)
+(define (/gen-mach-decls)
(string-append
(string-map (lambda (mach)
(gen-obj-sanitize mach
; Return C code to define the machine data.
-(define (-gen-mach-data)
+(define (/gen-mach-data)
(string-append
"const MACH *sim_machs[] =\n{\n"
(string-map (lambda (mach)
; Return C declarations of cpu model support stuff.
; ??? This goes in arch.h but a better place is each cpu.h.
-(define (-gen-arch-model-decls)
+(define (/gen-arch-model-decls)
(string-append
(gen-enum-decl 'model_type "model types"
"MODEL_"
; ARGBUF support is put in cpuall.h, which doesn't depend on sim-cpu.scm,
; so this support is here.
-; Utility of -gen-argbuf-fields-union to generate the definition for
+; Utility of /gen-argbuf-fields-union to generate the definition for
; <sformat-abuf> SBUF.
-(define (-gen-argbuf-elm sbuf)
+(define (/gen-argbuf-elm sbuf)
(logit 2 "Processing sbuf format " (obj:name sbuf) " ...\n")
(string-list
" struct { /* " (obj:comment sbuf) " */\n"
; Utility of gen-argbuf-type to generate the union of extracted ifields.
-(define (-gen-argbuf-fields-union)
+(define (/gen-argbuf-fields-union)
(string-list
"\
/* Instruction argument buffer. */
union sem_fields {\n"
- (string-list-map -gen-argbuf-elm (current-sbuf-list))
+ (string-list-map /gen-argbuf-elm (current-sbuf-list))
"\
#if WITH_SCACHE_PBB
/* Writeback handler. */
(logit 2 "Generating ARGBUF type ...\n")
(string-list
(if (and cpu-data? (with-scache?))
- (-gen-argbuf-fields-union)
+ (/gen-argbuf-fields-union)
"")
(if cpu-data? "" "#ifndef WANT_CPU\n")
"\
; .cpu file loading support
; Only run sim-analyze-insns! once.
-(define -sim-insns-analyzed? #f)
+(define /sim-insns-analyzed? #f)
; List of computed sformat argument buffers.
-(define -sim-sformat-abuf-list #f)
-(define (current-sbuf-list) -sim-sformat-abuf-list)
+(define /sim-sformat-abuf-list #f)
+(define (current-sbuf-list) /sim-sformat-abuf-list)
; Called before/after the .cpu file has been read in.
(define (sim-init!)
- (set! -sim-insns-analyzed? #f)
- (set! -sim-sformat-abuf-list #f)
+ (set! /sim-insns-analyzed? #f)
+ (set! /sim-sformat-abuf-list #f)
*UNSPECIFIED*
)
-;; Subroutine of -create-virtual-insns!.
+;; Subroutine of /create-virtual-insns!.
;; Add virtual insn INSN to the database.
;; We put virtual insns ahead of normal insns because they're kind of special,
;; and it helps to see them first in lists.
;; ORDINAL is a used to place the insn ahead of normal insns;
;; it is a pair so we can do the update for the next virtual insn here.
-(define (-virtual-insn-add! ordinal insn)
+(define (/virtual-insn-add! ordinal insn)
(obj-set-ordinal! insn (cdr ordinal))
(current-insn-add! insn)
(set-cdr! ordinal (- (cdr ordinal) 1))
; Create the virtual insns.
-(define (-create-virtual-insns!)
+(define (/create-virtual-insns!)
(let ((all (all-isas-attr-value))
(context (make-prefix-context "virtual insns"))
- ;; Record as a pair so -virtual-insn-add! can update it.
+ ;; Record as a pair so /virtual-insn-add! can update it.
(ordinal (cons #f -1)))
- (-virtual-insn-add!
+ (/virtual-insn-add!
ordinal
(insn-read context
'(name x-begin)
"))
))
- (-virtual-insn-add!
+ (/virtual-insn-add!
ordinal
(insn-read context
'(name x-chain)
"))
))
- (-virtual-insn-add!
+ (/virtual-insn-add!
ordinal
(insn-read context
'(name x-cti-chain)
"))
))
- (-virtual-insn-add!
+ (/virtual-insn-add!
ordinal
(insn-read context
'(name x-before)
"))
))
- (-virtual-insn-add!
+ (/virtual-insn-add!
ordinal
(insn-read context
'(name x-after)
"))
))
- (-virtual-insn-add!
+ (/virtual-insn-add!
ordinal
(insn-read context
'(name x-invalid)
; The code generators should first look for x-foo-@prefix@, then for x-foo.
; ??? This is good enough for the first pass. Will eventually need to use
; less C and more RTL.
- (-create-virtual-insns!)
+ (/create-virtual-insns!)
*UNSPECIFIED*
)
; This can only be done if one isa and one cpu family is being kept.
(assert-keep-one)
- (if (not -sim-insns-analyzed?)
+ (if (not /sim-insns-analyzed?)
(begin
(arch-analyze-insns! CURRENT-ARCH
#t) ; do analyze the semantics
; Compute the set of sformat argument buffers.
- (set! -sim-sformat-abuf-list (compute-sformat-argbufs! (current-sfmt-list)))
+ (set! /sim-sformat-abuf-list (compute-sformat-argbufs! (current-sfmt-list)))
- (set! -sim-insns-analyzed? #t)))
+ (set! /sim-insns-analyzed? #t)))
; Do our own error checking.
(assert (current-insn-lookup 'x-invalid))
; combined into one int to save space.
; ??? We assume there is at least one bool.
-(define (-gen-attr-accessors prefix attrs)
+(define (gen-attr-accessors prefix attrs)
(string-append
"/* " prefix " attribute accessor macros. */\n"
(string-map (lambda (attr)
; TOTAL-LENGTH is the total length of the value in VAL.
; BASE-VALUE is a C expression (string) containing the base part of the insn.
-(define (-gen-ifld-extract-base f total-length base-value)
+(define (/gen-ifld-extract-base f total-length base-value)
(let ((extraction
(string-append "EXTRACT_"
(if (current-arch-insn-lsb0?) "LSB0_" "MSB0_")
#:rtl-cover-fns? #f #:ifield-var? #t)))
)
-; Subroutine of -gen-ifld-extract-beyond to extract the relevant value
+; Subroutine of /gen-ifld-extract-beyond to extract the relevant value
; from WORD-NAME and move it into place.
-(define (-gen-extract-word word-name word-start word-length
+(define (/gen-extract-word word-name word-start word-length
field-start field-length
unsigned? lsb0?)
(let* ((word-end (+ word-start word-length))
; recording the rest of the insn, 32 bits at a time (with the last one
; containing whatever is left over).
-(define (-gen-ifld-extract-beyond f base-length total-length var-list)
+(define (/gen-ifld-extract-beyond f base-length total-length var-list)
; First compute the list of variables that contains pieces of the
; desired value.
(let ((start (+ (ifld-start f total-length) (ifld-word-offset f)))
lsb0?)
(loop (cdr var-list)
(cons "|"
- (cons (-gen-extract-word var-name
+ (cons (/gen-extract-word var-name
var-start
var-length
start length
(gen-sym f)
" = "
(if (adata-integral-insn? CURRENT-ARCH)
- (-gen-ifld-extract-base f total-length base-value)
+ (/gen-ifld-extract-base f total-length base-value)
(if (ifld-beyond-base? f base-length total-length)
- (-gen-ifld-extract-beyond f base-length total-length var-list)
- (-gen-ifld-extract-base f base-length base-value)))
+ (/gen-ifld-extract-beyond f base-length total-length var-list)
+ (/gen-ifld-extract-base f base-length base-value)))
";"
(if macro? " \\\n" "\n")
)
(gen-sym f)
)
-; Subroutine of gen-extract-ifields to compute arguments for -extract-chunk
+; Subroutine of gen-extract-ifields to compute arguments for /extract-chunk
; to extract values beyond the base insn.
; This is also used by gen-define-ifields to know how many vars are needed.
;
; help - without them we can only use heuristics (which must evolve).
; At least all the details are tucked away here.
-(define (-extract-chunk-specs base-length total-length alignment)
+(define (/extract-chunk-specs base-length total-length alignment)
(let ((chunk-length
(case alignment
; For the aligned and forced case split the insn up into base-insn
; Always fetch full CHUNK-LENGTH-sized chunks here,
; even if we don't actually need that many bytes.
; gen-ifetch only handles "normal" fetch sizes,
- ; and -gen-extract-word already knows how to find what
+ ; and /gen-extract-word already knows how to find what
; it needs if we give it too much.
(cons (cons start chunk-length)
result)))))
; Subfields are inserted before their corresponding multi-ifield as they
; are initialized in order.
-(define (-extract-insert-subfields iflds)
+(define (/extract-insert-subfields iflds)
(let loop ((result nil) (iflds iflds))
(cond ((null? iflds)
(reverse! result))
(let* ((base-length (if (adata-integral-insn? CURRENT-ARCH)
32
(state-base-insn-bitsize)))
- (chunk-specs (-extract-chunk-specs base-length total-length
+ (chunk-specs (/extract-chunk-specs base-length total-length
(current-arch-default-alignment))))
(string-list
(string-list-map (lambda (f)
(let ((macro-name (string-append
"EXTRACT_" (string-upcase (gen-sym ifmt))
"_VARS"))
- (ifields (-extract-insert-subfields (ifmt-ifields ifmt))))
+ (ifields (/extract-insert-subfields (ifmt-ifields ifmt))))
(if use-macro?
(string-list indent macro-name
" /*"
; Subroutine of gen-extract-ifields to fetch one value into VAR-NAME.
-(define (-extract-chunk offset bits var-name macro?)
+(define (/extract-chunk offset bits var-name macro?)
(string-append
" "
var-name
; variables holding the parts of the insn.
; CHUNK-SPECS is a list of (offset . length) pairs.
-(define (-gen-extract-beyond-var-list base-length var-prefix chunk-specs lsb0?)
+(define (/gen-extract-beyond-var-list base-length var-prefix chunk-specs lsb0?)
; ??? lsb0? support ok?
(cons (list "insn" 0 base-length)
(map (lambda (chunk-num chunk-spec)
(let* ((base-length (if (adata-integral-insn? CURRENT-ARCH)
32
(state-base-insn-bitsize)))
- (chunk-specs (-extract-chunk-specs base-length total-length
+ (chunk-specs (/extract-chunk-specs base-length total-length
(current-arch-default-alignment))))
(string-list
; If the insn has a trailing part, fetch it.
(if (> total-length base-length)
(let ()
(string-list-map (lambda (chunk-spec chunk-num)
- (-extract-chunk (car chunk-spec)
+ (/extract-chunk (car chunk-spec)
(cdr chunk-spec)
(string-append
"word_"
(if (multi-ifield? f)
(gen-multi-ifld-extract
f indent base-length total-length "insn"
- (-gen-extract-beyond-var-list base-length "word_"
+ (/gen-extract-beyond-var-list base-length "word_"
chunk-specs
(current-arch-insn-lsb0?))
macro?)
(gen-ifld-extract
f indent base-length total-length "insn"
- (-gen-extract-beyond-var-list base-length "word_"
+ (/gen-extract-beyond-var-list base-length "word_"
chunk-specs
(current-arch-insn-lsb0?))
macro?)))
(let ((macro-name (string-append
"EXTRACT_" (string-upcase (gen-sym ifmt))
"_CODE"))
- (ifields (-extract-insert-subfields (ifmt-ifields ifmt))))
+ (ifields (/extract-insert-subfields (ifmt-ifields ifmt))))
(if use-macro?
(string-list indent macro-name "\n")
(let ((indent (if macro? (string-append indent " ") indent)))
(define-getters <sformat-argbuf> sbuf (sfmts elms))
-; Subroutine of -sfmt-contents to return an ifield element.
+; Subroutine of /sfmt-contents to return an ifield element.
; The result is ("var-name" "C-type" bitsize).
-(define (-sfmt-ifld-elm f sfmt)
+(define (/sfmt-ifld-elm f sfmt)
(let ((real-mode (mode-real-mode (ifld-decode-mode f))))
(list (gen-sym f)
(mode:c-type real-mode)
64))
)
-; Subroutine of -sfmt-contents to return an operand element.
+; Subroutine of /sfmt-contents to return an operand element.
; These are in addition (or instead of) the actual ifields.
; This is also used to compute definitions of local vars needed in the
; !with-scache case.
; and is sorted by decreasing size, then C type, then variable name
; (as <sformat-argbuf> wants it).
-(define (-sfmt-contents sfmt)
+(define (/sfmt-contents sfmt)
(let ((needed-iflds (sfmt-needed-iflds sfmt))
(extracted-ops (sfmt-extracted-operands sfmt))
(in-ops (sfmt-in-ops sfmt))
#f))))
)
(logit 4
- "-sfmt-contents sfmt=" (obj:name sfmt)
+ "/sfmt-contents sfmt=" (obj:name sfmt)
" needed-iflds=" (string-map obj:str-name needed-iflds)
" extracted-ops=" (string-map obj:str-name extracted-ops)
" in-ops=" (string-map obj:str-name in-ops)
x)
(append
(map (lambda (f)
- (-sfmt-ifld-elm f sfmt))
+ (/sfmt-ifld-elm f sfmt))
needed-iflds)
(map (lambda (op)
(sfmt-op-sbuf-elm op sfmt))
; Return #t if ELM-LIST is a subset of SBUF.
; SBUF is an <sformat-argbuf> object.
-(define (-sbuf-subset? elm-list sbuf)
+(define (/sbuf-subset? elm-list sbuf)
; We take advantage of the fact that elements in each are already sorted.
; FIXME: Can speed up.
(let loop ((elm-list elm-list) (sbuf-elm-list (sbuf-elms sbuf)))
; SBUF-LIST is a list of <sformat-argbuf> objects.
; ELM-LIST is (elm1 elm2 ...).
-(define (-sbuf-lookup elm-list sbuf-list)
+(define (/sbuf-lookup elm-list sbuf-list)
(let loop ((sbuf-list sbuf-list))
(cond ((null? sbuf-list)
#f)
- ((-sbuf-subset? elm-list (car sbuf-list))
+ ((/sbuf-subset? elm-list (car sbuf-list))
(car sbuf-list))
(else
(loop (cdr sbuf-list)))))
; Sort by descending length. This helps building the result: while
; iterating over each element, its sbuf is either a subset of a
; previous entry or requires a new entry.
- (sort (map -sfmt-contents sfmt-list)
+ (sort (map /sfmt-contents sfmt-list)
(lambda (a b)
(> (length a) (length b)))))
; Build an <sformat-argbuf> object.
(let ((sfmt-data (car sfmt-contents)))
(if (null? (cdr sfmt-data))
(sfmt-set-sbuf! (car sfmt-data) empty-sbuf)
- (let ((sbuf (-sbuf-lookup (cdr sfmt-data) nub-sbufs)))
+ (let ((sbuf (/sbuf-lookup (cdr sfmt-data) nub-sbufs)))
(if (not sbuf)
(begin
(set! sbuf (build-sbuf sfmt-data))
(send (op:type self) 'sbuf-profile-data))))
)
-; Subroutine of -sfmt-contents to return an operand's profile element.
+; Subroutine of /sfmt-contents to return an operand's profile element.
; The result is (var-name "C-type" approx-bitsize) or #f if unneeded.
(define (sfmt-op-profile-elm op sfmt out?)
; Main procedure call tree:
; cgen-decode.{c,cxx}
-; -gen-decode-fn
+; /gen-decode-fn
; gen-decoder [our entry point]
; decode-build-table
-; -gen-decoder-switch
-; -gen-decoder-switch
+; /gen-decoder-switch
+; /gen-decoder-switch
;
; decode-build-table is called to construct a tree of "table-guts" elements
; (??? Need better name obviously),
; ENTIRE-VAL is passed as a hack for cgen 1.1 which would previously generate
; negative shifts. FIXME: Revisit for 1.2.
;
-; e.g. (-gen-decode-bits '(0 1 2 3 8 9 10 11) 0 16 "insn" #f)
+; e.g. (/gen-decode-bits '(0 1 2 3 8 9 10 11) 0 16 "insn" #f)
; --> "(((insn >> 8) & 0xf0) | ((insn >> 4) & 0xf))"
; FIXME: The generated code has some inefficiencies in edge cases. Later.
-(define (-gen-decode-bits bitnums start size val entire-val lsb0?)
+(define (/gen-decode-bits bitnums start size val entire-val lsb0?)
; Compute a list of lists of three numbers:
; (first bitnum in group, position in result (0=LSB), bits in result)
; Return code for the default entry of each switch table
;
-(define (-gen-decode-default-entry indent invalid-insn fn?)
+(define (/gen-decode-default-entry indent invalid-insn fn?)
(string-append
"itype = "
(gen-cpu-insn-enum (current-cpu) invalid-insn)
; Return code for one insn entry.
; REST is the remaining entries.
-(define (-gen-decode-insn-entry entry rest indent invalid-insn fn?)
+(define (/gen-decode-insn-entry entry rest indent invalid-insn fn?)
(assert (eq? 'insn (dtable-entry-type entry)))
(logit 3 "Generating decode insn entry for " (obj:name (dtable-entry-value entry)) " ...\n")
(string-append " goto extract_" fmt-name ";"))
" goto done;")
" }\n"
- indent " " (-gen-decode-default-entry indent invalid-insn fn?)))))
+ indent " " (/gen-decode-default-entry indent invalid-insn fn?)))))
)
-; Subroutine of -decode-expr-ifield-tracking.
+; Subroutine of /decode-expr-ifield-tracking.
; Return a list of all possible values for ifield IFLD-NAME.
; FIXME: Quick-n-dirty implementation. Should use bit arrays.
-(define (-decode-expr-ifield-values ifld-name)
+(define (/decode-expr-ifield-values ifld-name)
(let* ((ifld (current-ifld-lookup ifld-name))
(bits (ifld-length ifld)))
(if (mode-unsigned? (ifld-mode ifld))
(iota (logsll 1 bits) (- (logsll 1 (- bits 1))))))
)
-; Subroutine of -decode-expr-ifield-tracking,-decode-expr-ifield-mark-used.
+; Subroutine of /decode-expr-ifield-tracking,/decode-expr-ifield-mark-used.
; Create the search key for tracking table lookup.
-(define (-decode-expr-ifield-tracking-key insn ifld-name)
+(define (/decode-expr-ifield-tracking-key insn ifld-name)
(symbol-append (obj:name (insn-ifmt insn)) '-x- ifld-name)
)
-; Subroutine of -gen-decode-expr-entry.
+; Subroutine of /gen-decode-expr-entry.
; Return a table to track used ifield values.
; The table is an associative list of (key . value-list).
; KEY is "iformat-name-x-ifield-name".
; VALUE-LIST is a list of the unused values.
-(define (-decode-expr-ifield-tracking expr-list)
+(define (/decode-expr-ifield-tracking expr-list)
(let ((table1
(apply append
(map (lambda (entry)
(map (lambda (ifld-name)
(cons (exprtable-entry-insn entry)
(cons ifld-name
- (-decode-expr-ifield-values ifld-name))))
+ (/decode-expr-ifield-values ifld-name))))
(exprtable-entry-iflds entry)))
expr-list))))
; TABLE1 is a list of (insn ifld-name value1 value2 ...).
(nub (map (lambda (elm)
(cons
- (-decode-expr-ifield-tracking-key (car elm) (cadr elm))
+ (/decode-expr-ifield-tracking-key (car elm) (cadr elm))
(cddr elm)))
table1)
car))
)
-; Subroutine of -decode-expr-ifield-mark-used!.
+; Subroutine of /decode-expr-ifield-mark-used!.
; Return list of values completely used for ifield IFLD-NAME in EXPR.
; "completely used" here means the value won't appear elsewhere.
; e.g. in (andif (eq f-rd 15) (eq f-rx 14)) we don't know what happens
; for the (ne f-rx 14) case.
-(define (-decode-expr-ifield-values-used ifld-name expr)
+(define (/decode-expr-ifield-values-used ifld-name expr)
(case (rtx-name expr)
((eq)
(if (and (rtx-kind? 'ifield (rtx-cmp-op-arg expr 0))
(else nil))
)
-; Subroutine of -gen-decode-expr-entry.
+; Subroutine of /gen-decode-expr-entry.
; Mark ifield values used by EXPR-ENTRY in TRACKING-TABLE.
-(define (-decode-expr-ifield-mark-used! tracking-table expr-entry)
+(define (/decode-expr-ifield-mark-used! tracking-table expr-entry)
(let ((insn (exprtable-entry-insn expr-entry))
(expr (exprtable-entry-expr expr-entry))
(ifld-names (exprtable-entry-iflds expr-entry)))
(for-each (lambda (ifld-name)
(let ((table-entry
- (assq (-decode-expr-ifield-tracking-key insn ifld-name)
+ (assq (/decode-expr-ifield-tracking-key insn ifld-name)
tracking-table))
- (used (-decode-expr-ifield-values-used ifld-name expr)))
+ (used (/decode-expr-ifield-values-used ifld-name expr)))
(for-each (lambda (value)
(delq! value table-entry))
used)
*UNSPECIFIED*
)
-; Subroutine of -gen-decode-expr-entry.
+; Subroutine of /gen-decode-expr-entry.
; Return code to set `itype' and branch to the extraction phase.
-(define (-gen-decode-expr-set-itype indent insn-enum fmt-name fn?)
+(define (/gen-decode-expr-set-itype indent insn-enum fmt-name fn?)
(string-append
indent
"{ itype = "
; Generate code to decode the expression table in ENTRY.
; INVALID-INSN is the <insn> object of the pseudo insn to handle invalid ones.
-(define (-gen-decode-expr-entry entry indent invalid-insn fn?)
+(define (/gen-decode-expr-entry entry indent invalid-insn fn?)
(assert (eq? 'expr (dtable-entry-type entry)))
(logit 3 "Generating decode expr entry for " (exprtable-name (dtable-entry-value entry)) " ...\n")
(number->string (dtable-entry-index entry))
" :\n"
- (let ((iflds-tracking (-decode-expr-ifield-tracking expr-list))
+ (let ((iflds-tracking (/decode-expr-ifield-tracking expr-list))
(indent (string-append indent " ")))
(let loop ((expr-list expr-list) (code nil))
code
(append! code
(list
- (-gen-decode-expr-set-itype
+ (/gen-decode-expr-set-itype
indent
(gen-cpu-insn-enum (current-cpu) invalid-insn)
"sfmt_empty"
; Mark of those ifield values we use first.
; If there are none left afterwards, we can unconditionally
; choose this insn.
- (-decode-expr-ifield-mark-used! iflds-tracking (car expr-list))
+ (/decode-expr-ifield-mark-used! iflds-tracking (car expr-list))
(let ((next-code
; If this is the last expression, and it uses up all
; Need this in a list for a later append!.
(string-list
- (-gen-decode-expr-set-itype
+ (/gen-decode-expr-set-itype
indent
(gen-cpu-insn-enum (current-cpu) insn)
(gen-sym (insn-sfmt insn))
indent " if ("
(rtl-c 'BI expr nil #:ifield-var? #t)
")\n"
- (-gen-decode-expr-set-itype
+ (/gen-decode-expr-set-itype
(string-append indent " ")
(gen-cpu-insn-enum (current-cpu) insn)
(gen-sym (insn-sfmt insn))
; Generate code to decode TABLE.
; REST is the remaining entries.
; SWITCH-NUM, STARTBIT, DECODE-BITSIZE, INDENT, LSB0?, INVALID-INSN are same
-; as for -gen-decoder-switch.
+; as for /gen-decoder-switch.
-(define (-gen-decode-table-entry table rest switch-num startbit decode-bitsize indent lsb0? invalid-insn fn?)
+(define (/gen-decode-table-entry table rest switch-num startbit decode-bitsize indent lsb0? invalid-insn fn?)
(assert (eq? 'table (dtable-entry-type table)))
(logit 3 "Generating decode table entry for case " (dtable-entry-index table) " ...\n")
" /* fall through */\n"
(string-list
"\n"
- (-gen-decoder-switch switch-num
+ (/gen-decoder-switch switch-num
startbit
decode-bitsize
(subdtable-table (dtable-entry-value table))
fn?))))
)
-; Subroutine of -decode-sort-entries.
+; Subroutine of /decode-sort-entries.
; Return a boolean indicating if A,B are equivalent entries.
-(define (-decode-equiv-entries? a b)
+(define (/decode-equiv-entries? a b)
(let ((a-type (dtable-entry-type a))
(b-type (dtable-entry-type b)))
(if (eq? a-type b-type)
#f))
)
-; Subroutine of -gen-decoder-switch, sort ENTRIES according to desired
+; Subroutine of /gen-decoder-switch, sort ENTRIES according to desired
; print order (maximizes amount of fall-throughs, but maintains numerical
; order as much as possible).
; ??? This is an O(n^2) algorithm. An O(n Log(n)) algorithm can be done
; but it seemed more complicated than necessary for now.
-(define (-decode-sort-entries entries)
+(define (/decode-sort-entries entries)
(let ((find-equiv!
; Return list of entries in non-empty list L that have the same decode
; entry as the first entry. Entries found are marked with #f so
(let loop ((l (cdr l)) (result (cons first nil)))
(if (null? l)
(reverse! result)
- (if (and (car l) (-decode-equiv-entries? first (car l)))
+ (if (and (car l) (/decode-equiv-entries? first (car l)))
(let ((lval (car l)))
(set-car! l #f)
(loop (cdr l) (cons lval result)))
; else {}
; may well be less stressful on the compiler to optimize than small switch() stmts.
-(define (-gen-decoder-switch switch-num startbit decode-bitsize table-guts
+(define (/gen-decoder-switch switch-num startbit decode-bitsize table-guts
indent lsb0? invalid-insn fn?)
; For entries that are a single insn, we're done, otherwise recurse.
";\n"
indent " val = "))
(string-append indent " unsigned int val = "))
- (-gen-decode-bits (dtable-guts-bitnums table-guts)
+ (/gen-decode-bits (dtable-guts-bitnums table-guts)
(dtable-guts-startbit table-guts)
(dtable-guts-bitsize table-guts)
"insn" "entire_insn" lsb0?)
; The code is more readable, and icache use is improved, if we collapse
; common code into one case and use "fall throughs" for all but the last of
; a set of common cases.
- ; FIXME: We currently rely on -gen-decode-foo-entry to recognize the fall
+ ; FIXME: We currently rely on /gen-decode-foo-entry to recognize the fall
; through. We should take care of it ourselves.
- (let loop ((entries (-decode-sort-entries (dtable-guts-entries table-guts)))
+ (let loop ((entries (/decode-sort-entries (dtable-guts-entries table-guts)))
(result nil))
(if (null? entries)
(reverse! result)
(cdr entries)
(cons (case (dtable-entry-type (car entries))
((insn)
- (-gen-decode-insn-entry (car entries) (cdr entries) indent invalid-insn fn?))
+ (/gen-decode-insn-entry (car entries) (cdr entries) indent invalid-insn fn?))
((expr)
- (-gen-decode-expr-entry (car entries) indent invalid-insn fn?))
+ (/gen-decode-expr-entry (car entries) indent invalid-insn fn?))
((table)
- (-gen-decode-table-entry (car entries) (cdr entries)
+ (/gen-decode-table-entry (car entries) (cdr entries)
switch-num startbit decode-bitsize
indent lsb0? invalid-insn fn?))
)
; ??? Can delete if all cases are present.
indent " default : "
- (-gen-decode-default-entry indent invalid-insn fn?)
+ (/gen-decode-default-entry indent invalid-insn fn?)
indent " }\n"
indent "}\n"
)
; Now print it out.
- (-gen-decoder-switch "0" 0 decode-bitsize table-guts indent lsb0?
+ (/gen-decoder-switch "0" 0 decode-bitsize table-guts indent lsb0?
invalid-insn fn?)
)
)
; Extension to the current-output-port.
; Only valid inside string-write.
-(define -current-print-state #f)
+(define /current-print-state #f)
; Create a print-state object.
; This is written in portable Scheme so we don't use COS objects, etc.
(define string-write
(lambda strings
(let ((pstate (make-print-state)))
- (set! -current-print-state pstate)
- (for-each (lambda (elm) (-string-write pstate elm))
+ (set! /current-print-state pstate)
+ (for-each (lambda (elm) (/string-write pstate elm))
strings)
- (set! -current-print-state #f)
+ (set! /current-print-state #f)
""))
)
; Subroutine of string-write and string-write-map.
-(define (-string-write pstate expr)
+(define (/string-write pstate expr)
(cond ((string? expr) (display expr)) ; not write, we want raw text
((symbol? expr) (display expr))
- ((procedure? expr) (-string-write pstate (expr)))
+ ((procedure? expr) (/string-write pstate (expr)))
((pstate-cmd? expr) (display (pstate-cmd-do pstate expr)))
- ((list? expr) (for-each (lambda (x) (-string-write pstate x)) expr))
+ ((list? expr) (for-each (lambda (x) (/string-write pstate x)) expr))
(else (error "string-write: bad arg:" expr)))
*UNSPECIFIED*
)
; Combination of string-map and string-write.
(define (string-write-map proc arglist)
- (let ((pstate -current-print-state))
- (for-each (lambda (arg) (-string-write pstate (proc arg)))
+ (let ((pstate /current-print-state))
+ (for-each (lambda (arg) (/string-write pstate (proc arg)))
arglist))
""
)
(define string-list list)
(define string-list-map map)
-; Subroutine of string-list->string. Does same thing -string-write does.
+; Subroutine of string-list->string. Does same thing /string-write does.
-(define (-string-list-flatten pstate strlist)
+(define (/string-list-flatten pstate strlist)
(cond ((string? strlist) strlist)
((symbol? strlist) strlist)
- ((procedure? strlist) (-string-list-flatten pstate (strlist)))
+ ((procedure? strlist) (/string-list-flatten pstate (strlist)))
((pstate-cmd? strlist) (pstate-cmd-do pstate strlist))
((list? strlist) (apply string-append
(map (lambda (str)
- (-string-list-flatten pstate str))
+ (/string-list-flatten pstate str))
strlist)))
(else (error "string-list->string: bad arg:" strlist)))
)
; Flatten out a string list.
(define (string-list->string strlist)
- (-string-list-flatten (make-print-state) strlist)
+ (/string-list-flatten (make-print-state) strlist)
)
\f
; Prefix CHARS, a string of characters, with backslash in STR.
OSDN Git Service
