Changeset 10199


Ignore:
Timestamp:
Jul 25, 2008, 1:45:05 AM (11 years ago)
Author:
rme
Message:

Add support for 32-bit x86.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/compiler/X86/x86-lap.lisp

    r10188 r10199  
    114114(defun (setf frag-ref) (new frag index)
    115115  (setf (%vector-list-ref (frag-code-buffer frag) index) new))
     116
     117;;; get/set little-endian 32 bit word in frag at index
     118(defun frag-ref-32 (frag index)
     119  (let ((result 0))
     120    (setf (ldb (byte 8 0) result) (frag-ref frag index)
     121          (ldb (byte 8 8) result) (frag-ref frag (+ index 1))
     122          (ldb (byte 8 16) result) (frag-ref frag (+ index 2))
     123          (ldb (byte 8 24) result) (frag-ref frag (+ index 3)))
     124    result))
     125
     126(defun (setf frag-ref-32) (new frag index)
     127  (setf (frag-ref frag index) (ldb (byte 8 0) new)
     128        (frag-ref frag (+ index 1)) (ldb (byte 8 8) new)
     129        (frag-ref frag (+ index 2)) (ldb (byte 8 16) new)
     130        (frag-ref frag (+ index 3)) (ldb (byte 8 24) new)))
    116131
    117132(defun frag-length (frag)
     
    195210(defvar *x86-lap-labels* ())
    196211(defvar *x86-lap-constants* ())
    197 (defparameter *x86-lap-entry-offset* 15)
     212(defparameter *x86-lap-entry-offset* nil)
    198213(defparameter *x86-lap-fixed-code-words* nil)
    199 (defvar *x86-lap-macros* (make-hash-table :test #'equalp))
    200214(defvar *x86-lap-lfun-bits* 0)
    201 
    202 
    203215
    204216(defun x86-lap-macro-function (name)
     
    208220  (let* ((s (string name)))
    209221    (when (gethash s x86::*x86-opcode-template-lists*)
    210       (error "~s already defines an x86 instruction . " name))
    211     (setf (gethash s (backend-lap-macros *x86-backend*)) def)))
     222      (error "~s already defines an x86 instruction." name))
     223    (setf (gethash s (backend-lap-macros *target-backend*)) def)))
    212224
    213225(defmacro defx86lapmacro (name arglist &body body)
     
    379391
    380392(defun lookup-x86-register (regname designator)
    381   (let* ((r (typecase regname
    382               (symbol (or (gethash (string regname) x86::*x8664-registers*)
     393  (let* ((registers (target-arch-case (:x8632 x86::*x8632-registers*)
     394                                      (:x8664 x86::*x8664-registers*)))
     395         (register-entries (target-arch-case (:x8632 x86::*x8632-register-entries*)
     396                                             (:x8664 x86::*x8664-register-entries*)))
     397         (r (typecase regname
     398              (symbol (or (gethash (string regname) registers)
    383399                          (if (eq regname :rcontext)
    384                             (svref x86::*x8664-register-entries*
     400                            (svref register-entries
    385401                                   (ccl::backend-lisp-context-register *target-backend*)))
    386402                          (and (boundp regname)
     
    388404                                 (and (typep val 'fixnum)
    389405                                      (>= val 0)
    390                                       (< val (length x86::*x8664-register-entries*))
    391                                       (svref x86::*x8664-register-entries* val))))))
    392               (string (gethash regname x86::*x8664-registers*))
     406                                      (< val (length register-entries))
     407                                      (svref register-entries val))))))
     408              (string (gethash regname registers))
    393409              (fixnum (if (and (typep regname 'fixnum)
    394410                                      (>= regname 0)
    395                                       (< regname (length x86::*x8664-register-entries*)))
    396                         (svref x86::*x8664-register-entries* regname))))))
     411                                      (< regname (length register-entries)))
     412                        (svref register-entries regname))))))
    397413                               
    398414    (when r
    399415      (if (eq designator :%)
    400416        r
    401         (let* ((regtype (x86::reg-entry-reg-type r)))
    402           (unless (logtest regtype (x86::encode-operand-type :reg8 :reg16 :reg32 :reg64))
     417        (let* ((regtype (x86::reg-entry-reg-type r))
     418               (oktypes (target-arch-case
     419                        (:x8632 (x86::encode-operand-type :reg8 :reg16 :reg32))
     420                        (:x8664 (x86::encode-operand-type :reg8 :reg16 :reg32 :reg64)))))
     421          (unless (logtest regtype oktypes)
    403422            (error "Designator ~a can't be used with register ~a"
    404423                   designator (x86::reg-entry-reg-name r)))
    405424          (case designator
    406             (:%b (x86::x86-reg8 r))
     425            (:%b (if (x86-byte-reg-p (x86::reg-entry-reg-name r))
     426                   (x86::x86-reg8 r)
     427                   (error "Designator ~a can't be used with register ~a"
     428                          designator (x86::reg-entry-reg-name r))))
    407429            (:%w (x86::x86-reg16 r))
    408430            (:%l (x86::x86-reg32 r))
     
    413435              (lookup-x86-register form :%))))
    414436    (if r
    415       (x86::reg-entry-ordinal64 r)
     437      (target-arch-case (:x8632 (x86::reg-entry-ordinal32 r))
     438                        (:x8664 (x86::reg-entry-ordinal64 r)))
    416439      (multiple-value-bind (val condition)
    417440          (ignore-errors (eval form))
     
    421444          val)))))
    422445
    423 
     446(defun x86-acc-reg-p (regname)
     447  (let ((r (lookup-x86-register regname :%)))
     448    (if r
     449      (logtest (x86::encode-operand-type :acc) (x86::reg-entry-reg-type r)))))
     450
     451(defun x86-byte-reg-p (regname)
     452  (let ((r (lookup-x86-register regname :%)))
     453    (if r
     454      (target-arch-case
     455       (:x8632
     456        (or (<= (x86::reg-entry-reg-num r) x8632::ebx)
     457            (member (x86::reg-entry-reg-name r) '("ah" "ch" "dh" "bh") :test #'string=)))
     458       (:x8664 t)))))
     459     
    424460;;; It may seem strange to have an expression language in a lisp-based
    425461;;; assembler, since lisp is itself a fairly reasonable expression
     
    532568        (let* ((val (cadr form)))
    533569          (if (typep val 'fixnum)
    534             (setq form (ash val 3 #|x8664::fixnumshift|#))
     570            (setq form (ash val (arch::target-fixnum-shift (backend-target-arch *target-backend*))))
    535571            (let* ((constant-label (ensure-x86-lap-constant-label val )))
    536572              (setq form `(:^ ,(x86-lap-label-name constant-label)))))))
     
    682718                                (smallest-imm-type val)
    683719                                (x86::encode-operand-type :imm32s))))
     720                   ;; special case
     721                   (when (eq val :self)
     722                     (setq type (x86::encode-operand-type :self)))
    684723                   (x86::make-x86-immediate-operand :type type
    685724                                             :value expr))))
     
    703742        (x86::x86-instruction-base-opcode i) (x86::x86-opcode-template-base-opcode template)
    704743        (x86::x86-instruction-modrm-byte i) (x86::x86-opcode-template-modrm-byte template)
    705         (x86::x86-instruction-rex-prefix i) (x86::x86-opcode-template-rex-prefix template)
     744        (x86::x86-instruction-rex-prefix i) (target-arch-case
     745                                             (:x8632 nil)
     746                                             (:x8664
     747                                              (x86::x86-opcode-template-rex-prefix template)))
    706748        (x86::x86-instruction-sib-byte i) nil
    707749        (x86::x86-instruction-seg-prefix i) nil
     
    865907
    866908             
    867 
     909;;; xxx - might want to omit disp64 when doing 32 bit code
    868910(defun optimize-displacement-type (disp)
    869911  (if disp
     
    909951                          (x86::x86-instruction-extra insn)))
    910952
    911 
    912953(defun x86-generate-instruction-code (frag-list insn)
    913954  (let* ((template (x86::x86-instruction-opcode-template insn))
    914          (opcode-modifier (x86::x86-opcode-template-flags template))
     955         (flags (x86::x86-opcode-template-flags template))
    915956         (prefixes (x86::x86-opcode-template-prefixes template)))
    916957    (let* ((explicit-seg-prefix (x86::x86-instruction-seg-prefix insn)))
     
    918959        (push explicit-seg-prefix prefixes)))
    919960    (cond
    920       ((logtest (x86::encode-opcode-flags :jump) opcode-modifier)
     961      ((logtest (x86::encode-opcode-flags :jump) flags)
    921962       ;; a variable-length pc-relative branch, possibly preceded
    922963       ;; by prefixes (used for branch prediction, mostly.)
     
    10091050                   (if (logtest optype (x86::encode-operand-type :imm64))
    10101051                     (frag-list-push-64 frag-list val)
    1011                      (frag-list-push-32 frag-list val))))))))))
     1052                     ;; magic value denoting function object's
     1053                     ;; actual runtime address
     1054                     (if (logtest optype (x86::encode-operand-type :self))
     1055                       (let* ((frag (frag-list-current frag-list))
     1056                              (pos (frag-list-position frag-list)))
     1057                         (frag-list-push-32 frag-list 0)
     1058                         (push (make-reloc :type :self
     1059                                           :arg 0
     1060                                           :frag frag
     1061                                           :pos pos)
     1062                               (frag-relocs frag)))
     1063                       (frag-list-push-32 frag-list val)))))))))))
    10121064    (let* ((frag (frag-list-current frag-list)))
    10131065      (if (eq (car (frag-type frag)) :pending-talign)
     
    11351187  ;; make it all the way through the frag-list.
    11361188  (loop
    1137     (let* ((address 8))
     1189    (let* ((address (target-arch-case (:x8632 4) (:x8664 8)))) ;after header
    11381190      (declare (fixnum address))
    11391191      (when (do-dll-nodes (frag frag-list t)
     
    12801332                    (:expr16 (emit-short frag pos (x86-lap-expression-value arg)))
    12811333                    (:expr32 (emit-long frag pos (x86-lap-expression-value arg)))
    1282                     (:expr64 (emit-quad frag pos (x86-lap-expression-value arg)))))))))))))
    1283                              
     1334                    (:expr64 (emit-quad frag pos (x86-lap-expression-value arg)))
     1335                    (:self (emit-long frag pos (x86-lap-expression-value arg)))))))))))))
    12841336
    12851337(defun frag-emit-nops (frag count)
     
    13211373                                      (not (constant-symbol-p name))
    13221374                                      (or (not (gethash (string name)
    1323                                                         x86::*x8664-registers*))
    1324                                           (error "Symbol ~s already names and x86 register" name))
     1375                                                        (target-arch-case
     1376                                                         (:x8632 x86::*x8632-registers*)
     1377                                                         (:x8664 x86::*x8664-registers*))))
     1378                                          (error "Symbol ~s already names an x86 register" name))
    13251379                                      name)
    13261380                                 (error
     
    13531407        (do-dll-nodes (frag frag-list)
    13541408          (incf nbytes (frag-length frag)))
     1409        #+x8632-target
     1410        (when (>= nbytes (ash 1 18)) (compiler-function-overflow))
    13551411        (let* ((code-vector (make-array nbytes
    13561412                                        :element-type '(unsigned-byte 8)))
     
    13841440      (dolist (c constants)
    13851441        (setf (uvref function-vector (decf last)) (car c)))
    1386       (%function-vector-to-function function-vector))))
    1387 
    1388 
    1389      
     1442      #+x8632-target
     1443      (%update-self-references function-vector)
     1444      (function-vector-to-function function-vector))))
     1445
    13901446(defun %define-x86-lap-function (name forms &optional (bits 0))
     1447  (target-arch-case
     1448   (:x8632
     1449    (%define-x8632-lap-function name forms bits))
     1450   (:x8664
     1451    (%define-x8664-lap-function name forms bits))))
     1452
     1453(defun %define-x8664-lap-function (name forms &optional (bits 0))
    13911454  (let* ((*x86-lap-labels* ())
    13921455         (*x86-lap-constants* ())
     1456         (*x86-lap-entry-offset* x8664::fulltag-function)
    13931457         (*x86-lap-fixed-code-words* nil)
    13941458         (*x86-lap-lfun-bits* bits)
     
    14351499             name frag-list *x86-lap-constants* *x86-lap-lfun-bits* nil)))
    14361500
     1501(defun %define-x8632-lap-function (name forms &optional (bits 0))
     1502  (let* ((*x86-lap-labels* ())
     1503         (*x86-lap-constants* ())
     1504         (*x86-lap-entry-offset* x8632::fulltag-misc)
     1505         (*x86-lap-fixed-code-words* nil)
     1506         (*x86-lap-lfun-bits* bits)
     1507         (srt-tag (gensym))
     1508         (end-code-tag (gensym))
     1509         (entry-code-tag (gensym))
     1510         (instruction (x86::make-x86-instruction))
     1511         (main-frag-list (make-frag-list))
     1512         (exception-frag-list (make-frag-list))
     1513         (frag-list main-frag-list))
     1514    (make-x86-lap-label entry-code-tag)
     1515    (make-x86-lap-label srt-tag)
     1516    (make-x86-lap-label end-code-tag)
     1517    ;; count of 32-bit words from header to function boundary
     1518    ;; marker, inclusive.
     1519    (x86-lap-directive frag-list :short `(ash (+ (- (:^ ,end-code-tag) 4)
     1520                                                 *x86-lap-entry-offset*) -2))
     1521    (emit-x86-lap-label frag-list entry-code-tag)
     1522    (x86-lap-form '(movl ($ :self) (% x8632::fn)) frag-list instruction main-frag-list exception-frag-list)
     1523    (dolist (f forms)
     1524      (x86-lap-form f frag-list instruction main-frag-list exception-frag-list))
     1525    (x86-lap-directive frag-list :align 2)
     1526    (when *x86-lap-fixed-code-words*
     1527      ;; We have a code-size that we're trying to get to.  We need to
     1528      ;; include the self-reference table in the code-size, so decrement
     1529      ;; the size of the padding we would otherwise insert by the srt size.
     1530      (let ((srt-words 1))              ;for zero between end of code and srt
     1531        (do-dll-nodes (frag frag-list)
     1532          (dolist (reloc (frag-relocs frag))
     1533            (when (eq (reloc-type reloc) :self)
     1534              (incf srt-words))))
     1535        (decf *x86-lap-fixed-code-words* srt-words)
     1536        (if (plusp *x86-lap-fixed-code-words*)
     1537          (x86-lap-directive frag-list :org (ash *x86-lap-fixed-code-words* 2)))))
     1538    ;; self reference table
     1539    (x86-lap-directive frag-list :long 0)
     1540    (emit-x86-lap-label frag-list srt-tag)
     1541    ;; reserve space for self-reference offsets
     1542    (do-dll-nodes (frag frag-list)
     1543      (dolist (reloc (frag-relocs frag))
     1544        (when (eq (reloc-type reloc) :self)
     1545          (x86-lap-directive frag-list :long 0))))
     1546    (x86-lap-directive frag-list :long x8632::function-boundary-marker)
     1547    (emit-x86-lap-label frag-list end-code-tag)
     1548    (dolist (c (reverse *x86-lap-constants*))
     1549      (emit-x86-lap-label frag-list (x86-lap-label-name (cdr c)))
     1550      (x86-lap-directive frag-list :long 0))
     1551    (when name
     1552      (x86-lap-directive frag-list :long 0))
     1553    ;; room for lfun-bits
     1554    (x86-lap-directive frag-list :long 0)
     1555    (relax-frag-list frag-list)
     1556    (apply-relocs frag-list)
     1557    (fill-for-alignment frag-list)
     1558    ;; determine start of self-reference-table
     1559    (let* ((label (find srt-tag *x86-lap-labels* :test #'eq
     1560                                                 :key #'x86-lap-label-name))
     1561           (srt-frag (x86-lap-label-frag label))
     1562           (srt-index (x86-lap-label-offset label)))
     1563      ;; fill in self-reference offsets
     1564      (do-dll-nodes (frag frag-list)
     1565        (dolist (reloc (frag-relocs frag))
     1566          (when (eq (reloc-type reloc) :self)
     1567            (setf (frag-ref-32 srt-frag srt-index)
     1568                  (+ (frag-address frag) (reloc-pos reloc)))
     1569            (incf srt-index 4)))))
     1570    ;;(show-frag-bytes frag-list)
     1571    (funcall #-x8632-target #'cross-create-x86-function
     1572             #+x8632-target (if (eq *target-backend* *host-backend*)
     1573                              #'create-x86-function
     1574                              #'cross-create-x86-function)
     1575             name frag-list *x86-lap-constants* *x86-lap-lfun-bits* nil)))
    14371576
    14381577(defmacro defx86lapfunction (&environment env name arglist &body body
     
    14461585     (eval-when (:compile-toplevel)
    14471586       (note-function-info ',name t ,env))
    1448      #-x86-target
     1587     #-x8664-target
    14491588     (progn
    14501589       (eval-when (:load-toplevel)
     
    14521591       (eval-when (:execute)
    14531592         (%define-x86-lap-function ',name '((let ,arglist ,@body)))))
    1454      #+x86-target       ; just shorthand for defun
     1593     #+x8664-target     ; just shorthand for defun
    14551594     (%defun (nfunction ,name (lambda (&lap 0) (x86-lap-function ,name ,arglist ,@body))) ,doc)))
     1595
     1596(defmacro defx8632lapfunction (&environment env name arglist &body body
     1597                             &aux doc)
     1598  (if (not (endp body))
     1599      (and (stringp (car body))
     1600           (cdr body)
     1601           (setq doc (car body))
     1602           (setq body (cdr body))))
     1603  `(progn
     1604     (eval-when (:compile-toplevel)
     1605       (note-function-info ',name t ,env))
     1606     #-x8632-target
     1607     (progn
     1608       (eval-when (:load-toplevel)
     1609         (%defun (nfunction ,name (lambda (&lap 0) (x86-lap-function ,name ,arglist ,@body))) ,doc))
     1610       (eval-when (:execute)
     1611         (%define-x8632-lap-function ',name '((let ,arglist ,@body)))))
     1612     #+x8632-target
     1613     (%defun (nfunction ,name (lambda (&lap 0) (x86-lap-function ,name ,arglist ,@body))) ,doc)))
Note: See TracChangeset for help on using the changeset viewer.