Changeset 12257
 Timestamp:
 Jun 12, 2009, 2:30:32 PM (10 years ago)
 File:

 1 edited
Legend:
 Unmodified
 Added
 Removed

branches/working0711/ccl/compiler/X86/x862.lisp
r12256 r12257 206 206 207 207 (defvar *x862resultreg* x8664::arg_z) 208 209 (defvar *x8664nvrs* 210 `(,x8664::save0 ,x8664::save1 ,x8664::save2 ,x8664::save3)) 211 212 (defvar *reducedx8664nvrs* 213 `(,x8664::save0 ,x8664::save1 ,x8664::save2)) 214 215 (defvar *x8632nvrs* ()) 216 208 217 209 218 (defvar *x862argz* nil) … … 870 879 (defun x862digestsymbols () 871 880 (when *x862recordedsymbols* 881 (setq *x862recordedsymbols* (nx2recordedsymbolsinarglistorder *x862recordedsymbols* *x862curafunc*)) 872 882 (let* ((symlist *x862recordedsymbols*) 873 883 (len (length symlist)) … … 898 908 *x862reckless* (neq 0 (%ilogand2 $decl_unsafe decls)) 899 909 *x862trustdeclarations* (neq 0 (%ilogand2 $decl_trustdecls decls)))))) 900 901 902 (defun %x862biggercdrthan (x y)903 (declare (cons x y))904 (> (the fixnum (cdr x)) (the fixnum (cdr y))))905 906 ;;; Return an unordered list of "varsets": each var in a varset can be907 ;;; assigned a register and all vars in a varset can be assigned the908 ;;; same register (e.g., no scope conflicts.)909 910 (defun x862partitionvars (vars)911 (labels ((varweight (var)912 (let* ((bits (nxvarbits var)))913 (declare (fixnum bits))914 (if (eql 0 (logand bits (logior915 (ash 1 $vbitpuntable)916 (ash 1 $vbitspecial)917 (ash 1 $vbitnoreg))))918 (if (eql (logior (ash 1 $vbitclosed) (ash 1 $vbitsetq))919 (logand bits (logior (ash 1 $vbitclosed) (ash 1 $vbitsetq))))920 0921 (%i+ (%ilogand $vrefmask bits) (%ilsr 8 (%ilogand $vsetqmask bits))))922 0)))923 (sumweights (varlist)924 (let ((sum 0))925 (dolist (v varlist sum) (incf sum (varweight v)))))926 (varsdisjointp (v1 v2)927 (if (eq v1 v2)928 nil929 (if (memq v1 (varbindinginfo v2))930 nil931 (if (memq v2 (varbindinginfo v1))932 nil933 t)))))934 (setq vars (%sortlistnokey935 ;(deleteif #'(lambda (v) (eql (varweight v) 0)) vars)936 (do* ((handle (cons nil vars))937 (splice handle))938 ((null (cdr splice)) (cdr handle))939 (declare (dynamicextent handle) (type cons handle splice))940 (if (eql 0 (varweight (%car (cdr splice))))941 (rplacd splice (%cdr (cdr splice)))942 (setq splice (cdr splice))))943 #'(lambda (v1 v2) (%i> (varweight v1) (varweight v2)))))944 ;; This isn't optimal. It partitions all registerallocatable945 ;; variables into sets such that946 ;; 1) no variable is a member of more than one set and947 ;; 2) all variables in a given set are disjoint from each other948 ;; A set might have exactly one member.949 ;; If a register is allocated for any member of a set, it's950 ;; allocated for all members of that set.951 (let* ((varsets nil))952 (do* ((all vars (cdr all)))953 ((null all))954 (let* ((var (car all)))955 (when (dolist (already varsets t)956 (when (memq var (car already)) (return)))957 (let* ((varset (cons var nil)))958 (dolist (v (cdr all))959 (when (dolist (already varsets t)960 (when (memq v (car already)) (return)))961 (when (dolist (d varset t)962 (unless (varsdisjointp v d) (return)))963 (push v varset))))964 (let* ((weight (sumweights varset)))965 (declare (fixnum weight))966 (if (>= weight 3)967 (push (cons (nreverse varset) weight) varsets)))))))968 varsets)))969 970 ;;; Maybe globally allocate registers to symbols naming functions & variables,971 ;;; and to simple lexical variables.972 (defun x862allocateglobalregisters (fcells vcells allvars noregs)973 (if (or noregs (targetarchcase (:x8632 t)))974 (progn975 (dolist (c fcells) (%rplacd c nil))976 (dolist (c vcells) (%rplacd c nil))977 (values 0 nil))978 (let* ((maybe (x862partitionvars allvars)))979 (dolist (c fcells)980 (if (>= (the fixnum (cdr c)) 3) (push c maybe)))981 (dolist (c vcells)982 (if (>= (the fixnum (cdr c)) 3) (push c maybe)))983 (do* ((things (%sortlistnokey maybe #'%x862biggercdrthan) (cdr things))984 (n 0 (1+ n))985 (registers (targetarchcase986 (:x8632 (error "no nvrs on x8632"))987 (:x8664988 (if (= (backendlispcontextregister *targetbackend*) x8664::save3)989 (list x8664::save0 x8664::save1 x8664::save2)990 (list x8664::save0 x8664::save1 x8664::save2 x8664::save3)))))991 (regno (pop registers) (pop registers))992 (constantalist ()))993 ((or (null things) (null regno))994 (dolist (cell fcells) (%rplacd cell nil))995 (dolist (cell vcells) (%rplacd cell nil))996 (values n constantalist))997 (declare (list things)998 (fixnum n #regno#))999 (let* ((thing (car things)))1000 (if (or (memq thing fcells)1001 (memq thing vcells))1002 (push (cons thing regno) constantalist)1003 (dolist (var (car thing))1004 (nxsetvarbits var1005 (%ilogior (%ilogand (%ilognot $vrefmask) (nxvarbits var))1006 regno1007 (%ilsl $vbitreg 1))))))))))1008 910 1009 911 … … 1069 971 (x862setvarea seg arg (varea arg)) 1070 972 (let* ((lcell (pop lcells))) 1071 (if (setq reg ( x862assignregistervar arg))973 (if (setq reg (nx2assignregistervar arg)) 1072 974 (x862initregvar seg arg reg (x862vlocea vloc)) 1073 975 (x862bindvar seg arg vloc lcell)) … … 1077 979 (x862setvarea seg arg (varea arg)) 1078 980 (let* ((lcell (pop lcells))) 1079 (if (setq reg ( x862assignregistervar arg))981 (if (setq reg (nx2assignregistervar arg)) 1080 982 (x862initregvar seg arg reg (x862vlocea vloc)) 1081 983 (x862bindvar seg arg vloc lcell)) … … 1090 992 (x862setvarea seg var (varea var)) 1091 993 (let* ((lcell (pop lcells))) 1092 (if (setq reg ( x862assignregistervar var))994 (if (setq reg (nx2assignregistervar var)) 1093 995 (x862initregvar seg var reg (x862vlocea vloc)) 1094 996 (x862bindvar seg var vloc lcell)) … … 1098 1000 (if lexpr 1099 1001 (progn 1100 (if (setq reg ( x862assignregistervar rest))1002 (if (setq reg (nx2assignregistervar rest)) 1101 1003 (progn 1102 1004 (x862copyregister seg reg *x862argz*) … … 1107 1009 (x862bindvar seg rest loc *x862topvstacklcell*)))) 1108 1010 (let* ((rvloc (+ vloc (* 2 *x862targetnodesize* nkeys)))) 1109 (if (setq reg ( x862assignregistervar rest))1011 (if (setq reg (nx2assignregistervar rest)) 1110 1012 (x862initregvar seg rest reg (x862vlocea rvloc)) 1111 1013 (x862bindvar seg rest rvloc (pop lcells)))))) … … 1122 1024 (lcell (pop lcells)) 1123 1025 (splcell (pop splcells)) 1124 (reg ( x862assignregistervar var))1026 (reg (nx2assignregistervar var)) 1125 1027 (regloadedlabel (if reg (backendgetnextlabel)))) 1126 1028 (unless (nxnull initform) … … 1138 1040 (x862bindvar seg var vloc lcell)) 1139 1041 (when spvar 1140 (if (setq reg ( x862assignregistervar spvar))1042 (if (setq reg (nx2assignregistervar spvar)) 1141 1043 (x862initregvar seg spvar reg (x862vlocea spvloc)) 1142 1044 (x862bindvar seg spvar spvloc splcell)))) … … 1150 1052 (let* ((spvar (pop keysupp)) 1151 1053 (initform (pop keyinits)) 1152 (reg ( x862assignregistervar var))1054 (reg (nx2assignregistervar var)) 1153 1055 (regloadedlabel (if reg (backendgetnextlabel))) 1154 1056 (varlcell (pop lcells)) … … 1169 1071 (x862bindvar seg var vloc varlcell)) 1170 1072 (when spvar 1171 (if (setq reg ( x862assignregistervar spvar))1073 (if (setq reg (nx2assignregistervar spvar)) 1172 1074 (x862initregvar seg spvar reg (x862vlocea sploc)) 1173 1075 (x862bindvar seg spvar sploc splcell)))) … … 1178 1080 (defun x862vpushargregister (seg reg var) 1179 1081 (when var 1180 (let* ((bits (nxvarbits var))) 1181 (declare (fixnum bits)) 1182 (if (logbitp $vbitreg bits) 1183 var 1184 (progn 1185 (x862vpushregister seg reg :reserved) 1186 nil))))) 1082 (if (varnvr var) 1083 var 1084 (progn 1085 (x862vpushregister seg reg :reserved) 1086 nil)))) 1187 1087 1188 1088 … … 1327 1227 n)) 1328 1228 1229 1230 (defun x862acodeoperatorfunction (form) 1231 (or (and (acodep form) 1232 (svref *x862specials* (%ilogand #.operatoridmask (acodeoperator form)))) 1233 (compilerbug "x862form ? ~s" form))) 1234 1329 1235 (defun x862form (seg vreg xfer form &aux (note (acodenote form))) 1330 1236 (flet ((main (seg vreg xfer form) … … 1333 1239 (if (nxt form) 1334 1240 (x862t seg vreg xfer) 1335 (let* ((op nil) 1336 (fn nil)) 1337 (if (and (consp form) 1338 (setq fn (svref *x862specials* (%ilogand #.operatoridmask (setq op (acodeoperator form)))))) 1339 (if (and (null vreg) 1340 (%ilogbitp operatoracodesubformsbit op) 1341 (%ilogbitp operatorassignmentfreebit op)) 1342 (dolist (f (%cdr form) (x862branch seg xfer)) 1343 (x862form seg nil nil f )) 1344 (apply fn seg vreg xfer (%cdr form))) 1345 (compilerbug "x862form ? ~s" form))))))) 1241 (let* ((fn (x862acodeoperatorfunction form)) ;; also typechecks 1242 (op (acodeoperator form))) 1243 (if (and (null vreg) 1244 (%ilogbitp operatoracodesubformsbit op) 1245 (%ilogbitp operatorassignmentfreebit op)) 1246 (dolist (f (%cdr form) (x862branch seg xfer)) 1247 (x862form seg nil nil f )) 1248 (apply fn seg vreg xfer (%cdr form)))))))) 1346 1249 (if note 1347 1250 (let* ((start (x862emitnote seg :sourcelocationbegin note)) … … 1362 1265 ;; kind of screwy  encoding the source type in the dest register spec 1363 1266 (setnoderegspectypemodes freg hardregclassfprtypedouble)) 1364 (let* ((fn nil)) 1365 (if (and (consp form) 1366 (setq fn (svref *x862specials* (%ilogand #.operatoridmask (acodeoperator form))))) 1367 (apply fn seg freg nil (%cdr form)) 1368 (compilerbug "x862form ? ~s" form)))) 1369 1267 (let* ((fn (x862acodeoperatorfunction form))) 1268 (apply fn seg freg nil (%cdr form)))) 1370 1269 1371 1270 … … 1381 1280 (apply (svref *x862specials* (%ilogand operatoridmask op)) seg vreg xfer forms)) 1382 1281 1383 ;;; Returns true iff lexical variable VAR isn't setq'ed in FORM.1384 ;;; Punts a lot ...1385 (defun x862varnotsetbyformp (var form)1386 (or (not (%ilogbitp $vbitsetq (nxvarbits var)))1387 (x862setqedvarnotsetbyformp var form)))1388 1389 (defun x862setqedvarnotsetbyformp (var form)1390 (setq form (acodeunwrappedform form))1391 (or (atom form)1392 (x86constantformp form)1393 (x862lexicalreferencep form)1394 (let ((op (acodeoperator form))1395 (subforms nil))1396 (if (eq op (%nx1operator setqlexical))1397 (and (neq var (cadr form))1398 (x862setqedvarnotsetbyformp var (caddr form)))1399 (and (%ilogbitp operatorsideeffectfreebit op)1400 (flet ((notsetinformlist (formlist)1401 (dolist (subform formlist t)1402 (unless (x862setqedvarnotsetbyformp var subform) (return)))))1403 (if1404 (cond ((%ilogbitp operatoracodesubformsbit op) (setq subforms (%cdr form)))1405 ((%ilogbitp operatoracodelistbit op) (setq subforms (cadr form))))1406 (notsetinformlist subforms)1407 (and (or (eq op (%nx1operator call))1408 (eq op (%nx1operator lexicalfunctioncall)))1409 (x862setqedvarnotsetbyformp var (cadr form))1410 (setq subforms (caddr form))1411 (notsetinformlist (car subforms))1412 (notsetinformlist (cadr subforms))))))))))1413 1282 1414 1283 (defun x862checkfixnumoverflow (seg target &optional labelno) … … 1520 1389 (! setnargs n)))) 1521 1390 1522 (defun x862assignregistervar (v) 1523 (let ((bits (nxvarbits v))) 1524 (when (%ilogbitp $vbitreg bits) 1525 (%ilogand bits $vrefmask)))) 1391 1526 1392 1527 1393 (defun x862singlefloatbits (thesf) … … 1729 1595 (vregclass (and (not (eq vreg :push)) (hardregspecclass vreg))) 1730 1596 (vregmode 1731 (if (eql vregclass hardregclassgpr) 1597 (if (or (eql vregclass hardregclassgpr) 1598 (eql vregclass hardregclassfpr)) 1732 1599 (getregspecmode vreg) 1733 1600 hardregclassgprmodeinvalid))) … … 1741 1608 (if (and indexknownfixnum (<= indexknownfixnum (arch::targetmax64bitconstantindex arch))) 1742 1609 (! miscrefcnode target src indexknownfixnum) 1743 (! miscrefnode target src unscaledidx))))) 1610 (if unscaledidx 1611 (! miscrefnode target src unscaledidx) 1612 (withnodetarget (src) unscaledidx 1613 (x862absolutenatural seg unscaledidx nil (ash indexknownfixnum *x862targetfixnumshift*)) 1614 (! miscrefnode target src unscaledidx))))))) 1744 1615 (is32bit 1745 1616 (if (and indexknownfixnum (<= indexknownfixnum (arch::targetmax32bitconstantindex arch))) … … 1774 1645 (withimmtarget () idxreg 1775 1646 (if indexknownfixnum 1776 (x862absolutenatural seg idxreg nil ( + (arch::targetmiscdataoffset arch) (ash indexknownfixnum 2)))1647 (x862absolutenatural seg idxreg nil (ash indexknownfixnum 2)) 1777 1648 (! scale32bitmiscindex idxreg unscaledidx)) 1778 1649 (cond ((eq typekeyword :singlefloatvector) … … 1841 1712 ;; Down to the dregs. 1842 1713 (is64bit 1714 (withnodetarget (src) extra 1715 (unless unscaledidx (setq unscaledidx extra))) 1843 1716 (case typekeyword 1844 1717 (:doublefloatvector … … 2644 2517 value resultreg))) 2645 2518 (:x8664 2646 (x862threetargetedregforms seg 2647 vector src 2648 index unscaledidx 2649 value resultreg))))) 2519 (multiplevaluesetq (src unscaledidx resultreg) 2520 (x862threeuntargetedregforms seg 2521 vector src 2522 index unscaledidx 2523 value resultreg)))))) 2650 2524 (when safe 2651 2525 (let* ((*availablebackendimmtemps* *availablebackendimmtemps*) … … 2693 2567 (destructuringbind (fnform (stackargs regargs) &optional spreadp) (%cdr body) 2694 2568 (unless (and (eq spreadp t) 2695 (eq ( x862lexicalreferencep (%car regargs)) rest))2569 (eq (nx2lexicalreferencep (%car regargs)) rest)) 2696 2570 (return nil)) 2697 2571 (flet ((independentofallvalues (form) 2698 2572 (setq form (acodeunwrappedformvalue form)) 2699 2573 (or (x86constantformp form) 2700 (let* ((lexref ( x862lexicalreferencep form)))2574 (let* ((lexref (nx2lexicalreferencep form))) 2701 2575 (and lexref 2702 2576 (neq lexref rest) 2703 2577 (dolist (val restvalues t) 2704 (unless ( x862varnotsetbyformp lexref val)2578 (unless (nx2varnotsetbyformp lexref val) 2705 2579 (return)))))))) 2706 2580 (unless (or (eq op (%nx1operator lexicalfunctioncall)) … … 2723 2597 (setq body (%cadr body)) 2724 2598 (if (and (eq op (%nx1operator if)) 2725 (eq ( x862lexicalreferencep (%cadr body)) rest))2599 (eq (nx2lexicalreferencep (%cadr body)) rest)) 2726 2600 (setq body (%caddr body)) 2727 2601 (return nil))))))))) … … 2739 2613 (setq arglist (list nil (reverse stackargs))) 2740 2614 (setq arglist (list (butlast stackargs *x862targetnumargregs*) (reverse (last stackargs *x862targetnumargregs*))))))))) 2741 (let* ((lexref ( x862lexicalreferencep fn))2615 (let* ((lexref (nx2lexicalreferencep fn)) 2742 2616 (simplecase (or (fixnump fn) 2743 2617 (typep fn 'lreg) … … 2748 2622 (flet ((allsimple (args) 2749 2623 (dolist (arg args t) 2750 (when (and arg (not ( x862varnotsetbyformp lexref arg)))2624 (when (and arg (not (nx2varnotsetbyformp lexref arg))) 2751 2625 (return))))) 2752 2626 (and (allsimple (car arglist)) … … 3228 3102 3229 3103 3104 3105 3230 3106 (defun x862pushregister (seg areg) 3231 3107 (let* ((afloat (= (hardregspecclass areg) hardregclassfpr)) … … 3240 3116 (:x8632 3241 3117 (setq vinsn (! temppushsinglefloat areg)) 3242 (incf *x862cstack* *x862targetdnodesize*))3118 (x862openundo $undox86cframe)) 3243 3119 (:x8664 3244 3120 (setq vinsn (! vpushsinglefloat areg)) … … 3250 3126 (progn 3251 3127 (setq vinsn (! temppushdoublefloat areg)) 3252 (incf *x862cstack* 16))3128 (x862openundo $undox86cframe)) 3253 3129 (progn 3254 3130 (setq vinsn (! temppushunboxedword areg)) 3255 ( incf *x862cstack* *x862targetdnodesize*))))3131 (x862openundo $undox86cframe)))) 3256 3132 (:x8664 3257 3133 (setq vinsn … … 3259 3135 (! temppushdoublefloat areg) 3260 3136 (! temppushunboxedword areg))) 3261 ( setq *x862cstack* (+ *x862cstack* 16))))))3137 (x862openundo $undox86cframe))))) 3262 3138 vinsn))) 3139 3140 3263 3141 3264 3142 (defun x862popregister (seg areg) … … 3274 3152 (:x8632 3275 3153 (setq vinsn (! temppopsinglefloat areg)) 3276 (decf *x862cstack* *x862targetdnodesize*))3154 (x862closeundo)) 3277 3155 (:x8664 3278 3156 (setq vinsn (! vpopsinglefloat areg)) … … 3284 3162 (progn 3285 3163 (setq vinsn (! temppopdoublefloat areg)) 3286 ( decf *x862cstack* 16))3164 (x862closeundo)) 3287 3165 (progn 3288 3166 (setq vinsn (! temppopunboxedword areg)) 3289 ( decf *x862cstack* *x862targetdnodesize*))))3167 (x862closeundo)))) 3290 3168 (:x8664 3291 3169 (setq vinsn … … 3293 3171 (! temppopdoublefloat areg) 3294 3172 (! temppopunboxedword areg))) 3295 ( setq *x862cstack* ( *x862cstack* 16))))))3173 (x862closeundo))))) 3296 3174 vinsn))) 3297 3175 3176 ;;; If reg is a GPR and of mode node, use arg_z, otherwise, just return 3177 ;;; reg. 3298 3178 (defun x862accregfor (reg) 3299 3179 (withx86localvinsnmacros (seg) 3300 (let* ((class (hardregspecclass reg)) 3301 (mode (getregspecmode reg))) 3302 (declare (fixnum class mode)) 3303 (cond ((= class hardregclassfpr) 3304 (makewiredlreg *x862fp1* :class class :mode mode)) 3305 ((= class hardregclassgpr) 3306 (if (= mode hardregclassgprmodenode) 3307 ($ *x862argz*) 3308 (makewiredlreg *x862imm0* :mode mode))) 3309 (t (compilerbug "Unknown register class for reg ~s" reg)))))) 3180 (if (and (eql (hardregspecclass reg) hardregclassgpr) 3181 (eql (getregspecmode reg) hardregclassgprmodenode)) 3182 ($ *x862argz*) 3183 reg))) 3310 3184 3311 3185 ;;; The compiler often generates superfluous pushes & pops. Try to … … 3346 3220 ;;; would vpop the first argument out of line.) 3347 3221 (defun x862twotargetedregforms (seg aform areg bform breg) 3348 (let* ((avar ( x862lexicalreferencep aform))3222 (let* ((avar (nx2lexicalreferencep aform)) 3349 3223 (atriv (and (x862trivialp bform) (nx2nodegprp breg))) 3350 3224 (aconst (and (not atriv) (or (x86sideeffectfreeformp aform) 3351 (if avar ( x862varnotsetbyformp avar bform)))))3225 (if avar (nx2varnotsetbyformp avar bform))))) 3352 3226 apushed) 3353 3227 (progn … … 3366 3240 (defun x862twountargetedregforms (seg aform areg bform breg) 3367 3241 (withx86localvinsnmacros (seg) 3368 (let* ((avar ( x862lexicalreferencep aform))3242 (let* ((avar (nx2lexicalreferencep aform)) 3369 3243 (adest areg) 3370 3244 (bdest breg) 3371 3245 (atriv (and (x862trivialp bform) (nx2nodegprp breg))) 3372 3246 (aconst (and (not atriv) (or (x86sideeffectfreeformp aform) 3373 (if avar ( x862varnotsetbyformp avar bform)))))3247 (if avar (nx2varnotsetbyformp avar bform))))) 3374 3248 (apushed (not (or atriv aconst)))) 3375 3249 (progn … … 3399 3273 (aconst (and (not atriv) 3400 3274 (or (x86sideeffectfreeformp aform) 3401 (let ((avar ( x862lexicalreferencep aform)))3275 (let ((avar (nx2lexicalreferencep aform))) 3402 3276 (and avar 3403 ( x862varnotsetbyformp avar bform)3404 ( x862varnotsetbyformp avar cform))))))3277 (nx2varnotsetbyformp avar bform) 3278 (nx2varnotsetbyformp avar cform)))))) 3405 3279 (bconst (and (not btriv) 3406 3280 (or 3407 3281 (x86sideeffectfreeformp bform) 3408 (let ((bvar ( x862lexicalreferencep bform)))3409 (and bvar ( x862varnotsetbyformp bvar cform))))))3282 (let ((bvar (nx2lexicalreferencep bform))) 3283 (and bvar (nx2varnotsetbyformp bvar cform)))))) 3410 3284 (apushed nil) 3411 3285 (bpushed nil)) … … 3450 3324 (aconst (and (not atriv) 3451 3325 (or (x86sideeffectfreeformp aform) 3452 (let ((avar ( x862lexicalreferencep aform)))3326 (let ((avar (nx2lexicalreferencep aform))) 3453 3327 (and avar 3454 ( x862varnotsetbyformp avar bform)3455 ( x862varnotsetbyformp avar cform)3456 ( x862varnotsetbyformp avar dform))))))3328 (nx2varnotsetbyformp avar bform) 3329 (nx2varnotsetbyformp avar cform) 3330 (nx2varnotsetbyformp avar dform)))))) 3457 3331 (bconst (and (not btriv) 3458 3332 (or 3459 3333 (x86sideeffectfreeformp bform) 3460 (let ((bvar ( x862lexicalreferencep bform)))3334 (let ((bvar (nx2lexicalreferencep bform))) 3461 3335 (and bvar 3462 ( x862varnotsetbyformp bvar cform)3463 ( x862varnotsetbyformp bvar dform))))))3336 (nx2varnotsetbyformp bvar cform) 3337 (nx2varnotsetbyformp bvar dform)))))) 3464 3338 (cconst (and (not ctriv) 3465 3339 (or 3466 3340 (x86sideeffectfreeformp cform) 3467 (let ((cvar ( x862lexicalreferencep cform)))3468 (and cvar ( x862varnotsetbyformp cvar dform))))))3341 (let ((cvar (nx2lexicalreferencep cform))) 3342 (and cvar (nx2varnotsetbyformp cvar dform)))))) 3469 3343 (apushed nil) 3470 3344 (bpushed nil) … … 3511 3385 (aconst (and (not atriv) 3512 3386 (or (x86sideeffectfreeformp aform) 3513 (let ((avar ( x862lexicalreferencep aform)))3387 (let ((avar (nx2lexicalreferencep aform))) 3514 3388 (and avar 3515 ( x862varnotsetbyformp avar bform)3516 ( x862varnotsetbyformp avar cform))))))3389 (nx2varnotsetbyformp avar bform) 3390 (nx2varnotsetbyformp avar cform)))))) 3517 3391 (bconst (and (not btriv) 3518 3392 (or 3519 3393 (x86sideeffectfreeformp bform) 3520 (let ((bvar ( x862lexicalreferencep bform)))3521 (and bvar ( x862varnotsetbyformp bvar cform))))))3394 (let ((bvar (nx2lexicalreferencep bform))) 3395 (and bvar (nx2varnotsetbyformp bvar cform)))))) 3522 3396 (adest areg) 3523 3397 (bdest breg) … … 3564 3438 (aconst (and (not atriv) 3565 3439 (or (x86sideeffectfreeformp aform) 3566 (let ((avar ( x862lexicalreferencep aform)))3440 (let ((avar (nx2lexicalreferencep aform))) 3567 3441 (and avar 3568 ( x862varnotsetbyformp avar bform)3569 ( x862varnotsetbyformp avar cform)3570 ( x862varnotsetbyformp avar dform))))))3442 (nx2varnotsetbyformp avar bform) 3443 (nx2varnotsetbyformp avar cform) 3444 (nx2varnotsetbyformp avar dform)))))) 3571 3445 (bconst (and (not btriv) 3572 3446 (or 3573 3447 (x86sideeffectfreeformp bform) 3574 (let ((bvar ( x862lexicalreferencep bform)))3448 (let ((bvar (nx2lexicalreferencep bform))) 3575 3449 (and bvar 3576 ( x862varnotsetbyformp bvar cform)3577 ( x862varnotsetbyformp bvar dform))))))3450 (nx2varnotsetbyformp bvar cform) 3451 (nx2varnotsetbyformp bvar dform)))))) 3578 3452 (cconst (and (not ctriv) 3579 3453 (or 3580 3454 (x86sideeffectfreeformp cform) 3581 (let ((cvar ( x862lexicalreferencep cform)))3455 (let ((cvar (nx2lexicalreferencep cform))) 3582 3456 (and cvar 3583 ( x862varnotsetbyformp cvar dform))))))3457 (nx2varnotsetbyformp cvar dform)))))) 3584 3458 (adest areg) 3585 3459 (bdest breg) … … 3765 3639 (! compareu31constant reg (if ju31 jconstant iconstant)) 3766 3640 (unless (or ju31 (eq crbit x86::x86ebits)) 3767 (setq crbit (x862reversecrbit crbit))) 3641 (setq crbit (x862reversecrbit crbit))) 3642 (setq crbit (x862crbitforunsignedcomparison crbit)) 3768 3643 (^ crbit truep)) 3769 (withimmtarget () (ireg :natural) 3770 (withadditionalimmreg () 3771 (withimmtarget 3772 (ireg) (jreg :natural) 3773 (x862twotargetedregforms seg i ireg j jreg) 3774 (x862comparenaturalregisters seg vreg xfer ireg jreg crbit truep)))))))) 3775 3776 3777 (defun x862crbitforlogicalcomparison (crbit truep) 3778 (declare (fixnum crbit)) 3779 (let* ((unsigned 3780 (case crbit 3781 (#.x86::x86lbits x86::x86bbits) 3782 (#.x86::x86lebits x86::x86bebits ) 3783 (#.x86::x86gbits x86::x86abits) 3784 (#.x86::x86gebits x86::x86aebits) 3785 (t crbit)))) 3786 (declare (fixnum unsigned)) 3787 (if truep 3788 unsigned 3789 (logxor unsigned 1)))) 3644 (targetarchcase 3645 (:x8664 3646 (withimmtarget () (ireg :natural) 3647 (withimmtarget (ireg) (jreg :natural) 3648 (x862twotargetedregforms seg i ireg j jreg) 3649 (x862comparenaturalregisters seg vreg xfer ireg jreg crbit truep)))) 3650 (:x8632 3651 (withimmtarget () (jreg :natural) 3652 (x862onetargetedregform seg i jreg) 3653 (x862pushregister seg jreg) 3654 (x862onetargetedregform seg j jreg) 3655 (! temppoptemp1asunboxedword) 3656 (x862closeundo) 3657 (x862comparenaturalregisters seg vreg xfer ($ x8632::temp1) jreg crbit truep)))))))) 3658 3659 3660 3790 3661 3791 3662 (defun x862comparenaturalregisters (seg vreg xfer ireg jreg crbit truep) … … 3793 3664 (if vreg 3794 3665 (progn 3795 (setq crbit (x862crbitfor logicalcomparison crbit truep))3666 (setq crbit (x862crbitforunsignedcomparison crbit)) 3796 3667 (! compare ireg jreg) 3668 (targetarchcase 3669 (:x8664) 3670 (:x8632 (! marktemp1asnodepreservingflags))) 3797 3671 (regspeccrfgprcase 3798 3672 (vreg dest) … … 3800 3674 (progn 3801 3675 (ensuringnodetarget (target dest) 3676 (if (not truep) 3677 (setq crbit (logxor 1 crbit))) 3802 3678 (! crbit>boolean target crbit)) 3803 3679 (^)))) … … 4532 4408 (progn 4533 4409 (let* ((vloc *x862vstack*) 4534 (reg (let* ((r ( x862assignregistervar var)))4410 (reg (let* ((r (nx2assignregistervar var))) 4535 4411 (if r ($ r))))) 4536 4412 (if (x862loadeap val) … … 4997 4873 (%ilogand (%ilogior (%ilsl $vbitclosed 1) (%ilsl $vbitsetq 1)) bits))))))) 4998 4874 4999 (defun x862lexicalreferencep (form) 5000 (when (acodep form) 5001 (let ((op (acodeoperator (setq form (acodeunwrappedformvalue form))))) 5002 (when (or (eq op (%nx1operator lexicalreference)) 5003 (eq op (%nx1operator inheritedarg))) 5004 (%cadr form))))) 4875 5005 4876 5006 4877 (defun x862refsymbolvalue (seg vreg xfer sym checkboundp) … … 5518 5389 (defun x862bindstructuredvar (seg var vloc lcell &optional context) 5519 5390 (if (not (x862structuredvarp var)) 5520 (let* ((reg ( x862assignregistervar var)))5391 (let* ((reg (nx2assignregistervar var))) 5521 5392 (if reg 5522 5393 (x862initregvar seg var reg (x862vlocea vloc)) … … 6184 6055 (setq noregs (%ilogbitp $fbitnoregs fbits))) 6185 6056 (multiplevaluesetq (pregs reglocatives) 6186 (x862allocateglobalregisters *x862fcells* *x862vcells* (afuncallvars afunc) noregs)) 6057 (nx2allocateglobalregisters 6058 *x862fcells* 6059 *x862vcells* 6060 (afuncallvars afunc) 6061 inheritedvars 6062 (unless noregs 6063 (targetarchcase 6064 (:x8664 6065 (if (= (backendlispcontextregister *targetbackend*) x8664::save3) 6066 *reducedx8664nvrs* 6067 *x8664nvrs*)) 6068 (:x8632 6069 *x8632nvrs*))))) 6187 6070 (@ (backendgetnextlabel)) ; generic selfreference label, should be label #1 6188 6071 (! establishfn) … … 6350 6233 (let* ((var (car vars))) 6351 6234 (when var 6352 (let* ((reg ( x862assignregistervar var)))6235 (let* ((reg (nx2assignregistervar var))) 6353 6236 (x862copyregister seg reg argregnum) 6354 6237 (setf (varea var) reg)))))) … … 7607 7490 (keyword (if (and atype 7608 7491 (let* ((dims (arrayctypedimensions atype))) 7609 (and (not (atom dims)) 7610 (= (length dims) 1))) 7492 (or (eq dims '*) 7493 (and (not (atom dims)) 7494 (= (length dims) 1)))) 7611 7495 (not (arrayctypecomplexp atype))) 7612 7496 (funcall … … 7624 7508 (keyword (if (and atype 7625 7509 (let* ((dims (arrayctypedimensions atype))) 7626 (and (not (atom dims)) 7627 (= (length dims) 1))) 7510 (or (eq dims '*) 7511 (and (not (atom dims)) 7512 (= (length dims) 1)))) 7628 7513 (not (arrayctypecomplexp atype))) 7629 7514 (funcall … … 7830 7715 (dolist (var vars) 7831 7716 (let* ((lcell (pop lcells)) 7832 (reg ( x862assignregistervar var)))7717 (reg (nx2assignregistervar var))) 7833 7718 (if reg 7834 7719 (x862initregvar seg var reg (x862vlocea vloc)) … … 8401 8286 (setq val (%car valcopy)) 8402 8287 (cond ((or (%ilogbitp $vbitspecial (setq bits (nxvarbits var))) 8403 (and ( %ilogbitp $vbitreg bits)8288 (and (varnvr var) 8404 8289 (dolist (val (%cdr valcopy)) 8405 8290 (unless (x862trivialp val) (return t))))) … … 8675 8560 (ctype (if atype0 (specifiertype atype0))) 8676 8561 (atype (if (arrayctypep ctype) ctype)) 8562 (dims (and atype (arrayctypedimensions atype))) 8677 8563 (keyword (and atype 8678 (let* ((dims (arrayctypedimensions atype)))8679 8680 8564 (or (eq dims '*) 8565 (and (typep dims 'list) 8566 (= 2 (length dims)))) 8681 8567 (not (arrayctypecomplexp atype)) 8682 8568 (funcall … … 8685 8571 atype)))) 8686 8572 (cond (keyword 8687 (let* ((dims (arrayctypedimensions atype)) 8688 (dim0 (car dims)) 8573 (when (eq dims '*) 8574 (setq dims nil)) 8575 (let* ((dim0 (car dims)) 8689 8576 (dim1 (cadr dims))) 8690 8577 (x862aref2 seg … … 8730 8617 (ctype (if atype0 (specifiertype atype0))) 8731 8618 (atype (if (arrayctypep ctype) ctype)) 8619 (dims (and atype (arrayctypedimensions atype))) 8732 8620 (keyword (and atype 8733 (let* ((dims (arrayctypedimensions atype)))8734 8735 8621 (or (eq dims '*) 8622 (and (typep dims 'list) 8623 (= 3 (length dims)))) 8736 8624 (not (arrayctypecomplexp atype)) 8737 8625 (funcall … … 8740 8628 atype)))) 8741 8629 (cond (keyword 8742 (let* ((dims (arrayctypedimensions atype)) 8743 (dim0 (car dims)) 8630 (when (eq dims '*) 8631 (setq dims nil)) 8632 (let* ((dim0 (car dims)) 8744 8633 (dim1 (cadr dims)) 8745 8634 (dim2 (caddr dims))) … … 8772 8661 (ctype (if atype0 (specifiertype atype0))) 8773 8662 (atype (if (arrayctypep ctype) ctype)) 8663 (dims (and atype (arrayctypedimensions atype))) 8774 8664 (keyword (and atype 8775 (let* ((dims (arrayctypedimensions atype)))8776 8777 8665 (or (eq dims '*) 8666 (and (typep dims 'list) 8667 (= 2 (length dims)))) 8778 8668 (not (arrayctypecomplexp atype)) 8779 8669 (funcall … … 8782 8672 atype)))) 8783 8673 (cond (keyword 8784 (let* ((dims (arrayctypedimensions atype)) 8785 (dim0 (car dims)) 8674 (when (eq dims '*) 8675 (setq dims nil)) 8676 (let* ((dim0 (car dims)) 8786 8677 (dim1 (cadr dims))) 8787 8678 (x862aset2 seg … … 8811 8702 (ctype (if atype0 (specifiertype atype0))) 8812 8703 (atype (if (arrayctypep ctype) ctype)) 8704 (dims (and atype (arrayctypedimensions atype))) 8813 8705 (keyword (and atype 8814 (let* ((dims (arrayctypedimensions atype)))8815 8816 8706 (or (eq dims '*) 8707 (unless (atom dims) 8708 (= 3 (length dims)))) 8817 8709 (not (arrayctypecomplexp atype)) 8818 8710 (funcall … … 8821 8713 atype)))) 8822 8714 (cond (keyword 8823 (let* ((dims (arrayctypedimensions atype)) 8824 (dim0 (car dims)) 8715 (when (eq dims '*) 8716 (setq dims nil)) 8717 (let* ((dim0 (car dims)) 8825 8718 (dim1 (cadr dims)) 8826 8719 (dim2 (caddr dims))) … … 9555 9448 ((:doublefloat :unsigneddoubleword :signeddoubleword) 9556 9449 (incf nwords 2)) 9557 (t (incf nwords)))) 9450 (t 9451 (if (typep argspec 'unsignedbyte) 9452 (incf nwords argspec) 9453 (incf nwords))))) 9558 9454 (when (null argspecs) 9559 9455 (setq simpleforeignargs t)) … … 9605 9501 (x862onetargetedregform seg valform ptr) 9606 9502 (withadditionalimmreg (ptr) 9607 (withimmt arget (ptr) (r :natural)9503 (withimmtemps (ptr) (r) 9608 9504 (dotimes (i spec) 9609 9505 (! memrefcfullword r ptr (ash i x8632::wordshift)) 9610 (! setcarg r offset)))))9506 (! setcarg r (+ offset i)))))) 9611 9507 (incf offset spec)) 9612 9508 (withimmtarget () (valreg :natural)
Note: See TracChangeset
for help on using the changeset viewer.