Changeset 15801


Ignore:
Timestamp:
Apr 30, 2013, 9:20:09 PM (7 years ago)
Author:
gb
Message:

Inch some more.

Location:
branches/acode-rewrite/source
Files:
8 edited

Legend:

Unmodified
Added
Removed
  • branches/acode-rewrite/source/compiler/ARM/arm2.lisp

    r15607 r15801  
    10221022
    10231023
    1024 (defun arm2-structured-initopt (seg lcells vloc context vars inits spvars)
    1025   (with-arm-local-vinsn-macros (seg)
    1026     (dolist (var vars vloc)
    1027       (let* ((initform (pop inits))
    1028              (spvar (pop spvars))
    1029              (spvloc (%i+ vloc *arm2-target-node-size*))
    1030              (var-lcell (pop lcells))
    1031              (sp-reg ($ arm::arg_z))
    1032              (sp-lcell (pop lcells)))
    1033         (unless (nx-null initform)
    1034           (arm2-stack-to-register seg (arm2-vloc-ea spvloc) sp-reg)
    1035           (let ((skipinitlabel (backend-get-next-label)))
    1036             (with-crf-target () crf
    1037               (arm2-compare-register-to-nil seg crf (arm2-make-compound-cd 0 skipinitlabel) sp-reg arm::arm-cond-eq t))
    1038             (arm2-register-to-stack seg (arm2-one-untargeted-reg-form seg initform ($ arm::arg_z)) (arm2-vloc-ea vloc))
    1039             (@ skipinitlabel)))
    1040         (arm2-bind-structured-var seg var vloc var-lcell context)
    1041         (when spvar
    1042           (arm2-bind-var seg spvar spvloc sp-lcell)))
    1043       (setq vloc (%i+ vloc (* 2 *arm2-target-node-size*))))))
    1044 
    1045 
    1046 
    1047 (defun arm2-structured-init-keys (seg lcells vloc context allow-others keyvars keysupp keyinits keykeys)
    1048   (declare (ignore keykeys allow-others))
    1049   (with-arm-local-vinsn-macros (seg)
    1050     (dolist (var keyvars)
    1051       (let* ((spvar (pop keysupp))
    1052              (initform (pop keyinits))
    1053              (sploc (%i+ vloc *arm2-target-node-size*))
    1054              (var-lcell (pop lcells))
    1055              (sp-reg ($ arm::arg_z))
    1056              (sp-lcell (pop lcells)))
    1057         (unless (nx-null initform)
    1058           (arm2-stack-to-register seg (arm2-vloc-ea sploc) sp-reg)
    1059           (let ((skipinitlabel (backend-get-next-label)))
    1060             (with-crf-target () crf
    1061               (arm2-compare-register-to-nil seg crf (arm2-make-compound-cd 0 skipinitlabel) sp-reg arm::arm-cond-eq t))
    1062             (arm2-register-to-stack seg (arm2-one-untargeted-reg-form seg initform ($ arm::arg_z)) (arm2-vloc-ea vloc))
    1063             (@ skipinitlabel)))
    1064         (arm2-bind-structured-var seg var vloc var-lcell context)
    1065         (when spvar
    1066           (arm2-bind-var seg spvar sploc sp-lcell)))
    1067       (setq vloc (%i+ vloc (* 2 *arm2-target-node-size*))))))
     1024
     1025
     1026
     1027
     1028
    10681029
    10691030(defun arm2-vloc-ea (n &optional vcell-p)
     
    50855046    (arm2-close-var seg var)))
    50865047
    5087 (defun arm2-close-structured-var (seg var)
    5088   (if (arm2-structured-var-p var)
    5089     (apply #'arm2-close-structured-lambda seg (cdr var))
    5090     (arm2-close-var seg var)))
    5091 
    5092 (defun arm2-close-structured-lambda (seg whole req opt rest keys auxen)
    5093   (if whole
    5094     (arm2-close-var seg whole))
    5095   (dolist (var req)
    5096     (arm2-close-structured-var seg var))
    5097   (dolist (var (%car opt))
    5098     (arm2-close-structured-var seg var))
    5099   (dolist (var (%caddr opt))
    5100     (when var
    5101       (arm2-close-var seg var)))
    5102   (if rest
    5103     (arm2-close-structured-var seg rest))
    5104   (dolist (var (%cadr keys))
    5105     (arm2-close-structured-var seg var))
    5106   (dolist (var (%caddr keys))
    5107     (if var (arm2-close-var seg var)))
    5108   (dolist (var (%car auxen))
    5109     (arm2-close-var seg var)))
     5048
    51105049
    51115050
     
    51155054    (arm2-set-var-ea seg var (make-wired-lreg reg :class (hard-regspec-class reg) :mode (get-regspec-mode reg)))))
    51165055
    5117 (defun arm2-bind-structured-var (seg var vloc lcell &optional context)
    5118   (declare (ignore context))
    5119   (if (not (arm2-structured-var-p var))
    5120     (let* ((reg (nx2-assign-register-var var)))
    5121       (if reg
    5122         (arm2-init-regvar seg var reg (arm2-vloc-ea vloc))
    5123         (arm2-bind-var seg var vloc lcell)))
    5124     (compiler-bug "Old destructuring code ...")))
    5125 
    5126 (defun arm2-bind-structured-lambda (seg lcells vloc context whole req opt rest keys auxen
    5127                         &aux (nkeys (list-length (%cadr keys))))
    5128   (declare (fixnum vloc))
    5129   (when whole
    5130     (arm2-bind-structured-var seg whole vloc (pop lcells))
    5131     (incf vloc *arm2-target-node-size*))
    5132   (dolist (arg req)
    5133     (arm2-bind-structured-var seg arg vloc (pop lcells) context)
    5134     (incf vloc *arm2-target-node-size*))
    5135   (when opt
    5136    (if (arm2-hard-opt-p opt)
    5137      (setq vloc (apply #'arm2-structured-initopt seg lcells vloc context opt)
    5138            lcells (nthcdr (ash (length (car opt)) 1) lcells))
    5139      (dolist (var (%car opt))
    5140        (arm2-bind-structured-var seg var vloc (pop lcells) context)
    5141        (incf vloc *arm2-target-node-size*))))
    5142   (when rest
    5143     (arm2-bind-structured-var seg rest vloc (pop lcells) context)
    5144     (incf vloc *arm2-target-node-size*))
    5145   (when keys
    5146     (apply #'arm2-structured-init-keys seg lcells vloc context keys)
    5147     (setq vloc (%i+ vloc (* *arm2-target-node-size* (+ nkeys nkeys)))))
    5148   (arm2-seq-bind seg (%car auxen) (%cadr auxen)))
    5149 
    5150 (defun arm2-structured-var-p (var)
    5151   (and (consp var) (or (eq (%car var) *nx-lambdalist*)
    5152                        (eq (%car var) (%nx1-operator lambda-list)))))
    51535056
    51545057(defun arm2-simple-var (var &aux (bits (cadr var)))
     
    52565159            (compiler-bug "unknown payback token ~s" r)))))))
    52575160
    5258 (defun arm2-spread-lambda-list (seg listform whole req opt rest keys)
    5259   (with-arm-local-vinsn-macros (seg)
    5260     (let* ((numopt (length (%car opt)))
    5261            (nkeys (length (%cadr keys)))
    5262            (numreq (length req))
    5263            (vtotal numreq)
    5264            (old-top *arm2-top-vstack-lcell*)
    5265            (listreg ($ arm::arg_z))
    5266            (doadlword (dpb nkeys (byte 8 16) (dpb numopt (byte 8 8) (dpb numreq (byte 8 0) 0 )))))
    5267       (declare (fixnum numopt nkeys numreq vtotal doadlword))
    5268       (when (or (> numreq 255) (> numopt 255) (> nkeys 255))
    5269         (compiler-bug "A lambda list can contain a maximum of 255 required, 255 optional, and 255 keywords args"))
    5270       (if (fixnump listform)
    5271         (arm2-store-ea seg listform listreg)
    5272         (arm2-one-targeted-reg-form seg listform listreg))
    5273       (when whole
    5274         (arm2-vpush-register seg listreg :reserved))
    5275       (when keys
    5276         (setq doadlword (%ilogior2 (ash 1 25) doadlword))
    5277         (incf  vtotal (%ilsl 1 nkeys))
    5278         (if (%car keys)                 ; &allow-other-keys
    5279           (setq doadlword (%ilogior doadlword (ash 1 26))))
    5280         (arm2-store-immediate seg (%car (%cdr (%cdr (%cdr (%cdr keys))))) arm::temp2))
    5281       (when opt
    5282         (setq vtotal (%i+ vtotal numopt))
    5283         (when (arm2-hard-opt-p opt)
    5284           (setq doadlword (logior doadlword (ash 1 29)))
    5285           (setq vtotal (%i+ vtotal numopt))))
    5286       (when rest
    5287         (setq doadlword (%ilogior2 (ash 1 27) doadlword) vtotal (%i+ vtotal 1)))
    5288       (arm2-reserve-vstack-lcells vtotal)
    5289       (! load-adl doadlword)
    5290       (! debind)
    5291       (arm2-set-vstack (%i+ *arm2-vstack* (* *arm2-target-node-size* vtotal)))
    5292       (arm2-collect-lcells :reserved old-top))))
     5161
    52935162
    52945163
     
    58715740
    58725741
    5873 (defarm2 arm2-%primitive %primitive (seg vreg xfer &rest ignore)
    5874   (declare (ignore seg vreg xfer ignore))
    5875   (compiler-bug "You're probably losing big: using %primitive ..."))
     5742
    58765743
    58775744(defarm2 arm2-consp consp (seg vreg xfer cc form)
     
    70556922      (arm2-ternary-builtin seg vreg xfer '%aset1 v i n))))
    70566923
    7057 (defarm2 arm2-%i+ %i+ (seg vreg xfer form1 form2 &optional overflow)
    7058   (when overflow
    7059     (let* ((type *arm2-target-half-fixnum-type*))
    7060       (when (and (arm2-form-typep form1 type)
    7061                  (arm2-form-typep form2 type))
    7062         (setq overflow nil))))
    7063   (let* ((fix1 (acode-fixnum-form-p form1))
    7064          (fix2 (acode-fixnum-form-p form2))
    7065          (sum (and fix1 fix2 (if overflow (+ fix1 fix2) (%i+ fix1 fix2)))))
    7066     (cond ((null vreg)
    7067            (arm2-form seg nil nil form1)
    7068            (arm2-form seg nil xfer form2))
    7069           (sum
    7070            (if (nx1-target-fixnump sum)
    7071              (arm2-use-operator (%nx1-operator fixnum) seg vreg xfer sum)
    7072              (arm2-use-operator (%nx1-operator immediate) seg vreg xfer sum)))
    7073           (overflow
    7074            (multiple-value-bind (r1 r2) (arm2-two-untargeted-reg-forms seg form1 arm::arg_y form2 arm::arg_z)
    7075              (ensuring-node-target (target vreg)
    7076                (if *arm2-open-code-inline*
    7077                  (! fixnum-add-overflow-inline target r1 r2)
    7078                  (progn
    7079                    (! fixnum-add-overflow-ool ($ arm::arg_z) r1 r2)
    7080                    (arm2-copy-register seg target ($ arm::arg_z)))))
    7081              (^)))
    7082           (t                             
    7083            ;; There isn't any "addi" that checks for overflow, which is
    7084            ;; why we didn't bother.
    7085            (let* ((other (if (and fix1
    7086                                   (typep (ash fix1 *arm2-target-fixnum-shift*)
    7087                                          '(signed-byte 32))
    7088                                   (or (arm::encode-arm-immediate
    7089                                        (ash fix1 *arm2-target-fixnum-shift*))
    7090                                       (arm::encode-arm-immediate
    7091                                        (- (ash fix1 *arm2-target-fixnum-shift*)))))
    7092                            form2
    7093                            (if (and fix2
    7094                                     (typep (ash fix2 *arm2-target-fixnum-shift*)
     6924(defun arm2-fixnum-add (seg vreg xfer form1 form2 overflow)
     6925  (with-arm-local-vinsn-macros (seg vreg xfer)
     6926    (when overflow
     6927      (let* ((type *arm2-target-half-fixnum-type*))
     6928        (when (and (arm2-form-typep form1 type)
     6929                   (arm2-form-typep form2 type))
     6930          (setq overflow nil))))
     6931    (let* ((fix1 (acode-fixnum-form-p form1))
     6932           (fix2 (acode-fixnum-form-p form2))
     6933           (sum (and fix1 fix2 (if overflow (+ fix1 fix2) (%i+ fix1 fix2)))))
     6934      (cond ((null vreg)
     6935             (arm2-form seg nil nil form1)
     6936             (arm2-form seg nil xfer form2))
     6937            (sum
     6938             (if (nx1-target-fixnump sum)
     6939               (arm2-use-operator (%nx1-operator fixnum) seg vreg xfer sum)
     6940               (arm2-use-operator (%nx1-operator immediate) seg vreg xfer sum)))
     6941            (overflow
     6942             (multiple-value-bind (r1 r2) (arm2-two-untargeted-reg-forms seg form1 arm::arg_y form2 arm::arg_z)
     6943               (ensuring-node-target (target vreg)
     6944                 (if *arm2-open-code-inline*
     6945                   (! fixnum-add-overflow-inline target r1 r2)
     6946                   (progn
     6947                     (! fixnum-add-overflow-ool ($ arm::arg_z) r1 r2)
     6948                     (arm2-copy-register seg target ($ arm::arg_z)))))
     6949               (^)))
     6950            (t                             
     6951             ;; There isn't any "addi" that checks for overflow, which is
     6952             ;; why we didn't bother.
     6953             (let* ((other (if (and fix1
     6954                                    (typep (ash fix1 *arm2-target-fixnum-shift*)
    70956955                                           '(signed-byte 32))
    70966956                                    (or (arm::encode-arm-immediate
    7097                                          (ash fix2 *arm2-target-fixnum-shift*))
     6957                                         (ash fix1 *arm2-target-fixnum-shift*))
    70986958                                        (arm::encode-arm-immediate
    7099                                          (- (ash fix2 *arm2-target-fixnum-shift*)))))
    7100                              form1))))
    7101              (if (and fix1 fix2)
    7102                (arm2-lri seg vreg (ash (+ fix1 fix2) *arm2-target-fixnum-shift*))
    7103                (if other
    7104                  (let* ((constant (ash (or fix1 fix2) *arm2-target-fixnum-shift*))
    7105                         (reg (arm2-one-untargeted-reg-form seg other (if (and vreg (node-reg-p vreg)) vreg arm::arg_z))))
    7106                    (if (zerop constant)
    7107                      (<- reg)
     6959                                         (- (ash fix1 *arm2-target-fixnum-shift*)))))
     6960                             form2
     6961                             (if (and fix2
     6962                                      (typep (ash fix2 *arm2-target-fixnum-shift*)
     6963                                             '(signed-byte 32))
     6964                                      (or (arm::encode-arm-immediate
     6965                                           (ash fix2 *arm2-target-fixnum-shift*))
     6966                                          (arm::encode-arm-immediate
     6967                                           (- (ash fix2 *arm2-target-fixnum-shift*)))))
     6968                               form1))))
     6969               (if (and fix1 fix2)
     6970                 (arm2-lri seg vreg (ash (+ fix1 fix2) *arm2-target-fixnum-shift*))
     6971                 (if other
     6972                   (let* ((constant (ash (or fix1 fix2) *arm2-target-fixnum-shift*))
     6973                          (reg (arm2-one-untargeted-reg-form seg other (if (and vreg (node-reg-p vreg)) vreg arm::arg_z))))
     6974                     (if (zerop constant)
     6975                       (<- reg)
     6976                       (ensuring-node-target (target vreg)
     6977                         (! add-immediate target reg constant))))
     6978                   (multiple-value-bind (r1 r2) (arm2-two-untargeted-reg-forms seg form1 arm::arg_y form2 arm::arg_z)
    71086979                     (ensuring-node-target (target vreg)
    7109                        (! add-immediate target reg constant))))
    7110                  (multiple-value-bind (r1 r2) (arm2-two-untargeted-reg-forms seg form1 arm::arg_y form2 arm::arg_z)
    7111                    (ensuring-node-target (target vreg)
    7112                      (! fixnum-add target r1 r2)))))
    7113              (^))))))
     6980                       (! fixnum-add target r1 r2)))))
     6981               (^)))))))
     6982
     6983(defarm2 arm2-%i+ %i+ (seg vreg xfer form1 form2 &optional overflow)
     6984  (arm2-fixnum-add seg vreg xfer form1 form2 overflow))
     6985
     6986(defarm2 arm2-fixnum-add-overflow fixnum-add-overflow (seg vreg xfer form1 form2)
     6987  (arm2-fixnum-add seg vreg xfer form1 form2 t))
     6988
     6989(defarm2 arm2-fixnum-add-no-overflow fixnum-add-no-overflow (seg vreg xfer form1 form2)
     6990  (arm2-fixnum-add seg vreg xfer form1 form2 nil))
     6991   
     6992
     6993(defun arm2-fixnum-sub (seg vreg xfer num1 num2 overflow)
     6994  (with-arm-local-vinsn-macros (seg vreg xfer)
     6995    (when overflow
     6996      (let* ((type *arm2-target-half-fixnum-type*))
     6997        (when (and (arm2-form-typep num1 type)
     6998                   (arm2-form-typep num2 type))
     6999          (setq overflow nil))))
     7000    (let* ((v1 (acode-fixnum-form-p num1))
     7001           (v2 (acode-fixnum-form-p num2))
     7002           (diff (and v1 v2 (if overflow (- v1 v2) (%i- v1 v2)))))
     7003      (if diff
     7004        (if (nx1-target-fixnump diff)
     7005          (arm2-use-operator (%nx1-operator fixnum) seg vreg xfer diff)
     7006          (arm2-use-operator (%nx1-operator immediate) seg vreg xfer diff))
     7007        (if (and v2 (neq v2 most-negative-fixnum))
     7008          (arm2-use-operator (%nx1-operator %i+) seg vreg xfer num1 (make-acode (%nx1-operator fixnum) (- v2)) overflow)
     7009          (if (eq v2 0)
     7010            (arm2-form seg vreg xfer num1)
     7011            (cond
     7012              ((null vreg)
     7013               (arm2-form seg nil nil num1)
     7014               (arm2-form seg nil xfer num2))
     7015              (overflow
     7016               (multiple-value-bind (r1 r2) (arm2-two-untargeted-reg-forms seg num1 arm::arg_y num2 arm::arg_z)
     7017                 (ensuring-node-target (target vreg)
     7018                   (if *arm2-open-code-inline*
     7019                     (! fixnum-sub-overflow-inline target r1 r2)
     7020                     (progn
     7021                       (! fixnum-sub-overflow-ool ($ arm::arg_z) r1 r2)
     7022                       (arm2-copy-register seg target ($ arm::arg_z)))))
     7023                 (^)))
     7024              (t
     7025               (multiple-value-bind (r1 r2) (arm2-two-untargeted-reg-forms seg num1 arm::arg_y num2 arm::arg_z)
     7026                 (ensuring-node-target (target vreg)
     7027                   (! fixnum-sub target r1 r2))
     7028                 (^))))))))))
    71147029
    71157030(defarm2 arm2-%i- %i- (seg vreg xfer num1 num2 &optional overflow)
    7116   (when overflow
    7117     (let* ((type *arm2-target-half-fixnum-type*))
    7118       (when (and (arm2-form-typep num1 type)
    7119                  (arm2-form-typep num2 type))
    7120         (setq overflow nil))))
    7121   (let* ((v1 (acode-fixnum-form-p num1))
    7122          (v2 (acode-fixnum-form-p num2))
    7123          (diff (and v1 v2 (if overflow (- v1 v2) (%i- v1 v2)))))
    7124     (if diff
    7125       (if (nx1-target-fixnump diff)
    7126         (arm2-use-operator (%nx1-operator fixnum) seg vreg xfer diff)
    7127         (arm2-use-operator (%nx1-operator immediate) seg vreg xfer diff))
    7128       (if (and v2 (neq v2 most-negative-fixnum))
    7129         (arm2-use-operator (%nx1-operator %i+) seg vreg xfer num1 (make-acode (%nx1-operator fixnum) (- v2)) overflow)
    7130         (if (eq v2 0)
    7131           (arm2-form seg vreg xfer num1)
    7132           (cond
    7133            ((null vreg)
    7134             (arm2-form seg nil nil num1)
    7135             (arm2-form seg nil xfer num2))
    7136            (overflow
    7137             (multiple-value-bind (r1 r2) (arm2-two-untargeted-reg-forms seg num1 arm::arg_y num2 arm::arg_z)
    7138                (ensuring-node-target (target vreg)
    7139                  (if *arm2-open-code-inline*
    7140                    (! fixnum-sub-overflow-inline target r1 r2)
    7141                    (progn
    7142                      (! fixnum-sub-overflow-ool ($ arm::arg_z) r1 r2)
    7143                      (arm2-copy-register seg target ($ arm::arg_z)))))
    7144               (^)))
    7145            (t
    7146             (multiple-value-bind (r1 r2) (arm2-two-untargeted-reg-forms seg num1 arm::arg_y num2 arm::arg_z)
    7147               (ensuring-node-target (target vreg)
    7148                 (! fixnum-sub target r1 r2))
    7149               (^)))))))))
     7031  (arm2-fixnum-sub seg vreg xfer num1 num2 overflow))
     7032
     7033(defarm2 arm2-fixnum-sub-no-overflow fixnum-sub-no-overflow (seg vreg xfer num1 num2)
     7034  (arm2-fixnum-sub seg vreg xfer num1 num2 nil))
     7035
     7036(defarm2 arm2-fixnum-sub-overflow fixnum-sub-overflow (seg vreg xfer num1 num2)
     7037  (arm2-fixnum-sub seg vreg xfer num1 num2 t))
     7038
    71507039
    71517040(defarm2 arm2-%i* %i* (seg vreg xfer num1 num2)
     
    72317120        (arm2-close-var seg var)))))
    72327121
    7233 (defarm2 arm2-debind debind (seg vreg xfer lambda-list bindform req opt rest keys auxen whole body p2decls cdr-p)
    7234   (declare (ignore lambda-list))
    7235   (when cdr-p
    7236     (compiler-bug "Unsupported: old destructuring code, cdr-p case."))
    7237   (let* ((old-stack (arm2-encode-stack))
    7238          (*arm2-top-vstack-lcell* *arm2-top-vstack-lcell*)
    7239          (vloc *arm2-vstack*))
    7240     (with-arm-p2-declarations p2decls     
    7241       (arm2-bind-structured-lambda
    7242        seg
    7243        (arm2-spread-lambda-list seg bindform whole req opt rest keys)
    7244        vloc (arm2-vloc-ea vloc) whole req opt rest keys auxen)
    7245       (arm2-undo-body seg vreg xfer body old-stack)
    7246       (arm2-close-structured-lambda seg whole req opt rest keys auxen))))
     7122
    72477123
    72487124(defarm2 arm2-multiple-value-prog1 multiple-value-prog1 (seg vreg xfer forms)
     
    78297705            (arm2-close-var seg var)))))))
    78307706
    7831 ;;; Make a function call (e.g., to mapcar) with some of the toplevel arguments
    7832 ;;; stack-consed (downward) closures.  Bind temporaries to these closures so
    7833 ;;; that tail-recursion/non-local exits work right.
    7834 ;;; (all of the closures are distinct: FLET and LABELS establish dynamic extent themselves.)
    7835 (defarm2 arm2-with-downward-closures with-downward-closures (seg vreg xfer tempvars closures callform)
    7836   (let* ((old-stack (arm2-encode-stack)))
    7837     (arm2-seq-bind seg tempvars closures)
    7838     (arm2-undo-body seg vreg xfer callform old-stack)
    7839     (dolist (v tempvars) (arm2-close-var seg v))))
     7707
    78407708
    78417709
     
    86848552
    86858553
    8686 (defarm2 arm2-eabi-syscall eabi-syscall (seg vreg xfer idx argspecs argvals resultspec)
    8687   (let* ((*arm2-vstack* *arm2-vstack*)
    8688          (*arm2-top-vstack-lcell* *arm2-top-vstack-lcell*)
    8689          (*arm2-cstack* *arm2-cstack*)
    8690          (nextarg 0))
    8691     (declare (fixnum nextarg))
    8692     (! alloc-c-frame (the fixnum (length argvals)))
    8693     (arm2-open-undo $undo-arm-c-frame)
    8694     ;; Evaluate each form into the C frame, according to the matching argspec.
    8695     (do* ((specs argspecs (cdr specs))
    8696           (vals argvals (cdr vals)))
    8697          ((null specs))
    8698       (declare (list specs vals))
    8699       (let* ((valform (car vals))
    8700              (spec (car specs))
    8701              (absptr (acode-absolute-ptr-p valform)))
    8702         (case spec
    8703           (:address
    8704            (with-imm-target ()
    8705              (ptr :address)
    8706              (if absptr
    8707                (arm2-lri seg ptr absptr)
    8708                (arm2-one-targeted-reg-form seg valform ptr))
    8709              (! set-eabi-c-arg ptr nextarg)))
    8710           (t
    8711            (! set-eabi-c-arg
    8712               (with-imm-target ()
    8713                 (valreg :natural)
    8714                 (arm2-unboxed-integer-arg-to-reg seg valform valreg spec))
    8715               nextarg)))
    8716         (incf nextarg)))
    8717     (arm2-form seg arm::arg_z nil idx)
    8718     (! eabi-syscall)
    8719     (arm2-close-undo)
    8720     (when vreg
    8721       (if (eq resultspec :void)
    8722         (<- nil)
    8723         (<- (set-regspec-mode arm::imm0 (gpr-mode-name-value
    8724                                          (case resultspec
    8725                                            (:address :address)
    8726                                            (:signed-byte :s8)
    8727                                            (:unsigned-byte :u8)
    8728                                            (:signed-halfword :s16)
    8729                                            (:unsigned-halfword :u16)
    8730                                            (:signed-fullword :s32)
    8731                                            (t :u32)))))))
    8732     (^)))
     8554
    87338555
    87348556
  • branches/acode-rewrite/source/compiler/PPC/ppc2.lisp

    r15620 r15801  
    83708370
    83718371
    8372 (defppc2 ppc2-eabi-syscall eabi-syscall (seg vreg xfer idx argspecs argvals resultspec &optional monitor-exception-ports)
    8373   (declare (ignore monitor-exception-ports))
    8374   (let* ((*ppc2-vstack* *ppc2-vstack*)
    8375          (*ppc2-top-vstack-lcell* *ppc2-top-vstack-lcell*)
    8376          (*ppc2-cstack* *ppc2-cstack*)
    8377          (nextarg 0))
    8378     (declare (fixnum nextarg))
    8379     (! alloc-eabi-c-frame (the fixnum (length argvals)))
    8380     (ppc2-open-undo $undo-ppc-c-frame)
    8381     ;; Evaluate each form into the C frame, according to the matching argspec.
    8382     (do* ((specs argspecs (cdr specs))
    8383           (vals argvals (cdr vals)))
    8384          ((null specs))
    8385       (declare (list specs vals))
    8386       (let* ((valform (car vals))
    8387              (spec (car specs))
    8388              (absptr (acode-absolute-ptr-p valform)))
    8389         (case spec
    8390           (:address
    8391            (with-imm-target ()
    8392              (ptr :address)
    8393              (if absptr
    8394                (ppc2-lri seg ptr absptr)
    8395                (ppc2-one-targeted-reg-form seg valform ptr))
    8396              (! set-eabi-c-arg ptr nextarg)))
    8397           (t
    8398            (! set-eabi-c-arg
    8399               (with-imm-target ()
    8400                 (valreg :natural)
    8401                 (ppc2-unboxed-integer-arg-to-reg seg valform valreg spec))
    8402               nextarg)))
    8403         (incf nextarg)))
    8404     (ppc2-form seg ppc::arg_z nil idx)
    8405     (! eabi-syscall)
    8406     (ppc2-close-undo)
    8407     (when vreg
    8408       (if (eq resultspec :void)
    8409         (<- nil)
    8410         (<- (set-regspec-mode ppc::imm0 (gpr-mode-name-value
    8411                                          (case resultspec
    8412                                            (:address :address)
    8413                                            (:signed-byte :s8)
    8414                                            (:unsigned-byte :u8)
    8415                                            (:signed-halfword :s16)
    8416                                            (:unsigned-halfword :u16)
    8417                                            (:signed-fullword :s32)
    8418                                            (t :u32)))))))
    8419     (^)))
     8372
    84208373
    84218374
     
    85468499    (^)))
    85478500
    8548 (defppc2 ppc2-poweropen-syscall poweropen-syscall (seg vreg xfer idx argspecs argvals resultspec &optional monitor-exception-ports)
    8549   (declare (ignore monitor-exception-ports))
    8550   (let* ((*ppc2-vstack* *ppc2-vstack*)
    8551          (*ppc2-top-vstack-lcell* *ppc2-top-vstack-lcell*)
    8552          (*ppc2-cstack* *ppc2-cstack*))
    8553     (! alloc-c-frame (the fixnum
    8554                        (+ (the fixnum (length argvals))
    8555                           (the fixnum
    8556                             (let* ((n 0))
    8557                               (declare (fixnum n))
    8558                               (dolist (spec argspecs n)
    8559                                 (if (typep spec 'unsigned-byte)
    8560                                   (incf n (the fixnum
    8561                                             (1- (the fixnum spec))))))))
    8562                           (the fixnum
    8563                             (count-if
    8564                              #'(lambda (x)
    8565                                  (member x
    8566                                          '(:double-float
    8567                                            :unsigned-doubleword
    8568                                            :signed-doubleword)))
    8569                              argspecs)))))
    8570     (ppc2-open-undo $undo-ppc-c-frame)
    8571     (ppc2-poweropen-foreign-args seg argspecs argvals)
    8572     (ppc2-form seg ppc::arg_z nil idx)
    8573     (if (eq resultspec :signed-doubleword)
    8574       (! poweropen-syscall-s64)
    8575       (! poweropen-syscall))
    8576     (ppc2-close-undo)
    8577     (ppc2-poweropen-foreign-return seg vreg xfer resultspec)))
     8501
    85788502
    85798503(defun ppc2-identity (seg vreg xfer arg)
  • branches/acode-rewrite/source/compiler/X86/x862.lisp

    r15800 r15801  
    98699869  (x862-mvcall seg vreg xfer fn arglist))
    98709870
    9871 (defx862 x862-i386-syscall i386-syscall (seg vreg xfer idx argspecs argvals resultspec &optional monitor-exception-ports)
    9872   (declare (ignore monitor-exception-ports))
    9873   (let* ((*x862-vstack* *x862-vstack*)
    9874          (*x862-top-vstack-lcell* *x862-top-vstack-lcell*)
    9875          (*x862-cstack* *x862-cstack*)
    9876          (offset 0)
    9877          (nwords 0))
    9878     (dolist (argspec argspecs)
    9879       (case argspec
    9880         ((:unsigned-doubleword :signed-doubleword)
    9881          (incf nwords 2))
    9882         (t (incf nwords))))
    9883     (! alloc-c-frame nwords)
    9884     (x862-open-undo $undo-x86-c-frame)
    9885     (x862-vpush-register seg (x862-one-untargeted-reg-form seg idx x8632::arg_z))
    9886     ;; Evaluate each form into the C frame, according to the
    9887     ;; matching argspec.
    9888     (do* ((specs argspecs (cdr specs))
    9889           (vals argvals (cdr vals)))
    9890          ((null specs))
    9891       (declare (list specs vals))
    9892       (let* ((valform (car vals))
    9893              (spec (car specs))
    9894              (absptr (acode-absolute-ptr-p valform)))
    9895         (case spec
    9896           ((:unsigned-doubleword :signed-doubleword)
    9897            (x862-one-targeted-reg-form seg valform ($ x8632::arg_z))
    9898            (if (eq spec :signed-doubleword)
    9899              (! gets64)
    9900              (! getu64))
    9901            (! set-c-arg-from-mm0 offset)
    9902            (incf offset 2))
    9903           (:address
    9904            (with-imm-target () (ptr :address)
    9905              (if absptr
    9906                (x862-lri seg ptr absptr)
    9907                (x862-form seg ptr nil valform))
    9908              (! set-c-arg ptr offset))
    9909            (incf offset))
    9910           (t
    9911            (with-imm-target () (valreg :natural)
    9912              (let* ((reg (x862-unboxed-integer-arg-to-reg seg valform valreg spec)))
    9913                (! set-c-arg reg offset)
    9914                (incf offset)))))))
    9915     (x862-vpop-register seg ($ x8632::arg_z))
    9916     (case resultspec
    9917       ((:unsigned-doubleword :signed-doubleword)
    9918        (! syscall2))                    ;copies doubleword result into %mm0
    9919       (t
    9920        (! syscall)))
    9921     (x862-close-undo)
    9922     (when vreg
    9923       (cond ((eq resultspec :void) (<- nil))
    9924             ((eq resultspec :unsigned-doubleword)
    9925              (ensuring-node-target (target vreg)
    9926                (! makeu64)
    9927                (x862-copy-register seg target ($ *x862-arg-z*))))
    9928             ((eq resultspec :signed-doubleword)
    9929              (ensuring-node-target (target vreg)
    9930                (! makes64)
    9931                (x862-copy-register seg target ($ *x862-arg-z*))))
    9932             (t
    9933              (case resultspec
    9934                (:signed-byte (! sign-extend-s8 *x862-imm0* *x862-imm0*))
    9935                (:signed-halfword (! sign-extend-s16 *x862-imm0* *x862-imm0*))
    9936                (:unsigned-byte (! zero-extend-u8 *x862-imm0* *x862-imm0*))
    9937                (:unsigned-halfword (! zero-extend-u16 *x862-imm0* *x862-imm0*)))
    9938              (<- (make-wired-lreg x8632::imm0
    9939                                   :mode
    9940                                   (gpr-mode-name-value
    9941                                    (case resultspec
    9942                                      (:address :address)
    9943                                      (:signed-byte :s8)
    9944                                      (:unsigned-byte :u8)
    9945                                      (:signed-halfword :s16)
    9946                                      (:unsigned-halfword :u16)
    9947                                      (:signed-fullword :s32)
    9948                                      (t :u32))))))))
    9949     (^)))
    9950 
    9951 
    9952 (defx862 x862-syscall syscall (seg vreg xfer idx argspecs argvals resultspec &optional monitor-exception-ports)
    9953   (declare (ignore monitor-exception-ports))
    9954   (let* ((*x862-vstack* *x862-vstack*)
    9955          (*x862-top-vstack-lcell* *x862-top-vstack-lcell*)
    9956          (*x862-cstack* *x862-cstack*)
    9957          (gpr-offset 0)
    9958          (other-offset 6)
    9959          (nother-words 0)
    9960          (ngpr-args 0)
    9961          (simple-foreign-args nil))
    9962       (declare (fixnum  ngpr-args nother-words
    9963                         gpr-offset other-offset))
    9964       (dolist (argspec argspecs)
    9965         (declare (ignorable argspec))
    9966         (incf ngpr-args)
    9967         (if (> ngpr-args 6)
    9968           (incf nother-words)))
    9969       (let* ((total-words nother-words))
    9970         (when (zerop total-words)
    9971           (setq simple-foreign-args nil))
    9972         (! alloc-c-frame total-words))
    9973       (x862-open-undo $undo-x86-c-frame)
    9974       (setq ngpr-args 0)
    9975       (unless simple-foreign-args
    9976         (x862-vpush-register seg (x862-one-untargeted-reg-form seg idx *x862-arg-z*)))
    9977       ;; Evaluate each form into the C frame, according to the
    9978       ;; matching argspec.
    9979       (do* ((specs argspecs (cdr specs))
    9980             (vals argvals (cdr vals)))
    9981            ((null specs))
    9982         (declare (list specs vals))
    9983         (let* ((valform (car vals))
    9984                (spec (car specs))
    9985                (absptr (acode-absolute-ptr-p valform)))
    9986           (case spec
    9987             (:address
    9988              (with-imm-target () (ptr :address)
    9989                (if absptr
    9990                  (x862-lri seg ptr absptr)
    9991                  (x862-form seg ptr nil valform))
    9992                (incf ngpr-args)
    9993                (cond ((<= ngpr-args 6)
    9994                       (! set-c-arg ptr gpr-offset)
    9995                       (incf gpr-offset))
    9996                      (t
    9997                       (! set-c-arg ptr other-offset)
    9998                       (incf other-offset)))))
    9999             (t
    10000              (with-imm-target () (valreg :natural)
    10001                 (let* ((reg (x862-unboxed-integer-arg-to-reg seg valform valreg spec)))
    10002                   (incf ngpr-args)
    10003                   (cond ((<= ngpr-args 8)
    10004                          (! set-c-arg reg gpr-offset)
    10005                          (incf gpr-offset))
    10006                         (t
    10007                          (! set-c-arg reg other-offset)
    10008                          (incf other-offset)))))))))     
    10009       (unless simple-foreign-args
    10010         (x862-vpop-register seg ($ *x862-arg-z*)))
    10011       (! syscall)
    10012       (x862-close-undo)
    10013       (when vreg
    10014         (cond ((eq resultspec :void) (<- nil))
    10015               ((eq resultspec :unsigned-doubleword)
    10016                (ensuring-node-target (target vreg)
    10017                  (! makeu64)
    10018                  (x862-copy-register seg target ($ *x862-arg-z*))))
    10019               ((eq resultspec :signed-doubleword)
    10020                (ensuring-node-target (target vreg)
    10021                  (! makes64)
    10022                  (x862-copy-register seg target ($ *x862-arg-z*))))
    10023               (t
    10024                (case resultspec
    10025                  (:signed-byte (! sign-extend-s8 *x862-imm0* *x862-imm0*))
    10026                  (:signed-halfword (! sign-extend-s16 *x862-imm0* *x862-imm0*))
    10027                  (:signed-fullword (! sign-extend-s32 *x862-imm0* *x862-imm0*))
    10028                  (:unsigned-byte (! zero-extend-u8 *x862-imm0* *x862-imm0*))
    10029                  (:unsigned-halfword (! zero-extend-u16 *x862-imm0* *x862-imm0*))
    10030                  (:unsigned-fullword (! zero-extend-u32 *x862-imm0* *x862-imm0*)))               
    10031                (<- (make-wired-lreg *x862-imm0*
    10032                                     :mode
    10033                                     (gpr-mode-name-value
    10034                                      (case resultspec
    10035                                        (:address :address)
    10036                                        (:signed-byte :s8)
    10037                                        (:unsigned-byte :u8)
    10038                                        (:signed-halfword :s16)
    10039                                        (:unsigned-halfword :u16)
    10040                                        (:signed-fullword :s32)
    10041                                        (t :u32))))))))
    10042       (^)))
     9871
    100439872
    100449873(defx862 x862-i386-ff-call i386-ff-call (seg vreg xfer address argspecs argvals resultspec &optional monitor)
  • branches/acode-rewrite/source/compiler/acode-rewrite.lisp

    r15800 r15801  
    429429(def-acode-rewrite rewrite-nullary (t nil %unbound-marker %slot-unbound-marker %illegal-marker %current-tcr %foreign-stack-pointer %current-frame-ptr %interrupt-poll) asserted-type (&whole w))
    430430
    431 (def-acode-rewrite rewrite-call (call lexical-function-call builtin-call) asserted-type (&whole w callable arglist &optional spread-p)
     431(def-acode-rewrite rewrite-call (call lexical-function-call builtin-call multiple-value-call) asserted-type (&whole w callable arglist &optional spread-p)
    432432  (declare (ignore spread-p))
    433433  (when (acode-p callable)
     
    533533  (rewrite-acode-form body asserted-type))
    534534
    535 (def-acode-rewrite acode-rewrite-ff-call ff-call asserted-type (address argspecs argvals resultspec &optional monitor)
     535(def-acode-rewrite acode-rewrite-ff-call (ff-call eabi-ff-call poweropen-ff-call i386-ff-call) asserted-type (address argspecs argvals resultspec &optional monitor)
    536536  (declare (ignore argspecs resultspec monitor))
    537537  (rewrite-acode-form address)
  • branches/acode-rewrite/source/compiler/nx1.lisp

    r15800 r15801  
    16501650      ((:darwinx8632 :linuxx8632 :win32 :solarisx8632 :freebsdx8632) (%nx1-operator i386-ff-call))
    16511651      ((:linuxx8664 :freebsdx8664 :darwinx8664 :solarisx8664 :win64) (%nx1-operator ff-call)))))
    1652 
    1653 (defnx1 nx1-syscall ((%syscall)) context (idx &rest arg-specs-and-result-spec)
    1654   (flet ((map-to-representation-types (list)
    1655            (collect ((out))
    1656              (do* ((l list (cddr l)))
    1657                   ((null (cdr l))
    1658                    (if l
    1659                      (progn
    1660                        (out (foreign-type-to-representation-type (car l)))
    1661                        (out))
    1662                      (error "Missing result type in ~s" list)))
    1663                (out (foreign-type-to-representation-type (car l)))
    1664                (out (cadr l))))))
    1665           (nx1-ff-call-internal
    1666            context
    1667            idx (map-to-representation-types arg-specs-and-result-spec)
    1668            (ecase (backend-name *target-backend*)
    1669              (:linuxppc32 (%nx1-operator eabi-syscall))
    1670              ((:darwinppc32 :darwinppc64 :linuxppc64)
    1671               (%nx1-operator poweropen-syscall))
    1672              ((:darwinx8632 :linuxx632 :win32) (%nx1-operator i386-syscall))
    1673              ((:linuxx8664 :freebsdx8664 :darwinx8664 :solarisx8664 :win64) (%nx1-operator syscall))))))
    16741652
    16751653
  • branches/acode-rewrite/source/compiler/nxenv.lisp

    r15800 r15801  
    180180     (add2 . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask))
    181181     (sub2 . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask))
    182      (numeric-comparison . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-cc-invertable-mask))
     182     ()
    183183     (numcmp . #.(logior operator-assignment-free-mask operator-acode-subforms-mask operator-single-valued-mask operator-cc-invertable-mask))
    184184     (struct-ref . #.(logior operator-acode-subforms-mask operator-assignment-free-mask operator-single-valued-mask operator-side-effect-free-mask))
     
    243243     (consp . #.(logior operator-cc-invertable-mask operator-assignment-free-mask operator-acode-subforms-mask operator-side-effect-free-mask operator-boolean-mask))
    244244     (aset1 . #.(logior operator-acode-subforms-mask))
    245      (syscall . 0)
     245     ()
    246246     (car . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask))
    247247     (cdr . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask))
     
    298298     (%set-scharcode . #.(logior operator-single-valued-mask operator-acode-subforms-mask))
    299299     (lambda-list . 0)
    300      (ppc-lap-function . 0)
     300     ()
    301301     (lisptag . #.(logior operator-single-valued-mask operator-acode-subforms-mask))
    302302     (fulltag . #.(logior operator-single-valued-mask operator-acode-subforms-mask))
     
    331331     ()
    332332     ()
    333      (poweropen-syscall . 0)
     333     ()
    334334     (%debug-trap . #.operator-acode-subforms-mask)
    335335     (%%ineg . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask))
     
    342342     (eabi-ff-call . 0)
    343343     (%reference-external-entry-point . #.operator-acode-subforms-mask)
    344      (eabi-syscall . 0)
     344     ()
    345345     (%get-bit . #.(logior operator-assignment-free-mask operator-single-valued-mask operator-acode-subforms-mask operator-side-effect-free-mask))
    346346     (%set-bit   . #.(logior operator-single-valued-mask operator-acode-subforms-mask))
     
    387387     (%double-float . #.(logior operator-acode-subforms-mask operator-assignment-free-mask operator-single-valued-mask))
    388388     (i386-ff-call . 0)
    389      (i386-syscall . 0)
     389     ()
    390390     (%double-float-negate . #.(logior operator-acode-subforms-mask operator-assignment-free-mask operator-single-valued-mask))
    391391     (%single-float-negate . #.(logior operator-acode-subforms-mask operator-assignment-free-mask operator-single-valued-mask)) )))
  • branches/acode-rewrite/source/level-0/l0-numbers.lisp

    r15798 r15801  
    11611161           (let ((res (%unary-truncate (%short-float/-2! fnum ,divisor f2))))
    11621162             (values res
    1163                      (%short-float--2 fnum (%short-float*-2! (%short-float res f2) ,divisor f2)))))
     1163                     (- (the single-float fnum) (the single-float (%short-float*-2! (%short-float res f2) ,divisor f2))))))
    11641164         #+64-bit-target
    11651165         `(let* ((temp (%short-float ,number))
     
    12091209                          (let ((res (%unary-truncate (%short-float/-2! number divisor f2))))
    12101210                            (values res
    1211                                     (%short-float--2
    1212                                      number
    1213                                      (%short-float*-2! (%short-float res f2) divisor f2)))))
     1211                                    (-
     1212                                     (the single-float number)
     1213                                     (the single-float (%short-float*-2! (%short-float res f2) divisor f2))))))
    12141214                        #+64-bit-target
    12151215                        (let ((res (%unary-truncate
     
    12261226                          (let ((res (%unary-truncate (%short-float/-2! number fdiv f2))))
    12271227                            (values res
    1228                                     (%short-float--2
    1229                                      number
    1230                                      (%short-float*-2! (%short-float res f2) fdiv f2)))))
     1228                                    (-
     1229                                     (the single-float number)
     1230                                     (the single-float (%short-float*-2! (%short-float res f2) fdiv f2))))))
    12311231                        #+64-bit-target
    12321232                        (let* ((fdiv (%short-float divisor))
  • branches/acode-rewrite/source/level-1/l1-utils.lisp

    r15606 r15801  
    171171               ;; These are implementation-specific special forms :
    172172               nfunction
    173                ppc-lap-function fbind
     173               #+ppc-target
     174               ppc-lap-function
     175               #+arm-target
     176               arm-lap-function
     177               #+x86-target
     178               x86-lap-function
     179               fbind
    174180               with-c-frame with-variable-c-frame))
    175181  (%macro-have sym sym))
Note: See TracChangeset for help on using the changeset viewer.