Changeset 1407 for trunk


Ignore:
Timestamp:
May 13, 2005, 10:21:50 AM (16 years ago)
Author:
gb
Message:

U32/natural changes, start handling 64-bit register copies.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/ccl/compiler/PPC/ppc2.lisp

    r1254 r1407  
    184184
    185185
    186 ; Before any defppc2's, make the *ppc2-specials* vector.
     186;;; Before any defppc2's, make the *ppc2-specials* vector.
    187187
    188188(defvar *ppc2-all-lcells* ())
     
    220220  (ppc2-new-lcell :tos *ppc2-top-vstack-lcell* 0 0 nil))
    221221
    222 ; Alist mapping VARs to lcells/lregs
     222;;; Alist mapping VARs to lcells/lregs
    223223(defvar *ppc2-var-cells* ())
    224224
     
    246246
    247247 
    248 ; ensure that lcell's offset matches what we expect it to.
    249 ; For bootstrapping.
     248;;; ensure that lcell's offset matches what we expect it to.
     249;;; For bootstrapping.
    250250
    251251(defun ppc2-ensure-lcell-offset (c expected)
     
    285285      (<- valreg))))
    286286
    287 ; ensure that next-method-var is heap-consed (if it's closed over.)
    288 ; it isn't ever setqed, is it ?
     287;;; ensure that next-method-var is heap-consed (if it's closed over.)
     288;;; it isn't ever setqed, is it ?
    289289(defun ppc2-heap-cons-next-method-var (seg var)
    290290  (with-ppc-local-vinsn-macros (seg)
     
    592592  (> (the fixnum (cdr x)) (the fixnum (cdr y))))
    593593
    594 ; Return an unordered list of "varsets": each var in a varset can be assigned a register
    595 ; and all vars in a varset can be assigned the same register (e.g., no scope conflicts.)
     594;;; Return an unordered list of "varsets": each var in a varset can be assigned a register
     595;;; and all vars in a varset can be assigned the same register (e.g., no scope conflicts.)
    596596
    597597(defun ppc2-partition-vars (vars)
     
    654654      varsets)))
    655655
    656 ; Maybe globally allocate registers to symbols naming functions & variables,
    657 ; and to simple lexical variables.
     656;;; Maybe globally allocate registers to symbols naming functions & variables,
     657;;; and to simple lexical variables.
    658658(defun ppc2-allocate-global-registers (fcells vcells all-vars no-regs)
    659659  (if no-regs
     
    688688         
    689689   
    690 ;; Vpush the last N non-volatile-registers.
    691 ;; Could use a STM here, especially if N is largish or optimizing for space.
     690;;; Vpush the last N non-volatile-registers.
     691;;; Could use a STM here, especially if N is largish or optimizing for space.
    692692(defun ppc2-save-nvrs (seg n)
    693693  (declare (fixnum n))
     
    705705
    706706
    707 ; If there are an indefinite number of args/values on the vstack,
    708 ; we have to restore from a register that matches the compiler's
    709 ; notion of the vstack depth.  This can be computed by the caller
    710 ; (sum of vsp & nargs, or copy of vsp  before indefinite number of
    711 ; args pushed, etc.)
    712 ; We DON'T try to compute this from the saved context, since the
    713 ; saved vsp may belong to a different stack segment.  (It's cheaper
    714 ; to compute/copy than to load it, anyway.)
     707;;; If there are an indefinite number of args/values on the vstack,
     708;;; we have to restore from a register that matches the compiler's
     709;;; notion of the vstack depth.  This can be computed by the caller
     710;;; (sum of vsp & nargs, or copy of vsp  before indefinite number of
     711;;; args pushed, etc.)
     712;;; We DON'T try to compute this from the saved context, since the
     713;;; saved vsp may belong to a different stack segment.  (It's cheaper
     714;;; to compute/copy than to load it, anyway.)
    715715
    716716(defun ppc2-restore-nvrs (seg ea nregs &optional from-fp)
     
    724724
    725725
    726 ;; The change is to ask for a stack-consed rest var if the rest var is ignored.
    727 ;; And also to pop the rest var immediately if it's ignored, rather than at the end
    728 ;; of the function.  That will allow calling the final function tail-recursively. 
     726;;; The change is to ask for a stack-consed rest var if the rest var is ignored.
     727;;; And also to pop the rest var immediately if it's ignored, rather than at the end
     728;;; of the function.  That will allow calling the final function tail-recursively. 
    729729
    730730
     
    775775            (ppc2-load-lexpr-address seg reg)
    776776            (ppc2-set-var-ea seg rest reg))
    777           (with-imm-temps () ((nargs-cell :u32))
     777          (with-imm-temps () ((nargs-cell :natural))
    778778            (ppc2-load-lexpr-address seg nargs-cell)
    779779            (let* ((loc *ppc2-vstack*))
     
    851851      (setq vloc (%i+ vloc 8)))))
    852852
    853 ; Vpush register r, unless var gets a globally-assigned register.
    854 ; Return NIL if register was vpushed, else var.
     853;;; Vpush register r, unless var gets a globally-assigned register.
     854;;; Return NIL if register was vpushed, else var.
    855855(defun ppc2-vpush-arg-register (seg reg var)
    856856  (when var
     
    864864
    865865
    866 ; nargs has been validated, arguments defaulted and canonicalized.
    867 ; Save caller's context, then vpush any argument registers that
    868 ; didn't get global registers assigned to their variables.
    869 ; Return a list of vars/nils for each argument register
    870 ;  (nil if vpushed, var if still in arg_reg).
     866;;; nargs has been validated, arguments defaulted and canonicalized.
     867;;; Save caller's context, then vpush any argument registers that
     868;;; didn't get global registers assigned to their variables.
     869;;; Return a list of vars/nils for each argument register
     870;;;  (nil if vpushed, var if still in arg_reg).
    871871(defun ppc2-argregs-entry (seg revargs)
    872872  (with-ppc-local-vinsn-macros (seg)
     
    897897      reg-vars)))
    898898
    899 ; Just required args.
    900 ; Since this is just a stupid bootstrapping port, always save
    901 ; lisp context.
     899;;; Just required args.
     900;;; Since this is just a stupid bootstrapping port, always save
     901;;; lisp context.
    902902(defun ppc2-req-nargs-entry (seg rev-fixed-args)
    903903  (let* ((nargs (length rev-fixed-args)))
     
    908908      (ppc2-argregs-entry seg rev-fixed-args))))
    909909
    910 ; No more than three &optional args; all default to NIL and none have
    911 ; supplied-p vars.  No &key/&rest.
     910;;; No more than three &optional args; all default to NIL and none have
     911;;; supplied-p vars.  No &key/&rest.
    912912(defun ppc2-simple-opt-entry (seg rev-opt-args rev-req-args)
    913913  (let* ((min (length rev-req-args))
     
    927927      (ppc2-argregs-entry seg (append rev-opt-args rev-req-args)))))
    928928
    929 ; if "num-fixed" is > 0, we've already ensured that at least that many args
    930 ; were provided; that may enable us to generate better code for saving the
    931 ; argument registers.
    932 ; We're responsible for computing the caller's VSP and saving
    933 ; caller's state.
     929;;; if "num-fixed" is > 0, we've already ensured that at least that many args
     930;;; were provided; that may enable us to generate better code for saving the
     931;;; argument registers.
     932;;; We're responsible for computing the caller's VSP and saving
     933;;; caller's state.
    934934(defun ppc2-lexpr-entry (seg num-fixed)
    935935  (with-ppc-local-vinsn-macros (seg)
     
    10131013          (error "ppc2-form ? ~s" form))))))
    10141014
    1015 ; dest is a float reg - form is acode
     1015;;; dest is a float reg - form is acode
    10161016(defun ppc2-form-float (seg freg xfer form)
    10171017  (declare (ignore xfer))
     
    10401040  (apply (svref *ppc2-specials* (%ilogand operator-id-mask op)) seg vreg xfer forms))
    10411041
    1042 ; Returns true iff lexical variable VAR isn't setq'ed in FORM.
    1043 ; Punts a lot ...
     1042;;; Returns true iff lexical variable VAR isn't setq'ed in FORM.
     1043;;; Punts a lot ...
    10441044(defun ppc2-var-not-set-by-form-p (var form)
    10451045  (or (not (%ilogbitp $vbitsetq (nx-var-bits var)))
     
    10991099
    11001100
    1101 ; Emit a note at the end of the segment.
     1101;;; Emit a note at the end of the segment.
    11021102(defun ppc2-emit-note (seg class &rest info)
    11031103  (declare (dynamic-extent info))
     
    11061106    note))
    11071107
    1108 ; Emit a note immediately before the target vinsn.
     1108;;; Emit a note immediately before the target vinsn.
    11091109(defun ppc-prepend-note (vinsn class &rest info)
    11101110  (declare (dynamic-extent info))
     
    11561156      (%ilogand bits $vrefmask))))
    11571157
    1158 ; Can't cross-compile this.  Too bad.
     1158;;; Can't cross-compile this.  Too bad.
    11591159#+ppc32-host
    11601160(defun ppc2-single-float-bits (the-sf)
     
    12331233
    12341234
    1235 ; Returns label iff form is (local-go <tag>) and can go without adjusting stack.
     1235;;; Returns label iff form is (local-go <tag>) and can go without adjusting stack.
    12361236(defun ppc2-go-label (form)
    12371237  (let ((current-stack (ppc2-encode-stack)))
     
    12681268(defun ppc2-box-s32 (seg node-dest s32-src)
    12691269  (with-ppc-local-vinsn-macros (seg)
    1270     (if *ppc2-open-code-inline*
     1270    (if (target-arch-case
     1271         (:ppc32 *ppc2-open-code-inline*)
     1272         (:ppc64 t))
    12711273      (! s32->integer node-dest s32-src)
    12721274      (let* ((arg_z ($ ppc::arg_z))
     
    12761278        (ppc2-copy-register seg node-dest arg_z)))))
    12771279
     1280(defun ppc2-box-s64 (seg node-dest s64-src)
     1281  (with-ppc-local-vinsn-macros (seg)
     1282    (if (target-arch-case
     1283         (:ppc32 (error "Bug!"))
     1284         (:ppc64 *ppc2-open-code-inline*))
     1285      (! s64->integer node-dest s64-src)
     1286      (let* ((arg_z ($ ppc::arg_z))
     1287             (imm0 ($ ppc::imm0 :mode :s64)))
     1288        (ppc2-copy-register seg imm0 s64-src)
     1289        (! call-subprim .SPmakes64)
     1290        (ppc2-copy-register seg node-dest arg_z)))))
     1291
    12781292(defun ppc2-box-u32 (seg node-dest u32-src)
    12791293  (with-ppc-local-vinsn-macros (seg)
    1280     (if *ppc2-open-code-inline*
     1294    (if (target-arch-case
     1295         (:ppc32 *ppc2-open-code-inline*)
     1296         (:ppc64 t))
    12811297      (! u32->integer node-dest u32-src)
    12821298      (let* ((arg_z ($ ppc::arg_z))
     
    12861302        (ppc2-copy-register seg node-dest arg_z)))))
    12871303
    1288 
    1289 ; safe = T means assume "vector" is miscobj, do bounds check.
    1290 ; safe = fixnum means check that subtag of vector = "safe" and do bounds check.
    1291 ; safe = nil means crash&burn.
     1304(defun ppc2-box-u64 (seg node-dest u64-src)
     1305  (with-ppc-local-vinsn-macros (seg)
     1306    (if (target-arch-case
     1307         (:ppc32 (error "Bug!"))
     1308         (:ppc64 *ppc2-open-code-inline*))
     1309      (! u64->integer node-dest u64-src)
     1310      (let* ((arg_z ($ ppc::arg_z))
     1311             (imm0 ($ ppc::imm0 :mode :u64)))
     1312        (ppc2-copy-register seg imm0 u64-src)
     1313        (! call-subprim .SPmakeu64)
     1314        (ppc2-copy-register seg node-dest arg_z)))))
     1315
     1316
     1317;;; safe = T means assume "vector" is miscobj, do bounds check.
     1318;;; safe = fixnum means check that subtag of vector = "safe" and do bounds check.
     1319;;; safe = nil means crash&burn.
    12921320;;; This mostly knows how to reference the elements of an immediate miscobj.
    12931321(defun ppc2-vref (seg vreg xfer type-keyword vector index safe)
     
    14261454                    (^)))))))))))
    14271455
    1428 ; In this case, the target register is an fp reg and the vector is declared
    1429 ; do be a double-float vector.  Avoid boxing the result!
     1456;;; In this case, the target register is an fp reg and the vector is declared
     1457;;; do be a double-float vector.  Avoid boxing the result!
    14301458(defun ppc2-df-vref (seg vreg xfer vector index safe)
    14311459  (with-ppc-local-vinsn-macros (seg vreg xfer)
     
    17711799                             (! misc-set-c-u32 temp src index-known-fixnum)
    17721800                             (progn
    1773                                (setq idx-reg (make-unwired-lreg (select-imm-temp :u32)))
     1801                               (setq idx-reg (make-unwired-lreg (select-imm-temp :natural)))
    17741802                               (if index-known-fixnum
    17751803                                 (ppc2-absolute-natural seg idx-reg nil (+ (arch::target-misc-data-offset arch) (ash index-known-fixnum 2)))
     
    17931821                             (! misc-set-c-u8 temp src index-known-fixnum)
    17941822                             (progn
    1795                                (setq idx-reg (make-unwired-lreg (select-imm-temp :u32)))
     1823                               (setq idx-reg (make-unwired-lreg (select-imm-temp :natural)))
    17961824                               (if index-known-fixnum
    17971825                                 (ppc2-absolute-natural seg idx-reg nil (+ (arch::target-misc-data-offset arch) index-known-fixnum))
     
    18111839                             (! misc-set-c-u16 temp src index-known-fixnum)
    18121840                             (progn
    1813                                (setq idx-reg (make-unwired-lreg (select-imm-temp :u32)))
     1841                               (setq idx-reg (make-unwired-lreg (select-imm-temp :natural)))
    18141842                               (if index-known-fixnum
    18151843                                 (ppc2-absolute-natural seg idx-reg nil (+ (arch::target-misc-data-offset arch) (ash index-known-fixnum 1)))
     
    18821910                (^)))))))))
    18831911
    1884 ;; In this case, the destination (vreg) is either an FPR or null, so
    1885 ;; we can maybe avoid boxing the value.
     1912;;; In this case, the destination (vreg) is either an FPR or null, so
     1913;;; we can maybe avoid boxing the value.
    18861914(defun ppc2-df-vset (seg vreg xfer vector index value safe)
    18871915  (with-ppc-local-vinsn-macros (seg vreg xfer)
     
    19491977      immref)))
    19501978
    1951 ; If BODY is essentially an APPLY involving an &rest arg, try to avoid
    1952 ; consing it.
     1979;;; If BODY is essentially an APPLY involving an &rest arg, try to avoid
     1980;;; consing it.
    19531981(defun ppc2-eliminate-&rest (body rest key-p auxen rest-values)
    19541982  (when (and rest (not key-p) (not (cadr auxen)) rest-values)
     
    20882116        (! call-known-symbol-ool)))))
    20892117
    2090 ; Nargs = nil -> multiple-value case.
     2118;;; Nargs = nil -> multiple-value case.
    20912119(defun ppc2-invoke-fn (seg fn nargs spread-p xfer)
    20922120  (with-ppc-local-vinsn-macros (seg)
     
    22772305            (declare (fixnum cell))
    22782306            (progn
    2279               (ppc2-lri seg ppc::imm0 (logior (ash vsize ppc32::num-subtag-bits) (ppc2-lookup-target-uvector-subtag :function)))
     2307              (ppc2-lri seg
     2308                        ppc::imm0
     2309                        (arch::make-vheader vsize (ppc2-lookup-target-uvector-subtag :function)))
    22802310              (! %alloc-misc-fixed dest ppc::imm0 (ash vsize (arch::target-word-shift arch)))
    22812311              )       
     
    23922422
    23932423
    2394 ; treat form as a 32-bit immediate value and load it into immreg.
    2395 ; This is the "lenient" version of 32-bit-ness; OSTYPEs and chars
    2396 ; count, and we don't care about the integer's sign.
     2424;;; treat form as a 32-bit immediate value and load it into immreg.
     2425;;; This is the "lenient" version of 32-bit-ness; OSTYPEs and chars
     2426;;; count, and we don't care about the integer's sign.
    23972427
    23982428(defun ppc2-unboxed-integer-arg-to-reg (seg form immreg)
     
    24012431      (if value
    24022432        (if (eql value 0)
    2403           ($  ppc::rzero :mode :u32)
     2433          ($  ppc::rzero :mode :natural)
    24042434          (progn
    24052435            (unless (typep immreg 'lreg)
    2406               (setq immreg (make-unwired-lreg immreg :mode (gpr-mode-name-value :u32))))
     2436              (setq immreg (make-unwired-lreg immreg :mode (gpr-mode-name-value :natural))))
    24072437            (ppc2-lri seg immreg value)
    24082438            immreg))
     
    24102440          (ppc2-one-targeted-reg-form seg form ($ ppc::arg_z))
    24112441          (! getXlong)
    2412           ($ ppc::imm0 :mode :u32))))))
     2442          ($ ppc::imm0 :mode :natural))))))
    24132443
    24142444
     
    25392569               
    25402570       
    2541 ; we never leave the first form pushed (the 68K compiler had some subprims that
    2542 ; would vpop the first argument out of line.)
     2571;;; we never leave the first form pushed (the 68K compiler had some subprims that
     2572;;; would vpop the first argument out of line.)
    25432573(defun ppc2-two-targeted-reg-forms (seg aform areg bform breg)
    25442574  (unless (typep areg 'lreg)
     
    27892819
    27902820
    2791 ; There are other cases involving constants that are worth exploiting.
     2821;;; There are other cases involving constants that are worth exploiting.
    27922822(defun ppc2-compare (seg vreg xfer i j cr-bit true-p)
    27932823  (with-ppc-local-vinsn-macros (seg vreg xfer)
     
    28192849            (ppc2-compare-registers seg vreg xfer ireg jreg cr-bit true-p)))))))
    28202850
    2821 (defun ppc2-u32-compare (seg vreg xfer i j cr-bit true-p)
     2851(defun ppc2-natural-compare (seg vreg xfer i j cr-bit true-p)
    28222852  (with-ppc-local-vinsn-macros (seg vreg xfer)
    28232853    (let* ((jconstant (acode-fixnum-form-p j))
     
    28282858      (if (and boolean (or ju16 iu16))
    28292859        (with-imm-target
    2830             () (reg :u32)
     2860            () (reg :natural)
    28312861            (ppc2-one-targeted-reg-form seg (if ju16 i j) reg)
    28322862            (! compare-unsigned-u16const vreg reg (if ju16 jconstant iconstant))
     
    28342864              (setq cr-bit (- 1 cr-bit)))
    28352865            (^ cr-bit true-p))
    2836         (with-imm-target
    2837             () (ireg :u32)
    2838             (with-imm-target
    2839                 (ireg) (jreg :u32)
     2866        (with-imm-target ()
     2867          (ireg :natural)
     2868            (with-imm-target 
     2869                (ireg) (jreg :natural)
    28402870                (ppc2-two-targeted-reg-forms seg i ireg j jreg)
    2841                 (ppc2-compare-u32-registers seg vreg xfer ireg jreg cr-bit true-p)))))))
    2842 
    2843 (defun ppc2-compare-u32-registers (seg vreg xfer ireg jreg cr-bit true-p)
     2871                (ppc2-compare-natural-registers seg vreg xfer ireg jreg cr-bit true-p)))))))
     2872
     2873(defun ppc2-compare-natural-registers (seg vreg xfer ireg jreg cr-bit true-p)
    28442874  (with-ppc-local-vinsn-macros (seg vreg xfer)
    28452875    (if vreg
     
    28492879         (! compare-logical dest ireg jreg)
    28502880         (^ cr-bit true-p))
    2851        (with-imm-temps () ((b31-reg :u32))
     2881       (with-imm-temps () ((b31-reg :natural))
    28522882         (ecase cr-bit
    28532883           (#. ppc::ppc-eq-bit
     
    28762906         (! compare dest ireg jreg)
    28772907         (^ cr-bit true-p))
    2878        (with-imm-temps () ((b31-reg :u32))
     2908       (with-imm-temps () ((b31-reg :natural))
    28792909         (ecase cr-bit
    28802910           (#. ppc::ppc-eq-bit
     
    29032933         (! compare-to-nil dest ireg)
    29042934         (^ cr-bit true-p))
    2905        (with-imm-temps () ((b31-reg :u32))
     2935       (with-imm-temps () ((b31-reg :natural))
    29062936         (ecase cr-bit
    29072937           (#. ppc::ppc-eq-bit
     
    29142944      (^))))
    29152945
    2916 ; Have to extract a bit out of the CR when a boolean result needed.
     2946;;; Have to extract a bit out of the CR when a boolean result needed.
    29172947(defun ppc2-compare-double-float-registers (seg vreg xfer ireg jreg cr-bit true-p)
    29182948  (with-ppc-local-vinsn-macros (seg vreg xfer)
     
    29232953         (! double-float-compare dest ireg jreg)
    29242954         (^ cr-bit true-p))
    2925        (with-imm-temps () ((lowbit-reg :u32))
     2955       (with-imm-temps () ((lowbit-reg :natural))
    29262956         (with-crf-target () flags
    29272957           (! double-float-compare flags ireg jreg)
     
    30293059                ;; (MR dest-gpr rzero) would be.
    30303060                (! lri dest-gpr 0)
    3031                 (case dest-mode
    3032                   (#.hard-reg-class-gpr-mode-node      ; boxed result.
    3033                    (case src-mode
    3034                      (#.hard-reg-class-gpr-mode-node
    3035                       (unless (eql  dest-gpr src-gpr)
    3036                         (! copy-gpr dest src)))
    3037                      (#.hard-reg-class-gpr-mode-u32
    3038                       (ppc2-box-u32 seg dest src))
    3039                      (#.hard-reg-class-gpr-mode-s32
    3040                       (ppc2-box-s32 seg dest src))
    3041                      (#.hard-reg-class-gpr-mode-u16
    3042                       (! u16->fixnum dest src))
    3043                      (#.hard-reg-class-gpr-mode-s16
    3044                       (! s16->fixnum dest src))
    3045                      (#.hard-reg-class-gpr-mode-u8
    3046                       (! u8->fixnum dest src))
    3047                      (#.hard-reg-class-gpr-mode-s8
    3048                       (! s8->fixnum dest src))
    3049                      (#.hard-reg-class-gpr-mode-address
    3050                       (! macptr->heap dest src))))
    3051                   ((#.hard-reg-class-gpr-mode-u32
    3052                     #.hard-reg-class-gpr-mode-address)
    3053                    (case src-mode
    3054                      (#.hard-reg-class-gpr-mode-node
    3055                       (let* ((src-type (get-node-regspec-type-modes src)))
    3056                         (declare (fixnum src-type))
    3057                         (case dest-mode
    3058                           (#.hard-reg-class-gpr-mode-u32
    3059                            (! unbox-u32 dest src))
    3060                           (#.hard-reg-class-gpr-mode-address
    3061                            (unless (logbitp #.hard-reg-class-gpr-mode-address src-type)
    3062                              (! trap-unless-macptr src))
    3063                            (! deref-macptr dest src)))))
    3064                      ((#.hard-reg-class-gpr-mode-u32
    3065                        #.hard-reg-class-gpr-mode-s32
    3066                        #.hard-reg-class-gpr-mode-address)
    3067                       (unless (eql  dest-gpr src-gpr)
    3068                         (! copy-gpr dest src)))
    3069                      ((#.hard-reg-class-gpr-mode-u16
    3070                        #.hard-reg-class-gpr-mode-s16)
    3071                       (! u16->u32 dest src))
    3072                      ((#.hard-reg-class-gpr-mode-u8
    3073                        #.hard-reg-class-gpr-mode-s8)
    3074                       (! u8->u32 dest src))))
    3075                   (#.hard-reg-class-gpr-mode-s32
    3076                    (case src-mode
    3077                      (#.hard-reg-class-gpr-mode-node
    3078                       (! unbox-s32 dest src))
    3079                      ((#.hard-reg-class-gpr-mode-u32
    3080                        #.hard-reg-class-gpr-mode-s32
    3081                        #.hard-reg-class-gpr-mode-address)
    3082                       (unless (eql  dest-gpr src-gpr)
    3083                         (! copy-gpr dest src)))
    3084                      (#.hard-reg-class-gpr-mode-u16
    3085                       (! u16->u32 dest src))                 
    3086                      (#.hard-reg-class-gpr-mode-s16
    3087                       (! s16->s32 dest src))
    3088                      (#.hard-reg-class-gpr-mode-u8
    3089                       (! u8->u32 dest src))
    3090                      (#.hard-reg-class-gpr-mode-s8
    3091                       (! s8->s32 dest src))))
    3092                   (#.hard-reg-class-gpr-mode-u16
    3093                    (case src-mode
    3094                      (#.hard-reg-class-gpr-mode-node
    3095                       (! unbox-u16 dest src))
    3096                      ((#.hard-reg-class-gpr-mode-u8
    3097                        #.hard-reg-class-gpr-mode-s8)
    3098                       (! u8->u32 dest src))
    3099                      (t
    3100                       (unless (eql dest-gpr src-gpr)
    3101                         (! copy-gpr dest src)))))
    3102                   (#.hard-reg-class-gpr-mode-s16
    3103                    (case src-mode
    3104                      (#.hard-reg-class-gpr-mode-node
    3105                       (! unbox-s16 dest src))
    3106                      (#.hard-reg-class-gpr-mode-s8
    3107                       (! s8->s32 dest src))
    3108                      (#.hard-reg-class-gpr-mode-u8
    3109                       (! u8->u32 dest src))
    3110                      (t
    3111                       (unless (eql dest-gpr src-gpr)
    3112                         (! copy-gpr dest src)))))
    3113                   (#.hard-reg-class-gpr-mode-u8
    3114                    (case src-mode
    3115                      (#.hard-reg-class-gpr-mode-node
    3116                       (! unbox-u8 dest src))
    3117                      (t
    3118                       (unless (eql dest-gpr src-gpr)
    3119                         (! copy-gpr dest src)))))
    3120                   (#.hard-reg-class-gpr-mode-s8
    3121                    (case src-mode
    3122                      (#.hard-reg-class-gpr-mode-node
    3123                       (! unbox-s8 dest src))
    3124                      (t
    3125                       (unless (eql dest-gpr src-gpr)
    3126                         (! copy-gpr dest src)))))))
     3061                ;; This is the "GPR <- GPR" case.  There are
     3062                ;; word-size dependencies, but there's also
     3063                ;; lots of redundancy here.
     3064                (target-arch-case
     3065                 (:ppc32
     3066                  (case dest-mode
     3067                    (#.hard-reg-class-gpr-mode-node ; boxed result.
     3068                     (case src-mode
     3069                       (#.hard-reg-class-gpr-mode-node
     3070                        (unless (eql  dest-gpr src-gpr)
     3071                          (! copy-gpr dest src)))
     3072                       (#.hard-reg-class-gpr-mode-u32
     3073                        (ppc2-box-u32 seg dest src))
     3074                       (#.hard-reg-class-gpr-mode-s32
     3075                        (ppc2-box-s32 seg dest src))
     3076                       (#.hard-reg-class-gpr-mode-u16
     3077                        (! u16->fixnum dest src))
     3078                       (#.hard-reg-class-gpr-mode-s16
     3079                        (! s16->fixnum dest src))
     3080                       (#.hard-reg-class-gpr-mode-u8
     3081                        (! u8->fixnum dest src))
     3082                       (#.hard-reg-class-gpr-mode-s8
     3083                        (! s8->fixnum dest src))
     3084                       (#.hard-reg-class-gpr-mode-address
     3085                        (! macptr->heap dest src))))
     3086                    ((#.hard-reg-class-gpr-mode-u32
     3087                      #.hard-reg-class-gpr-mode-address)
     3088                     (case src-mode
     3089                       (#.hard-reg-class-gpr-mode-node
     3090                        (let* ((src-type (get-node-regspec-type-modes src)))
     3091                          (declare (fixnum src-type))
     3092                          (case dest-mode
     3093                            (#.hard-reg-class-gpr-mode-u32
     3094                             (! unbox-u32 dest src))
     3095                            (#.hard-reg-class-gpr-mode-address
     3096                             (unless (logbitp #.hard-reg-class-gpr-mode-address src-type)
     3097                               (! trap-unless-macptr src))
     3098                             (! deref-macptr dest src)))))
     3099                       ((#.hard-reg-class-gpr-mode-u32
     3100                         #.hard-reg-class-gpr-mode-s32
     3101                         #.hard-reg-class-gpr-mode-address)
     3102                        (unless (eql  dest-gpr src-gpr)
     3103                          (! copy-gpr dest src)))
     3104                       ((#.hard-reg-class-gpr-mode-u16
     3105                         #.hard-reg-class-gpr-mode-s16)
     3106                        (! u16->u32 dest src))
     3107                       ((#.hard-reg-class-gpr-mode-u8
     3108                         #.hard-reg-class-gpr-mode-s8)
     3109                        (! u8->u32 dest src))))
     3110                    (#.hard-reg-class-gpr-mode-s32
     3111                     (case src-mode
     3112                       (#.hard-reg-class-gpr-mode-node
     3113                        (! unbox-s32 dest src))
     3114                       ((#.hard-reg-class-gpr-mode-u32
     3115                         #.hard-reg-class-gpr-mode-s32
     3116                         #.hard-reg-class-gpr-mode-address)
     3117                        (unless (eql  dest-gpr src-gpr)
     3118                          (! copy-gpr dest src)))
     3119                       (#.hard-reg-class-gpr-mode-u16
     3120                        (! u16->u32 dest src))                 
     3121                       (#.hard-reg-class-gpr-mode-s16
     3122                        (! s16->s32 dest src))
     3123                       (#.hard-reg-class-gpr-mode-u8
     3124                        (! u8->u32 dest src))
     3125                       (#.hard-reg-class-gpr-mode-s8
     3126                        (! s8->s32 dest src))))
     3127                    (#.hard-reg-class-gpr-mode-u16
     3128                     (case src-mode
     3129                       (#.hard-reg-class-gpr-mode-node
     3130                        (! unbox-u16 dest src))
     3131                       ((#.hard-reg-class-gpr-mode-u8
     3132                         #.hard-reg-class-gpr-mode-s8)
     3133                        (! u8->u32 dest src))
     3134                       (t
     3135                        (unless (eql dest-gpr src-gpr)
     3136                          (! copy-gpr dest src)))))
     3137                    (#.hard-reg-class-gpr-mode-s16
     3138                     (case src-mode
     3139                       (#.hard-reg-class-gpr-mode-node
     3140                        (! unbox-s16 dest src))
     3141                       (#.hard-reg-class-gpr-mode-s8
     3142                        (! s8->s32 dest src))
     3143                       (#.hard-reg-class-gpr-mode-u8
     3144                        (! u8->u32 dest src))
     3145                       (t
     3146                        (unless (eql dest-gpr src-gpr)
     3147                          (! copy-gpr dest src)))))
     3148                    (#.hard-reg-class-gpr-mode-u8
     3149                     (case src-mode
     3150                       (#.hard-reg-class-gpr-mode-node
     3151                        (! unbox-u8 dest src))
     3152                       (t
     3153                        (unless (eql dest-gpr src-gpr)
     3154                          (! copy-gpr dest src)))))
     3155                    (#.hard-reg-class-gpr-mode-s8
     3156                     (case src-mode
     3157                       (#.hard-reg-class-gpr-mode-node
     3158                        (! unbox-s8 dest src))
     3159                       (t
     3160                        (unless (eql dest-gpr src-gpr)
     3161                          (! copy-gpr dest src)))))))
     3162                 (:ppc64
     3163                  (case dest-mode
     3164                    (#.hard-reg-class-gpr-mode-node ; boxed result.
     3165                     (case src-mode
     3166                       (#.hard-reg-class-gpr-mode-node
     3167                        (unless (eql  dest-gpr src-gpr)
     3168                          (! copy-gpr dest src)))
     3169                       (#.hard-reg-class-gpr-mode-u64
     3170                        (ppc2-box-u64 seg dest src))
     3171                       (#.hard-reg-class-gpr-mode-s64
     3172                        (ppc2-box-s64 seg dest src))
     3173                       (#.hard-reg-class-gpr-mode-u32
     3174                        (ppc2-box-u32 seg dest src))
     3175                       (#.hard-reg-class-gpr-mode-s32
     3176                        (ppc2-box-s32 seg dest src))
     3177                       (#.hard-reg-class-gpr-mode-u16
     3178                        (! u16->fixnum dest src))
     3179                       (#.hard-reg-class-gpr-mode-s16
     3180                        (! s16->fixnum dest src))
     3181                       (#.hard-reg-class-gpr-mode-u8
     3182                        (! u8->fixnum dest src))
     3183                       (#.hard-reg-class-gpr-mode-s8
     3184                        (! s8->fixnum dest src))
     3185                       (#.hard-reg-class-gpr-mode-address
     3186                        (! macptr->heap dest src))))
     3187                    ((#.hard-reg-class-gpr-mode-u64
     3188                      #.hard-reg-class-gpr-mode-address)
     3189                     (case src-mode
     3190                       (#.hard-reg-class-gpr-mode-node
     3191                        (let* ((src-type (get-node-regspec-type-modes src)))
     3192                          (declare (fixnum src-type))
     3193                          (case dest-mode
     3194                            (#.hard-reg-class-gpr-mode-u64
     3195                             (! unbox-u64 dest src))
     3196                            (#.hard-reg-class-gpr-mode-address
     3197                             (unless (logbitp #.hard-reg-class-gpr-mode-address src-type)
     3198                               (! trap-unless-macptr src))
     3199                             (! deref-macptr dest src)))))
     3200                       ((#.hard-reg-class-gpr-mode-u64
     3201                         #.hard-reg-class-gpr-mode-s64
     3202                         #.hard-reg-class-gpr-mode-address)
     3203                        (unless (eql  dest-gpr src-gpr)
     3204                          (! copy-gpr dest src)))
     3205                       ((#.hard-reg-class-gpr-mode-u16
     3206                         #.hard-reg-class-gpr-mode-s16)
     3207                        (! u16->u32 dest src))
     3208                       ((#.hard-reg-class-gpr-mode-u8
     3209                         #.hard-reg-class-gpr-mode-s8)
     3210                        (! u8->u32 dest src))))
     3211                    (#.hard-reg-class-gpr-mode-s32
     3212                     (case src-mode
     3213                       (#.hard-reg-class-gpr-mode-node
     3214                        (! unbox-s32 dest src))
     3215                       ((#.hard-reg-class-gpr-mode-u32
     3216                         #.hard-reg-class-gpr-mode-s32
     3217                         #.hard-reg-class-gpr-mode-address)
     3218                        (unless (eql  dest-gpr src-gpr)
     3219                          (! copy-gpr dest src)))
     3220                       (#.hard-reg-class-gpr-mode-u16
     3221                        (! u16->u32 dest src))                 
     3222                       (#.hard-reg-class-gpr-mode-s16
     3223                        (! s16->s32 dest src))
     3224                       (#.hard-reg-class-gpr-mode-u8
     3225                        (! u8->u32 dest src))
     3226                       (#.hard-reg-class-gpr-mode-s8
     3227                        (! s8->s32 dest src))))
     3228                    (#.hard-reg-class-gpr-mode-u16
     3229                     (case src-mode
     3230                       (#.hard-reg-class-gpr-mode-node
     3231                        (! unbox-u16 dest src))
     3232                       ((#.hard-reg-class-gpr-mode-u8
     3233                         #.hard-reg-class-gpr-mode-s8)
     3234                        (! u8->u32 dest src))
     3235                       (t
     3236                        (unless (eql dest-gpr src-gpr)
     3237                          (! copy-gpr dest src)))))
     3238                    (#.hard-reg-class-gpr-mode-s16
     3239                     (case src-mode
     3240                       (#.hard-reg-class-gpr-mode-node
     3241                        (! unbox-s16 dest src))
     3242                       (#.hard-reg-class-gpr-mode-s8
     3243                        (! s8->s32 dest src))
     3244                       (#.hard-reg-class-gpr-mode-u8
     3245                        (! u8->u32 dest src))
     3246                       (t
     3247                        (unless (eql dest-gpr src-gpr)
     3248                          (! copy-gpr dest src)))))
     3249                    (#.hard-reg-class-gpr-mode-u8
     3250                     (case src-mode
     3251                       (#.hard-reg-class-gpr-mode-node
     3252                        (! unbox-u8 dest src))
     3253                       (t
     3254                        (unless (eql dest-gpr src-gpr)
     3255                          (! copy-gpr dest src)))))
     3256                    (#.hard-reg-class-gpr-mode-s8
     3257                     (case src-mode
     3258                       (#.hard-reg-class-gpr-mode-node
     3259                        (! unbox-s8 dest src))
     3260                       (t
     3261                        (unless (eql dest-gpr src-gpr)
     3262                          (! copy-gpr dest src)))))))))
    31273263              (if src-gpr
    31283264                (if dest-fpr
     
    31633299  nil)
    31643300
    3165 ; bind vars to initforms, as per let*, &aux.
     3301;;; bind vars to initforms, as per let*, &aux.
    31663302(defun ppc2-seq-bind (seg vars initforms)
    31673303  (dolist (var vars)
     
    33303466
    33313467
    3332 ; Never make a vcell if this is an inherited var.
    3333 ; If the var's inherited, its bits won't be a fixnum (and will
    3334 ; therefore be different from what NX-VAR-BITS returns.)
     3468;;; Never make a vcell if this is an inherited var.
     3469;;; If the var's inherited, its bits won't be a fixnum (and will
     3470;;; therefore be different from what NX-VAR-BITS returns.)
    33353471(defun ppc2-bind-var (seg var vloc &optional lcell &aux
    33363472                          (bits (nx-var-bits var))
     
    34153551      (ppc2-adjust-vstack (* 3 *ppc2-target-node-size*)))))
    34163552
    3417 ; Store the contents of EA - which denotes either a vframe location
    3418 ; or a hard register - in reg.
     3553;;; Store the contents of EA - which denotes either a vframe location
     3554;;; or a hard register - in reg.
    34193555
    34203556(defun ppc2-store-ea (seg ea reg)
     
    34313567     
    34323568
    3433 ; Callers should really be sure that this is what they want to use.
     3569;;; Callers should really be sure that this is what they want to use.
    34343570(defun ppc2-absolute-natural (seg vreg xfer value)
    34353571  (with-ppc-local-vinsn-macros (seg vreg xfer)
     
    34713607
    34723608
    3473 ; If "value-first-p" is true and both "offset" and "val" need to be
    3474 ; evaluated, evaluate "val" before evaluating "offset".
     3609;;; If "value-first-p" is true and both "offset" and "val" need to be
     3610;;; evaluated, evaluate "val" before evaluating "offset".
    34753611(defun ppc2-%immediate-set-ptr (seg vreg xfer  ptr offset val value-first-p)
    34763612  (with-ppc-local-vinsn-macros (seg vreg xfer)
     
    38473983
    38483984
    3849 ; "Trivial" means can be evaluated without allocating or modifying registers.
    3850 ; Interim definition, which will probably stay here forever.
     3985;;; "Trivial" means can be evaluated without allocating or modifying registers.
     3986;;; Interim definition, which will probably stay here forever.
    38513987(defun ppc2-trivial-p (form &aux op bits)
    38523988  (setq form (nx-untyped-form form))
     
    38874023    (^)))
    38884024
    3889 ;; Should be less eager to box result
     4025;;; Should be less eager to box result
    38904026(defun ppc2-extract-charcode (seg vreg xfer char safe)
    38914027  (with-ppc-local-vinsn-macros (seg vreg xfer)
     
    39124048      (^))))
    39134049
    3914 ; If safe, ensure that index is a fixnum (if non-constant)
    3915 ; and check vector bound.
    3916 ; If we're going to have to evaluate the index into a register (to do
    3917 ; the bounds check), but know that the index could be a constant 16-bit
    3918 ; displacement, this'll look pretty silly ..
     4050;;; If safe, ensure that index is a fixnum (if non-constant)
     4051;;; and check vector bound.
     4052;;; If we're going to have to evaluate the index into a register (to do
     4053;;; the bounds check), but know that the index could be a constant 16-bit
     4054;;; displacement, this'll look pretty silly ..
    39194055(defun ppc2-misc-node-ref (seg vreg xfer miscobj index safe)
    39204056  (with-ppc-local-vinsn-macros (seg vreg xfer)
     
    39614097
    39624098(defun ppc2-misc-byte-count (subtag element-count)
    3963   (declare (fixnum subtag))
    3964   (if (or (= ppc32::fulltag-nodeheader (logand subtag ppc32::fulltagmask))
    3965           (<= subtag ppc32::max-32-bit-ivector-subtag))
    3966     (ash element-count 2)
    3967     (if (<= subtag ppc32::max-8-bit-ivector-subtag)
    3968       element-count
    3969       (if (<= subtag ppc32::max-16-bit-ivector-subtag)
    3970         (ash element-count 1)
    3971         (if (= subtag ppc32::subtag-bit-vector)
    3972           (ash (+ element-count 7) -3)
    3973           (+ 4 (ash element-count 3)))))))
    3974 
    3975 ; The naive approach is to vpush all of the initforms, allocate the miscobj,
    3976 ; then sit in a loop vpopping the values into the vector.
    3977 ; That's "naive" when most of the initforms in question are "side-effect-free"
    3978 ; (constant references or references to un-SETQed lexicals), in which case
    3979 ; it makes more sense to just store the things into the vector cells, vpushing/
    3980 ; vpopping only those things that aren't side-effect-free.  (It's necessary
    3981 ; to evaluate any non-trivial forms before allocating the miscobj, since that
    3982 ; ensures that the initforms are older (in the EGC sense) than it is.)
    3983 ; The break-even point space-wise is when there are around 3 non-trivial initforms
    3984 ; to worry about.
     4099  (funcall (arch::target-array-data-size-function
     4100            (backend-target-arch *target-backend*))
     4101           subtag element-count))
     4102
     4103
     4104;;; The naive approach is to vpush all of the initforms, allocate the
     4105;;; miscobj, then sit in a loop vpopping the values into the vector.
     4106;;; That's "naive" when most of the initforms in question are
     4107;;; "side-effect-free" (constant references or references to un-SETQed
     4108;;; lexicals), in which case it makes more sense to just store the
     4109;;; things into the vector cells, vpushing/ vpopping only those things
     4110;;; that aren't side-effect-free.  (It's necessary to evaluate any
     4111;;; non-trivial forms before allocating the miscobj, since that
     4112;;; ensures that the initforms are older (in the EGC sense) than it
     4113;;; is.)  The break-even point space-wise is when there are around 3
     4114;;; non-trivial initforms to worry about.
    39854115
    39864116
     
    39984128                         (unless (ppc-side-effect-free-form-p f)
    39994129                           (incf count)))))
    4000              (header (logior (ash n target::num-subtag-bits) subtag)))
     4130             (header (arch::make-vheader n subtag)))
    40014131        (declare (fixnum n nntriv))
    40024132        (cond ( (or *ppc2-open-code-inline* (> nntriv 3))
     
    40284158                           (setq reg (ppc2-one-untargeted-reg-form seg form nodetemp))
    40294159                           (progn
    4030                              (decf pushed-cell 4)
     4160                             (decf pushed-cell *ppc2-target-node-size*)
    40314161                             (ppc2-stack-to-register seg (ppc2-vloc-ea pushed-cell) nodetemp)))
    40324162                         (! misc-set-c-node reg target index)))))
     
    40354165     (^)))
    40364166
    4037 ;; Heap-allocated constants -might- need memoization: they might be newly-created,
    4038 ;; as in the case of synthesized toplevel functions in .pfsl files.
     4167;;; Heap-allocated constants -might- need memoization: they might be newly-created,
     4168;;; as in the case of synthesized toplevel functions in .pfsl files.
    40394169(defun ppc2-acode-needs-memoization (valform)
    40404170  (if (ppc2-form-typep valform 'fixnum)
     
    41044234    lab))
    41054235
    4106 ; If we know that the form is something that sets a CR bit,
    4107 ; allocate a CR field and evaluate the form in such a way
    4108 ; as to set that bit.
    4109 ; If it's a compile-time constant, branch accordingly and
    4110 ; let the dead code die.
    4111 ; Otherwise, evaluate it to some handy register and compare
    4112 ; that register to RNIL.
    4113 ; "XFER" is a compound destination.
     4236;;; If we know that the form is something that sets a CR bit,
     4237;;; allocate a CR field and evaluate the form in such a way
     4238;;; as to set that bit.
     4239;;; If it's a compile-time constant, branch accordingly and
     4240;;; let the dead code die.
     4241;;; Otherwise, evaluate it to some handy register and compare
     4242;;; that register to RNIL.
     4243;;; "XFER" is a compound destination.
    41144244(defun ppc2-conditional-form (seg xfer form)
    41154245  (let* ((uwf (acode-unwrapped-form form)))
     
    42224352                 (if (characterp form) (%char-code form))))))))
    42234353
    4224 ; execute body, cleanup afterwards (if need to)
     4354;;; execute body, cleanup afterwards (if need to)
    42254355(defun ppc2-undo-body (seg vreg xfer body old-stack)
    42264356  (let* ((current-stack (ppc2-encode-stack))
     
    42804410    exit-vstack))
    42814411
    4282 ; We can sometimes combine unwinding the catch stack with returning from the function
    4283 ; by jumping to a subprim that knows how to do this.  If catch frames were distinguished
    4284 ; from unwind-protect frames, we might be able to do this even when saved registers
    4285 ; are involved (but the subprims restore them from the last catch frame.)
    4286 ; *** there are currently only subprims to handle the "1 frame" case; add more ***
     4412;;; We can sometimes combine unwinding the catch stack with returning from the function
     4413;;; by jumping to a subprim that knows how to do this.  If catch frames were distinguished
     4414;;; from unwind-protect frames, we might be able to do this even when saved registers
     4415;;; are involved (but the subprims restore them from the last catch frame.)
     4416;;; *** there are currently only subprims to handle the "1 frame" case; add more ***
    42874417(defun ppc2-do-return (seg)
    42884418  (let* ((*ppc2-vstack* *ppc2-vstack*)
     
    45524682
    45534683
    4554 ; Restore the N most recent dynamic bindings.
     4684;;; Restore the N most recent dynamic bindings.
    45554685(defun ppc2-dpayback (seg n)
    45564686  (declare (fixnum n))
     
    46374767  (ppc2-free-lcells))
    46384768
    4639 ; It's not clear whether or not predicates, etc. want to look
    4640 ; at an lreg or just at its value slot.
    4641 ; It's clear that the assembler just wants the value, and that
    4642 ; the value had better be assigned by the time we start generating
    4643 ; machine code.
    4644 ; For now, we replace lregs in the operand vector with their values
    4645 ; on entry, but it might be reasonable to make PARSE-OPERAND-FORM
    4646 ; deal with lregs ...
     4769;;; It's not clear whether or not predicates, etc. want to look
     4770;;; at an lreg or just at its value slot.
     4771;;; It's clear that the assembler just wants the value, and that
     4772;;; the value had better be assigned by the time we start generating
     4773;;; machine code.
     4774;;; For now, we replace lregs in the operand vector with their values
     4775;;; on entry, but it might be reasonable to make PARSE-OPERAND-FORM
     4776;;; deal with lregs ...
    46474777(defun ppc2-expand-vinsn (vinsn)
    46484778  (let* ((template (vinsn-template vinsn))
     
    50565186  (ppc2-misc-node-ref seg vreg xfer vector index (unless *ppc2-reckless* (ppc2-lookup-target-uvector-subtag :simple-vector))))
    50575187
    5058 ;; It'd be nice if this didn't box the result.  Worse things happen ...
    5059 ;;  Once there's a robust mechanism, adding a CHARCODE storage class shouldn't be hard.
     5188;;; It'd be nice if this didn't box the result.  Worse things happen ...
     5189;;;  Once there's a robust mechanism, adding a CHARCODE storage class shouldn't be hard.
    50605190(defppc2 ppc2-%sbchar %sbchar (seg vreg xfer string index)
    50615191  (ppc2-vref seg vreg xfer :simple-string string index (unless *ppc2-reckless* (ppc2-lookup-target-uvector-subtag :simple-string))))
     
    51305260
    51315261(defppc2 ppc2-vector vector (seg vreg xfer arglist)
    5132   (ppc2-allocate-initialized-gvector seg vreg xfer ppc32::subtag-simple-vector arglist))
     5262  (ppc2-allocate-initialized-gvector seg vreg xfer
     5263                                     (ppc2-lookup-target-uvector-subtag
     5264                                      :simple-vector) arglist))
    51335265
    51345266(defppc2 ppc2-%ppc-gvector %ppc-gvector (seg vreg xfer arglist)
     
    51465278          (<- ppc::arg_z)
    51475279          (^))
    5148         (let* ((subtag-tag (logand subtag ppc32::full-tag-mask)))
    5149           (declare (fixnum subtag-tag))
    5150           (unless (= subtag-tag ppc32::fulltag-nodeheader)
    5151             (let* ((newtag ppc32::subtag-simple-vector))
    5152               (warn "%gvector: subtag was ~d, using ~d instead" subtag newtag)
    5153               (setq subtag newtag)))
    5154           (ppc2-allocate-initialized-gvector seg vreg xfer subtag (cdr all-on-stack)))))))
    5155 
    5156 ;; Should be less eager to box result
     5280        (ppc2-allocate-initialized-gvector seg vreg xfer subtag (cdr all-on-stack))))))
     5281
     5282;;; Should be less eager to box result
    51575283(defppc2 ppc2-%char-code %char-code (seg vreg xfer c)
    51585284  (ppc2-extract-charcode seg vreg xfer c nil))
     
    51825308      (^))))
    51835309
    5184 ; in a lot of (typical ?) cases, it might be possible to use a rotate-and-mask instead
    5185 ; of andi./andis.
     5310;;; in a lot of (typical ?) cases, it might be possible to use a rotate-and-mask instead
     5311;;; of andi./andis.
    51865312
    51875313(defppc2 ppc2-%ilogand2 %ilogand2 (seg vreg xfer form1 form2)
     
    58045930         (let* ((fix1 (acode-fixnum-form-p form1))
    58055931                (fix2 (acode-fixnum-form-p form2))
    5806                 (other (if fix1 form2 (if fix2 form1))))
     5932                (other (if (and fix1
     5933                                (typep (ash fix1 *ppc2-target-fixnum-shift*)
     5934                                       '(signed-byte 32)))
     5935                         form2
     5936                         (if (and fix2
     5937                                  (typep (ash fix2 *ppc2-target-fixnum-shift*)
     5938                                              '(signed-byte 32)))
     5939                           form1))))
    58075940           (if (and fix1 fix2)
    58085941             (ppc2-lri seg vreg (ash (+ fix1 fix2) *ppc2-target-fixnum-shift*))
     
    58335966    (if (and v1 v2)
    58345967      (ppc2-use-operator (%nx1-operator fixnum) seg vreg xfer (%i- v1 v2))
    5835       (if (and v2  (neq v2 most-negative-fixnum))
     5968      (if (and v2 (neq v2 most-negative-fixnum))
    58365969        (ppc2-use-operator (%nx1-operator %i+) seg vreg xfer num1 (make-acode (%nx1-operator fixnum) (- v2)) overflow)
    58375970        (if (eq v2 0)
     
    59946127           (nbytes (if (and subtag nelements) (ppc2-misc-byte-count subtag nelements))))
    59956128      (if (and  nbytes (null initval)
    5996                (< (logand (lognot 7) (+ nbytes 4 7)) #x8000))
     6129                (< (logand
     6130                    (lognot (1- (* 2 *ppc2-target-node-size*)))
     6131                    (+ nbytes *ppc2-target-node-size*
     6132                       (1- (* 2 *ppc2-target-node-size*)))) #x8000))
    59976133        (with-imm-temps () (header)
    59986134          (ppc2-lri seg header (arch::make-vheader nelements subtag))
     
    60096145              (! misc-alloc)
    60106146              (<- ($ ppc::arg_z))))))
    6011       (^))))
     6147        (^))))
    60126148
    60136149(defppc2 ppc2-%iasr %iasr (seg vreg xfer form1 form2)
     
    60466182    (ppc2-compare seg vreg xfer form1 form2 cr-bit true-p)))
    60476183
    6048 (defppc2 ppc2-%u32<> %u32<> (seg vreg xfer cc form1 form2)
     6184(defppc2 ppc2-%natural<> %natural<> (seg vreg xfer cc form1 form2)
    60496185  (multiple-value-bind (cr-bit true-p) (acode-condition-to-ppc-cr-bit cc)
    6050     (ppc2-u32-compare seg vreg xfer form1 form2 cr-bit true-p)))
     6186    (ppc2-natural-compare seg vreg xfer form1 form2 cr-bit true-p)))
    60516187
    60526188(defppc2 ppc2-double-float-compare double-float-compare (seg vreg xfer cc form1 form2)
     
    63136449     
    63146450                                     
    6315 ; This returns an unboxed object, unless the caller wants to box it.
     6451;;; This returns an unboxed object, unless the caller wants to box it.
    63166452(defppc2 ppc2-immediate-get-xxx immediate-get-xxx (seg vreg xfer bits ptr offset)
    63176453  (let* ((lowbits (%ilogand2 3 bits))
     
    63376473           (and offval (%i> (integer-length offval) 15) (setq offval nil))
    63386474           (and absptr (%i> (integer-length absptr) 15) (setq absptr nil))
    6339            (with-imm-target () (dest :u32)
     6475           (with-imm-target () (dest :natural)
    63406476             (if absptr
    63416477               (if (eq size 4)
     
    63746510                         (! mem-ref-u16 dest src-reg offset-reg)
    63756511                         (! mem-ref-u8 dest src-reg offset-reg)))))))
    6376              ; %get-fixnum: if storing to a node vreg, ignore any overflow.
     6512             ;; %get-fixnum: if storing to a node vreg, ignore any overflow.
    63776513             (if (and (eq size 4)
    63786514                      (%ilogbitp 5 bits)
     
    64886624            (ppc2-close-var seg var)))))))
    64896625
    6490 ; Make a function call (e.g., to mapcar) with some of the toplevel arguments
    6491 ; stack-consed (downward) closures.  Bind temporaries to these closures so
    6492 ; that tail-recursion/non-local exits work right.
    6493 ; (all of the closures are distinct: FLET and LABELS establish dynamic extent themselves.)
     6626;;; Make a function call (e.g., to mapcar) with some of the toplevel arguments
     6627;;; stack-consed (downward) closures.  Bind temporaries to these closures so
     6628;;; that tail-recursion/non-local exits work right.
     6629;;; (all of the closures are distinct: FLET and LABELS establish dynamic extent themselves.)
    64946630(defppc2 ppc2-with-downward-closures with-downward-closures (seg vreg xfer tempvars closures callform)
    64956631  (let* ((old-stack (ppc2-encode-stack)))
     
    65816717               (^))))))
    65826718
    6583 (defppc2 ppc2-%fixnum-ref-u32 %fixnum-ref-u32 (seg vreg xfer base offset)
     6719(defppc2 ppc2-%fixnum-ref-natural %fixnum-ref-natural (seg vreg xfer base offset)
    65846720  (let* ((fixoffset (acode-fixnum-form-p offset)))
    65856721    (cond ((null vreg)
     
    65876723           (ppc2-form seg nil xfer offset))
    65886724          ((typep fixoffset '(signed-byte 16))
    6589            (with-imm-target () (val :u32)
     6725           (with-imm-target () (val :natural)
    65906726             (! lisp-word-ref-c val
    65916727                (ppc2-one-untargeted-reg-form seg base ppc::arg_z)
     
    65976733               (with-imm-target () (otemp :s32)
    65986734                 (! fixnum->s32 otemp oreg)
    6599                  (with-imm-target () (val :u32)
     6735                 (with-imm-target () (val :natural)
    66006736                   (! lisp-word-ref val breg otemp)
    66016737                   (<- val)))
     
    67276863           
    67286864
    6729 ; cons a macptr, unless "vreg" is an immediate register of mode :address.
     6865;;; cons a macptr, unless "vreg" is an immediate register of mode :address.
    67306866(defppc2 ppc2-%consmacptr% %consmacptr% (seg vreg xfer form)
    67316867  (cond ((null vreg) (ppc2-form seg nil xfer form))
     
    67426878    (with-imm-target () (address-reg :address)
    67436879      (ppc2-form seg address-reg nil form)
    6744       (<- (set-regspec-mode address-reg (gpr-mode-name-value :u32)))
     6880      (<- (set-regspec-mode address-reg (gpr-mode-name-value :natural)))
    67456881      (^))))
    67466882
     
    67516887      (unless (logbitp (hard-regspec-value vreg) ppc-imm-regs)
    67526888        (error "I give up.  When will I get this right ?"))
    6753       (let* ((u32-reg (ppc2-one-targeted-reg-form seg
    6754                                                     form
    6755                                                     ($ vreg :mode :u32))))
    6756         (<- u32-reg)
     6889      (let* ((natural-reg (ppc2-one-targeted-reg-form seg
     6890                                                      form
     6891                                                      ($ vreg :mode :natural))))
     6892        (<- natural-reg)
    67576893        (^)))))
    67586894
     
    68737009
    68747010
    6875 ; If we didn't use this for stack consing, turn it into a call.  Ugh.
     7011;;; If we didn't use this for stack consing, turn it into a call.  Ugh.
    68767012
    68777013(defppc2 ppc2-make-list make-list (seg vreg xfer size initial-element)
     
    71407276           (! set-eabi-c-arg
    71417277              (with-imm-target ()
    7142                 (valreg :u32)
     7278                (valreg :natural)
    71437279                (ppc2-unboxed-integer-arg-to-reg seg valform valreg))
    71447280              nextarg)))
     
    72177353               (decf nextarg))
    72187354             (with-imm-target ()
    7219                (valreg :u32)
     7355               (valreg :natural)
    72207356               (if longval
    72217357                 (ppc2-lri seg valreg longval)
     
    74347570                      (incf other-offset)))))
    74357571            (t
    7436              (with-imm-target () (valreg :u32)
     7572             (with-imm-target () (valreg :natural)
    74377573                (let* ((reg (ppc2-unboxed-integer-arg-to-reg seg valform valreg)))
    74387574                  (incf ngpr-args)
     
    75697705
    75707706
    7571 ;; Under MacsBug 5.3 (and some others ?), this'll do a low-level user
    7572 ;; break.  If the debugger doesn't recognize the trap instruction,
    7573 ;; you'll have to manually advance the PC past it.  "arg" winds up in the
    7574 ;; arg_z register; whatever's in arg_z on return is returned by
    7575 ;; the %debug-trap construct.
     7707;;; Under MacsBug 5.3 (and some others ?), this'll do a low-level user
     7708;;; break.  If the debugger doesn't recognize the trap instruction,
     7709;;; you'll have to manually advance the PC past it.  "arg" winds up in the
     7710;;; arg_z register; whatever's in arg_z on return is returned by
     7711;;; the %debug-trap construct.
    75767712
    75777713(defppc2 ppc2-%debug-trap %debug-trap (seg vreg xfer arg)
     
    75897725    (^)))
    75907726
    7591 (defppc2 ppc2-%u32+ %u32+ (seg vreg xfer x y)
     7727(defppc2 ppc2-%natural+ %natural+ (seg vreg xfer x y)
    75927728  (if (null vreg)
    75937729    (progn
     
    76017737               (u15y (and (typep fix-y '(unsigned-byte 15)) fix-y)))
    76027738          (if (not (or u15x u15y))
    7603             (with-imm-target () (xreg :u32)
    7604               (with-imm-target (xreg) (yreg :u32)
     7739            (with-imm-target () (xreg :natural)
     7740              (with-imm-target (xreg) (yreg :natural)
    76057741                (ppc2-two-targeted-reg-forms seg x xreg y yreg)
    7606                 (! %u32+ xreg xreg yreg))
     7742                (! %natural+ xreg xreg yreg))
    76077743              (<- xreg))
    76087744            (let* ((other (if u15x y x)))
    7609               (with-imm-target () (other-reg :u32)
     7745              (with-imm-target () (other-reg :natural)
    76107746                (ppc2-one-targeted-reg-form seg other other-reg)
    7611                 (! %u32+-c other-reg other-reg (or u15x u15y))
     7747                (! %natural+-c other-reg other-reg (or u15x u15y))
    76127748                (<- other-reg))))
    76137749          (^))))))
    76147750
    7615 (defppc2 ppc2-%u32- %u32- (seg vreg xfer x y)
     7751(defppc2 ppc2-%natural- %natural- (seg vreg xfer x y)
    76167752  (if (null vreg)
    76177753    (progn
     
    76247760        (let* ((u15y (and (typep fix-y '(unsigned-byte 15)) fix-y)))
    76257761          (if (not u15y)
    7626             (with-imm-target () (xreg :u32)
    7627               (with-imm-target (xreg) (yreg :u32)
     7762            (with-imm-target () (xreg :natural)
     7763              (with-imm-target (xreg) (yreg :natural)
    76287764                (ppc2-two-targeted-reg-forms seg x xreg y yreg)
    7629                 (! %u32- xreg xreg yreg))
     7765                (! %natural- xreg xreg yreg))
    76307766              (<- xreg))
    76317767            (progn
    7632               (with-imm-target () (xreg :u32)
     7768              (with-imm-target () (xreg :natural)
    76337769                (ppc2-one-targeted-reg-form seg x xreg)
    7634                 (! %u32--c xreg xreg u15y)
     7770                (! %natural--c xreg xreg u15y)
    76357771                (<- xreg))))
    76367772          (^))))))
    76377773
    7638 (defppc2 ppc2-%u32-logior %u32-logior (seg vreg xfer x y)
     7774(defppc2 ppc2-%natural-logior %natural-logior (seg vreg xfer x y)
    76397775  (if (null vreg)
    76407776    (progn
    76417777      (ppc2-form seg nil nil x)
    76427778      (ppc2-form seg nil xfer y))
    7643     (let* ((u32x (nx-u32-constant-p x))
    7644            (u32y (nx-u32-constant-p y)))
    7645       (if (and u32x u32y)
    7646         (ppc2-absolute-natural seg vreg xfer (logior u32x u32y))
    7647         (let* ((constant (or u32x u32y)))
     7779    (let* ((naturalx (nx-natural-constant-p x))
     7780           (naturaly (nx-natural-constant-p y)))
     7781      (if (and naturalx naturaly)
     7782        (ppc2-absolute-natural seg vreg xfer (logior naturalx naturaly))
     7783        (let* ((u32x (nx-u32-constant-p x))
     7784               (u32y (nx-u32-constant-p y))
     7785               (constant (or u32x u32y)))
    76487786          (if (not constant)
    7649             (with-imm-target () (xreg :u32)
    7650               (with-imm-target (xreg) (yreg :u32)
     7787            (with-imm-target () (xreg :natural)
     7788              (with-imm-target (xreg) (yreg :natural)
    76517789                (ppc2-two-targeted-reg-forms seg x xreg y yreg)
    7652                 (! %u32-logior xreg xreg yreg))
     7790                (! %natural-logior xreg xreg yreg))
    76537791              (<- xreg))
    76547792            (let* ((other (if u32x y x))
    76557793                   (high (ldb (byte 16 16) constant))
    76567794                   (low (ldb (byte 16 0) constant)))
    7657               (with-imm-target () (other-reg :u32)
     7795              (with-imm-target () (other-reg :natural)
    76587796                (ppc2-one-targeted-reg-form seg other other-reg)
    7659                 (! %u32-logior-c other-reg other-reg high low)
     7797                (! %natural-logior-c other-reg other-reg high low)
    76607798                (<- other-reg))))
    76617799          (^))))))
    76627800
    7663 (defppc2 ppc2-%u32-logxor %u32-logxor (seg vreg xfer x y)
     7801(defppc2 ppc2-%natural-logxor %natural-logxor (seg vreg xfer x y)
    76647802  (if (null vreg)
    76657803    (progn
    76667804      (ppc2-form seg nil nil x)
    76677805      (ppc2-form seg nil xfer y))
    7668     (let* ((u32x (nx-u32-constant-p x))
    7669            (u32y (nx-u32-constant-p y)))
    7670       (if (and u32x u32y)
    7671         (ppc2-absolute-natural seg vreg xfer (logxor u32x u32y))
    7672         (let* ((constant (or u32x u32y)))
     7806    (let* ((naturalx (nx-natural-constant-p x))
     7807           (naturaly (nx-natural-constant-p y)))
     7808      (if (and naturalx naturaly)
     7809        (ppc2-absolute-natural seg vreg xfer (logxor naturalx naturaly))
     7810        (let* ((u32x (nx-u32-constant-p x))
     7811               (u32y (nx-u32-constant-p y))
     7812               (constant (or u32x u32y)))
    76737813          (if (not constant)
    7674             (with-imm-target () (xreg :u32)
    7675               (with-imm-target (xreg) (yreg :u32)
     7814            (with-imm-target () (xreg :natural)
     7815              (with-imm-target (xreg) (yreg :natural)
    76767816                (ppc2-two-targeted-reg-forms seg x xreg y yreg)
    7677                 (! %u32-logxor xreg xreg yreg))
     7817                (! %natural-logxor xreg xreg yreg))
    76787818              (<- xreg))
    76797819            (let* ((other (if u32x y x))
    76807820                   (high (ldb (byte 16 16) constant))
    76817821                   (low (ldb (byte 16 0) constant)))
    7682               (with-imm-target () (other-reg :u32)
     7822              (with-imm-target () (other-reg :natural)
    76837823                (ppc2-one-targeted-reg-form seg other other-reg)
    7684                 (! %u32-logxor-c other-reg other-reg high low)
     7824                (! %natural-logxor-c other-reg other-reg high low)
    76857825                (<- other-reg))))
    76867826          (^))))))
    76877827
    7688 (defppc2 ppc2-%u32-logand %u32-logand (seg vreg xfer x y)
     7828(defppc2 ppc2-%natural-logand %natural-logand (seg vreg xfer x y)
    76897829  (if (null vreg)
    76907830    (progn
    76917831      (ppc2-form seg nil nil x)
    76927832      (ppc2-form seg nil xfer y))
    7693     (let* ((u32x (nx-u32-constant-p x))
    7694            (u32y (nx-u32-constant-p y)))
    7695       (if (and u32x u32y)
    7696         (ppc2-absolute-natural seg vreg xfer (logand u32x u32y))
    7697         (let* ((constant (or u32x u32y)))
     7833    (let* ((naturalx (nx-natural-constant-p x))
     7834           (naturaly (nx-natural-constant-p y)))
     7835      (if (and naturalx naturaly)
     7836        (ppc2-absolute-natural seg vreg xfer (logand naturalx naturaly))
     7837        (let* ((u32x (nx-u32-constant-p x))
     7838               (u32y (nx-u32-constant-p y))
     7839               (constant (or u32x u32y)))
    76987840          (if (not constant)
    7699             (with-imm-target () (xreg :u32)
    7700               (with-imm-target (xreg) (yreg :u32)
     7841            (with-imm-target () (xreg :natural)
     7842              (with-imm-target (xreg) (yreg :natural)
    77017843                (ppc2-two-targeted-reg-forms seg x xreg y yreg)
    7702                 (! %u32-logand xreg xreg yreg))
     7844                (! %natural-logand xreg xreg yreg))
    77037845              (<- xreg))
    7704             (let* ((other (if u32x y x))
    7705                    (constant (or u32x u32y)))
    7706               (with-imm-target () (other-reg :u32)
     7846            (let* ((other (if u32x y x)))
     7847              (with-imm-target () (other-reg :natural)
    77077848                (ppc2-one-targeted-reg-form seg other other-reg)
    77087849                (multiple-value-bind (start-bit stop-bit)
    77097850                    (ppc2-mask-bits constant)
    77107851                  (if start-bit
    7711                     (! %u32-logand-mask-c other-reg other-reg start-bit stop-bit)
     7852                    (! %natural-logand-mask-c other-reg other-reg start-bit stop-bit)
    77127853                    (let* ((high (ldb (byte 16 16) constant))
    77137854                           (low (ldb (byte 16 0) constant)))
     
    77167857                                   (= low high))
    77177858                        (if (= low 0)
    7718                           (! %u32-logand-high-c other-reg other-reg high)
     7859                          (! %natural-logand-high-c other-reg other-reg high)
    77197860                          (if (= high 0)
    7720                             (! %u32-logand-low-c other-reg other-reg low)
    7721                             (with-imm-target (other-reg) (const-reg :u32)
     7861                            (! %natural-logand-low-c other-reg other-reg low)
     7862                            (with-imm-target (other-reg) (const-reg :natural)
    77227863                              (ppc2-absolute-natural seg const-reg nil constant)
    7723                               (! %u32-logand other-reg other-reg const-reg))))))))
     7864                              (! %natural-logand other-reg other-reg const-reg))))))))
    77247865                (<- other-reg))))
    77257866          (^))))))
    77267867
    7727 (defppc2 ppc2-u32-shift-right u32-shift-right (seg vreg xfer num amt)
    7728   (with-imm-target () (dest :u32)
     7868(defppc2 ppc2-natural-shift-right natural-shift-right (seg vreg xfer num amt)
     7869  (with-imm-target () (dest :natural)
    77297870    (ppc2-one-targeted-reg-form seg num dest)
    7730     (! u32-shift-right dest dest (acode-fixnum-form-p amt))
     7871    (! natural-shift-right dest dest (acode-fixnum-form-p amt))
    77317872    (<- dest)
    77327873    (^)))
    77337874
    7734 (defppc2 ppc2-u32-shift-left u32-shift-left (seg vreg xfer num amt)
    7735   (with-imm-target () (dest :u32)
     7875(defppc2 ppc2-natural-shift-left natural-shift-left (seg vreg xfer num amt)
     7876  (with-imm-target () (dest :natural)
    77367877    (ppc2-one-targeted-reg-form seg num dest)
    7737     (! u32-shift-left dest dest (acode-fixnum-form-p amt))
     7878    (! natural-shift-left dest dest (acode-fixnum-form-p amt))
    77387879    (<- dest)
    77397880    (^)))
Note: See TracChangeset for help on using the changeset viewer.