Commit 3c058c76 authored by wlott's avatar wlott
Browse files

Explicity frob on *target-backend* at meta compile time instead of assuming

some sort of macroexpand/eval-when magic.  Also deposit templates in the
info-environment from *target-backend* instead of the default info env (if,
of course, there is one).
parent 1e8d3d25
......@@ -61,12 +61,12 @@
(defun meta-sc-or-lose (x)
(the sc
(or (gethash x (backend-meta-sc-names *backend*))
(or (gethash x (backend-meta-sc-names *target-backend*))
(error "~S is not a defined storage class." x))))
(defun meta-sb-or-lose (x)
(the sb
(or (gethash x (backend-meta-sb-names *backend*))
(or (gethash x (backend-meta-sb-names *target-backend*))
(error "~S is not a defined storage base." x))))
(defun meta-sc-number-or-lose (x)
......@@ -105,9 +105,10 @@
(make-finite-sb :name name :kind kind :size size))))
(eval-when (compile load eval)
(setf (gethash ',name (backend-meta-sb-names *backend*)) ',res))
(setf (gethash ',name (backend-meta-sb-names *target-backend*))
,(if (eq kind :non-packed)
`(setf (gethash ',name (backend-sb-names *backend*))
`(setf (gethash ',name (backend-sb-names *target-backend*))
(copy-sb ',res))
`(let ((res (copy-finite-sb ',res)))
(setf (finite-sb-always-live res)
......@@ -116,11 +117,12 @@
(make-array ',size :initial-element '#()))
(setf (finite-sb-live-tns res)
(make-array ',size :initial-element nil))
(setf (gethash ',name (backend-sb-names *backend*)) res)))
(setf (gethash ',name (backend-sb-names *target-backend*))
(setf (backend-sb-list *backend*)
(setf (backend-sb-list *target-backend*)
(cons (sb-or-lose ',name)
(remove ',name (backend-sb-list *backend*)
(remove ',name (backend-sb-list *target-backend*)
:key #'sb-name)))
......@@ -203,17 +205,19 @@
:constant-scs (mapcar #'meta-sc-or-lose
(setf (gethash ',name (backend-meta-sc-names *backend*)) res)
(setf (svref (backend-meta-sc-numbers *backend*) ',number) res)
(setf (gethash ',name (backend-meta-sc-names *target-backend*)) res)
(setf (svref (backend-meta-sc-numbers *target-backend*) ',number)
(setf (svref (sc-load-costs res) ',number) 0)))
(let ((old (svref (backend-sc-numbers *backend*) ',number)))
(let ((old (svref (backend-sc-numbers *target-backend*) ',number)))
(when (and old (not (eq (sc-name old) ',name)))
(warn "Redefining SC number ~D from ~S to ~S." ',number
(sc-name old) ',name)))
(setf (svref (backend-sc-numbers *backend*) ',number) (meta-sc-or-lose ',name))
(setf (gethash ',name (backend-sc-names *backend*))
(setf (svref (backend-sc-numbers *target-backend*) ',number)
(meta-sc-or-lose ',name))
(setf (gethash ',name (backend-sc-names *target-backend*))
(meta-sc-or-lose ',name))
(setf (sc-sb (sc-or-lose ',name)) (sb-or-lose ',sb-name))
......@@ -345,7 +349,7 @@
(defun meta-primitive-type-or-lose (name)
(the primitive-type
(or (gethash name (backend-meta-primitive-type-names *backend*))
(or (gethash name (backend-meta-primitive-type-names *target-backend*))
(error "~S is not a defined primitive type." name))))
); eval-when
......@@ -372,11 +376,13 @@
(get-type `(specifier-type ',type)))
(eval-when (compile load eval)
(setf (gethash ',name (backend-meta-primitive-type-names *backend*))
(setf (gethash ',name (backend-meta-primitive-type-names
(make-primitive-type :name ',name :scs ',scns
:type ,get-type)))
,(once-only ((n-old `(gethash ',name
(backend-primitive-type-names *backend*)))
(n-type get-type))
(cond (,n-old
......@@ -384,7 +390,8 @@
(setf (primitive-type-type ,n-old) ,n-type))
(setf (gethash ',name
(backend-primitive-type-names *backend*))
(make-primitive-type :name ',name :scs ',scns
:type ,n-type))))
......@@ -398,7 +405,7 @@
Define name to be an alias for Result in VOP operand type restrictions."
`(eval-when (compile load eval)
(setf (gethash ',name (backend-primitive-type-aliases *backend*))
(setf (gethash ',name (backend-primitive-type-aliases *target-backend*))
......@@ -449,12 +456,13 @@
(dolist (allowed (primitive-type-scs ptype) nil)
(when (eql allowed scn)
(return t))
(let ((allowed-sc (svref (,sc-numbers-fun *backend*) allowed)))
(let ((allowed-sc (svref ,sc-numbers-fun allowed)))
(when (or (member sc (sc-alternate-scs allowed-sc))
(member sc (sc-constant-scs allowed-sc)))
(return t)))))))))
(frob sc-allowed-by-primitive-type backend-sc-numbers nil)
(frob meta-sc-allowed-by-primitive-type backend-meta-sc-numbers t))
(frob sc-allowed-by-primitive-type (backend-sc-numbers *backend*) nil)
(frob meta-sc-allowed-by-primitive-type
(backend-meta-sc-numbers *target-backend*) t))
;;;; VOP definition structures:
......@@ -661,7 +669,7 @@
(defun vop-parse-or-lose (name)
(the vop-parse
(or (gethash name (backend-parsed-vops *backend*))
(or (gethash name (backend-parsed-vops *target-backend*))
(error "~S is not the name of a defined VOP." name))))
......@@ -1430,7 +1438,7 @@
(dotimes (i sc-number-limit)
(unless (svref costs i)
(let ((op-sc (svref (backend-meta-sc-numbers *backend*) i)))
(let ((op-sc (svref (backend-meta-sc-numbers *target-backend*) i)))
(when op-sc
(let ((cost (if load-p
(svref (sc-move-costs load-sc) i)
......@@ -1516,7 +1524,7 @@
((symbolp spec)
(let ((alias (gethash spec
(if alias
(parse-operand-type alias)
`(:or ,spec))))
......@@ -1534,7 +1542,7 @@
(let ((alias
(gethash item
(if alias
(let ((alias (parse-operand-type alias)))
(unless (eq (car alias) :or)
......@@ -1707,7 +1715,11 @@
(defun set-up-function-translation (parse n-template)
(declare (type vop-parse parse))
(mapcar #'(lambda (name)
`(let ((info (function-info-or-lose ',name)))
`(let ((info
(let ((*info-environment*
(or (backend-info-environment *target-backend*)
(function-info-or-lose ',name))))
(setf (function-info-templates info)
(adjoin-template ,n-template
(function-info-templates info)))
......@@ -2061,10 +2073,12 @@
(eval-when (compile load eval)
(setf (gethash ',name (backend-parsed-vops *backend*)) ',parse))
(setf (gethash ',name (backend-parsed-vops *target-backend*))
(let ((,n-res ,(set-up-vop-info iparse parse)))
(setf (gethash ',name (backend-template-names *backend*)) ,n-res)
(setf (gethash ',name (backend-template-names *target-backend*))
(setf (template-type ,n-res)
(specifier-type (template-type-specifier ,n-res)))
,@(set-up-function-translation parse n-res))
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment