1(define-syntax architecture
2  (let ([fn (format "~a.ss" (constant architecture))])
3    (with-source-path 'architecture fn
4      (lambda (fn)
5        (let* ([p ($open-file-input-port 'include fn)]
6               [sfd ($source-file-descriptor fn p)]
7               [p (transcoded-port p (current-transcoder))])
8          (let ([do-read ($make-read p sfd 0)])
9            (let* ([regs (do-read)] [inst (do-read)] [asm (do-read)])
10              (when (eof-object? asm) ($oops #f "too few expressions in ~a" fn))
11              (unless (eof-object? (do-read)) ($oops #f "too many expressions in ~a" fn))
12              (close-input-port p)
13              (lambda (x)
14                (syntax-case x (registers instructions assembler)
15                  [(k registers) (datum->syntax #'k regs)]
16                  [(k instructions) (datum->syntax #'k inst)]
17                  [(k assembler) (datum->syntax #'k asm)])))))))))
18
19(define-syntax define-reserved-registers
20  (lambda (x)
21    (syntax-case x ()
22      [(_ [regid alias ... callee-save? mdinfo type] ...)
23       (syntax-case #'(regid ...) (%tc %sfp) [(%tc %sfp . others) #t] [_ #f])
24       #'(begin
25           (begin
26             (define-once regid (make-reg 'regid 'mdinfo (tc-disp regid) callee-save? 'type))
27             (module (alias ...) (define x regid) (define alias x) ...))
28           ...)])))
29
30(define-syntax define-register-aliases
31  (syntax-rules ()
32    [(_ regid reg-alias ...) (begin (define reg-alias regid) ...)]))
33
34(define-syntax define-allocable-registers
35  (lambda (x)
36    (assert (fx<= (constant asm-arg-reg-cnt) (constant asm-arg-reg-max)))
37    (syntax-case x ()
38      [(_ regvec arg-registers extra-registers extra-fpregisters make-reg-spillinfo
39          [regid reg-alias ... callee-save? mdinfo type] ...)
40       (with-syntax ([((tc-disp ...) (arg-regid ...) (extra-regid ...) (extra-fpregid ...))
41                      (syntax-case #'([regid type] ...) (%ac0 %xp %ts %td uptr)
42                        [([%ac0 _] [%xp _] [%ts _] [%td _] [other other-type] ...)
43                         (let f ([other* #'(other ...)]
44                                 [other-type* #'(other-type ...)]
45                                 [rtc-disp* '()]
46                                 [arg-offset (constant tc-arg-regs-disp)]
47                                 [fp-offset (constant tc-fpregs-disp)]
48                                 [rextra* '()]
49                                 [rfpextra* '()])
50                           (if (null? other*)
51                               (cond
52                                 [(not (fx= (length rextra*) (constant asm-arg-reg-max)))
53                                  (syntax-error x (format "asm-arg-reg-max extra registers are not specified ~s" (syntax->datum rextra*)))]
54                                 [(not (fx= (length rfpextra*) (constant asm-fpreg-max)))
55                                  (syntax-error x (format "asm-fpreg-max extra registers are not specified ~s" (syntax->datum rfpextra*)))]
56                                 [else
57                                   (let ([extra* (reverse rextra*)]
58                                         [fpextra* (reverse rfpextra*)])
59                                     (list
60                                       (list*
61                                         (constant tc-ac0-disp)
62                                         (constant tc-xp-disp)
63                                         (constant tc-ts-disp)
64                                         (constant tc-td-disp)
65                                         (reverse rtc-disp*))
66                                       (list-head extra* (constant asm-arg-reg-cnt))
67                                       (list-tail extra* (constant asm-arg-reg-cnt))
68                                       fpextra*))])
69                               (let ([other (car other*)])
70                                 (if (memq (syntax->datum other) '(%ac1 %yp %cp %ret))
71                                     (f (cdr other*) (cdr other-type*) (cons #`(tc-disp #,other) rtc-disp*)
72                                        arg-offset fp-offset rextra* rfpextra*)
73                                     (if (eq? (syntax->datum (car other-type*)) 'fp)
74                                         (f (cdr other*) (cdr other-type*) (cons fp-offset rtc-disp*)
75                                            arg-offset (fx+ fp-offset (constant double-bytes)) rextra* (cons other rfpextra*))
76                                         (f (cdr other*) (cdr other-type*) (cons arg-offset rtc-disp*)
77                                            (fx+ arg-offset (constant ptr-bytes)) fp-offset (cons other rextra*) rfpextra*))))))]
78                        [_ (syntax-error x "missing or out-of-order required registers")])]
79                     [(reg-spillinfo-index ...) (iota (length #'(regid ...)))])
80         #'(begin
81             (define-once regid (let ([r (make-reg 'regid 'mdinfo tc-disp callee-save? 'type)])
82                                  (var-spillinfo-redirect! r reg-spillinfo-index)
83                                  r))
84             ...
85             (define-register-aliases regid reg-alias ...) ...
86             (define regvec (vector regid ...))
87             (define arg-registers (list arg-regid ...))
88             (define extra-registers (list extra-regid ...))
89             (define extra-fpregisters (list extra-fpregid ...))
90             (define (make-reg-spillinfo)
91               (vector (make-redirect-var 'regid)
92                       ...))))])))
93
94(define-syntax define-machine-dependent-registers
95  (lambda (x)
96    (syntax-case x ()
97      [(_ [regid alias ... callee-save? mdinfo type] ...)
98       #'(begin
99           (begin
100             (define-once regid (make-reg 'regid 'mdinfo #f callee-save? 'type))
101             (module (alias ...) (define x regid) (define alias x) ...))
102           ...)])))
103
104(define-syntax define-registers
105  (lambda (x)
106    (syntax-case x (reserved allocable machine-dependent)
107      [(k (reserved [rreg rreg-alias ... rreg-callee-save? rreg-mdinfo rreg-type] ...)
108          (allocable [areg areg-alias ... areg-callee-save? areg-mdinfo areg-type] ...)
109          (machine-depdendent [mdreg mdreg-alias ... mdreg-callee-save? mdreg-mdinfo mdreg-type] ...))
110       (with-implicit (k regvec arg-registers extra-registers extra-fpregisters real-register? make-reg-spillinfo)
111         #`(begin
112             (define-reserved-registers [rreg rreg-alias ... rreg-callee-save? rreg-mdinfo rreg-type] ...)
113             (define-allocable-registers regvec arg-registers extra-registers extra-fpregisters make-reg-spillinfo
114               [areg areg-alias ... areg-callee-save? areg-mdinfo areg-type] ...)
115             (define-machine-dependent-registers [mdreg mdreg-alias ... mdreg-callee-save? mdreg-mdinfo mdreg-type] ...)
116             (define-syntax real-register?
117               (with-syntax ([real-reg* #''(rreg ... rreg-alias ... ... areg ... areg-alias ... ... mdreg ... mdreg-alias ... ...)])
118                 (syntax-rules ()
119                   [(_ e) (memq e real-reg*)])))))])))
120
121(architecture registers)
122
123; pseudo register used for mref's with no actual index
124(define-once %zero (make-reg 'zero #f #f #f #f))
125
126;; define %ref-ret to be sfp[0] on machines w/no ret register
127;;
128;; The ret register, if any, is used to pass a return address to a
129;; function. All functions currently stash the ret register in
130;; sfp[0] and return to sfp[0] instead of the ret register, so the
131;; register doesn't have to be saved and restored for non-tail
132;; calls --- so use sfp[0] instead of the ret registerr to refer
133;; to the current call's return address. (A leaf procedure could
134;; do better, but doesn't currently.)
135(define-syntax %ref-ret
136  (lambda (x)
137    (meta-cond
138      [(real-register? '%ret) #'%ret]
139      [else (with-syntax ([%mref (datum->syntax x '%mref)])
140              #'(%mref ,%sfp 0))])))
141
142(define-syntax reg-cons*
143  (lambda (x)
144    (syntax-case x ()
145      [(_ ?reg ... ?reg*)
146       (fold-right
147         (lambda (reg reg*)
148           (cond
149             [(real-register? (syntax->datum reg))
150              #`(cons #,reg #,reg*)]
151             [else reg*]))
152         #'?reg* #'(?reg ...))])))
153
154(define-syntax reg-list
155  (syntax-rules ()
156    [(_ ?reg ...) (reg-cons* ?reg ... '())]))
157
158(define-syntax with-saved-ret-reg
159  (lambda (x)
160    (syntax-case x ()
161      [(k ?e)
162       (if (real-register? '%ret)
163           (with-implicit (k %seq %mref)
164             #'(%seq
165                 (set! ,(%mref ,%sfp 0) ,%ret)
166                 ,?e
167                 (set! ,%ret ,(%mref ,%sfp 0))))
168           #'?e)])))
169