| 1 | ;;;-*- Mode: Lisp; Package: CCL -*-
|
|---|
| 2 | ;;;
|
|---|
| 3 | ;;; Copyright (C) 2005, Clozure Associates
|
|---|
| 4 | ;;; This file is part of OpenMCL.
|
|---|
| 5 | ;;;
|
|---|
| 6 | ;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
|
|---|
| 7 | ;;; License , known as the LLGPL and distributed with OpenMCL as the
|
|---|
| 8 | ;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL,
|
|---|
| 9 | ;;; which is distributed with OpenMCL as the file "LGPL". Where these
|
|---|
| 10 | ;;; conflict, the preamble takes precedence.
|
|---|
| 11 | ;;;
|
|---|
| 12 | ;;; OpenMCL is referenced in the preamble as the "LIBRARY."
|
|---|
| 13 | ;;;
|
|---|
| 14 | ;;; The LLGPL is also available online at
|
|---|
| 15 | ;;; http://opensource.franz.com/preamble.html
|
|---|
| 16 |
|
|---|
| 17 | (in-package "CCL")
|
|---|
| 18 |
|
|---|
| 19 | (next-nx-defops)
|
|---|
| 20 | (defvar *x862-specials* nil)
|
|---|
| 21 | (let* ((newsize (%i+ (next-nx-num-ops) 10))
|
|---|
| 22 | (old *x862-specials*)
|
|---|
| 23 | (oldsize (length old)))
|
|---|
| 24 | (declare (fixnum newsize oldsize))
|
|---|
| 25 | (unless (>= oldsize newsize)
|
|---|
| 26 | (let* ((v (make-array newsize :initial-element nil)))
|
|---|
| 27 | (dotimes (i oldsize (setq *x862-specials* v))
|
|---|
| 28 | (setf (svref v i) (svref old i))))))
|
|---|
| 29 |
|
|---|
| 30 | (defun x86-encode-vinsn-operand-type (thing backend)
|
|---|
| 31 | (when thing
|
|---|
| 32 | (if (atom thing)
|
|---|
| 33 | (x86::encode-operand-type :label)
|
|---|
| 34 | (ecase (car thing)
|
|---|
| 35 | (:% (ecase (arch::target-lisp-node-size (backend-target-arch backend))
|
|---|
| 36 | (8 (x86::encode-operand-type :reg64))
|
|---|
| 37 | (4 (x86::encode-operand-type :reg32))))
|
|---|
| 38 | (:%q (x86::encode-operand-type :reg64))
|
|---|
| 39 | (:%l (x86::encode-operand-type :reg32))
|
|---|
| 40 | (:%w (x86::encode-operand-type :reg16))
|
|---|
| 41 | (:%b (x86::encode-operand-type :reg8))
|
|---|
| 42 | (:%xmm (x86::encode-operand-type :regxmm))
|
|---|
| 43 | (:%mmx (x86::encode-operand-type :regmmx))
|
|---|
| 44 | (:@ (x86::encode-operand-type :anymem))
|
|---|
| 45 | (:$1 (x86::encode-operand-type :imm1) )
|
|---|
| 46 | (:$b (x86::encode-operand-type :imm8s ))
|
|---|
| 47 | (:$ub (x86::encode-operand-type :imm8))
|
|---|
| 48 | (:$w (x86::encode-operand-type :imm16))
|
|---|
| 49 | (:$l (x86::encode-operand-type :imm32s))
|
|---|
| 50 | (:$ul (x86::encode-operand-type :imm32))
|
|---|
| 51 | (:$q (x86::encode-operand-type :imm64))
|
|---|
| 52 | (:%shift (x86::encode-operand-type :shiftcount :reg8))))))
|
|---|
| 53 |
|
|---|
| 54 | (defun lookup-x86-opcode (form backend)
|
|---|
| 55 | (when (consp form)
|
|---|
| 56 | (let* ((name (string (car form)))
|
|---|
| 57 | (templates (gethash name x86::*x86-opcode-template-lists*)))
|
|---|
| 58 | (declare (fixnum node-size))
|
|---|
| 59 | (when templates
|
|---|
| 60 | (flet ((optype (thing)
|
|---|
| 61 | (x86-encode-vinsn-operand-type thing backend)))
|
|---|
| 62 | (let* ((operands (cdr form))
|
|---|
| 63 | (type0 (optype (pop operands)))
|
|---|
| 64 | (type1 (optype (pop operands)))
|
|---|
| 65 | (type2 (optype (car operands))))
|
|---|
| 66 | (dolist (template templates)
|
|---|
| 67 | (when (x86::match-template-types template type0 type1 type2)
|
|---|
| 68 | (collect ((types))
|
|---|
| 69 | (if type0 (types type0))
|
|---|
| 70 | (if type1 (types type1))
|
|---|
| 71 | (if type2 (types type2))
|
|---|
| 72 | (return (values (x86::x86-opcode-template-ordinal template)
|
|---|
| 73 | (types))))))))))))
|
|---|
| 74 |
|
|---|
| 75 | (defun fixup-opcode-ordinals (vinsn-template opcode-templates)
|
|---|
| 76 | (let* ((changed ()))
|
|---|
| 77 | (dolist (vinsn-opcode (vinsn-template-opcode-alist vinsn-template))
|
|---|
| 78 | (destructuring-bind (old-ordinal name &optional type0 type1 type2) vinsn-opcode
|
|---|
| 79 | (let* ((opcode-templates (gethash name opcode-templates)))
|
|---|
| 80 | (unless opcode-templates
|
|---|
| 81 | (error "Unknown X86 instruction - ~a. Odd, because it was once a known instruction." name))
|
|---|
| 82 | (let* ((new-ordinal (dolist (template opcode-templates)
|
|---|
| 83 | (when (x86::match-template-types template type0 type1 type2)
|
|---|
| 84 | (return (x86::x86-opcode-template-ordinal template))))))
|
|---|
| 85 | (unless new-ordinal
|
|---|
| 86 | (error "No match for opcode ~s in ~s" vinsn-opcode vinsn-template))
|
|---|
| 87 | (unless (eql old-ordinal new-ordinal)
|
|---|
| 88 | (setf (car vinsn-opcode) new-ordinal)
|
|---|
| 89 | (push (cons old-ordinal new-ordinal) changed))))))
|
|---|
| 90 | (when changed
|
|---|
| 91 | ;;(format t "~& opcode ordinals changed in ~s: ~s" vinsn-template changed)
|
|---|
| 92 | (flet ((update-instruction (i)
|
|---|
| 93 | (when (consp i)
|
|---|
| 94 | (let* ((pair (assoc (car i) changed :test #'eq)))
|
|---|
| 95 | (when pair
|
|---|
| 96 | (setf (car i) (cdr pair)))))))
|
|---|
| 97 | (labels ((fixup-form (form)
|
|---|
| 98 | (unless (atom form)
|
|---|
| 99 | (if (atom (car form))
|
|---|
| 100 | (update-instruction form)
|
|---|
| 101 | (dolist (f (cdr form))
|
|---|
| 102 | (fixup-form f))))))
|
|---|
| 103 | (dolist (form (vinsn-template-body vinsn-template))
|
|---|
| 104 | (fixup-form form)))))))
|
|---|
| 105 |
|
|---|
| 106 | (defparameter *report-missing-vinsns* nil)
|
|---|
| 107 |
|
|---|
| 108 | (defun fixup-x86-vinsn-templates (template-hash opcode-templates)
|
|---|
| 109 | (maphash #'(lambda (name vinsn-template)
|
|---|
| 110 | (if (not (cdr vinsn-template))
|
|---|
| 111 | (when *report-missing-vinsns*
|
|---|
| 112 | (warn "Reference to undefined vinsn ~s" name))
|
|---|
| 113 | (fixup-opcode-ordinals (cdr vinsn-template) opcode-templates)))
|
|---|
| 114 | template-hash))
|
|---|
| 115 |
|
|---|
| 116 |
|
|---|
| 117 |
|
|---|
| 118 | ;;; This defines a template. All expressions in the body must be
|
|---|
| 119 | ;;; evaluable at macroexpansion time.
|
|---|
| 120 | (defun define-x86-vinsn (backend vinsn-name results args temps body)
|
|---|
| 121 | (let* ((opcode-lookup (backend-lookup-opcode backend))
|
|---|
| 122 | (backend-name (backend-name backend))
|
|---|
| 123 | (arch-name (backend-target-arch-name backend))
|
|---|
| 124 | (template-hash (backend-p2-template-hash-name backend))
|
|---|
| 125 | (name-list ())
|
|---|
| 126 | (attrs 0)
|
|---|
| 127 | (nhybrids 0)
|
|---|
| 128 | (local-labels ())
|
|---|
| 129 | (referenced-labels ())
|
|---|
| 130 | (source-indicator (form-symbol arch-name "-VINSN"))
|
|---|
| 131 | (opcode-alist ()))
|
|---|
| 132 | (flet ((valid-spec-name (x)
|
|---|
| 133 | (or (and (consp x)
|
|---|
| 134 | (consp (cdr x))
|
|---|
| 135 | (null (cddr x))
|
|---|
| 136 | (atom (car x))
|
|---|
| 137 | (or (assoc (cadr x) *vreg-specifier-constant-constraints* :test #'eq)
|
|---|
| 138 | (assoc (cadr x) *spec-class-storage-class-alist* :test #'eq)
|
|---|
| 139 | (eq (cadr x) :label)
|
|---|
| 140 | (and (consp (cadr x)) (eq (caadr x) :label) (consp (cdadr x)) (null (cddadr x)))
|
|---|
| 141 | (and (consp (cadr x))
|
|---|
| 142 | (or
|
|---|
| 143 | (assoc (caadr x) *vreg-specifier-constant-constraints* :test #'eq)
|
|---|
| 144 | (assoc (caadr x) *spec-class-storage-class-alist* :test #'eq))))
|
|---|
| 145 | (car x))
|
|---|
| 146 | (error "Invalid vreg spec: ~s" x)))
|
|---|
| 147 | (add-spec-name (vname)
|
|---|
| 148 | (if (member vname name-list :test #'eq)
|
|---|
| 149 | (error "Duplicate name ~s in vinsn ~s" vname vinsn-name)
|
|---|
| 150 | (push vname name-list))))
|
|---|
| 151 | (declare (dynamic-extent valid-spec-name add-spec-name))
|
|---|
| 152 | (when (consp vinsn-name)
|
|---|
| 153 | (setq attrs (encode-vinsn-attributes (cdr vinsn-name))
|
|---|
| 154 | vinsn-name (car vinsn-name)))
|
|---|
| 155 | (unless (and (symbolp vinsn-name) (eq *CCL-PACKAGE* (symbol-package vinsn-name)))
|
|---|
| 156 | (setq vinsn-name (intern (string vinsn-name) *CCL-PACKAGE*)))
|
|---|
| 157 | (dolist (n (append args temps))
|
|---|
| 158 | (add-spec-name (valid-spec-name n)))
|
|---|
| 159 | (dolist (form body)
|
|---|
| 160 | (if (atom form)
|
|---|
| 161 | (add-spec-name form)))
|
|---|
| 162 | (setq name-list (nreverse name-list))
|
|---|
| 163 | ;; We now know that "args" is an alist; we don't know if
|
|---|
| 164 | ;; "results" is. First, make sure that there are no duplicate
|
|---|
| 165 | ;; result names (and validate "results".)
|
|---|
| 166 | (do* ((res results tail)
|
|---|
| 167 | (tail (cdr res) (cdr tail)))
|
|---|
| 168 | ((null res))
|
|---|
| 169 | (let* ((name (valid-spec-name (car res))))
|
|---|
| 170 | (if (assoc name tail :test #'eq)
|
|---|
| 171 | (error "Duplicate result name ~s in ~s." name results))))
|
|---|
| 172 | (let* ((non-hybrid-results ())
|
|---|
| 173 | (match-args args))
|
|---|
| 174 | (dolist (res results)
|
|---|
| 175 | (let* ((res-name (car res)))
|
|---|
| 176 | (if (not (assoc res-name args :test #'eq))
|
|---|
| 177 | (if (not (= nhybrids 0))
|
|---|
| 178 | (error "result ~s should also name an argument. " res-name)
|
|---|
| 179 | (push res-name non-hybrid-results))
|
|---|
| 180 | (if (eq res-name (caar match-args))
|
|---|
| 181 | (setf nhybrids (1+ nhybrids)
|
|---|
| 182 | match-args (cdr match-args))
|
|---|
| 183 | (error "~S - hybrid results should appear in same order as arguments." res-name)))))
|
|---|
| 184 | (dolist (name non-hybrid-results)
|
|---|
| 185 | (add-spec-name name)))
|
|---|
| 186 | (let* ((k -1))
|
|---|
| 187 | (declare (fixnum k))
|
|---|
| 188 | (let* ((name-alist (mapcar #'(lambda (n) (cons n (list (incf k)))) name-list)))
|
|---|
| 189 | (flet ((find-name (n)
|
|---|
| 190 | (let* ((pair (assoc n name-alist :test #'eq)))
|
|---|
| 191 | (declare (list pair))
|
|---|
| 192 | (if pair
|
|---|
| 193 | (cdr pair)
|
|---|
| 194 | (or (subprim-name->offset n backend)
|
|---|
| 195 | (error "Unknown name ~s" n))))))
|
|---|
| 196 | (labels ((simplify-simple-operand (op)
|
|---|
| 197 | (if (atom op)
|
|---|
| 198 | (if (typep op 'fixnum)
|
|---|
| 199 | op
|
|---|
| 200 | (if (eq op :rcontext)
|
|---|
| 201 | op
|
|---|
| 202 | (if (constantp op)
|
|---|
| 203 | (progn
|
|---|
| 204 | (if (keywordp op)
|
|---|
| 205 | (pushnew op referenced-labels))
|
|---|
| 206 | (eval op))
|
|---|
| 207 | (find-name op))))
|
|---|
| 208 | (if (eq (car op) :^)
|
|---|
| 209 | (list :^ (simplify-simple-operand (cadr op)))
|
|---|
| 210 | (if (eq (car op) :apply)
|
|---|
| 211 | `(,(cadr op) ,@(mapcar #'simplify-operand (cddr op)))
|
|---|
| 212 | (if (member (car op)
|
|---|
| 213 | '(:tra :align :byte :word :long :quad :talign))
|
|---|
| 214 | `(,(car op) ,(simplify-operand (cadr op)))
|
|---|
| 215 | (simplify-operand (eval op))))))) ; Handler-case this?
|
|---|
| 216 | (simplify-memory-operand (op)
|
|---|
| 217 | ;; This happens to be the only place that
|
|---|
| 218 | ;; we allow segment registers.
|
|---|
| 219 | (let* ((seg nil)
|
|---|
| 220 | (disp nil)
|
|---|
| 221 | (base nil)
|
|---|
| 222 | (index nil)
|
|---|
| 223 | (scale nil))
|
|---|
| 224 | (do* ((form op (cdr form)))
|
|---|
| 225 | ((null form) (list seg disp base index scale))
|
|---|
| 226 | (let* ((head (car form)))
|
|---|
| 227 | (if (consp head)
|
|---|
| 228 | (case (car head)
|
|---|
| 229 | (:%seg
|
|---|
| 230 | (if (eq form op)
|
|---|
| 231 | (setq seg (simplify-operand (cadr head)))
|
|---|
| 232 | (error "Bad :%seg in ~s" op)))
|
|---|
| 233 | ((:%q :% :%l)
|
|---|
| 234 | (let* ((r (simplify-operand head)))
|
|---|
| 235 | (if base
|
|---|
| 236 | (if index
|
|---|
| 237 | (error "Extra register ~s in ~s"
|
|---|
| 238 | head op)
|
|---|
| 239 | (setq index r))
|
|---|
| 240 | (setq base r))))
|
|---|
| 241 | (t
|
|---|
| 242 | (if (and (null (cdr form))
|
|---|
| 243 | (or disp base index))
|
|---|
| 244 | (progn
|
|---|
| 245 | (setq scale (simplify-simple-operand head))
|
|---|
| 246 | (if (and base (not index))
|
|---|
| 247 | (setq index base base nil)))
|
|---|
| 248 | (if (not (or disp base index))
|
|---|
| 249 | (setq disp (simplify-simple-operand head))
|
|---|
| 250 | (error "~s not expected in ~s" op)))))
|
|---|
| 251 | (if (and (null (cdr form))
|
|---|
| 252 | (or disp base index))
|
|---|
| 253 | (progn
|
|---|
| 254 | (setq scale (simplify-simple-operand head))
|
|---|
| 255 | (if (and base (not index))
|
|---|
| 256 | (setq index base base nil)))
|
|---|
| 257 | (if (not (or disp base index))
|
|---|
| 258 | (setq disp (simplify-simple-operand head))
|
|---|
| 259 | (error "~s not expected in ~s" op))))))))
|
|---|
| 260 | (simplify-operand (op)
|
|---|
| 261 | (cond ((atom op)
|
|---|
| 262 | (simplify-simple-operand op))
|
|---|
| 263 | ((eq (car op) :@)
|
|---|
| 264 | (cons :@
|
|---|
| 265 | (simplify-memory-operand (cdr op))))
|
|---|
| 266 | ((member (car op)
|
|---|
| 267 | '(:% :%q :%l :%w :%b :$ :$1 :$b :$ub :$w :$l
|
|---|
| 268 | :$ul :$q :%mmx :%xmm :%shift))
|
|---|
| 269 | (simplify-simple-operand (cadr op)))
|
|---|
| 270 | (t
|
|---|
| 271 | (simplify-simple-operand op)))))
|
|---|
| 272 | (labels ((simplify-constraint (guard)
|
|---|
| 273 | ;; A constraint is one of
|
|---|
| 274 |
|
|---|
| 275 | ;; (:eq|:lt|:gt vreg-name constant) ; "value"
|
|---|
| 276 | ;; of vreg relop constant
|
|---|
| 277 |
|
|---|
| 278 | ;; (:pred <function-name> <operand>* ;
|
|---|
| 279 | ;; <function-name> unquoted, each <operand>
|
|---|
| 280 | ;; is a vreg-name or constant expression.
|
|---|
| 281 |
|
|---|
| 282 | ;; (:type vreg-name typeval) ; vreg is of
|
|---|
| 283 | ;; "type" typeval
|
|---|
| 284 | ;;
|
|---|
| 285 | ;;(:not <constraint>) ; constraint is false
|
|---|
| 286 | ;; (:and <constraint> ...) ; conjuntion
|
|---|
| 287 | ;; (:or <constraint> ...) ; disjunction
|
|---|
| 288 | ;; There's no "else"; we'll see how ugly it
|
|---|
| 289 | ;; is without one.
|
|---|
| 290 | (destructuring-bind (guardname &rest others) guard
|
|---|
| 291 | (ecase guardname
|
|---|
| 292 | (:not
|
|---|
| 293 | (destructuring-bind (negation) others
|
|---|
| 294 | `(:not ,(simplify-constraint negation))))
|
|---|
| 295 | (:pred
|
|---|
| 296 | (destructuring-bind (predicate &rest operands) others
|
|---|
| 297 | `(:pred ,predicate ,@(mapcar #'simplify-operand operands))))
|
|---|
| 298 | ((:eq :lt :gt :type)
|
|---|
| 299 | (destructuring-bind (vreg constant) others
|
|---|
| 300 | (unless (constantp constant)
|
|---|
| 301 | (error "~S : not constant in constraint ~s ." constant guard))
|
|---|
| 302 | `(,guardname ,(find-name vreg) ,(eval constant))))
|
|---|
| 303 | ((:or :and)
|
|---|
| 304 | (unless others (error "Missing constraint list in ~s ." guard))
|
|---|
| 305 | `(,guardname ,(mapcar #'simplify-constraint others))))))
|
|---|
| 306 | (simplify-form (form)
|
|---|
| 307 | (if (atom form)
|
|---|
| 308 | (progn
|
|---|
| 309 | (if (keywordp form) (push form local-labels) )
|
|---|
| 310 | form)
|
|---|
| 311 | (destructuring-bind (&whole w opname &rest opvals) form
|
|---|
| 312 | (if (consp opname) ; A constraint, we presume ...
|
|---|
| 313 | (cons (simplify-constraint opname)
|
|---|
| 314 | (mapcar #'simplify-form opvals))
|
|---|
| 315 | (if (keywordp opname)
|
|---|
| 316 | (progn
|
|---|
| 317 | (list opname
|
|---|
| 318 | (simplify-operand (car opvals)))
|
|---|
| 319 | )
|
|---|
| 320 | (let* ((name (string opname)))
|
|---|
| 321 | (multiple-value-bind (opnum types)
|
|---|
| 322 | (funcall opcode-lookup form backend)
|
|---|
| 323 | (if (not opnum)
|
|---|
| 324 | (error "Unknown ~A instruction in ~s" backend-name form)
|
|---|
| 325 | (let* ((opvals (mapcar #'simplify-operand opvals)))
|
|---|
| 326 | (setf (assq opnum opcode-alist) (cons name types))
|
|---|
| 327 | `(,opnum ,@opvals)))))))))))
|
|---|
| 328 | (let* ((template (make-vinsn-template :name vinsn-name
|
|---|
| 329 | :result-vreg-specs results
|
|---|
| 330 | :argument-vreg-specs args
|
|---|
| 331 | :temp-vreg-specs temps
|
|---|
| 332 | :nhybrids nhybrids
|
|---|
| 333 | :results&args (append results (nthcdr nhybrids args))
|
|---|
| 334 | :nvp (- (+ (length results) (length args) (length temps))
|
|---|
| 335 | nhybrids)
|
|---|
| 336 | :body (prog1 (mapcar #'simplify-form body)
|
|---|
| 337 | (dolist (ref referenced-labels)
|
|---|
| 338 | (unless (memq ref local-labels)
|
|---|
| 339 | (error
|
|---|
| 340 | "local-label ~S was referenced but ~
|
|---|
| 341 | never defined in VINSN-TEMPLATE definition for ~s"
|
|---|
| 342 | ref vinsn-name))))
|
|---|
| 343 | :local-labels local-labels
|
|---|
| 344 | :attributes attrs
|
|---|
| 345 | :opcode-alist opcode-alist)))
|
|---|
| 346 |
|
|---|
| 347 | `(progn
|
|---|
| 348 | (set-vinsn-template ',vinsn-name ,template ,template-hash)
|
|---|
| 349 | (record-source-file ',vinsn-name ',source-indicator)
|
|---|
| 350 | ',vinsn-name))))))))))
|
|---|
| 351 |
|
|---|
| 352 |
|
|---|
| 353 |
|
|---|
| 354 | #+x8632-target
|
|---|
| 355 | (require "X8632-BACKEND")
|
|---|
| 356 | #+x8664-target
|
|---|
| 357 | (require "X8664-BACKEND")
|
|---|
| 358 |
|
|---|
| 359 | (defparameter *x86-backend*
|
|---|
| 360 | #+x8632-target *x8632-backend*
|
|---|
| 361 | #+x8664-target *x8664-backend*
|
|---|
| 362 | #-x86-target nil)
|
|---|
| 363 |
|
|---|
| 364 |
|
|---|
| 365 | (defun fixup-x86-backend (&rest args)
|
|---|
| 366 | #+x8632-target (apply #'fixup-x8632-backend args)
|
|---|
| 367 | #+x8664-target (apply #'fixup-x8664-backend args)
|
|---|
| 368 | #-x86-target (declare (ignore args))
|
|---|
| 369 | )
|
|---|
| 370 |
|
|---|
| 371 | (provide "X86-BACKEND")
|
|---|
