Changeset 11559
 Timestamp:
 Dec 28, 2008, 12:10:06 PM (11 years ago)
 File:

 1 edited
Legend:
 Unmodified
 Added
 Removed

trunk/source/compiler/X86/x862.lisp
r11451 r11559 203 203 204 204 (defvar *x862resultreg* x8664::arg_z) 205 206 (defvar *x8664nvrs* 207 `(,x8664::save0 ,x8664::save1 ,x8664::save2 ,x8664::save3)) 208 209 (defvar *reducedx8664nvrs* 210 `(,x8664::save0 ,x8664::save1 ,x8664::save2)) 211 212 (defvar *x8632nvrs* ()) 213 205 214 206 215 (defvar *x862argz* nil) … … 894 903 895 904 896 (defun %x862biggercdrthan (x y)897 (declare (cons x y))898 (> (the fixnum (cdr x)) (the fixnum (cdr y))))899 900 ;;; Return an unordered list of "varsets": each var in a varset can be901 ;;; assigned a register and all vars in a varset can be assigned the902 ;;; same register (e.g., no scope conflicts.)903 904 (defun x862partitionvars (vars)905 (labels ((varweight (var)906 (let* ((bits (nxvarbits var)))907 (declare (fixnum bits))908 (if (eql 0 (logand bits (logior909 (ash 1 $vbitpuntable)910 (ash 1 $vbitspecial)911 (ash 1 $vbitnoreg))))912 (if (eql (logior (ash 1 $vbitclosed) (ash 1 $vbitsetq))913 (logand bits (logior (ash 1 $vbitclosed) (ash 1 $vbitsetq))))914 0915 (%i+ (%ilogand $vrefmask bits) (%ilsr 8 (%ilogand $vsetqmask bits))))916 0)))917 (sumweights (varlist)918 (let ((sum 0))919 (dolist (v varlist sum) (incf sum (varweight v)))))920 (varsdisjointp (v1 v2)921 (if (eq v1 v2)922 nil923 (if (memq v1 (varbindinginfo v2))924 nil925 (if (memq v2 (varbindinginfo v1))926 nil927 t)))))928 (setq vars (%sortlistnokey929 ;(deleteif #'(lambda (v) (eql (varweight v) 0)) vars)930 (do* ((handle (cons nil vars))931 (splice handle))932 ((null (cdr splice)) (cdr handle))933 (declare (dynamicextent handle) (type cons handle splice))934 (if (eql 0 (varweight (%car (cdr splice))))935 (rplacd splice (%cdr (cdr splice)))936 (setq splice (cdr splice))))937 #'(lambda (v1 v2) (%i> (varweight v1) (varweight v2)))))938 ;; This isn't optimal. It partitions all registerallocatable939 ;; variables into sets such that940 ;; 1) no variable is a member of more than one set and941 ;; 2) all variables in a given set are disjoint from each other942 ;; A set might have exactly one member.943 ;; If a register is allocated for any member of a set, it's944 ;; allocated for all members of that set.945 (let* ((varsets nil))946 (do* ((all vars (cdr all)))947 ((null all))948 (let* ((var (car all)))949 (when (dolist (already varsets t)950 (when (memq var (car already)) (return)))951 (let* ((varset (cons var nil)))952 (dolist (v (cdr all))953 (when (dolist (already varsets t)954 (when (memq v (car already)) (return)))955 (when (dolist (d varset t)956 (unless (varsdisjointp v d) (return)))957 (push v varset))))958 (let* ((weight (sumweights varset)))959 (declare (fixnum weight))960 (if (>= weight 3)961 (push (cons (nreverse varset) weight) varsets)))))))962 varsets)))963 964 ;;; Maybe globally allocate registers to symbols naming functions & variables,965 ;;; and to simple lexical variables.966 (defun x862allocateglobalregisters (fcells vcells allvars noregs)967 (if (or noregs (targetarchcase (:x8632 t)))968 (progn969 (dolist (c fcells) (%rplacd c nil))970 (dolist (c vcells) (%rplacd c nil))971 (values 0 nil))972 (let* ((maybe (x862partitionvars allvars)))973 (dolist (c fcells)974 (if (>= (the fixnum (cdr c)) 3) (push c maybe)))975 (dolist (c vcells)976 (if (>= (the fixnum (cdr c)) 3) (push c maybe)))977 (do* ((things (%sortlistnokey maybe #'%x862biggercdrthan) (cdr things))978 (n 0 (1+ n))979 (registers (targetarchcase980 (:x8632 (error "no nvrs on x8632"))981 (:x8664982 (if (= (backendlispcontextregister *targetbackend*) x8664::save3)983 (list x8664::save0 x8664::save1 x8664::save2)984 (list x8664::save0 x8664::save1 x8664::save2 x8664::save3)))))985 (regno (pop registers) (pop registers))986 (constantalist ()))987 ((or (null things) (null regno))988 (dolist (cell fcells) (%rplacd cell nil))989 (dolist (cell vcells) (%rplacd cell nil))990 (values n constantalist))991 (declare (list things)992 (fixnum n regno))993 (let* ((thing (car things)))994 (if (or (memq thing fcells)995 (memq thing vcells))996 (push (cons thing regno) constantalist)997 (dolist (var (car thing))998 (nxsetvarbits var999 (%ilogior (%ilogand (%ilognot $vrefmask) (nxvarbits var))1000 regno1001 (%ilsl $vbitreg 1))))))))))1002 1003 1004 905 1005 906 ;;; Vpush the last N nonvolatileregisters. … … 1063 964 (x862setvarea seg arg (varea arg)) 1064 965 (let* ((lcell (pop lcells))) 1065 (if (setq reg ( x862assignregistervar arg))966 (if (setq reg (nx2assignregistervar arg)) 1066 967 (x862initregvar seg arg reg (x862vlocea vloc)) 1067 968 (x862bindvar seg arg vloc lcell)) … … 1071 972 (x862setvarea seg arg (varea arg)) 1072 973 (let* ((lcell (pop lcells))) 1073 (if (setq reg ( x862assignregistervar arg))974 (if (setq reg (nx2assignregistervar arg)) 1074 975 (x862initregvar seg arg reg (x862vlocea vloc)) 1075 976 (x862bindvar seg arg vloc lcell)) … … 1084 985 (x862setvarea seg var (varea var)) 1085 986 (let* ((lcell (pop lcells))) 1086 (if (setq reg ( x862assignregistervar var))987 (if (setq reg (nx2assignregistervar var)) 1087 988 (x862initregvar seg var reg (x862vlocea vloc)) 1088 989 (x862bindvar seg var vloc lcell)) … … 1092 993 (if lexpr 1093 994 (progn 1094 (if (setq reg ( x862assignregistervar rest))995 (if (setq reg (nx2assignregistervar rest)) 1095 996 (progn 1096 997 (x862copyregister seg reg *x862argz*) … … 1101 1002 (x862bindvar seg rest loc *x862topvstacklcell*)))) 1102 1003 (let* ((rvloc (+ vloc (* 2 *x862targetnodesize* nkeys)))) 1103 (if (setq reg ( x862assignregistervar rest))1004 (if (setq reg (nx2assignregistervar rest)) 1104 1005 (x862initregvar seg rest reg (x862vlocea rvloc)) 1105 1006 (x862bindvar seg rest rvloc (pop lcells)))))) … … 1116 1017 (lcell (pop lcells)) 1117 1018 (splcell (pop splcells)) 1118 (reg ( x862assignregistervar var))1019 (reg (nx2assignregistervar var)) 1119 1020 (regloadedlabel (if reg (backendgetnextlabel)))) 1120 1021 (unless (nxnull initform) … … 1132 1033 (x862bindvar seg var vloc lcell)) 1133 1034 (when spvar 1134 (if (setq reg ( x862assignregistervar spvar))1035 (if (setq reg (nx2assignregistervar spvar)) 1135 1036 (x862initregvar seg spvar reg (x862vlocea spvloc)) 1136 1037 (x862bindvar seg spvar spvloc splcell)))) … … 1144 1045 (let* ((spvar (pop keysupp)) 1145 1046 (initform (pop keyinits)) 1146 (reg ( x862assignregistervar var))1047 (reg (nx2assignregistervar var)) 1147 1048 (regloadedlabel (if reg (backendgetnextlabel))) 1148 1049 (varlcell (pop lcells)) … … 1163 1064 (x862bindvar seg var vloc varlcell)) 1164 1065 (when spvar 1165 (if (setq reg ( x862assignregistervar spvar))1066 (if (setq reg (nx2assignregistervar spvar)) 1166 1067 (x862initregvar seg spvar reg (x862vlocea sploc)) 1167 1068 (x862bindvar seg spvar sploc splcell)))) … … 1172 1073 (defun x862vpushargregister (seg reg var) 1173 1074 (when var 1174 (let* ((bits (nxvarbits var))) 1175 (declare (fixnum bits)) 1176 (if (logbitp $vbitreg bits) 1177 var 1178 (progn 1179 (x862vpushregister seg reg :reserved) 1180 nil))))) 1075 (if (varnvr var) 1076 var 1077 (progn 1078 (x862vpushregister seg reg :reserved) 1079 nil)))) 1181 1080 1182 1081 … … 1401 1300 (apply (svref *x862specials* (%ilogand operatoridmask op)) seg vreg xfer forms)) 1402 1301 1403 ;;; Returns true iff lexical variable VAR isn't setq'ed in FORM.1404 ;;; Punts a lot ...1405 (defun x862varnotsetbyformp (var form)1406 (let* ((bits (nxvarbits var)))1407 (or (not (%ilogbitp $vbitsetq bits))1408 (x862setqedvarnotsetbyformp var form (logbitp $vbitclosed bits)))))1409 1410 (defun x862setqedvarnotsetbyformp (var form &optional closed)1411 (setq form (acodeunwrappedform form))1412 (or (atom form)1413 (x86constantformp form)1414 (x862lexicalreferencep form)1415 (let ((op (acodeoperator form))1416 (subforms nil))1417 (if (eq op (%nx1operator setqlexical))1418 (and (neq var (cadr form))1419 (x862setqedvarnotsetbyformp var (caddr form)))1420 (and (or (not closed)1421 (logbitp operatorsideeffectfreebit op))1422 (flet ((notsetinformlist (formlist)1423 (dolist (subform formlist t)1424 (unless (x862setqedvarnotsetbyformp var subform closed) (return)))))1425 (if1426 (cond ((%ilogbitp operatoracodesubformsbit op) (setq subforms (%cdr form)))1427 ((%ilogbitp operatoracodelistbit op) (setq subforms (cadr form))))1428 (notsetinformlist subforms)1429 (and (or (eq op (%nx1operator call))1430 (eq op (%nx1operator lexicalfunctioncall)))1431 (x862setqedvarnotsetbyformp var (cadr form))1432 (setq subforms (caddr form))1433 (notsetinformlist (car subforms))1434 (notsetinformlist (cadr subforms))))))))))1435 1302 1436 1303 (defun x862checkfixnumoverflow (seg target &optional labelno) … … 1542 1409 (! setnargs n)))) 1543 1410 1544 (defun x862assignregistervar (v) 1545 (let ((bits (nxvarbits v))) 1546 (when (%ilogbitp $vbitreg bits) 1547 (%ilogand bits $vrefmask)))) 1411 1548 1412 1549 1413 (defun x862singlefloatbits (thesf) … … 2699 2563 (destructuringbind (fnform (stackargs regargs) &optional spreadp) (%cdr body) 2700 2564 (unless (and (eq spreadp t) 2701 (eq ( x862lexicalreferencep (%car regargs)) rest))2565 (eq (nx2lexicalreferencep (%car regargs)) rest)) 2702 2566 (return nil)) 2703 2567 (flet ((independentofallvalues (form) 2704 2568 (setq form (acodeunwrappedformvalue form)) 2705 2569 (or (x86constantformp form) 2706 (let* ((lexref ( x862lexicalreferencep form)))2570 (let* ((lexref (nx2lexicalreferencep form))) 2707 2571 (and lexref 2708 2572 (neq lexref rest) 2709 2573 (dolist (val restvalues t) 2710 (unless ( x862varnotsetbyformp lexref val)2574 (unless (nx2varnotsetbyformp lexref val) 2711 2575 (return)))))))) 2712 2576 (unless (or (eq op (%nx1operator lexicalfunctioncall)) … … 2729 2593 (setq body (%cadr body)) 2730 2594 (if (and (eq op (%nx1operator if)) 2731 (eq ( x862lexicalreferencep (%cadr body)) rest))2595 (eq (nx2lexicalreferencep (%cadr body)) rest)) 2732 2596 (setq body (%caddr body)) 2733 2597 (return nil))))))))) … … 2745 2609 (setq arglist (list nil (reverse stackargs))) 2746 2610 (setq arglist (list (butlast stackargs *x862targetnumargregs*) (reverse (last stackargs *x862targetnumargregs*))))))))) 2747 (let* ((lexref ( x862lexicalreferencep fn))2611 (let* ((lexref (nx2lexicalreferencep fn)) 2748 2612 (simplecase (or (fixnump fn) 2749 2613 (typep fn 'lreg) … … 2754 2618 (flet ((allsimple (args) 2755 2619 (dolist (arg args t) 2756 (when (and arg (not ( x862varnotsetbyformp lexref arg)))2620 (when (and arg (not (nx2varnotsetbyformp lexref arg))) 2757 2621 (return))))) 2758 2622 (and (allsimple (car arglist)) … … 3355 3219 (unless (typep breg 'lreg) 3356 3220 (warn "~s is not an lreg (2/2)" breg)) 3357 (let* ((avar ( x862lexicalreferencep aform))3221 (let* ((avar (nx2lexicalreferencep aform)) 3358 3222 (atriv (x862trivialp bform)) 3359 3223 (aconst (and (not atriv) (or (x86sideeffectfreeformp aform) 3360 (if avar ( x862varnotsetbyformp avar bform)))))3224 (if avar (nx2varnotsetbyformp avar bform))))) 3361 3225 apushed) 3362 3226 (progn … … 3375 3239 (defun x862twountargetedregforms (seg aform areg bform breg) 3376 3240 (withx86localvinsnmacros (seg) 3377 (let* ((avar ( x862lexicalreferencep aform))3241 (let* ((avar (nx2lexicalreferencep aform)) 3378 3242 (adest areg) 3379 3243 (bdest breg) 3380 3244 (atriv (x862trivialp bform)) 3381 3245 (aconst (and (not atriv) (or (x86sideeffectfreeformp aform) 3382 (if avar ( x862varnotsetbyformp avar bform)))))3246 (if avar (nx2varnotsetbyformp avar bform))))) 3383 3247 (apushed (not (or atriv aconst)))) 3384 3248 (progn … … 3409 3273 (aconst (and (not atriv) 3410 3274 (or (x86sideeffectfreeformp aform) 3411 (let ((avar ( x862lexicalreferencep aform)))3275 (let ((avar (nx2lexicalreferencep aform))) 3412 3276 (and avar 3413 ( x862varnotsetbyformp avar bform)3414 ( x862varnotsetbyformp avar cform))))))3277 (nx2varnotsetbyformp avar bform) 3278 (nx2varnotsetbyformp avar cform)))))) 3415 3279 (bconst (and (not btriv) 3416 3280 (or 3417 3281 (x86sideeffectfreeformp bform) 3418 (let ((bvar ( x862lexicalreferencep bform)))3419 (and bvar ( x862varnotsetbyformp bvar cform))))))3282 (let ((bvar (nx2lexicalreferencep bform))) 3283 (and bvar (nx2varnotsetbyformp bvar cform)))))) 3420 3284 (apushed nil) 3421 3285 (bpushed nil)) … … 3459 3323 (aconst (and (not atriv) 3460 3324 (or (x86sideeffectfreeformp aform) 3461 (let ((avar ( x862lexicalreferencep aform)))3325 (let ((avar (nx2lexicalreferencep aform))) 3462 3326 (and avar 3463 ( x862varnotsetbyformp avar bform)3464 ( x862varnotsetbyformp avar cform)3465 ( x862varnotsetbyformp avar dform))))))3327 (nx2varnotsetbyformp avar bform) 3328 (nx2varnotsetbyformp avar cform) 3329 (nx2varnotsetbyformp avar dform)))))) 3466 3330 (bconst (and (not btriv) 3467 3331 (or 3468 3332 (x86sideeffectfreeformp bform) 3469 (let ((bvar ( x862lexicalreferencep bform)))3333 (let ((bvar (nx2lexicalreferencep bform))) 3470 3334 (and bvar 3471 ( x862varnotsetbyformp bvar cform)3472 ( x862varnotsetbyformp bvar dform))))))3335 (nx2varnotsetbyformp bvar cform) 3336 (nx2varnotsetbyformp bvar dform)))))) 3473 3337 (cconst (and (not ctriv) 3474 3338 (or 3475 3339 (x86sideeffectfreeformp cform) 3476 (let ((cvar ( x862lexicalreferencep cform)))3477 (and cvar ( x862varnotsetbyformp cvar dform))))))3340 (let ((cvar (nx2lexicalreferencep cform))) 3341 (and cvar (nx2varnotsetbyformp cvar dform)))))) 3478 3342 (apushed nil) 3479 3343 (bpushed nil) … … 3515 3379 (aconst (and (not atriv) 3516 3380 (or (x86sideeffectfreeformp aform) 3517 (let ((avar ( x862lexicalreferencep aform)))3381 (let ((avar (nx2lexicalreferencep aform))) 3518 3382 (and avar 3519 ( x862varnotsetbyformp avar bform)3520 ( x862varnotsetbyformp avar cform))))))3383 (nx2varnotsetbyformp avar bform) 3384 (nx2varnotsetbyformp avar cform)))))) 3521 3385 (bconst (and (not btriv) 3522 3386 (or 3523 3387 (x86sideeffectfreeformp bform) 3524 (let ((bvar ( x862lexicalreferencep bform)))3525 (and bvar ( x862varnotsetbyformp bvar cform))))))3388 (let ((bvar (nx2lexicalreferencep bform))) 3389 (and bvar (nx2varnotsetbyformp bvar cform)))))) 3526 3390 (adest areg) 3527 3391 (bdest breg) … … 3560 3424 (aconst (and (not atriv) 3561 3425 (or (x86sideeffectfreeformp aform) 3562 (let ((avar ( x862lexicalreferencep aform)))3426 (let ((avar (nx2lexicalreferencep aform))) 3563 3427 (and avar 3564 ( x862varnotsetbyformp avar bform)3565 ( x862varnotsetbyformp avar cform)3566 ( x862varnotsetbyformp avar dform))))))3428 (nx2varnotsetbyformp avar bform) 3429 (nx2varnotsetbyformp avar cform) 3430 (nx2varnotsetbyformp avar dform)))))) 3567 3431 (bconst (and (not btriv) 3568 3432 (or 3569 3433 (x86sideeffectfreeformp bform) 3570 (let ((bvar ( x862lexicalreferencep bform)))3434 (let ((bvar (nx2lexicalreferencep bform))) 3571 3435 (and bvar 3572 ( x862varnotsetbyformp bvar cform)3573 ( x862varnotsetbyformp bvar dform))))))3436 (nx2varnotsetbyformp bvar cform) 3437 (nx2varnotsetbyformp bvar dform)))))) 3574 3438 (cconst (and (not ctriv) 3575 3439 (or 3576 3440 (x86sideeffectfreeformp cform) 3577 (let ((cvar ( x862lexicalreferencep cform)))3441 (let ((cvar (nx2lexicalreferencep cform))) 3578 3442 (and cvar 3579 ( x862varnotsetbyformp cvar dform))))))3443 (nx2varnotsetbyformp cvar dform)))))) 3580 3444 (adest areg) 3581 3445 (bdest breg) … … 4498 4362 (progn 4499 4363 (let* ((vloc *x862vstack*) 4500 (reg (let* ((r ( x862assignregistervar var)))4364 (reg (let* ((r (nx2assignregistervar var))) 4501 4365 (if r ($ r))))) 4502 4366 (if (x862loadeap val) … … 4963 4827 (%ilogand (%ilogior (%ilsl $vbitclosed 1) (%ilsl $vbitsetq 1)) bits))))))) 4964 4828 4965 (defun x862lexicalreferencep (form) 4966 (when (acodep form) 4967 (let ((op (acodeoperator (setq form (acodeunwrappedformvalue form))))) 4968 (when (or (eq op (%nx1operator lexicalreference)) 4969 (eq op (%nx1operator inheritedarg))) 4970 (%cadr form))))) 4829 4971 4830 4972 4831 (defun x862refsymbolvalue (seg vreg xfer sym checkboundp) … … 5485 5344 (defun x862bindstructuredvar (seg var vloc lcell &optional context) 5486 5345 (if (not (x862structuredvarp var)) 5487 (let* ((reg ( x862assignregistervar var)))5346 (let* ((reg (nx2assignregistervar var))) 5488 5347 (if reg 5489 5348 (x862initregvar seg var reg (x862vlocea vloc)) … … 6151 6010 (setq noregs (%ilogbitp $fbitnoregs fbits))) 6152 6011 (multiplevaluesetq (pregs reglocatives) 6153 (x862allocateglobalregisters *x862fcells* *x862vcells* (afuncallvars afunc) noregs)) 6012 (nx2allocateglobalregisters 6013 *x862fcells* 6014 *x862vcells* 6015 (afuncallvars afunc) 6016 inheritedvars 6017 (unless noregs 6018 (targetarchcase 6019 (:x8664 6020 (if (= (backendlispcontextregister *targetbackend*) x8664::save3) 6021 *reducedx8664nvrs* 6022 *x8664nvrs*)) 6023 (:x8632 6024 *x8632nvrs*))))) 6154 6025 (@ (backendgetnextlabel)) ; generic selfreference label, should be label #1 6155 6026 (! establishfn) … … 6318 6189 (let* ((var (car vars))) 6319 6190 (when var 6320 (let* ((reg ( x862assignregistervar var)))6191 (let* ((reg (nx2assignregistervar var))) 6321 6192 (x862copyregister seg reg argregnum) 6322 6193 (setf (varea var) reg)))))) … … 7790 7661 (dolist (var vars) 7791 7662 (let* ((lcell (pop lcells)) 7792 (reg ( x862assignregistervar var)))7663 (reg (nx2assignregistervar var))) 7793 7664 (if reg 7794 7665 (x862initregvar seg var reg (x862vlocea vloc)) … … 8361 8232 (setq val (%car valcopy)) 8362 8233 (cond ((or (%ilogbitp $vbitspecial (setq bits (nxvarbits var))) 8363 (and ( %ilogbitp $vbitreg bits)8234 (and (varnvr var) 8364 8235 (dolist (val (%cdr valcopy)) 8365 8236 (unless (x862trivialp val) (return t)))))
Note: See TracChangeset
for help on using the changeset viewer.