Changeset 6139


Ignore:
Timestamp:
Apr 5, 2007, 3:48:52 PM (12 years ago)
Author:
gb
Message:

Things seem to basically be working on darwinppc32. Needs some smoke-testing
on darwinppc64.


File:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/objc-gf/ccl/examples/objc-runtime.lisp

    r6130 r6139  
    13951395                 arg-temp)
    13961396           (incf nstackargs)))))))
     1397
     1398#+(and apple-objc ppc32-target)
     1399(defun %process-varargs-list (gpr-pointer fpr-pointer ngprs nfprs arglist)
     1400  (dolist (arg-temp arglist)
     1401    (typecase arg-temp
     1402      ((signed-byte 32)
     1403       (setf (paref gpr-pointer (:* (:signed 32)) ngprs) arg-temp)
     1404       (incf ngprs))
     1405      ((unsigned-byte 32)
     1406       (setf (paref gpr-pointer (:* (:unsigned 32)) ngprs) arg-temp)
     1407       (incf ngprs))
     1408      (macptr
     1409       (setf (paref gpr-pointer (:* :address) ngprs) arg-temp)
     1410       (incf ngprs))
     1411      (single-float
     1412       (when (< nfprs 13)
     1413         (setf (paref fpr-pointer (:* :double-float) nfprs) (float arg-temp 0.0d0))
     1414         (incf nfprs))
     1415       (setf (paref gpr-pointer (:* :single-float) ngprs) arg-temp)
     1416       (incf ngprs))
     1417      (double-float
     1418       (when (< nfprs 13)
     1419         (setf (paref fpr-pointer (:* :double-float) nfprs) arg-temp)
     1420         (incf nfprs))
     1421       (multiple-value-bind (high low) (double-float-bits arg-temp)
     1422         (setf (paref gpr-pointer (:* :unsigned) ngprs) high)
     1423         (incf ngprs)
     1424         (setf (paref gpr-pointer (:* :unsigned) ngprs) low)
     1425         (incf nfprs)))
     1426      ((or (signed-byte 64)
     1427           (unsigned-byte 64))
     1428       (setf (paref gpr-pointer (:* :unsigned) ngprs) (ldb (byte 32 32) arg-temp))
     1429       (incf ngprs)
     1430       (setf (paref gpr-pointer (:* :unsigned) ngprs) (ldb (byte 32 0) arg-temp))
     1431       (incf ngprs)))))
     1432
     1433#+(and apple-objc ppc64-target)
     1434(defun %process-varargs-list (gpr-pointer fpr-pointer ngprs nfprs arglist)
     1435  (dolist (arg-temp arglist)
     1436    (typecase arg-temp
     1437      ((signed-byte 64)
     1438       (setf (paref gpr-pointer (:* (:signed 64)) ngprs) arg-temp)
     1439       (incf ngprs))
     1440      ((unsigned-byte 64)
     1441       (setf (paref gpr-pointer (:* (:unsigned 64)) ngprs) arg-temp)
     1442       (incf ngprs))
     1443      (macptr
     1444       (setf (paref gpr-pointer (:* :address) ngprs) arg-temp)
     1445       (incf ngprs))
     1446      (single-float
     1447       (when (< nfprs 13)
     1448         (setf (paref fpr-pointer (:* :double-float) nfprs) (float arg-temp 0.0d0))
     1449         (incf nfprs))
     1450       (setf (paref gpr-pointer (:* (:unsigned 64)) ngprs) (single-float-bits arg-temp))
     1451       (incf ngprs))
     1452      (double-float
     1453       (when (< nfprs 13)
     1454         (setf (paref fpr-pointer (:* :double-float) nfprs) arg-temp)
     1455         (incf nfprs))
     1456       (setf (paref gpr-pointer (:* :double-float) ngprs) arg-temp)
     1457       (incf ngprs)))))
     1458
    13971459                         
    13981460#+apple-objc
    13991461(eval-when (:compile-toplevel :execute)
    14001462  #+x8664-target
    1401   (%def-foreign-type :<MARG> (foreign-pointer-type-to (parse-foreign-type :x86_64_marg_list))))
     1463  (%def-foreign-type :<MARG> (foreign-pointer-type-to (parse-foreign-type :x86_64_marg_list)))
     1464  #+ppc-target
     1465  (def-foreign-type :<MARG>
     1466      (:struct nil
     1467               (:fp<P>arams (:array :double 13))
     1468               (:linkage (:array :uintptr_t 6))
     1469               (:reg<P>arams (:array :uintptr_t 8))
     1470               (:stack<P>arams (:array :uintptr_t) 0)))
     1471  )
    14021472
    14031473 
     1474#+(and apple-objc x8664-target)
    14041475(defun %compile-varargs-send-function-for-signature (sig)
    1405   (declare (ignorable sig super-p))
    1406   #+(and apple-objc x8664-target)
    14071476  (let* ((return-type-spec (car sig))
    14081477         (arg-type-specs (butlast (cdr sig)))
     
    14921561                                        (* 8 ,stack-total))))
    14931562             
    1494              (setf (pref ,marg-ptr :<MARG>.rax) ,stack-total)
     1563             (setf (pref ,marg-ptr :<MARG>.rax) ,fpr-total)
    14951564             (with-macptrs ((,regparams (pref ,marg-ptr :<MARG>.reg<P>arams))
    14961565                            (,stackparams (pref ,marg-ptr :<MARG>.stack<P>arams)))
     
    15021571                              :size_t (+ 48 (* 8 ,stack-total))
    15031572                              :address ,marg-ptr
    1504                               ,return-type-spec))))))))
    1505   #-(and apple-objc x8664-target)
    1506   (warn "Varargs function for signature ~s NYI" sig)
    1507   )
     1573                              ,return-type-spec)))))))))
     1574
     1575#+(and apple-objc ppc32-target)
     1576(defun %compile-varargs-send-function-for-signature (sig)
     1577  (let* ((return-type-spec (car sig))
     1578         (arg-type-specs (butlast (cdr sig)))
     1579         (args (objc-gen-message-arglist (length arg-type-specs)))
     1580         (receiver (gensym))
     1581         (selector (gensym))
     1582         (rest-arg (gensym))
     1583         (arg-temp (gensym))
     1584         (marg-ptr (gensym))
     1585         (regparams (gensym))
     1586         (selptr (gensym))
     1587         (gpr-total (gensym))
     1588         (n-static-gprs 2)              ;receiver, selptr
     1589         (n-static-fprs 0))
     1590    (collect ((static-arg-forms))
     1591      (static-arg-forms `(setf (paref ,regparams (:* address) 0) ,receiver))
     1592      (static-arg-forms `(setf (paref ,regparams (:* address) 1) ,selptr))
     1593      (do* ((args args (cdr args))
     1594            (arg-type-specs arg-type-specs (cdr arg-type-specs)))
     1595           ((null args))
     1596        (let* ((arg (car args))
     1597               (spec (car arg-type-specs))
     1598               (static-arg-type (parse-foreign-type spec))
     1599               (gpr-base regparams)
     1600               (fpr-base marg-ptr)
     1601               (gpr-offset (* n-static-gprs 4)))
     1602          (etypecase static-arg-type
     1603            (foreign-integer-type
     1604             (let* ((bits (foreign-type-bits static-arg-type))
     1605                    (signed (foreign-integer-type-signed static-arg-type)))
     1606               (if (> bits 32)
     1607                 (progn
     1608                   (static-arg-forms
     1609                    `(setf (,(if signed '%%get-signed-longlong '%%get-unsigned-long-long)
     1610                            ,gpr-base ,gpr-offset)
     1611                      ,arg))
     1612                   (incf n-static-gprs 2))
     1613                 (progn
     1614                   (if (eq spec :<BOOL>)
     1615                     (setq arg `(%coerce-to-bool ,arg)))
     1616                   (static-arg-forms
     1617                    `(setf (paref ,gpr-base (:* (
     1618                                                 ,(if (foreign-integer-type-signed static-arg-type)
     1619                                                      :signed
     1620                                                      :unsigned)
     1621                                           32)) ,gpr-offset)
     1622                ,arg))
     1623                   (incf n-static-gprs)))))
     1624            (foreign-single-float-type
     1625             (static-arg-forms
     1626              `(setf (paref ,gpr-base (:* :single-float) ,n-static-gprs) ,arg))
     1627             (when (< n-static-fprs 13)
     1628               (static-arg-forms
     1629                `(setf (paref ,fpr-base (:* :double-float) ,n-static-fprs)
     1630                  (float (paref ,gpr-base (:* :single-float) ,n-static-gprs) 0.0d0)))
     1631               (incf n-static-fprs))
     1632             (incf n-static-gprs))
     1633            (foreign-double-float-type
     1634             (static-arg-forms
     1635              `(setf (%get-double-float ,gpr-base ,gpr-offset) ,arg))
     1636             (when (< n-static-fprs 13)
     1637               (static-arg-forms
     1638                `(setf (paref ,fpr-base (:* :double-float) ,n-static-fprs)
     1639                  (%get-double-float ,gpr-base ,gpr-offset)))
     1640               (incf n-static-fprs))
     1641             (incf n-static-gprs 2))
     1642            (foreign-pointer-type
     1643             (static-arg-forms
     1644              `(setf (paref ,gpr-base (:* address) ,n-static-gprs) ,arg))
     1645               (incf n-static-gprs)))))
     1646      (compile
     1647       nil
     1648       `(lambda (,receiver ,selector ,@args &rest ,rest-arg)
     1649         (declare (dynamic-extent ,rest-arg))
     1650         (let* ((,selptr (%get-selector ,selector))
     1651                (,gpr-total ,n-static-gprs))
     1652           (dolist (,arg-temp ,rest-arg)
     1653             (if (or (typep ,arg-temp 'double-float)
     1654                     (and (typep ,arg-temp 'integer)
     1655                          (if (< ,arg-temp 0)
     1656                            (>= (integer-length ,arg-temp) 32)
     1657                            (> (integer-length ,arg-temp) 32))))
     1658               (incf ,gpr-total 2)
     1659               (incf ,gpr-total 1)))
     1660           (if (> ,gpr-total 8)
     1661             (setq ,gpr-total (- ,gpr-total 8))
     1662             (setq ,gpr-total 0))           
     1663           (%stack-block ((,marg-ptr (+ ,(%foreign-type-or-record-size
     1664                                          :<MARG> :bytes)
     1665                                        (* 4 ,gpr-total))))
     1666             
     1667             (with-macptrs ((,regparams (pref ,marg-ptr :<MARG>.reg<P>arams)))
     1668               (progn ,@(static-arg-forms))
     1669               (%process-varargs-list ,regparams ,marg-ptr ,n-static-gprs ,n-static-fprs  ,rest-arg)
     1670               (external-call "_objc_msgSendv"
     1671                              :address ,receiver
     1672                              :address ,selptr
     1673                              :size_t (+ 32 (* 4 ,gpr-total))
     1674                              :address ,marg-ptr
     1675                              ,return-type-spec)))))))))
     1676
     1677#+(and apple-objc ppc64-target)
     1678(defun %compile-varargs-send-function-for-signature (sig)
     1679  (let* ((return-type-spec (car sig))
     1680         (arg-type-specs (butlast (cdr sig)))
     1681         (args (objc-gen-message-arglist (length arg-type-specs)))
     1682         (receiver (gensym))
     1683         (selector (gensym))
     1684         (rest-arg (gensym))
     1685         (arg-temp (gensym))
     1686         (marg-ptr (gensym))
     1687         (regparams (gensym))
     1688         (selptr (gensym))
     1689         (gpr-total (gensym))
     1690         (n-static-gprs 2)              ;receiver, selptr
     1691         (n-static-fprs 0))
     1692    (collect ((static-arg-forms))
     1693      (static-arg-forms `(setf (paref ,regparams (:* address) 0) ,receiver))
     1694      (static-arg-forms `(setf (paref ,regparams (:* address) 1) ,selptr))
     1695      (do* ((args args (cdr args))
     1696            (arg-type-specs arg-type-specs (cdr arg-type-specs)))
     1697           ((null args))
     1698        (let* ((arg (car args))
     1699               (spec (car arg-type-specs))
     1700               (static-arg-type (parse-foreign-type spec))
     1701               (gpr-base regparams)
     1702               (fpr-base marg-ptr)
     1703               (gpr-offset (* n-static-gprs 8)))
     1704          (etypecase static-arg-type
     1705            (foreign-integer-type
     1706             (let* ((bits (foreign-type-bits static-arg-type))
     1707                    (signed (foreign-integer-type-signed static-arg-type)))
     1708                 (progn
     1709                   (if (eq spec :<BOOL>)
     1710                     (setq arg `(%coerce-to-bool ,arg)))
     1711                   (static-arg-forms
     1712                    `(setf (paref ,gpr-base (:* (
     1713                                                 ,(if (foreign-integer-type-signed static-arg-type)
     1714                                                      :signed
     1715                                                      :unsigned)
     1716                                           64)) ,gpr-offset)
     1717                      ,arg))
     1718                   (incf n-static-gprs))))
     1719            (foreign-single-float-type
     1720             (static-arg-forms
     1721              `(setf (%get-single-float ,gpr-base ,(+ 4 (* 8 n-static-gprs))) ,arg))
     1722             (when (< n-static-fprs 13)
     1723               (static-arg-forms
     1724                `(setf (paref ,fpr-base (:* :double-float) ,n-static-fprs)
     1725                  (float (%get-single-float ,gpr-base ,(+ 4 (* 8 n-static-gprs))) 0.0d0)))
     1726               (incf n-static-fprs))
     1727             (incf n-static-gprs))
     1728            (foreign-double-float-type
     1729             (static-arg-forms
     1730              `(setf (%get-double-float ,gpr-base ,gpr-offset) ,arg))
     1731             (when (< n-static-fprs 13)
     1732               (static-arg-forms
     1733                `(setf (paref ,fpr-base (:* :double-float) ,n-static-fprs)
     1734                  (%get-double-float ,gpr-base ,gpr-offset)))
     1735               (incf n-static-fprs))
     1736             (incf n-static-gprs 1))
     1737            (foreign-pointer-type
     1738             (static-arg-forms
     1739              `(setf (paref ,gpr-base (:* address) ,n-static-gprs) ,arg))
     1740               (incf n-static-gprs)))))
     1741      (compile
     1742       nil
     1743       `(lambda (,receiver ,selector ,@args &rest ,rest-arg)
     1744         (declare (dynamic-extent ,rest-arg))
     1745         (let* ((,selptr (%get-selector ,selector))
     1746                (,gpr-total ,n-static-gprs))
     1747           (dolist (,arg-temp ,rest-arg)
     1748             (incf ,gpr-total 1))
     1749           (if (> ,gpr-total 8)
     1750             (setq ,gpr-total (- ,gpr-total 8))
     1751             (setq ,gpr-total 0))           
     1752           (%stack-block ((,marg-ptr (+ ,(%foreign-type-or-record-size
     1753                                          :<MARG> :bytes)
     1754                                        (* 8 ,gpr-total))))
     1755             
     1756             (with-macptrs ((,regparams (pref ,marg-ptr :<MARG>.reg<P>arams)))
     1757               (progn ,@(static-arg-forms))
     1758               (%process-varargs-list ,regparams ,marg-ptr ,n-static-gprs ,n-static-fprs  ,rest-arg)
     1759               (external-call "_objc_msgSendv"
     1760                              :address ,receiver
     1761                              :address ,selptr
     1762                              :size_t (+ 64 (* 8 ,gpr-total))
     1763                              :address ,marg-ptr
     1764                              ,return-type-spec)))))))))
     1765
     1766#-(and apple-objc (or x8664-target 32-target))
     1767(defun %compile-varargs-send-function-for-signature (sig)
     1768  (warn "Varargs function for signature ~s NYI" sig))
     1769
    15081770
    15091771
Note: See TracChangeset for help on using the changeset viewer.