1;;; x86.ss 2;;; Copyright 1984-2017 Cisco Systems, Inc. 3;;; 4;;; Licensed under the Apache License, Version 2.0 (the "License"); 5;;; you may not use this file except in compliance with the License. 6;;; You may obtain a copy of the License at 7;;; 8;;; http://www.apache.org/licenses/LICENSE-2.0 9;;; 10;;; Unless required by applicable law or agreed to in writing, software 11;;; distributed under the License is distributed on an "AS IS" BASIS, 12;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13;;; See the License for the specific language governing permissions and 14;;; limitations under the License. 15 16;;; SECTION 1: registers 17(define-registers 18 (reserved 19 [%tc %edi #t 7 uptr] 20 [%sfp %ebp #t 5 uptr] 21 #;[%ap] 22 #;[%esp] 23 #;[%eap] 24 #;[%trap]) 25 (allocable ; keep in sync with all-but-byte-registers below 26 [%ac0 %edx #f 2 uptr] 27 [%xp %ecx #f 1 uptr] 28 [%ts %eax #f 0 uptr] 29 [%td %ebx #t 3 uptr] 30 #;[%ret] 31 #;[%cp] 32 #;[%ac1] 33 #;[%yp] 34 [%esi #t 6 uptr] 35 [%fp1 #f 2 fp] 36 [%fp2 #f 3 fp]) 37 (machine-dependent 38 [%fptmp1 #f 0 fp] 39 [%fptmp2 #f 1 fp] 40 [%sp #t 4 uptr] 41 #;[%esi #f 6])) 42 43;;; SECTION 2: instructions 44(module (md-handle-jump ; also sets primitive handlers 45 mem->mem 46 fpmem->fpmem 47 coercible? 48 coerce-opnd 49 acsame-mem 50 acsame-ur) 51 (import asm-module) 52 53 (define all-but-byte-registers 54 ; include only allocable registers that aren't byte registers 55 ; keep in sync with define-registers above 56 (lambda () 57 (list %esi))) 58 59 (define real-imm32? 60 (lambda (x) 61 (nanopass-case (L15c Triv) x 62 [(immediate ,imm) 63 (constant-case ptr-bits 64 [(32) #t] ; allows 2^31...2^32-1 per immediate? 65 [(64) (signed-32? imm)])] ; 2^31...2^32-1 aren't 32-bit values on 64-bit machines 66 [else #f]))) 67 68 (define negatable-real-imm32? 69 (lambda (x) 70 (nanopass-case (L15c Triv) x 71 [(immediate ,imm) (<= #x-7FFFFFFF imm #x7FFFFFFF)] 72 [else #f]))) 73 74 (define literal@->mem 75 (lambda (a k) 76 (nanopass-case (L15c Triv) a 77 ; NOTE: x86_64 and risc arch's will need to deal with this differently 78 [(literal ,info) (k (with-output-language (L15d Triv) `(literal ,info)))]))) 79 80 (define mref->mref 81 (lambda (a k) 82 (nanopass-case (L15c Triv) a 83 ; NOTE: x86_64 and risc arch's will need to deal with limitations on the offset 84 [(mref ,lvalue0 ,lvalue1 ,imm ,type) 85 (lvalue->ur lvalue0 86 (lambda (x0) 87 (lvalue->ur lvalue1 88 (lambda (x1) 89 (k (with-output-language (L15d Triv) `(mref ,x0 ,x1 ,imm ,type)))))))]))) 90 91 (define mem->mem 92 (lambda (a k) 93 (cond 94 [(literal@? a) (literal@->mem a k)] 95 [else (mref->mref a k)]))) 96 97 (define fpmem->fpmem mem->mem) 98 99 ;; `define-instruction` code takes care of `ur` and `fpur`, to which 100 ;; all type-compatible values must convert 101 (define-syntax coercible? 102 (syntax-rules () 103 [(_ ?a ?aty*) 104 (let ([a ?a] [aty* ?aty*]) 105 (or (and (memq 'imm32 aty*) (imm32? a)) 106 (and (memq 'imm aty*) (imm? a)) 107 (and (memq 'zero aty*) (imm0? a)) 108 (and (memq 'real-imm32 aty*) (real-imm32? a)) 109 (and (memq 'negatable-real-imm32 aty*) (negatable-real-imm32? a)) 110 (and (memq 'mem aty*) (mem? a)) 111 (and (memq 'fpmem aty*) (fpmem? a))))])) 112 113 ;; `define-instruction` doesn't try to cover `ur` and `fpur` 114 (define-syntax coerce-opnd ; passes k something compatible with aty* 115 (syntax-rules () 116 [(_ ?a ?aty* ?k) 117 (let ([a ?a] [aty* ?aty*] [k ?k]) 118 (cond 119 [(and (memq 'mem aty*) (mem? a)) (mem->mem a k)] 120 [(and (memq 'fpmem aty*) (fpmem? a)) (mem->mem a k)] 121 [(and (memq 'imm32 aty*) (imm32? a)) (k (imm->imm a))] 122 [(and (memq 'imm aty*) (imm? a)) (k (imm->imm a))] 123 [(and (memq 'zero aty*) (imm0? a)) (k (imm->imm a))] 124 [(and (memq 'real-imm32 aty*) (real-imm32? a)) (k (imm->imm a))] 125 [(and (memq 'negatable-real-imm32 aty*) (negatable-real-imm32? a)) (k (imm->imm a))] 126 [(memq 'ur aty*) 127 (cond 128 [(ur? a) (k a)] 129 [(imm? a) 130 (let ([u (make-tmp 'u)]) 131 (seq 132 (build-set! ,u ,(imm->imm a)) 133 (k u)))] 134 [(mem? a) 135 (mem->mem a 136 (lambda (a) 137 (let ([u (make-tmp 'u)]) 138 (seq 139 (build-set! ,u ,a) 140 (k u)))))] 141 [else (sorry! 'coerce-opnd "unexpected operand ~s" a)])] 142 [(memq 'fpur aty*) 143 (cond 144 [(fpur? a) (k a)] 145 [(fpmem? a) 146 (mem->mem a 147 (lambda (a) 148 (let ([u (make-tmp 'u 'fp)]) 149 (seq 150 (build-set! ,u ,a) 151 (k u)))))] 152 [else 153 (sorry! 'coerce-opnd "unexpected operand ~s" a)])] 154 [else (sorry! 'coerce-opnd "cannot coerce ~s to ~s" a aty*)]))])) 155 156 (define-who extract-imm 157 (lambda (e) 158 (nanopass-case (L15d Triv) e 159 [(immediate ,imm) imm] 160 [else (sorry! who "~s is not an immediate" e)]))) 161 162 (define md-handle-jump 163 (lambda (t) 164 (with-output-language (L15d Tail) 165 (nanopass-case (L15c Triv) t 166 [,lvalue 167 (if (mem? lvalue) 168 (mem->mem lvalue 169 (lambda (mref) 170 (values '() `(jump ,mref)))) 171 (values '() `(jump ,lvalue)))] 172 [(literal ,info) 173 (guard (and (not (info-literal-indirect? info)) 174 (memq (info-literal-type info) '(entry library-code)))) 175 (values '() `(jump (literal ,info)))] 176 [(label-ref ,l ,offset) 177 (values '() `(jump (label-ref ,l ,offset)))] 178 [else 179 (let ([tmp (make-tmp 'utmp)]) 180 (values 181 (with-output-language (L15d Effect) `(set! ,(make-live-info) ,tmp ,t)) 182 `(jump ,tmp)))])))) 183 184 (define-syntax acsame-mem 185 (lambda (stx) 186 (syntax-case stx () 187 [(_ orig c cty (b bty* ...) k) 188 #'(mem->mem c 189 (lambda (c) 190 (k c b)))] 191 [(_ orig c cty k) 192 #'(mem->mem c 193 (lambda (c) 194 (k c)))]))) 195 196 (define-syntax acsame-ur 197 (lambda (stx) 198 (syntax-case stx () 199 [(moi orig c cty (b bty* ...) k) 200 #`(cond 201 [(ur? c) (k c b)] 202 [(lmem? c) 203 (nanopass-case (L15c Triv) c 204 [(mref ,lvalue0 ,lvalue1 ,imm ,type) 205 (lvalue->ur 206 lvalue0 207 (lambda (x0) 208 (lvalue->ur 209 lvalue1 210 (lambda (x1) 211 (let ([u (make-tmp 'u)]) 212 (seq 213 (build-set! ,u (mref ,x0 ,x1 ,imm ,type)) 214 (k u b) 215 (build-set! (mref ,x0 ,x1 ,imm ,type) ,u)))))))])] 216 ;; can't be literal@ since literals can't be lvalues 217 [else (sorry! 'moi "unexpected operand ~s" c)])] 218 [(moi orig c cty k) 219 #`(if (ur? c) 220 (k c) 221 (mem->mem c 222 (lambda (c) 223 (let ([u (make-tmp 'u)]) 224 (seq 225 (build-set! ,u ,c) 226 (k u) 227 (build-set! ,c ,u))))))]))) 228 229 ; x is not the same as z in any clause that follows a clause where (x z) 230 ; and y is coercible to one of its types, however: 231 ; WARNING: do not assume that if x isn't the same as z then x is independent 232 ; of z, since x might be an mref with z as it's base or index 233 234 (define-instruction value (-) 235 [(op (z mem) (x z) (y ur imm32)) 236 `(set! ,(make-live-info) ,z (asm ,info ,asm-sub ,x ,y))] 237 [(op (z mem) (x zero) (y z)) 238 `(set! ,(make-live-info) ,z (asm ,info ,asm-negate ,y))] 239 [(op (z ur) (x z) (y ur mem imm32)) 240 `(set! ,(make-live-info) ,z (asm ,info ,asm-sub ,x ,y))] 241 [(op (z ur) (x zero) (y ur)) 242 (seq 243 `(set! ,(make-live-info) ,z ,y) 244 `(set! ,(make-live-info) ,z (asm ,info ,asm-negate ,z)))] 245 [(op (z ur) (x ur mem imm32) (y z)) 246 `(set! ,(make-live-info) ,z (asm ,info ,asm-sub-negate ,y ,x))] 247 [(op (z ur) (x ur) (y negatable-real-imm32)) 248 (seq 249 `(move-related ,z ,x) 250 `(set! ,(make-live-info) ,z (asm ,info ,(asm-lea1 (- (extract-imm y))) ,x)))] 251 [(op (z ur) (x mem imm32) (y ur)) 252 (let ([t (make-tmp 'u)]) 253 (seq 254 `(set! ,(make-live-info) ,t ,y) 255 `(set! ,(make-live-info) ,t (asm ,info ,asm-sub-negate ,t ,x)) 256 `(set! ,(make-live-info) ,z ,t)))] 257 [(op (z ur) (x ur) (y ur mem imm32)) 258 (let ([t (make-tmp 'u)]) 259 (seq 260 `(set! ,(make-live-info) ,t ,x) 261 `(set! ,(make-live-info) ,t (asm ,info ,asm-sub ,t ,y)) 262 `(set! ,(make-live-info) ,z ,t)))]) 263 264 (define-instruction value (-/ovfl -/eq -/pos) ; must set condition codes, so can't use lea or sub-negate 265 [(op (z mem) (x z) (y ur imm32)) 266 `(set! ,(make-live-info) ,z (asm ,info ,asm-sub ,x ,y))] 267 [(op (z mem) (x zero) (y z)) 268 `(set! ,(make-live-info) ,z (asm ,info ,asm-negate ,y))] 269 [(op (z ur) (x z) (y ur mem imm32)) 270 `(set! ,(make-live-info) ,z (asm ,info ,asm-sub ,x ,y))] 271 [(op (z ur) (x zero) (y ur)) 272 (seq 273 `(set! ,(make-live-info) ,z ,y) 274 `(set! ,(make-live-info) ,z (asm ,info ,asm-negate ,z)))] 275 [(op (z ur) (x ur) (y ur mem imm32)) 276 (let ([t (make-tmp 'u)]) 277 (seq 278 `(set! ,(make-live-info) ,t ,x) 279 `(set! ,(make-live-info) ,t (asm ,info ,asm-sub ,t ,y)) 280 `(set! ,(make-live-info) ,z ,t)))]) 281 282 (define-instruction value (+) 283 [(op (z mem) (x z) (y ur imm32)) 284 `(set! ,(make-live-info) ,z (asm ,info ,asm-add ,z ,y))] 285 [(op (z mem) (x ur imm32) (y z)) 286 `(set! ,(make-live-info) ,z (asm ,info ,asm-add ,z ,x))] 287 [(op (z ur) (x z) (y ur mem imm32)) 288 `(set! ,(make-live-info) ,z (asm ,info ,asm-add ,z ,y))] 289 [(op (z ur) (x ur mem imm32) (y z)) 290 `(set! ,(make-live-info) ,z (asm ,info ,asm-add ,z ,x))] 291 [(op (z ur) (x ur) (y real-imm32)) 292 (seq 293 `(move-related ,z ,x) 294 `(set! ,(make-live-info) ,z (asm ,info ,(asm-lea1 (extract-imm y)) ,x)))] 295 [(op (z ur) (x real-imm32) (y ur)) 296 (seq 297 `(move-related ,z ,y) 298 `(set! ,(make-live-info) ,z (asm ,info ,(asm-lea1 (extract-imm x)) ,y)))] 299 [(op (z ur) (x ur) (y mem imm32)) 300 (let ([t (make-tmp 'u)]) 301 (seq 302 `(set! ,(make-live-info) ,t ,x) 303 `(set! ,(make-live-info) ,t (asm ,info ,asm-add ,t ,y)) 304 `(set! ,(make-live-info) ,z ,t)))] 305 [(op (z ur) (x mem imm32) (y ur)) 306 (let ([t (make-tmp 'u)]) 307 (seq 308 `(set! ,(make-live-info) ,t ,y) 309 `(set! ,(make-live-info) ,t (asm ,info ,asm-add ,t ,x)) 310 `(set! ,(make-live-info) ,z ,t)))] 311 [(op (z ur) (x ur) (y ur)) 312 (seq 313 `(move-related ,z ,y) 314 `(move-related ,z ,x) 315 `(set! ,(make-live-info) ,z (asm ,info ,(asm-lea2 0) ,x ,y)))]) 316 317 (define-instruction value (+/ovfl +/carry) ; must set condition codes, so can't use lea 318 [(op (z mem) (x z) (y ur imm32)) 319 `(set! ,(make-live-info) ,z (asm ,info ,asm-add ,z ,y))] 320 [(op (z mem) (x ur imm32) (y z)) 321 `(set! ,(make-live-info) ,z (asm ,info ,asm-add ,z ,x))] 322 [(op (z ur) (x z) (y ur mem imm32)) 323 `(set! ,(make-live-info) ,z (asm ,info ,asm-add ,z ,y))] 324 [(op (z ur) (x ur mem imm32) (y z)) 325 `(set! ,(make-live-info) ,z (asm ,info ,asm-add ,z ,x))] 326 [(op (z ur) (x ur) (y mem imm32)) 327 (let ([t (make-tmp 'u)]) 328 (seq 329 `(set! ,(make-live-info) ,t ,x) 330 `(set! ,(make-live-info) ,t (asm ,info ,asm-add ,t ,y)) 331 `(set! ,(make-live-info) ,z ,t)))] 332 [(op (z ur) (x mem imm32) (y ur)) 333 (let ([t (make-tmp 'u)]) 334 (seq 335 `(set! ,(make-live-info) ,t ,y) 336 `(set! ,(make-live-info) ,t (asm ,info ,asm-add ,t ,x)) 337 `(set! ,(make-live-info) ,z ,t)))] 338 [(op (z ur) (x ur) (y ur)) 339 (let ([t (make-tmp 'u)]) 340 (seq 341 `(set! ,(make-live-info) ,t ,x) 342 `(set! ,(make-live-info) ,t (asm ,info ,asm-add ,t ,y)) 343 `(set! ,(make-live-info) ,z ,t)))]) 344 345 (define-instruction value (* */ovfl) ; */ovfl must set mulitply-overflow flag on overflow 346 [(op (z ur) (x z) (y ur mem)) 347 `(set! ,(make-live-info) ,z (asm ,info ,asm-mul ,z ,y))] 348 [(op (z ur) (x ur mem) (y z)) 349 `(set! ,(make-live-info) ,z (asm ,info ,asm-mul ,z ,x))] 350 [(op (z ur) (x ur mem) (y imm32)) 351 `(set! ,(make-live-info) ,z (asm ,info ,asm-muli ,x ,y))] 352 [(op (z ur) (x imm32) (y ur mem)) 353 `(set! ,(make-live-info) ,z (asm ,info ,asm-muli ,y ,x))] 354 [(op (z ur) (x ur) (y ur)) 355 (let ([t (make-tmp 'u)]) 356 (seq 357 `(set! ,(make-live-info) ,t ,x) 358 `(set! ,(make-live-info) ,t (asm ,info ,asm-mul ,t ,y)) 359 `(set! ,(make-live-info) ,z ,t)))]) 360 361 (define-instruction value (/) 362 (definitions 363 (define go 364 (lambda (z x y) 365 (let ([ueax (make-precolored-unspillable 'ueax %eax)] 366 [uedx (make-precolored-unspillable 'uedx %edx)]) 367 (with-output-language (L15d Effect) 368 (seq 369 `(set! ,(make-live-info) ,ueax ,x) 370 `(set! ,(make-live-info) ,uedx (asm ,null-info ,asm-sext-eax->edx ,ueax)) 371 `(set! ,(make-live-info) ,ueax (asm ,null-info ,asm-div ,ueax ,uedx ,y)) 372 `(set! ,(make-live-info) ,z ,ueax))))))) 373 [(op (z mem) (x ur mem imm) (y ur mem)) (go z x y)] 374 [(op (z ur) (x ur mem imm) (y ur mem)) (go z x y)]) 375 376 (define-instruction value (logand logor logxor) 377 [(op (z mem) (x z) (y ur imm32)) 378 `(set! ,(make-live-info) ,z (asm ,info ,(asm-addop op) ,z ,y))] 379 [(op (z mem) (x ur imm32) (y z)) 380 `(set! ,(make-live-info) ,z (asm ,info ,(asm-addop op) ,z ,x))] 381 [(op (z ur) (x z) (y ur mem imm32)) 382 `(set! ,(make-live-info) ,z (asm ,info ,(asm-addop op) ,z ,y))] 383 [(op (z ur) (x ur mem imm32) (y z)) 384 `(set! ,(make-live-info) ,z (asm ,info ,(asm-addop op) ,z ,x))] 385 [(op (z ur) (x ur) (y mem imm32)) 386 (let ([t (make-tmp 'u)]) 387 (seq 388 `(set! ,(make-live-info) ,t ,x) 389 `(set! ,(make-live-info) ,t (asm ,info ,(asm-addop op) ,t ,y)) 390 `(set! ,(make-live-info) ,z ,t)))] 391 [(op (z ur) (x ur mem imm32) (y ur)) 392 (let ([t (make-tmp 'u)]) 393 (seq 394 `(set! ,(make-live-info) ,t ,y) 395 `(set! ,(make-live-info) ,t (asm ,info ,(asm-addop op) ,t ,x)) 396 `(set! ,(make-live-info) ,z ,t)))]) 397 398 (define-instruction value (lognot) 399 [(op (z mem) (x z)) 400 `(set! ,(make-live-info) ,z (asm ,info ,asm-lognot ,x))] 401 [(op (z ur) (x z)) 402 `(set! ,(make-live-info) ,z (asm ,info ,asm-lognot ,x))] 403 [(op (z ur) (x ur mem imm32)) 404 (seq 405 `(set! ,(make-live-info) ,z ,x) 406 `(set! ,(make-live-info) ,z (asm ,info ,asm-lognot ,z)))]) 407 408 ; TODO: use lea for certain constant shifts when x != z 409 (define-instruction value (sll srl sra) 410 (definitions 411 (define go 412 (lambda (info op z x y) 413 (let ([uecx (make-precolored-unspillable 'uecx %ecx)]) 414 (with-output-language (L15d Effect) 415 (seq 416 `(set! ,(make-live-info) ,uecx ,y) 417 `(set! ,(make-live-info) ,z (asm ,info ,(asm-shiftop op) ,x ,uecx)))))))) 418 [(op (z mem) (x z) (y imm32)) 419 `(set! ,(make-live-info) ,z (asm ,info ,(asm-shiftop op) ,x ,y))] 420 ;; NB: need to return in these cases? 421 [(op (z mem) (x z) (y ur mem imm)) (go info op z x y)] 422 [(op (z ur) (x z) (y imm32)) 423 `(set! ,(make-live-info) ,z (asm ,info ,(asm-shiftop op) ,x ,y))] 424 [(op (z ur) (x z) (y ur mem imm)) (go info op z x y)] 425 [(op (z ur) (x ur mem imm32) (y imm32)) 426 (let ([t (make-tmp 'u)]) 427 (seq 428 `(set! ,(make-live-info) ,t ,x) 429 `(set! ,(make-live-info) ,t (asm ,info ,(asm-shiftop op) ,t ,y)) 430 `(set! ,(make-live-info) ,z ,t)))] 431 [(op (z ur) (x ur mem imm32) (y ur mem imm)) 432 (let ([t (make-tmp 'u)]) 433 (seq 434 `(set! ,(make-live-info) ,t ,x) 435 (go info op t t y) 436 `(set! ,(make-live-info) ,z ,t)))]) 437 438 (define-instruction value move 439 [(op (z mem) (x ur imm32)) 440 `(set! ,(make-live-info) ,z ,x)] 441 [(op (z ur) (x ur mem imm)) 442 ; NOTE: risc arch's will need to deal with limitations on imm 443 `(set! ,(make-live-info) ,z ,x)]) 444 445 (define-instruction value lea1 446 [(op (z ur) (x ur)) 447 ; TODO: risc arch, x86_64 must handle cases where offset is too lage 448 `(set! ,(make-live-info) ,z (asm ,info ,(asm-lea1 (info-lea-offset info)) ,x))]) 449 450 (define-instruction value lea2 451 [(op (z ur) (x ur) (y ur)) 452 ; TODO: risc arch, x86_64 must handle cases where offset is too lage 453 `(set! ,(make-live-info) ,z (asm ,info ,(asm-lea2 (info-lea-offset info)) ,x ,y))]) 454 455 (define-instruction value (sext8 sext16 zext8 zext16) 456 [(op (z ur) (x ur mem)) `(set! ,(make-live-info) ,z (asm ,info ,(asm-move/extend op) ,x))]) 457 458 (define-instruction value (load) 459 (definitions 460 (define maybe-swap 461 (lambda (info z expr) 462 (with-output-language (L15d Effect) 463 (if (info-load-swapped? info) 464 (seq 465 expr 466 `(set! ,(make-live-info) ,z (asm ,info ,(asm-swap (info-load-type info)) ,z))) 467 expr))))) 468 [(op (z ur) (x ur) (y ur) (w imm32)) 469 (maybe-swap info z 470 `(set! ,(make-live-info) ,z (asm ,info ,(asm-load (info-load-type info)) ,x ,y ,w)))] 471 [(op (z ur) (x ur) (y ur) (w ur)) 472 (maybe-swap info z 473 (if (eq? y %zero) 474 `(set! ,(make-live-info) ,z (asm ,info ,(asm-load (info-load-type info)) ,x ,w (immediate 0))) 475 (let ([u (make-tmp 'u)]) 476 (seq 477 `(set! ,(make-live-info) ,u (asm ,null-info ,(asm-lea2 0) ,y ,w)) 478 `(set! ,(make-live-info) ,z (asm ,info ,(asm-load (info-load-type info)) ,x ,u (immediate 0)))))))]) 479 480 (define-instruction effect (store) 481 (definitions 482 (define maybe-swap 483 (lambda (swapped? w k) 484 (with-output-language (L15d Effect) 485 (if swapped? 486 (let ([u (make-tmp 'u)]) 487 (seq 488 `(set! ,(make-live-info) ,u ,w) 489 `(set! ,(make-live-info) ,u (asm ,info ,(asm-swap (info-load-type info)) ,u)) 490 (k u))) 491 (k w))))) 492 (define select-value-register 493 (lambda (type w k) 494 (if (and (ur? w) (memq type '(integer-8 unsigned-8))) 495 (let ([u (make-restricted-unspillable 'ubyte (all-but-byte-registers))]) 496 (with-output-language (L15d Effect) 497 (seq 498 `(set! ,(make-live-info) ,u ,w) 499 (k u)))) 500 (k w))))) 501 [(op (x ur) (y ur) (z imm32) (w ur real-imm32)) 502 (let ([type (info-load-type info)]) 503 (select-value-register type w 504 (lambda (w) 505 (maybe-swap (info-load-swapped? info) w 506 (lambda (w) 507 `(asm ,info ,(asm-store type) ,x ,y ,z ,w))))))] 508 [(op (x ur) (y ur) (z ur) (w ur real-imm32)) 509 (let ([type (info-load-type info)]) 510 (select-value-register type w 511 (lambda (w) 512 (maybe-swap (info-load-swapped? info) w 513 (lambda (w) 514 (if (eq? y %zero) 515 `(asm ,info ,(asm-store type) ,x ,z (immediate 0) ,w) 516 (let ([u (make-tmp 'u)]) 517 (seq 518 `(set! ,(make-live-info) ,u (asm ,null-info ,(asm-lea2 0) ,y ,z)) 519 `(asm ,info ,(asm-store type) ,x ,u (immediate 0) ,w)))))))))]) 520 521 (define-instruction value (fstpl) 522 [(op (z fpmem)) `(set! ,(make-live-info) ,z (asm ,info ,asm-fstpl))] 523 [(op (z fpur)) (seq 524 `(set! ,(make-live-info) ,(%mref ,%sp ,%zero -8 fp) (asm ,info ,asm-fstpl)) 525 `(set! ,(make-live-info) ,z ,(%mref ,%sp ,%zero -8 fp)))]) 526 527 (define-instruction value (fstps) 528 [(op (z fpmem)) `(set! ,(make-live-info) ,z (asm ,info ,asm-fstps))]) 529 530 (define-instruction effect (fldl) 531 [(op (z fpmem)) `(asm ,info ,asm-fldl ,z)]) 532 533 (define-instruction effect (flds) 534 [(op (z mem)) `(asm ,info ,asm-flds ,z)]) 535 536 (define-instruction value (load-single->double) 537 [(op (x fpur) (y fpmem)) 538 `(set! ,(make-live-info) ,x (asm ,info ,(asm-fl-cvt 'single->double) ,y))]) 539 540 (define-instruction effect (store-double->single) 541 [(op (x fpmem) (y fpmem fpur)) 542 (let ([u (make-tmp 'u 'fp)]) 543 (seq 544 `(set! ,(make-live-info) ,u (asm ,null-info ,(asm-fl-cvt 'double->single) ,y)) 545 `(asm ,info ,asm-store-single ,x ,u)))]) 546 547 (define-instruction value (fpt) 548 [(op (x fpur) (y ur)) `(set! ,(make-live-info) ,x (asm ,info ,asm-fpt ,y))]) 549 550 (define-instruction value (fpmove) 551 [(op (x fpmem) (y fpur)) `(set! ,(make-live-info) ,x (asm ,info ,asm-fpmove ,y))] 552 [(op (x fpur) (y fpmem fpur)) `(set! ,(make-live-info) ,x (asm ,info ,asm-fpmove ,y))]) 553 554 (define-instruction value (fpcastto/hi) ; little endian: high bytes are at +4 555 [(op (x ur) (y fpmem)) `(set! ,(make-live-info) ,x (asm ,info ,(asm-movefrom 4) ,y))] 556 [(op (x ur) (y fpur)) `(set! ,(make-live-info) ,x (asm ,info ,(asm-fpcastto 32) ,y))]) 557 558 (define-instruction value (fpcastto/lo) ; little endian: low byte are immediate bytes 559 [(op (x ur) (y fpmem)) `(set! ,(make-live-info) ,x (asm ,info ,asm-move ,y))] 560 [(op (x ur) (y fpur)) `(set! ,(make-live-info) ,x (asm ,info ,(asm-fpcastto 0) ,y))]) 561 562 (define-instruction value (fpcastfrom) 563 [(op (x fpmem) (hi ur) (lo ur)) `(set! ,(make-live-info) ,x (asm ,info ,asm-fpmovefrom ,lo ,hi))] 564 [(op (x fpur) (hi ur) (lo ur)) `(set! ,(make-live-info) ,x (asm ,info ,asm-fpcastfrom ,lo ,hi))]) 565 566 (define-instruction value (fp+ fp- fp* fp/) 567 [(op (x fpur) (y fpmem fpur) (z fpmem fpur)) 568 `(set! ,(make-live-info) ,x (asm ,info ,(asm-fpop-2 op) ,y ,z))]) 569 570 (define-instruction value (fpsqrt) 571 [(op (x fpur) (y fpmem fpur)) `(set! ,(make-live-info) ,x (asm ,info ,asm-fpsqrt ,y))]) 572 573 (define-instruction value (fpsingle) 574 [(op (x fpur) (y fpmem fpur)) `(set! ,(make-live-info) ,x (asm ,info ,asm-fpsingle ,y))]) 575 576 (define-instruction effect inc-cc-counter 577 [(op (x ur) (y imm32 ur) (z imm32 ur)) `(asm ,info ,asm-inc-cc-counter ,x ,y ,z)]) 578 579 (define-instruction effect inc-profile-counter 580 [(op (x ur mem) (y imm32 ur)) `(asm ,info ,asm-inc-profile-counter ,x ,y)]) 581 582 (define-instruction value (fptrunc) 583 [(op (z ur) (x fpmem fpur)) `(set! ,(make-live-info) ,z (asm ,info ,asm-fptrunc ,x))]) 584 585 ;; no kills since we expect to be called when all necessary state has already been saved 586 (define-instruction value get-tc 587 [(op (z ur)) 588 (safe-assert (eq? z %eax)) 589 `(set! ,(make-live-info) ,z (asm ,info ,asm-get-tc))]) 590 591 (define-instruction value activate-thread 592 [(op (z ur)) 593 (safe-assert (eq? z %eax)) ; see get-tc 594 `(set! ,(make-live-info) ,z (asm ,info ,asm-activate-thread))]) 595 596 (define-instruction effect deactivate-thread 597 [(op) 598 `(asm ,info ,asm-deactivate-thread)]) 599 600 (define-instruction effect unactivate-thread 601 [(op) 602 `(asm ,info ,asm-unactivate-thread)]) 603 604 ; TODO: should we insist that asm-library-call preserve %ts and %td? 605 ; TODO: risc architectures will have to take info-asmlib-save-ra? into account 606 (define-instruction value asmlibcall 607 [(op (z ur)) 608 `(set! ,(make-live-info) ,z (asm ,info ,(asm-library-call (info-asmlib-libspec info)) ,(info-kill*-live*-live* info) ...))]) 609 610 (define-instruction effect asmlibcall! 611 [(op) `(asm ,info ,(asm-library-call (info-asmlib-libspec info)) ,(info-kill*-live*-live* info) ...)]) 612 613 (safe-assert (reg-callee-save? %tc)) ; no need to save-restore 614 (define-instruction effect (c-simple-call) 615 [(op) `(asm ,info ,(asm-c-simple-call (info-c-simple-call-entry info)))]) 616 617 (define-instruction value pop 618 [(op (z ur)) `(set! ,(make-live-info) ,z (asm ,info ,asm-pop))]) 619 620 (define-instruction pred (fp= fp< fp<=) 621 [(op (x fpmem) (y fpur)) 622 (let ([info (make-info-condition-code op #t #f)]) ; NB: reversed? flag is assumed to be #t 623 (values '() `(asm ,info ,(asm-fp-relop info) ,x ,y)))] 624 [(op (x fpur) (y fpur)) 625 (let ([info (make-info-condition-code op #t #f)]) ; NB: reversed? flag is assumed to be #t 626 (values '() `(asm ,info ,(asm-fp-relop info) ,x ,y)))]) 627 628 (define-instruction pred (eq? u< < > <= >=) 629 ; the idea (following from the intel x86/x86_64 documentation) 630 ; is that we want to squeeze this into a CMP that allows one of 631 ; the following formats: 632 ; CMP r/m, imm 633 ; CMP r/m, r 634 ; CMP r, r/m 635 ; the last format we may want to drop, since it uses a different 636 ; format from the one above it, but is interchangable with it, 637 ; if we reverse the operands. 638 [(op (x mem) (y ur imm32)) 639 (let ([info (make-info-condition-code op #f #t)]) 640 (values '() `(asm ,info ,(asm-relop info) ,x ,y)))] 641 [(op (x ur) (y mem)) 642 (let ([info (make-info-condition-code op #t #t)]) 643 (values '() `(asm ,info ,(asm-relop info) ,y ,x)))] 644 [(op (x imm32) (y ur mem)) 645 (let ([info (make-info-condition-code op #t #t)]) 646 (values '() `(asm ,info ,(asm-relop info) ,y ,x)))] 647 [(op (x ur) (y ur imm32)) 648 (let ([info (make-info-condition-code op #f #t)]) 649 (values '() `(asm ,info ,(asm-relop info) ,x ,y)))]) 650 651 (define-instruction pred (condition-code) 652 [(op) (values '() `(asm ,info ,(asm-condition-code info)))]) 653 654 (let* ([info-cc-eq (make-info-condition-code 'eq? #f #t)] 655 [asm-eq (asm-relop info-cc-eq)]) 656 (define-instruction pred (type-check?) 657 [(op (x ur mem) (mask imm32 ur) (type imm32 ur)) 658 (let ([tmp (make-tmp 'u)]) 659 (values 660 (with-output-language (L15d Effect) 661 (seq 662 `(set! ,(make-live-info) ,tmp ,x) 663 `(set! ,(make-live-info) ,tmp (asm ,null-info ,asm-logand ,tmp ,mask)))) 664 `(asm ,info-cc-eq ,asm-eq ,tmp ,type)))]) 665 666 (define-instruction pred (logtest log!test) 667 [(op (x mem) (y ur imm32)) 668 (values '() `(asm ,info-cc-eq ,(asm-logtest (eq? op 'log!test) info-cc-eq) ,x ,y))] 669 [(op (x ur imm32) (y mem)) 670 (values '() `(asm ,info-cc-eq ,(asm-logtest (eq? op 'log!test) info-cc-eq) ,y ,x))] 671 [(op (x imm32) (y ur)) 672 (values '() `(asm ,info-cc-eq ,(asm-logtest (eq? op 'log!test) info-cc-eq) ,y ,x))] 673 [(op (x ur) (y ur imm32)) 674 (values '() `(asm ,info-cc-eq ,(asm-logtest (eq? op 'log!test) info-cc-eq) ,x ,y))]) 675 676 (define-instruction pred (lock!) 677 [(op (x ur) (y ur) (w imm32)) 678 (let ([uts (make-precolored-unspillable 'uts %ts)]) 679 (values 680 (nanopass-case (L15d Triv) w 681 [(immediate ,imm) 682 (with-output-language (L15d Effect) 683 (seq 684 `(set! ,(make-live-info) ,uts (immediate 1)) 685 `(set! ,(make-live-info) ,uts 686 (asm ,info ,asm-exchange ,uts 687 (mref ,x ,y ,imm uptr)))))]) 688 `(asm ,info-cc-eq ,asm-eq ,uts (immediate 0))))])) 689 690 (define-instruction effect (locked-incr!) 691 [(op (x ur) (y ur) (w imm32)) 692 `(asm ,info ,asm-locked-incr ,x ,y ,w)]) 693 694 (define-instruction effect (locked-decr!) 695 [(op (x ur) (y ur) (w imm32)) 696 `(asm ,info ,asm-locked-decr ,x ,y ,w)]) 697 698 (define-instruction effect (cas) 699 [(op (x ur) (y ur) (w imm32) (old ur) (new ur)) 700 (let ([ueax (make-precolored-unspillable 'ueax %eax)]) 701 (with-output-language (L15d Effect) 702 (seq 703 `(set! ,(make-live-info) ,ueax ,old) 704 ;; NB: may modify %eax: 705 `(asm ,info ,asm-locked-cmpxchg ,x ,y ,w ,ueax ,new))))]) 706 707 (define-instruction effect (pause) 708 [(op) `(asm ,info ,asm-pause)]) 709 710 (define-instruction value read-performance-monitoring-counter 711 [(op (z ur) (x ur mem imm)) 712 (safe-assert (eq? z %eax)) 713 (safe-assert (and (info-kill*? info) (memq %edx (info-kill*-kill* info)))) 714 (let ([uecx (make-precolored-unspillable 'uecx %ecx)]) 715 (seq 716 `(set! ,(make-live-info) ,uecx ,x) 717 `(set! ,(make-live-info) ,z (asm ,info ,asm-read-performance-monitoring-counter ,uecx))))]) 718 719 (define-instruction value read-time-stamp-counter 720 [(op (z ur)) 721 (safe-assert (eq? z %eax)) 722 (safe-assert (and (info-kill*? info) (memq %edx (info-kill*-kill* info)))) 723 `(set! ,(make-live-info) ,z (asm ,info ,asm-read-time-stamp-counter))]) 724 725 (define-instruction effect (c-call) 726 [(op (x ur mem)) `(asm ,info ,asm-indirect-call ,x)]) 727 728 (define-instruction effect (push) 729 [(op (x ur)) `(asm ,info ,asm-push ,x)]) 730 731 (define-instruction effect (check-stack-align) 732 [(op) `(asm ,info ,asm-check-stack-align)]) 733 734 (define-instruction effect save-flrv 735 [(op) `(asm ,info ,asm-save-flrv)]) 736 737 (define-instruction effect restore-flrv 738 [(op) `(asm ,info ,asm-restore-flrv)]) 739 740 (define-instruction effect invoke-prelude 741 [(op) 742 (constant-case machine-type-name 743 [(i3nt ti3nt) `(set! ,(make-live-info) ,%tc (mref ,%sp ,%zero 4 uptr))] 744 [else 745 (seq 746 `(set! ,(make-live-info) ,%tc (mref ,%sp ,%zero 4 uptr)) 747 `(set! ,(make-live-info) ,%sp (asm ,info ,asm-sub ,%sp (immediate 12))))])]) 748 ) 749 750;;; SECTION 3: assembler 751(module asm-module (; required exports 752 asm-move asm-move/extend asm-movefrom asm-load asm-store asm-swap asm-library-call asm-library-jump 753 asm-mul asm-muli asm-addop asm-add asm-sub asm-negate asm-sub-negate 754 asm-pop asm-shiftop asm-sll asm-logand asm-lognot 755 asm-logtest asm-fp-relop asm-relop asm-push asm-indirect-jump asm-literal-jump 756 asm-direct-jump asm-return-address asm-jump asm-conditional-jump 757 asm-lea1 asm-lea2 asm-indirect-call asm-fstpl asm-fstps asm-fldl asm-flds asm-condition-code 758 asm-fl-cvt asm-store-single asm-fpt asm-fptrunc asm-fpsingle asm-div 759 asm-exchange asm-pause asm-locked-incr asm-locked-decr asm-locked-cmpxchg 760 asm-fpop-2 asm-fpmove asm-fpmovefrom asm-fpcastfrom asm-fpcastto asm-fpsqrt asm-c-simple-call 761 asm-save-flrv asm-restore-flrv asm-return asm-c-return asm-size asm-check-stack-align 762 asm-enter asm-foreign-call asm-foreign-callable 763 asm-inc-profile-counter 764 asm-inc-cc-counter asm-read-time-stamp-counter asm-read-performance-monitoring-counter 765 ; threaded version specific 766 asm-get-tc asm-activate-thread asm-deactivate-thread asm-unactivate-thread 767 ; machine dependent exports 768 asm-sext-eax->edx) 769 770 (define byte-register? 771 (lambda (x) 772 (or (eq? x %eax) (eq? x %ebx) (eq? x %ecx) (eq? x %edx)))) 773 774 (define ax-register? 775 (case-lambda 776 [(x) (record-case x [(reg) r #t] [else #f])] 777 [(x reg) (record-case x [(reg) r (eq? r reg)] [else #f])])) 778 779 (define ax-fp-register? 780 (lambda (x) (record-case x [(reg) r (eq? 'fp (reg-type r))] [else #f]))) 781 782 (define ax-ea-reg-code 783 (lambda (ea) 784 (record-case ea 785 [(reg) r (reg-mdinfo r)] 786 [else (sorry! 'ax-ea-reg-code "ea=~s" ea)]))) 787 788 (define ax-imm-data 789 (lambda (ea) 790 (record-case ea 791 [(imm) (n) n] 792 [else ($oops 'assembler-internal "ax-imm-data ea=~s" ea)]))) 793 794 ; define-op sets up assembly op macros-- 795 ; suffixes are a sub-list of (b w l)-- 796 ; the opcode, the size (byte word or long), and all other expressions 797 ; are passed to the specified handler-- 798 ; for prefix 'p' and each suffix 's' a macro of the form 'ps' is set up-- 799 ; if no suffix is specified the prefix is defined as a macro 800 (define-syntax define-op 801 (lambda (x) 802 (syntax-case x () 803 [(k prefix (suffix ...) handler e ...) 804 (let ([suffix* (datum (suffix ...))]) 805 (unless (andmap (lambda (x) (memq x '(b w *))) suffix*) 806 (syntax-error x (format "invalid suffix list ~s" suffix*))) 807 (with-syntax ([(op ...) (map (lambda (x) 808 (if (eq? x '*) 809 (construct-name #'k "386op-" #'prefix) 810 (construct-name #'k "386op-" #'prefix x))) 811 suffix*)] 812 [(size ...) (map (lambda (x) 813 (case x [(b) #'byte] [(w) #'word] [(*) #'long])) 814 suffix*)]) 815 #'(begin 816 (define-syntax op 817 (syntax-rules () 818 [(_ mneu arg (... ...)) 819 (handler 'mneu 'size e ... arg (... ...))])) 820 ...)))] 821 [(k op handler e ...) 822 (with-syntax ([op (construct-name #'k "386op-" #'op)]) 823 #'(define-syntax op 824 (syntax-rules () 825 [(_ mneu arg (... ...)) 826 (handler 'mneu e ... arg (... ...))])))]))) 827 828 (define-syntax emit 829 (lambda (x) 830 (syntax-case x () 831 [(k op x ...) 832 (with-syntax ([emit-op (construct-name #'k "386op-" #'op)]) 833 #'(emit-op op x ...))]))) 834 835 ;;; note that the assembler isn't clever--you must be very explicit about 836 ;;; which flavor you want, and there are a few new varieties introduced 837 ;;; (commented-out opcodes are not currently used by the assembler-- 838 ;;; spaces are left to indicate possible size extensions) 839 840 (define-op asl (*) unary-op #b1101001 #b100) ; shifts by CL 841 (define-op lsr (*) unary-op #b1101001 #b101) ; shifts by CL 842 (define-op asr (*) unary-op #b1101001 #b111) ; shifts by CL 843 (define-op asli (*) shifti-op #b1100000 #b100) 844 (define-op lsri (*) shifti-op #b1100000 #b101) 845 (define-op asri (*) shifti-op #b1100000 #b111) 846 847 (define-op addi (b *) addi-op #b100000 #b000) 848 (define-op subi (b *) addi-op #b100000 #b101) 849 (define-op cmpi (b *) addi-op #b100000 #b111) 850 851 (define-op adci (b *) addi-op #b100000 #b010) 852 853 (define-op ori (b *) logi-op #b001) 854 (define-op andi (b *) logi-op #b100) 855 (define-op xori (b *) logi-op #b110) 856 (define-op testi (b *) testi-op #b1111011 #b000) 857 858 (define-op movi (b w *) movi-op #b1100011 #b000) 859 860 (define-op mov (b w *) binary-op #b100010) 861 (define-op movsb mul-op #b00001111 #b10111110) 862 (define-op movsw mul-op #b00001111 #b10111111) 863 (define-op movzb mul-op #b00001111 #b10110110) 864 (define-op movzw mul-op #b00001111 #b10110111) 865 866 (define-op add (b *) binary-op #b000000) 867 (define-op or (b *) binary-op #b000010) 868 (define-op and (b *) binary-op #b001000) 869 (define-op sub (b *) binary-op #b001010) 870 (define-op xor (b *) binary-op #b001100) 871 (define-op test (b *) test-op #b1000010) 872 (define-op cmp (b *) binary-op #b001110) 873 (define-op xchg (b *) xchg-op #b1000011) 874 (define-op bswap byte-reg-op2 #b00001111 #b11001) 875 876 (define-op divsax (*) unary-op #b1111011 #b111) 877 (define-op mulsax (*) unary-op #b1111011 #b100) 878 (define-op muls mul-op #b00001111 #b10101111) 879 (define-op mulsi muli-op #b01101001) 880 881 (define-op lea lea-op #b10001101) 882 883 (define-op pop byte-reg-op1 #b01011) 884 (define-op push byte-reg-op1 #b01010) 885 (define-op pushi pushil-op) 886 (define-op pushall byte-op #b01100000) 887 (define-op popall byte-op #b01100001) 888 (define-op pushf byte-op #b10011100) 889 (define-op popf byte-op #b10011101) 890 (define-op nop byte-op #b10010000) 891 (define-op ret byte-op #b11000011) 892 (define-op retl byte+short-op #b11000010) 893 (define-op sahf byte-op #b10011110) 894 (define-op extad byte-op #b10011001) ; extend eax to edx 895 896 (define-op int3 byte-op #b11001100) 897 898 (define-op rdtsc two-byte-op #b1111 #b00110001) ; read time-stamp counter 899 (define-op rdpmc two-byte-op #b1111 #b00110011) ; read performance monitoring counter 900 (define-op pause two-byte-op #b11110011 #b10010000) ; equivalent to rep nop 901 902 (define-op dec (b *) unary-op #b1111111 #b001) 903 (define-op inc (b *) unary-op #b1111111 #b000) 904 (define-op neg (b *) unary-op #b1111011 #b011) 905 (define-op not (b *) unary-op #b1111011 #b010) 906 907 (define-op locked-dec (b *) locked-unary-op #b1111111 #b001) 908 (define-op locked-inc (b *) locked-unary-op #b1111111 #b000) 909 910 (define-op locked-cmpxchg (*) locked-cmpxchg-op) 911 912 ; also do inc-reg dec-reg 913 914 (define-op call jump-op #b010) 915 (define-op jmp jump-op #b100) ; ow - was #b011 (looks like lcal*) 916 (define-op bra bra-op) 917 (define-op bsr bsr-op) 918 919 (define-op bvs branch-op #b0000) ; jump on overflow 920 (define-op bvc branch-op #b0001) ; jump on not overflow 921 (define-op bcs branch-op #b0010) ; jump on below (carry set) 922 (define-op bcc branch-op #b0011) ; jump on not below (carry clear) 923 (define-op beq branch-op #b0100) ; jump on equal 924 (define-op bne branch-op #b0101) ; jump on not equal 925 (define-op bls branch-op #b0110) ; jump on less or same (below or equal) 926 (define-op bhi branch-op #b0111) ; jump on higher (above) 927 (define-op blt branch-op #b1100) ; jump on less than 928 (define-op bge branch-op #b1101) ; jump on greater than or equal 929 (define-op ble branch-op #b1110) ; jump on less than or equal 930 (define-op bgt branch-op #b1111) ; jump on greater than 931 932 ; coprocessor ops required to handle calling conventions 933 (define-op fldl float-op2 #b101 #b000) ; double memory push => ST[0] 934 (define-op flds float-op2 #b001 #b000) ; single memory push => ST[0] 935 (define-op fstpl float-op2 #b101 #b011) ; ST[0] => double memory, pop 936 (define-op fstps float-op2 #b001 #b011) ; ST[0] => single memory, pop 937 938 ; SSE2 instructions (pulled from x86_64macros.ss) 939 (define-op sse.addsd sse-op1 #xF2 #x58) 940 (define-op sse.andpd sse-op1 #x66 #x54) 941 (define-op sse.cvtss2sd sse-op1 #xF3 #x5A) 942 (define-op sse.cvtsd2ss sse-op1 #xF2 #x5A) 943 (define-op sse.cvttsd2si sse-op1 #xF2 #x2C) 944 (define-op sse.cvtsi2sd sse-op1 #xF2 #x2A) 945 (define-op sse.divsd sse-op1 #xF2 #x5E) 946 (define-op sse.movd sse-op2 #x66 #x6E #x7E) 947 (define-op sse.movsd sse-op2 #xF2 #x10 #x11) 948 (define-op sse.movss sse-op2 #xF3 #x10 #x11) 949 (define-op sse.mulsd sse-op1 #xF2 #x59) 950 (define-op sse.sqrtsd sse-op1 #xF2 #x51) 951 (define-op sse.subsd sse-op1 #xF2 #x5C) 952 (define-op sse.ucomisd sse-op1 #x66 #x2E) 953 (define-op sse.xorpd sse-op1 #x66 #x57) 954 (define-op sse.psllq sse-shift 6) 955 (define-op sse.psrlq sse-shift 2) 956 (define-op sse.orpd sse-op1 #x66 #x56) 957 958 (define sse-op1 959 (lambda (op prefix-code op-code source dest-reg code*) 960 (emit-code (op source dest-reg code*) 961 (build byte prefix-code) 962 (build byte #x0F) 963 (build byte op-code) 964 (ax-ea-modrm-reg source dest-reg) 965 (ax-ea-sib source) 966 (ax-ea-addr-disp source)))) 967 968 (define sse-op2 969 (lambda (op prefix-code dstreg-op-code srcreg-op-code source dest code*) 970 (cond 971 [(ax-fp-register? source) 972 (emit-code (op source dest code*) 973 (build byte prefix-code) 974 (build byte #x0F) 975 (build byte srcreg-op-code) 976 (ax-ea-modrm-reg dest source) 977 (ax-ea-sib dest) 978 (ax-ea-addr-disp dest))] 979 [(ax-fp-register? dest) 980 (emit-code (op source dest code*) 981 (build byte prefix-code) 982 (build byte #x0F) 983 (build byte dstreg-op-code) 984 (ax-ea-modrm-reg source dest) 985 (ax-ea-sib source) 986 (ax-ea-addr-disp source))] 987 [else 988 ($oops 'assembler-internal "sse-op2 source=~s dest=~s" source dest)]))) 989 990 (define sse-shift 991 (lambda (op op-code dest-reg amt code*) 992 (emit-code (op dest-reg amt code*) 993 (build byte #x66) 994 (build byte #x0F) 995 (build byte #x73) 996 (ax-ea-modrm-ttt dest-reg op-code) 997 (build byte amt)))) 998 999 (define float-op2 1000 (lambda (op op-code1 op-code2 source-ea code*) 1001 (emit-code (op source-ea code*) 1002 (build byte 1003 (byte-fields 1004 [3 #b11011] 1005 [0 op-code1])) 1006 (ax-ea-modrm-ttt source-ea op-code2) 1007 (ax-ea-sib source-ea) 1008 (ax-ea-addr-disp source-ea)))) 1009 1010 (define mul-op 1011 ; used for movzbl as well as mulsl 1012 (lambda (op op-code1 op-code2 source-ea dest-reg code*) 1013 (emit-code (op source-ea dest-reg code*) 1014 (build byte op-code1) 1015 (build byte op-code2) 1016 (ax-ea-modrm-reg source-ea dest-reg) 1017 (ax-ea-sib source-ea) 1018 (ax-ea-addr-disp source-ea)))) 1019 1020 (define muli-op 1021 (lambda (op op-code imm-data source-ea dest-reg code*) 1022 (emit-code (op imm-data source-ea dest-reg code*) 1023 (build byte op-code) 1024 (ax-ea-modrm-reg source-ea dest-reg) 1025 (ax-ea-sib source-ea) 1026 (ax-ea-addr-disp source-ea) 1027 (build long (ax-imm-data imm-data))))) 1028 1029 (define lea-op 1030 (lambda (op op-code source-ea reg code*) 1031 (emit-code (op source-ea reg code*) 1032 (build byte op-code) 1033 (ax-ea-modrm-reg source-ea reg) 1034 (ax-ea-sib source-ea) 1035 (ax-ea-addr-disp source-ea)))) 1036 1037 (define test-op 1038 (lambda (op size op-code source-ea reg code*) 1039 (emit-code (op source-ea reg code*) 1040 (build byte 1041 (byte-fields 1042 [1 op-code] 1043 [0 (ax-size-code size)])) 1044 (ax-ea-modrm-reg source-ea reg) 1045 (ax-ea-sib source-ea) 1046 (ax-ea-addr-disp source-ea)))) 1047 1048 (define unary-op 1049 (lambda (op size op-code ttt-code dest-ea code*) 1050 (emit-code (op dest-ea code*) 1051 (build byte 1052 (byte-fields 1053 [1 op-code] 1054 [0 (ax-size-code size)])) 1055 (ax-ea-modrm-ttt dest-ea ttt-code) 1056 (ax-ea-sib dest-ea) 1057 (ax-ea-addr-disp dest-ea)))) 1058 1059 (define locked-unary-op 1060 (lambda (op size op-code ttt-code dest-ea code*) 1061 (emit-code (op dest-ea code*) 1062 (build byte #xf0) ; lock prefix 1063 (build byte 1064 (byte-fields 1065 [1 op-code] 1066 [0 (ax-size-code size)])) 1067 (ax-ea-modrm-ttt dest-ea ttt-code) 1068 (ax-ea-sib dest-ea) 1069 (ax-ea-addr-disp dest-ea)))) 1070 1071 (define locked-cmpxchg-op 1072 (lambda (op size dest-ea new-reg code*) 1073 (begin 1074 (emit-code (op dest-ea new-reg code*) 1075 (build byte #xf0) ; lock prefix 1076 (build byte #x0f) 1077 (build byte 1078 (byte-fields 1079 [1 #b1011000] 1080 [0 (ax-size-code size)])) 1081 (ax-ea-modrm-reg dest-ea new-reg) 1082 (ax-ea-sib dest-ea) 1083 (ax-ea-addr-disp dest-ea))))) 1084 1085 (define pushil-op 1086 (lambda (op imm-ea code*) 1087 (if (ax-range? -128 imm-ea 127) 1088 (emit-code (op imm-ea code*) 1089 (build byte 106) 1090 (ax-ea-imm-data 'byte imm-ea)) 1091 (emit-code (op imm-ea code*) 1092 (build byte 104) 1093 (ax-ea-imm-data 'long imm-ea))))) 1094 1095 ; imm-data can be either an (imm n) or else a (literal size addr) record. 1096 ; 1097 (define testi-op 1098 (lambda (op size op-code ttt-code imm-ea dest-ea code*) 1099 (emit-code (op imm-ea dest-ea code*) 1100 (build byte 1101 (byte-fields 1102 [1 op-code] 1103 [0 (ax-size-code size)])) 1104 (ax-ea-modrm-ttt dest-ea ttt-code) 1105 (ax-ea-sib dest-ea) 1106 (ax-ea-addr-disp dest-ea) 1107 (ax-ea-imm-data size imm-ea)))) 1108 1109 (define logi-op 1110 (lambda (op size ttt-code imm-ea dest-ea code*) 1111 (if (and (eq? size 'long) 1112 (record-case imm-ea 1113 [(imm) (n) (<= -128 n 127)] 1114 [else #f])) 1115 (emit-code (op imm-ea dest-ea code*) 1116 (build byte 1117 (byte-fields 1118 [1 #b1000001] 1119 [0 (ax-size-code size)])) 1120 (ax-ea-modrm-ttt dest-ea ttt-code) 1121 (ax-ea-sib dest-ea) 1122 (ax-ea-addr-disp dest-ea) 1123 (ax-ea-imm-data 'byte imm-ea)) 1124 (emit-code (op imm-ea dest-ea code*) 1125 (build byte 1126 (byte-fields 1127 [1 #b1000000] 1128 [0 (ax-size-code size)])) 1129 (ax-ea-modrm-ttt dest-ea ttt-code) 1130 (ax-ea-sib dest-ea) 1131 (ax-ea-addr-disp dest-ea) 1132 (ax-ea-imm-data size imm-ea))))) 1133 1134 (define addi-op 1135 (lambda (op size op-code ttt-code imm-ea dest-ea code*) 1136 (if (and (eq? size 'long) 1137 (record-case imm-ea 1138 [(imm) (n) (<= -128 n 127)] 1139 [else #f])) 1140 (emit-code (op imm-ea dest-ea code*) 1141 (build byte 1142 (byte-fields 1143 [2 op-code] 1144 [1 1] 1145 [0 (ax-size-code size)])) 1146 (ax-ea-modrm-ttt dest-ea ttt-code) 1147 (ax-ea-sib dest-ea) 1148 (ax-ea-addr-disp dest-ea) 1149 (ax-ea-imm-data 'byte imm-ea)) 1150 (emit-code (op imm-ea dest-ea code*) 1151 (build byte 1152 (byte-fields 1153 [2 op-code] 1154 [1 0] 1155 [0 (ax-size-code size)])) 1156 (ax-ea-modrm-ttt dest-ea ttt-code) 1157 (ax-ea-sib dest-ea) 1158 (ax-ea-addr-disp dest-ea) 1159 (ax-ea-imm-data size imm-ea))))) 1160 1161 (define movi-op 1162 (lambda (op size op-code ttt-code imm-ea dest-ea code*) 1163 (cond 1164 [(ax-register? dest-ea) 1165 (emit-code (op imm-ea dest-ea code*) 1166 (and (eq? size 'word) (build byte 102)) 1167 (build byte 1168 (byte-fields 1169 [4 11] 1170 [3 (ax-size-code size)] 1171 [0 (ax-ea-reg-code dest-ea)])) 1172 (ax-ea-imm-data size imm-ea))] 1173 [else 1174 (emit-code (op imm-ea dest-ea code*) 1175 (and (eq? size 'word) (build byte 102)) 1176 (build byte 1177 (byte-fields 1178 [1 99] 1179 [0 (ax-size-code size)])) 1180 (ax-ea-modrm-ttt dest-ea ttt-code) 1181 (ax-ea-sib dest-ea) 1182 (ax-ea-addr-disp dest-ea) 1183 (ax-ea-imm-data size imm-ea))]))) 1184 1185 ;;; always need byte immediate data for shift ops 1186 (define shifti-op 1187 (lambda (op size op-code ttt-code imm-ea dest-ea code*) 1188 (emit-code (op imm-ea dest-ea code*) 1189 (build byte 1190 (byte-fields 1191 [1 op-code] 1192 [0 (ax-size-code size)])) 1193 (ax-ea-modrm-ttt dest-ea ttt-code) 1194 (ax-ea-sib dest-ea) 1195 (ax-ea-addr-disp dest-ea) 1196 (ax-ea-imm-data 'byte imm-ea)))) 1197 1198 (define binary-op 1199 (lambda (op size op-code source dest code*) 1200 (cond 1201 [(ax-register? source) 1202 (emit-code (op source dest code*) 1203 (and (eq? size 'word) (build byte 102)) 1204 (build byte 1205 (byte-fields 1206 [2 op-code] 1207 [1 0] 1208 [0 (ax-size-code size)])) 1209 (ax-ea-modrm-reg dest source) 1210 (ax-ea-sib dest) 1211 (ax-ea-addr-disp dest))] 1212 [(ax-register? dest) 1213 (emit-code (op source dest code*) 1214 (and (eq? size 'word) (build byte 102)) 1215 (build byte 1216 (byte-fields 1217 [2 op-code] 1218 [1 1] 1219 [0 (ax-size-code size)])) 1220 (ax-ea-modrm-reg source dest) 1221 (ax-ea-sib source) 1222 (ax-ea-addr-disp source))] 1223 [else 1224 ($oops 'assembler-internal "binary-op source=~s dest=~s" source dest)]))) 1225 1226 (define xchg-op 1227 (lambda (op size op-code source dest code*) 1228 (cond 1229 [(ax-register? source) 1230 (emit-code (op source dest code*) 1231 (build byte 1232 (byte-fields 1233 [1 op-code] 1234 [0 (ax-size-code size)])) 1235 (ax-ea-modrm-reg dest source) 1236 (ax-ea-sib dest) 1237 (ax-ea-addr-disp dest))] 1238 [(ax-register? dest) 1239 (emit-code (op source dest code*) 1240 (build byte 1241 (byte-fields 1242 [1 op-code] 1243 [0 (ax-size-code size)])) 1244 (ax-ea-modrm-reg source dest) 1245 (ax-ea-sib source) 1246 (ax-ea-addr-disp source))] 1247 [else 1248 ($oops 'assembler-internal "xchg-op source=~s dest=~s" source dest)]))) 1249 1250 (define branch-op 1251 (lambda (op condition-code disp code*) 1252 (record-case disp 1253 [(label) (offset l) 1254 (if (and (fixnum? offset) (fx<= -128 offset 127)) 1255 (emit-code (op disp code*) 1256 (build byte 1257 (byte-fields 1258 [4 7] 1259 [0 condition-code])) 1260 (build byte offset)) 1261 (emit-code (op disp code*) 1262 (build byte 15) 1263 (build byte 1264 (byte-fields 1265 [4 8] 1266 [0 condition-code])) 1267 (build long offset)))] 1268 [else 1269 (emit-code (op disp code*) 1270 (build byte 15) 1271 (build byte 1272 (byte-fields 1273 [4 8] 1274 [0 condition-code])) 1275 (ax-ea-branch-disp disp))]))) 1276 1277 (define jump-op 1278 (lambda (op ttt-code dest-ea code*) 1279 (emit-code (op dest-ea code*) 1280 (build byte 255) 1281 (ax-ea-modrm-ttt dest-ea ttt-code) 1282 (ax-ea-sib dest-ea) 1283 (ax-ea-addr-disp dest-ea)))) 1284 1285 (define bra-op 1286 (lambda (op disp code*) 1287 (record-case disp 1288 [(label) (offset l) 1289 (if (and (fixnum? offset) (fx<= -128 offset 127)) 1290 (emit-code (op disp code*) 1291 (build byte #b11101011) 1292 (build byte offset)) 1293 (emit-code (op disp code*) 1294 (build byte #b11101001) 1295 (build long offset)))] 1296 [else 1297 (emit-code (op disp code*) 1298 (build byte #b11101001) 1299 (ax-ea-branch-disp disp))]))) 1300 1301 (define bsr-op 1302 (lambda (op disp code*) 1303 (emit-code (op disp code*) 1304 (build byte #b11101000) 1305 (if (pair? disp) 1306 (ax-ea-branch-disp disp) 1307 (build long disp))))) 1308 1309 (define byte-op 1310 (lambda (op op-code code*) 1311 (emit-code (op code*) 1312 (build byte op-code)))) 1313 1314 (define two-byte-op 1315 (lambda (op op-code1 op-code2 code*) 1316 (emit-code (op code*) 1317 (build byte op-code1) 1318 (build byte op-code2)))) 1319 1320 (define byte+short-op 1321 (lambda (op op-code1 t code*) 1322 (emit-code (op code*) 1323 (build byte op-code1) 1324 (build byte (fxand (cadr t) #xFF)) 1325 (build byte (fxsrl (cadr t) 16))))) 1326 1327 (define byte-reg-op1 1328 (lambda (op op-code1 reg code*) 1329 (begin 1330 (unless (ax-register? reg) 1331 ($oops 'assembler-internal "(byte-reg-op) ~s is not a real register" reg)) 1332 (emit-code (op reg code*) 1333 (build byte 1334 (byte-fields 1335 [3 op-code1] 1336 [0 (ax-ea-reg-code reg)])))))) 1337 1338 (define byte-reg-op2 1339 (lambda (op op-code1 op-code2 reg code*) 1340 (begin 1341 (unless (ax-register? reg) 1342 ($oops 'assembler-internal "(byte-reg-op) ~s is not a real register" reg)) 1343 (emit-code (op reg code*) 1344 (build byte op-code1) 1345 (build byte 1346 (byte-fields 1347 [3 op-code2] 1348 [0 (ax-ea-reg-code reg)])))))) 1349 1350 (define-syntax emit-code 1351 (lambda (x) 1352 (define build-maybe-cons* 1353 (lambda (e* e-ls) 1354 (if (null? e*) 1355 e-ls 1356 #`(let ([t #,(car e*)] [ls #,(build-maybe-cons* (cdr e*) e-ls)]) 1357 (if t (cons t ls) ls))))) 1358 (syntax-case x () 1359 [(_ (op opnd ... ?code*) chunk ...) 1360 (build-maybe-cons* #'(chunk ...) 1361 #'(aop-cons* `(asm ,op ,opnd ...) ?code*))]))) 1362 1363 (define-who ax-size-code 1364 (lambda (x) 1365 (case x 1366 [(byte) 0] 1367 [(word) 1] 1368 [(long) 1] 1369 [else (sorry! who "invalid size ~s" x)]))) 1370 1371 (define-syntax build 1372 (syntax-rules () 1373 [(_ x e) 1374 (and (memq (datum x) '(byte word long)) (integer? (datum e))) 1375 (quote (x . e))] 1376 [(_ x e) 1377 (memq (datum x) '(byte word long)) 1378 (cons 'x e)])) 1379 1380 (define-syntax byte-fields 1381 (syntax-rules () 1382 [(byte-fields (n e) ...) 1383 (andmap fixnum? (datum (n ...))) 1384 (fx+ (fxsll e n) ...)])) 1385 1386 (define ax-ea-addr-disp 1387 (lambda (dest-ea) 1388 (record-case dest-ea 1389 [(index) (size index-reg base-reg) 1390 (cond 1391 [(and (eqv? 0 size) (not (eq? base-reg %ebp))) #f] 1392 [(ax-byte-size? size) (build byte size)] 1393 [else (build long size)])] 1394 [(literal@) stuff (cons 'abs stuff)] 1395 [(disp) (size reg) 1396 (cond 1397 [(and (eqv? 0 size) (not (eq? reg %ebp))) #f] ; indirect 1398 [(ax-byte-size? size) (build byte size)] 1399 [else (build long size)])] 1400 [(reg) r #f] 1401 [else ($oops 'assembler-internal "ax-ea-addr-disp dest-ea=~s" dest-ea)]))) 1402 1403 (define ax-ea-sib 1404 (let ([ax-ss-index-base 1405 (lambda (index-reg base-reg) 1406 (build byte 1407 (byte-fields 1408 [6 #b00] ; 2 bits, scaled by bytes. 1409 [3 index-reg] ; 3 bits, index register. 1410 [0 base-reg])))]) ; 3 bits, base register. 1411 (lambda (dest-ea) 1412 (record-case dest-ea 1413 [(index) (size index-reg base-reg) 1414 (ax-ss-index-base (reg-mdinfo index-reg) (reg-mdinfo base-reg))] 1415 [(literal@) (size addr) #f] 1416 [(disp) (size reg) 1417 (and (eq? reg %sp) (ax-ss-index-base #b100 #b100))] 1418 [(reg) r #f] 1419 [else ($oops 'assembler-internal "ax-ea-sib dest-ea=~s" dest-ea)])))) 1420 1421 (define ax-ea-modrm-reg 1422 (lambda (dest-ea reg) 1423 (ax-ea-modrm-ttt dest-ea (ax-ea-reg-code reg)))) 1424 1425 (define ax-ea-modrm-ttt 1426 (letrec 1427 ([ax-mod-ttt-r/m 1428 (lambda (mod ttt r/m) 1429 (build byte 1430 (byte-fields 1431 [6 mod] ; 2 bits 1432 [3 ttt] ; 3 bits 1433 [0 r/m])))] ; 3 bits 1434 [ax-r/m ; 3 bits 1435 (lambda (dest-ea) 1436 (record-case dest-ea 1437 [(index) (size index-reg base-reg) #b100] 1438 [(literal@) (size addr) #b101] 1439 [(disp) (size reg) (reg-mdinfo reg)] 1440 [(reg) r (reg-mdinfo r)] 1441 [else ($oops 'assembler-internal "ax-r/m dest-ea=~s" dest-ea)]))] 1442 [ax-mod ; 2 bits 1443 (lambda (dest-ea) 1444 (record-case dest-ea 1445 [(index) (size index-reg base-reg) 1446 (cond 1447 [(and (eqv? 0 size) (not (eq? base-reg %ebp))) #b00] 1448 [(ax-byte-size? size) #b01] 1449 [else #b10])] 1450 [(literal@) stuff #b00] 1451 [(disp) (size reg) 1452 (cond 1453 [(and (eqv? 0 size) (not (eq? reg %ebp))) #b00] ; indirect 1454 [(ax-byte-size? size) #b01] 1455 [else #b10])] 1456 [(reg) r #b11] 1457 [else ($oops 'assembler-internal "ax-mod dest-ea ~s" dest-ea)]))]) 1458 (lambda (dest-ea ttt) 1459 (ax-mod-ttt-r/m (ax-mod dest-ea) ttt (ax-r/m dest-ea))))) 1460 1461 (define ax-ea-imm-data 1462 (lambda (size imm-data) 1463 (record-case imm-data 1464 [(literal) stuff (cons 'abs stuff)] 1465 [(funcrel) stuff (cons 'funcrel (ax-ea-imm-data 'long stuff))] 1466 [(imm) (n) (cons size n)] 1467 [else ($oops 'assembler-internal 1468 "ax-ea-imm-data imm-data=~s" imm-data)]))) 1469 1470 (define ax-byte-size? 1471 (lambda (n) 1472 (<= -128 n 127))) 1473 1474 (define ax-range? 1475 (lambda (low x high) 1476 (record-case x 1477 [(imm) (n) (<= low n high)] 1478 [else #f]))) 1479 1480 (define ax-ea-branch-disp 1481 (lambda (dest-ea) 1482 (record-case dest-ea 1483 [(literal) stuff (cons 'rel stuff)] 1484 [else ($oops 'assembler-internal 1485 "ax-ea-branch-disp dest-ea=~s" dest-ea)]))) 1486 1487 (define asm-size 1488 (lambda (x) 1489 (case (car x) 1490 [(asm) 0] 1491 [(byte) 1] 1492 [(word) 2] 1493 [else 4]))) 1494 1495 (define shift-address 1496 (lambda (src offset) 1497 (record-case src 1498 [(disp) (imm x1) `(disp ,(fx+ imm offset) ,x1)] 1499 [(index) (imm x2 x1) `(index ,(fx+ imm offset) ,x2 ,x1)] 1500 [else ($oops 'shift-address "unexpected shift-address argument ~s" src)]))) 1501 1502 (define asm-move 1503 (lambda (code* dest src) 1504 (Trivit (dest src) 1505 (record-case src 1506 [(imm) (n) 1507 (if (and (eqv? n 0) (record-case dest [(reg) r #t] [else #f])) 1508 (emit xor dest dest code*) 1509 (emit movi src dest code*))] 1510 [(literal) stuff (emit movi src dest code*)] 1511 [else (emit mov src dest code*)])))) 1512 1513 (define-who asm-move/extend 1514 (lambda (op) 1515 (lambda (code* dest src) 1516 (Trivit (dest src) 1517 (case op 1518 [(sext8) (emit movsb src dest code*)] 1519 [(sext16) (emit movsw src dest code*)] 1520 [(zext8) (emit movzb src dest code*)] 1521 [(zext16) (emit movzw src dest code*)] 1522 [else (sorry! who "unexpected op ~s" op)]))))) 1523 1524 (define asm-movefrom 1525 (lambda (offset) 1526 (lambda (code* dest src) 1527 (Trivit (dest src) 1528 (emit mov (shift-address src offset) dest code*))))) 1529 1530 (define asm-fstpl 1531 (lambda (code* dest) 1532 (Trivit (dest) 1533 (emit fstpl dest code*)))) 1534 1535 (define asm-fstps 1536 (lambda (code* dest) 1537 (Trivit (dest) 1538 (emit fstps dest code*)))) 1539 1540 (define asm-fldl 1541 (lambda (code* src) 1542 (Trivit (src) 1543 (emit fldl src code*)))) 1544 1545 (define asm-flds 1546 (lambda (code* src) 1547 (Trivit (src) 1548 (emit flds src code*)))) 1549 1550 (define asm-fl-cvt 1551 (lambda (op) 1552 (lambda (code* dest-reg src) 1553 (Trivit (src) 1554 (case op 1555 [(single->double) (emit sse.cvtss2sd src (cons 'reg dest-reg) code*)] 1556 [(double->single) (emit sse.cvtsd2ss src (cons 'reg dest-reg) code*)]))))) 1557 1558 (define asm-store-single 1559 (lambda (code* dest flreg) 1560 (Trivit (dest) 1561 (emit sse.movss (cons 'reg flreg) dest code*)))) 1562 1563 (define asm-fpsingle 1564 (lambda (code* dest src) 1565 (Trivit (dest src) 1566 (emit sse.cvtsd2ss src dest 1567 (emit sse.cvtss2sd dest dest code*))))) 1568 1569 (define asm-fpt 1570 (lambda (code* dest src) 1571 (Trivit (dest src) 1572 (emit sse.cvtsi2sd src dest code*)))) 1573 1574 (define asm-fpop-2 1575 (lambda (op) 1576 (lambda (code* dest-reg src1 src2) 1577 (define (emit-it src dest code*) 1578 (case op 1579 [(fp+) (emit sse.addsd src dest code*)] 1580 [(fp-) (emit sse.subsd src dest code*)] 1581 [(fp*) (emit sse.mulsd src dest code*)] 1582 [(fp/) (emit sse.divsd src dest code*)])) 1583 (cond 1584 [(eq? dest-reg src1) 1585 (Trivit (dest-reg src2) 1586 (emit-it src2 dest-reg code*))] 1587 [(eq? dest-reg src2) 1588 (if (memq op '(fp+ fp*)) 1589 (Trivit (dest-reg src1) 1590 (emit-it src1 dest-reg code*)) 1591 (Trivit (dest-reg src1 src2) 1592 (emit sse.movsd src2 (cons 'reg %fptmp1) 1593 (emit sse.movsd src1 dest-reg 1594 (emit-it (cons 'reg %fptmp1) dest-reg code*)))))] 1595 [else 1596 (Trivit (dest-reg src1 src2) 1597 (emit sse.movsd src1 dest-reg 1598 (emit-it src2 dest-reg code*)))])))) 1599 1600 (define asm-fpsqrt 1601 (lambda (code* dest-reg src) 1602 (Trivit (dest-reg src) 1603 (emit sse.sqrtsd src dest-reg code*)))) 1604 1605 (define asm-fpmove 1606 (lambda (code* dest src) 1607 (Trivit (dest src) 1608 (emit sse.movsd src dest code*)))) 1609 1610 (define asm-fpmovefrom 1611 (lambda (code* dest src1 src2) 1612 (Trivit (dest src1 src2) 1613 (emit mov src1 dest 1614 (emit mov src2 (shift-address dest 4) code*))))) 1615 1616 (define asm-fpcastfrom 1617 (lambda (code* dest-reg src1 src2) 1618 (Trivit (dest-reg src1 src2) 1619 (emit sse.movd src1 dest-reg 1620 (emit sse.movd src2 (cons 'reg %fptmp1) 1621 (emit sse.psllq (cons 'reg %fptmp1) 32 1622 (emit sse.orpd (cons 'reg %fptmp1) dest-reg code*))))))) 1623 1624 (define asm-fpcastto 1625 (lambda (shift) 1626 (lambda (code* dest src) 1627 (Trivit (dest src) 1628 (cond 1629 [(eqv? shift 0) 1630 (emit sse.movd src dest code*)] 1631 [else 1632 (emit sse.movsd src (cons 'reg %fptmp1) 1633 (emit sse.psrlq (cons 'reg %fptmp1) shift 1634 (emit sse.movd (cons 'reg %fptmp1) dest code*)))]))))) 1635 1636 (define asm-fptrunc 1637 (lambda (code* dest src) 1638 (Trivit (dest src) 1639 (emit sse.cvttsd2si src dest code*)))) 1640 1641 (define asm-load 1642 (lambda (type) 1643 (lambda (code* dest base index offset) 1644 (Trivit (dest) 1645 (let ([src (build-mem-opnd base index offset)]) 1646 (case type 1647 [(integer-32 unsigned-32) (emit mov src dest code*)] 1648 [(integer-16) (emit movsw src dest code*)] 1649 [(unsigned-16) (emit movzw src dest code*)] 1650 [(integer-8) (emit movsb src dest code*)] 1651 [(unsigned-8) (emit movzb src dest code*)] 1652 [else (sorry! 'asm-load "unexpected mref type ~s" type)])))))) 1653 1654 (define asm-store 1655 (lambda (type) 1656 (lambda (code* base index offset src) 1657 (define imm8 (lambda (n) `(imm ,(modulo n #x100)))) 1658 (define imm16 (lambda (n) `(imm ,(modulo n #x10000)))) 1659 (Trivit (src) 1660 (let ([dest (build-mem-opnd base index offset)]) 1661 (record-case src 1662 [(imm) (n) 1663 (case type 1664 [(integer-32 unsigned-32) (emit movi src dest code*)] 1665 [(integer-16 unsigned-16) (emit moviw (imm16 n) dest code*)] 1666 [(integer-8 unsigned-8) (emit movib (imm8 n) dest code*)] 1667 [else (sorry! 'asm-store "unexpected mset! type ~s" type)])] 1668 [(literal) stuff 1669 (case type 1670 [(integer-32 unsigned-32) (emit movi src dest code*)] 1671 [(integer-16 unsigned-16) (emit moviw src dest code*)] 1672 [(integer-8 unsigned-8) (emit movib src dest code*)] 1673 [else (sorry! 'asm-store "unexpected mset! type ~s" type)])] 1674 [else 1675 (case type 1676 [(integer-32 unsigned-32) (emit mov src dest code*)] 1677 [(integer-16 unsigned-16) (emit movw src dest code*)] 1678 [(integer-8 unsigned-8) (emit movb src dest code*)] 1679 [else (sorry! 'asm-store "unexpected mset! type ~s" type)])])))))) 1680 1681 (define asm-swap 1682 (lambda (type) 1683 (lambda (code* dest src) 1684 (Trivit (dest) 1685 (safe-assert (equal? (Triv->rand src) dest)) 1686 (emit bswap dest 1687 (case type 1688 [(integer-16) (emit asri '(imm 16) dest code*)] 1689 [(unsigned-16) (emit lsri '(imm 16) dest code*)] 1690 [(integer-32 unsigned-32) code*] 1691 [else ($oops 'assembler-internal "unexpected asm-swap type argument ~s" type)])))))) 1692 1693 (define asm-mul 1694 (lambda (code* dest src0 src1) 1695 (Trivit (dest src1) 1696 (safe-assert (equal? (Triv->rand src0) dest)) 1697 (emit muls src1 dest code*)))) 1698 1699 (define asm-div 1700 (lambda (code* dest-eax src-eax src-edx src2) 1701 (Trivit (src2) 1702 (safe-assert (and (eq? dest-eax %eax) (eq? src-eax %eax) (eq? src-edx %edx))) 1703 (emit divsax src2 code*)))) 1704 1705 (define asm-sext-eax->edx 1706 (lambda (code* dest-edx src-eax) 1707 (safe-assert (and (eq? dest-edx %edx) (eq? src-eax %eax))) 1708 (emit extad code*))) 1709 1710 (define asm-muli 1711 (lambda (code* dest src0 src1) 1712 (Trivit (dest src0 src1) 1713 (emit mulsi src1 src0 dest code*)))) 1714 1715 (define-who asm-addop 1716 (lambda (op) 1717 (case op 1718 [(+) asm-add] 1719 [(logand) asm-logand] 1720 [(logor) asm-logor] 1721 [(logxor) asm-logxor] 1722 [else ($oops who "unsupported op ~s" op)]))) 1723 1724 (define asm-add 1725 (lambda (code* dest src0 src1) 1726 (Trivit (dest src1) 1727 (safe-assert (equal? (Triv->rand src0) dest)) 1728 (record-case src1 1729 [(imm literal) stuff (emit addi src1 dest code*)] 1730 [else (emit add src1 dest code*)])))) 1731 1732 (define asm-read-performance-monitoring-counter 1733 (lambda (code* dest src) 1734 ; edx is an implied dest and included in info's kill list 1735 (safe-assert (eq? dest %eax)) 1736 (safe-assert (eq? src %ecx)) 1737 (emit rdpmc code*))) 1738 1739 (define asm-read-time-stamp-counter 1740 (lambda (code* dest) 1741 ; edx is an implied dest and included in info's kill list 1742 (safe-assert (eq? dest %eax)) 1743 (emit rdtsc code*))) 1744 1745 (define asm-inc-profile-counter 1746 (lambda (code* dest src) 1747 (Trivit (dest src) 1748 (record-case src 1749 [(imm) (n) (if (eqv? n 1) (emit inc dest code*) (emit addi src dest code*))] 1750 [(literal) stuff (emit addi src dest code*)] 1751 [else (emit add src dest code*)])))) 1752 1753 (define-who asm-inc-cc-counter 1754 (lambda (code* base offset val) 1755 (let-values ([(lo-dest hi-dest) 1756 (nanopass-case (L16 Triv) offset 1757 [(immediate ,imm) 1758 (values `(disp ,imm ,base) `(disp ,(+ imm (constant ptr-bytes)) ,base))] 1759 [,x (values `(index 0 ,x ,base) `(index ,(constant ptr-bytes) ,x ,base))] 1760 [else ($oops who "unexpected increment offset ~s" offset)])]) 1761 (let ([code* (emit adci '(imm 0) hi-dest code*)]) 1762 (nanopass-case (L16 Triv) val 1763 [(immediate ,imm) (emit addi `(imm ,imm) lo-dest code*)] 1764 [,x (emit add (cons 'reg x) lo-dest code*)] 1765 [else ($oops who "unsupported increment ~s" val)]))))) 1766 1767 (define asm-sub 1768 (lambda (code* dest src0 src1) 1769 (Trivit (dest src1) 1770 (safe-assert (equal? (Triv->rand src0) dest)) 1771 (record-case src1 1772 [(imm literal) stuff (emit subi src1 dest code*)] 1773 [else (emit sub src1 dest code*)])))) 1774 1775 (define asm-negate 1776 (lambda (code* dest src) 1777 (Trivit (dest) 1778 (safe-assert (equal? (Triv->rand src) dest)) 1779 (emit neg dest code*)))) 1780 1781 (define asm-sub-negate 1782 (lambda (code* dest src0 src1) 1783 (Trivit (dest src1) 1784 (safe-assert (equal? (Triv->rand src0) dest)) 1785 (let ([code* (emit neg dest code*)]) 1786 (record-case src1 1787 [(imm literal) stuff (emit subi src1 dest code*)] 1788 [else (emit sub src1 dest code*)]))))) 1789 1790 (define asm-pop 1791 (lambda (code* dest) 1792 (Trivit (dest) 1793 (emit pop dest code*)))) 1794 1795 (define asm-return 1796 (lambda () 1797 (constant-case machine-type-name 1798 ; remove padding added by asm-enter 1799 [(i3nt ti3nt) (emit ret '())] 1800 [else (emit addi '(imm 12) (cons 'reg %sp) (emit ret '()))]))) 1801 1802 (define asm-c-return 1803 (lambda (info) 1804 (if (info-c-return? info) 1805 (let ([offset (info-c-return-offset info)]) 1806 (safe-assert (<= 0 offset #xFFFF)) 1807 (emit retl `(imm ,offset) '())) 1808 (emit ret '())))) 1809 1810 ;; debugging helper; use as `(%inline check-stack-align)` 1811 (define asm-check-stack-align 1812 (lambda (code*) 1813 (emit testi (list 'imm 15) (cons 'reg %sp) 1814 (emit beq `(label 1 #f) 1815 (emit int3 code*))))) 1816 1817 (define asm-locked-incr 1818 (lambda (code* base index offset) 1819 (let ([dest (build-mem-opnd base index offset)]) 1820 (emit locked-inc dest code*)))) 1821 1822 (define asm-locked-decr 1823 (lambda (code* base index offset) 1824 (let ([dest (build-mem-opnd base index offset)]) 1825 (emit locked-dec dest code*)))) 1826 1827 (define asm-locked-cmpxchg 1828 (lambda (code* base index offset old-v new-v) 1829 (let ([dest (build-mem-opnd base index offset)]) 1830 (emit locked-cmpxchg dest (cons 'reg new-v) code*)))) 1831 1832 (define asm-pause 1833 (lambda (code*) 1834 (emit pause code*))) 1835 1836 (define asm-exchange 1837 (lambda (code* dest src0 src1) 1838 (Trivit (dest src1) 1839 (safe-assert (equal? (Triv->rand src0) dest)) 1840 (emit xchg src1 dest code*)))) 1841 1842 (define-who asm-shiftop 1843 (lambda (op) 1844 (case op 1845 [(sll) asm-sll] 1846 [(srl) asm-srl] 1847 [(sra) asm-sra] 1848 [else ($oops who "unsupported op ~s" op)]))) 1849 1850 (define asm-sll 1851 (lambda (code* dest src0 src1) 1852 (Trivit (dest src1) 1853 (safe-assert (equal? (Triv->rand src0) dest)) 1854 (record-case src1 1855 [(imm literal) stuff (emit asli src1 dest code*)] 1856 [else 1857 (safe-assert (ax-register? src1 %ecx)) 1858 (emit asl dest code*)])))) 1859 1860 (define asm-srl 1861 (lambda (code* dest src0 src1) 1862 (Trivit (dest src1) 1863 (safe-assert (equal? (Triv->rand src0) dest)) 1864 (record-case src1 1865 [(imm literal) stuff (emit lsri src1 dest code*)] 1866 [else 1867 (safe-assert (ax-register? src1 %ecx)) 1868 (emit lsr dest code*)])))) 1869 1870 (define asm-sra 1871 (lambda (code* dest src0 src1) 1872 (Trivit (dest src1) 1873 (safe-assert (equal? (Triv->rand src0) dest)) 1874 (record-case src1 1875 [(imm literal) stuff (emit asri src1 dest code*)] 1876 [else 1877 (safe-assert (ax-register? src1 %ecx)) 1878 (emit asr dest code*)])))) 1879 1880 (define asm-logand 1881 (lambda (code* dest src0 src1) 1882 (Trivit (dest src1) 1883 (safe-assert (equal? (Triv->rand src0) dest)) 1884 (record-case src1 1885 [(imm literal) stuff (emit andi src1 dest code*)] 1886 [else (emit and src1 dest code*)])))) 1887 1888 (define asm-logor 1889 (lambda (code* dest src0 src1) 1890 (Trivit (dest src1) 1891 (safe-assert (equal? (Triv->rand src0) dest)) 1892 (record-case src1 1893 [(imm literal) stuff (emit ori src1 dest code*)] 1894 [else (emit or src1 dest code*)])))) 1895 1896 (define asm-logxor 1897 (lambda (code* dest src0 src1) 1898 (Trivit (dest src1) 1899 (safe-assert (equal? (Triv->rand src0) dest)) 1900 (record-case src1 1901 [(imm literal) stuff (emit xori src1 dest code*)] 1902 [else (emit xor src1 dest code*)])))) 1903 1904 (define asm-lognot 1905 (lambda (code* dest src) 1906 (Trivit (dest) 1907 (safe-assert (equal? (Triv->rand src) dest)) 1908 (emit not dest code*)))) 1909 1910 (define asm-lea1 1911 (lambda (offset) 1912 (rec asm-lea1-internal 1913 (lambda (code* dest src) 1914 (if (eq? src dest) 1915 (Trivit (dest) 1916 (emit addi `(imm ,offset) dest code*)) 1917 (Trivit (dest) 1918 (emit lea `(disp ,offset ,src) dest code*))))))) 1919 1920 (define asm-lea2 1921 (lambda (offset) 1922 (rec asm-lea2-internal 1923 (lambda (code* dest src1 src2) 1924 (cond 1925 [(and (eq? src1 dest) (fx= offset 0)) 1926 (Trivit (dest src2) 1927 (emit add src2 dest code*))] 1928 [(and (eq? src2 dest) (fx= offset 0)) 1929 (Trivit (dest src1) 1930 (emit add src1 dest code*))] 1931 [else 1932 (Trivit (dest) 1933 (emit lea `(index ,offset ,src1 ,src2) 1934 dest code*))]))))) 1935 1936 (define asm-logtest 1937 (lambda (i? info) 1938 (lambda (l1 l2 offset x y) 1939 (Trivit (x y) 1940 (safe-assert 1941 (record-case x 1942 [(disp reg index literal@) stuff #t] 1943 [else #f])) 1944 (values 1945 (record-case y 1946 [(imm) (n) 1947 (if (and (fixnum? n) 1948 (fx= (fxlogand n #xff) n) 1949 (record-case x 1950 [(reg) r (byte-register? r)] 1951 ; counting on little-endian byte order 1952 [(disp index literal@) stuff #t])) 1953 (emit testib y x '()) 1954 (emit testi y x '()))] 1955 [(literal) stuff (emit testi y x '())] 1956 [else (emit test x y '())]) 1957 (let-values ([(l1 l2) (if i? (values l2 l1) (values l1 l2))]) 1958 (asm-conditional-jump info l2 l1 offset))))))) 1959 1960 (define asm-fp-relop 1961 (lambda (info) 1962 (lambda (l1 l2 offset x y) 1963 (values 1964 (Trivit (x y) 1965 (emit sse.ucomisd x y '())) 1966 (asm-conditional-jump info l1 l2 offset))))) 1967 1968 (define asm-relop 1969 (lambda (info) 1970 (rec asm-relop-internal 1971 (lambda (l1 l2 offset x y) 1972 (Trivit (x y) 1973 (safe-assert 1974 (record-case x 1975 [(reg disp index literal@) ignore #t] 1976 [else #f])) 1977 (values 1978 (record-case y 1979 [(imm literal) stuff (emit cmpi y x '())] 1980 [else (emit cmp y x '())]) 1981 (asm-conditional-jump info l1 l2 offset))))))) 1982 1983 (define asm-condition-code 1984 (lambda (info) 1985 (rec asm-check-flag-internal 1986 (lambda (l1 l2 offset) 1987 (values '() (asm-conditional-jump info l1 l2 offset)))))) 1988 1989 ; TODO: should this also handle pushil? 1990 (define asm-push 1991 (lambda (code* x) 1992 (Trivit (x) 1993 (emit push x code*)))) 1994 1995 (define asm-save-flrv 1996 (lambda (code*) 1997 ; we normally need 8 to store the floating point return variable, but 1998 ; on some OS's we need 16 in order to get the required 16-byte alignment 1999 (emit subi `(imm ,(constant-case machine-type-name [(i3nt ti3nt) 8] [else 16])) 2000 (cons 'reg %sp) 2001 (emit fstpl `(disp 0 ,%sp) code*)))) 2002 2003 (define asm-restore-flrv 2004 (lambda (code*) 2005 ; we normally need 8 to store the floating point return variable, but 2006 ; on some OS's we need 16 in order to get the required 16-byte alignment 2007 (emit fldl `(disp 0 ,%sp) 2008 (emit addi `(imm ,(constant-case machine-type-name [(i3nt ti3nt) 8] [else 16])) 2009 (cons 'reg %sp) code*)))) 2010 2011 (define asm-library-jump 2012 (lambda (l) 2013 (emit bra 2014 `(literal ,(constant code-data-disp) (library-code ,(libspec-label-libspec l))) 2015 '()))) 2016 2017 (define asm-library-call 2018 (lambda (libspec) 2019 (let ([target `(literal ,(constant code-data-disp) (library-code ,libspec))]) 2020 (rec asm-asm-call-internal 2021 (lambda (code* . ignore) ; ignore arguments, which must be in fixed locations 2022 (emit bsr target code*)))))) 2023 2024 (define asm-c-simple-call 2025 (lambda (entry) 2026 (let ([target `(literal 0 (entry ,entry))]) 2027 (rec asm-c-simple-call-internal 2028 (lambda (code*) 2029 (emit bsr target code*)))))) 2030 2031 (define asm-get-tc 2032 (let ([target `(literal 0 (entry ,(lookup-c-entry get-thread-context)))]) 2033 (lambda (code* dest) ; dest is ignored, since it is always the first C result (eax in this case) 2034 (emit bsr target code*)))) 2035 2036 (define asm-activate-thread 2037 (let ([target `(literal 0 (entry ,(lookup-c-entry activate-thread)))]) 2038 (lambda (code* dest) ; dest is ignored, as in asm-get-tc 2039 (emit bsr target code*)))) 2040 2041 (define asm-deactivate-thread 2042 (let ([target `(literal 0 (entry ,(lookup-c-entry deactivate-thread)))]) 2043 (lambda (code*) 2044 (emit bsr target code*)))) 2045 2046 (define asm-unactivate-thread 2047 (let ([target `(literal 0 (entry ,(lookup-c-entry unactivate-thread)))]) 2048 (lambda (code*) 2049 (emit bsr target code*)))) 2050 2051 (define asm-indirect-call 2052 (lambda (code* t) 2053 (Trivit (t) 2054 (emit call t code*)))) 2055 2056 (define asm-direct-jump 2057 (lambda (l offset) 2058 (let ([offset (adjust-return-point-offset offset l)]) 2059 (emit bra (make-funcrel 'literal l offset) '())))) 2060 2061 (define asm-literal-jump 2062 (lambda (info) 2063 (emit bra 2064 `(literal ,(info-literal-offset info) (,(info-literal-type info) ,(info-literal-addr info))) 2065 '()))) 2066 2067 (define asm-indirect-jump 2068 (lambda (t) 2069 (Trivit (t) 2070 (emit jmp t '())))) 2071 2072 (define-who asm-return-address 2073 (lambda (dest l incr-offset next-addr) 2074 ; no pc-relative addressing on x86 (except via call/pop), 2075 ; so just use move and let the linker hook it up 2076 (make-rachunk dest l incr-offset next-addr 2077 (asm-move '() dest (with-output-language (L16 Triv) `(label-ref ,l ,incr-offset)))))) 2078 2079 (define asm-jump 2080 (lambda (l next-addr) 2081 (make-gchunk l next-addr 2082 (cond 2083 [(local-label-offset l) => 2084 (lambda (offset) 2085 (let ([disp (fx- next-addr offset)]) 2086 (if (fx= disp 0) 2087 '() 2088 (emit bra `(label ,disp ,l) '()))))] 2089 [else 2090 ; label must be somewhere above. generate something so that a hard loop 2091 ; doesn't get dropped. this also has some chance of being the right size 2092 ; for the final branch instruction. 2093 (emit bra `(label 0 ,l) '())])))) 2094 2095 (define-who asm-conditional-jump 2096 (lambda (info l1 l2 next-addr) 2097 (define get-disp-opnd 2098 (lambda (next-addr l) 2099 (cond 2100 [(and (local-label? l) (local-label-offset l)) => 2101 (lambda (offset) 2102 (let ([disp (fx- next-addr offset)]) 2103 (values disp `(label ,disp ,l))))] 2104 [(libspec-label? l) 2105 (values 0 `(literal ,(constant code-data-disp) (library-code ,(libspec-label-libspec l))))] 2106 [else (values 0 `(label 0 ,l))]))) 2107 (let ([type (info-condition-code-type info)] 2108 [reversed? (info-condition-code-reversed? info)]) 2109 (make-cgchunk info l1 l2 next-addr 2110 (let () 2111 (define-syntax pred-case 2112 (lambda (x) 2113 (define build-bop-seq 2114 (lambda (bop opnd1 opnd2 l2 body) 2115 #`(let ([code* (emit #,bop #,opnd1 code*)]) 2116 (let-values ([(disp #,opnd2) (get-disp-opnd (fx+ next-addr (asm-size* code*)) #,l2)]) 2117 #,body)))) 2118 (define handle-or 2119 (lambda (e opnd l) 2120 (syntax-case e (or) 2121 [(or bop1 bop2) 2122 (build-bop-seq #'bop2 opnd opnd l 2123 #`(emit bop1 #,opnd code*))] 2124 [bop #`(emit bop #,opnd code*)]))) 2125 (define handle-reverse 2126 (lambda (e opnd l) 2127 (syntax-case e (r?) 2128 [(r? c1 c2) #`(if reversed? #,(handle-or #'c1 opnd l) #,(handle-or #'c2 opnd l))] 2129 [_ (handle-or e opnd l)]))) 2130 (define handle-inverse 2131 (lambda (e) 2132 (syntax-case e (i?) 2133 [(i? c1 c2) 2134 #`(cond 2135 [(fx= disp1 0) #,(handle-reverse #'c1 #'opnd2 #'l2)] 2136 [(fx= disp2 0) #,(handle-reverse #'c2 #'opnd1 #'l1)] 2137 [else #,(build-bop-seq #'bra #'opnd2 #'opnd1 #'l1 2138 (handle-reverse #'c2 #'opnd1 #'l1))])] 2139 [_ #`(cond ; treating e as c1: inverted condition, branching to false label 2140 [(fx= disp1 0) #,(handle-reverse e #'opnd2 #'l2)] 2141 [else #,(build-bop-seq #'bra #'opnd1 #'opnd2 #'l2 2142 (handle-reverse e #'opnd2 #'l2))])]))) 2143 (syntax-case x () 2144 [(_ [(pred ...) cl-body] ...) 2145 (with-syntax ([(cl-body ...) (map handle-inverse #'(cl-body ...))]) 2146 #'(let ([code* '()]) 2147 (let-values ([(disp1 opnd1) (get-disp-opnd next-addr l1)] 2148 [(disp2 opnd2) (get-disp-opnd next-addr l2)]) 2149 (case type 2150 [(pred ...) cl-body] ... 2151 [else ($oops who "~s branch type is currently unsupported" type)]))))]))) 2152 (pred-case 2153 [(eq?) (i? bne beq)] 2154 [(u<) (i? (r? bls bcc) (r? bhi bcs))] 2155 [(<) (i? (r? ble bge) (r? bgt blt))] 2156 [(<=) (i? (r? blt bgt) (r? bge ble))] 2157 [(>) (i? (r? bge ble) (r? blt bgt))] 2158 [(>=) (i? (r? bgt blt) (r? ble bge))] 2159 [(overflow multiply-overflow) (i? bvc bvs)] 2160 [(positive) (i? ble bgt)] 2161 [(carry) (i? bcc bcs)] 2162 ; unordered: zf,pf,cf <- 111; gt: 000; lt: 001; eq: 100 2163 ; reversed & inverted: !(fl< y x) = !(fl> x y) iff zf = 1 & cf = 1 2164 [(fp<) bls] 2165 ; reversed & inverted: !(fl<= y x) = !(fl>= x y) iff cf = 1 2166 [(fp<=) bcs] 2167 ; inverted: !(fl= x y) iff zf = 0 or cf (or pf) = 1 2168 [(fp=) (or bne bcs)])))))) 2169 2170 (constant-case machine-type-name 2171 [(i3nt ti3nt) (define asm-enter values)] 2172 [else 2173 (define-syntax asm-enter 2174 (lambda (x) 2175 (syntax-case x () 2176 [(k e) 2177 (with-implicit (k %seq %inline) 2178 #'(%seq 2179 ; adjust to 16-byte boundary, accounting for 4-byte return address pushed by call 2180 (set! ,%sp ,(%inline - ,%sp (immediate 12))) 2181 ,e))])))]) 2182 2183 (define callee-expects-result-pointer? 2184 (lambda (result-type) 2185 (nanopass-case (Ltype Type) result-type 2186 [(fp-ftd& ,ftd) (constant-case machine-type-name 2187 [(i3osx ti3osx i3nt ti3nt) 2188 (case ($ftd-size ftd) 2189 [(1 2 4 8) #f] 2190 [else #t])] 2191 [else ($ftd-compound? ftd)])] 2192 [else #f]))) 2193 (define callee-pops-result-pointer? 2194 (lambda (result-type) 2195 (callee-expects-result-pointer? result-type))) 2196 (define fill-result-pointer-from-registers? 2197 (lambda (result-type) 2198 (nanopass-case (Ltype Type) result-type 2199 [(fp-ftd& ,ftd) (not (callee-expects-result-pointer? result-type))] 2200 [else #f]))) 2201 2202 (module (push-registers pop-registers push-registers-size) 2203 (define (move-registers regs fp-reg-count load? offset e) 2204 (with-output-language (L13 Effect) 2205 (cond 2206 [(fx> fp-reg-count 0) 2207 (let ([offset (fx- offset 8)]) 2208 (move-registers regs (fx- fp-reg-count 1) load? offset 2209 (cond 2210 [load? `(seq ,(%inline fldl ,(%mref ,%sp ,%zero ,offset fp)) ,e)] 2211 [else `(seq ,e (set! ,(%mref ,%sp ,%zero ,offset fp) ,(%inline fstpl)))])))] 2212 [(pair? regs) 2213 (let ([offset (fx- offset 4)]) 2214 (move-registers (cdr regs) 0 load? offset 2215 (cond 2216 [load? `(seq (set! ,(car regs) ,(%mref ,%sp ,offset)) ,e)] 2217 [else `(seq ,e (set! ,(%mref ,%sp ,offset) ,(car regs)))])))] 2218 [else e]))) 2219 (define (push-registers-size regs fp-reg-count arg-count) 2220 ;; Align with the expectation that `arg-count` arguments 2221 ;; will be pushed later, before a function call 2222 (let ([offset (fx+ (fx* 4 (length regs)) (fx* 8 fp-reg-count))]) 2223 (constant-case machine-type-name 2224 [(i3nt ti3nt) offset] 2225 [else 2226 (fx- (fxlogand (fx+ offset (fx* 4 arg-count) 15) -16) 2227 (fx* 4 arg-count))]))) 2228 (define (push-registers regs fp-reg-count arg-count) 2229 (let ([offset (push-registers-size regs fp-reg-count arg-count)]) 2230 (move-registers regs fp-reg-count #f offset 2231 (with-output-language (L13 Effect) 2232 `(set! ,%sp ,(%inline - ,%sp (immediate ,offset))))))) 2233 (define (pop-registers regs fp-reg-count arg-count) 2234 (let ([offset (push-registers-size regs fp-reg-count arg-count)]) 2235 (move-registers regs fp-reg-count #t offset 2236 (with-output-language (L13 Effect) 2237 `(set! ,%sp ,(%inline + ,%sp (immediate ,offset)))))))) 2238 2239 (define asm-foreign-call 2240 (with-output-language (L13 Effect) 2241 (letrec ([load-double-stack 2242 (lambda (offset) 2243 (lambda (x) ; unboxed 2244 `(set! ,(%mref ,%sp ,%zero ,offset fp) ,x)))] 2245 [load-single-stack 2246 (lambda (offset) 2247 (lambda (x) ; unboxed 2248 (%inline store-double->single ,(%mref ,%sp ,%zero ,offset fp) ,x)))] 2249 [load-stack 2250 (lambda (offset) 2251 (lambda (rhs) ; requires rhs 2252 `(set! ,(%mref ,%sp ,offset) ,rhs)))] 2253 [load-stack64 2254 (lambda (offset) 2255 (lambda (lorhs hirhs) ; requires rhs 2256 (%seq 2257 (set! ,(%mref ,%sp ,offset) ,lorhs) 2258 (set! ,(%mref ,%sp ,(fx+ offset 4)) ,hirhs))))] 2259 [load-content 2260 (lambda (offset len) 2261 (lambda (x) ; requires var 2262 (let loop ([offset offset] [x-offset 0] [len len]) 2263 (cond 2264 [(= len 0) `(nop)] 2265 [(>= len 4) 2266 `(seq 2267 (set! ,(%mref ,%sp ,offset) (inline ,(make-info-load 'integer-32 #f) 2268 ,%load ,x ,%zero (immediate ,x-offset))) 2269 ,(loop (fx+ offset 4) (fx+ x-offset 4) (fx- len 4)))] 2270 [(>= len 2) 2271 (%seq 2272 (set! ,%eax (inline ,(make-info-load 'integer-16 #f) 2273 ,%load ,x ,%zero (immediate ,x-offset))) 2274 (inline ,(make-info-load 'integer-16 #f) 2275 ,%store ,%sp ,%zero (immediate ,offset) 2276 ,%eax) 2277 ,(loop (fx+ offset 2) (fx+ x-offset 2) (fx- len 2)))] 2278 [else 2279 (%seq 2280 (set! ,%eax (inline ,(make-info-load 'integer-8 #f) 2281 ,%load ,x ,%zero (immediate ,x-offset))) 2282 (inline ,(make-info-load 'integer-8 #f) 2283 ,%store ,%sp ,%zero (immediate ,offset) 2284 ,%eax))]))))] 2285 [do-stack 2286 (lambda (types locs n result-type) 2287 (if (null? types) 2288 (values n locs) 2289 (nanopass-case (Ltype Type) (car types) 2290 [(fp-double-float) 2291 (do-stack (cdr types) 2292 (cons (load-double-stack n) locs) 2293 (fx+ n 8) 2294 #f)] 2295 [(fp-single-float) 2296 (do-stack (cdr types) 2297 (cons (load-single-stack n) locs) 2298 (fx+ n 4) 2299 #f)] 2300 [(fp-ftd& ,ftd) 2301 (do-stack (cdr types) 2302 (cons (load-content n ($ftd-size ftd)) locs) 2303 (fx+ n (fxlogand (fx+ ($ftd-size ftd) 3) -4)) 2304 #f)] 2305 [(fp-ftd ,ftd) 2306 (cond 2307 [(and result-type 2308 (fill-result-pointer-from-registers? result-type)) 2309 ;; Callee doesn't expect this argument; move 2310 ;; it to the end just to save it for filling 2311 ;; when the callee returns 2312 (let ([end-n 0]) 2313 (with-values (do-stack (cdr types) 2314 (cons (lambda (rhs) 2315 ((load-stack end-n) rhs)) 2316 locs) 2317 n 2318 #f) 2319 (lambda (frame-size locs) 2320 (set! end-n frame-size) 2321 (values (fx+ frame-size 4) locs))))] 2322 [else 2323 (do-stack (cdr types) 2324 (cons (load-stack n) locs) 2325 (fx+ n 4) 2326 #f)])] 2327 [else 2328 (if (nanopass-case (Ltype Type) (car types) 2329 [(fp-integer ,bits) (fx= bits 64)] 2330 [(fp-unsigned ,bits) (fx= bits 64)] 2331 [else #f]) 2332 (do-stack (cdr types) 2333 (cons (load-stack64 n) locs) 2334 (fx+ n 8) 2335 #f) 2336 (do-stack (cdr types) 2337 (cons (load-stack n) locs) 2338 (fx+ n 4) 2339 #f))])))]) 2340 (define (get-result-registers fill-result-here? result-type) 2341 (cond 2342 [fill-result-here? 2343 (let* ([ftd (nanopass-case (Ltype Type) result-type 2344 [(fp-ftd& ,ftd) ftd])] 2345 [size ($ftd-size ftd)]) 2346 (case size 2347 [(4) 2348 (cond 2349 [(and (if-feature windows (not ($ftd-compound? ftd)) #t) 2350 (equal? '((float 4 0)) ($ftd->members ftd))) 2351 (values '() 1)] 2352 [else (values (reg-list %eax) 0)])] 2353 [(8) 2354 (cond 2355 [(and (if-feature windows (not ($ftd-compound? ftd)) #t) 2356 (equal? '((float 8 0)) ($ftd->members ftd))) 2357 (values '() 1)] 2358 [else (values (reg-list %eax %edx) 0)])] 2359 [else (values (reg-list %eax) 0)]))] 2360 [else 2361 (nanopass-case (Ltype Type) result-type 2362 [(fp-double-float) (values '() 1)] 2363 [(fp-single-float) (values '() 1)] 2364 [(fp-integer ,bits) 2365 (case bits 2366 [(64) (values (reg-list %eax %edx) 0)] 2367 [else (values (reg-list %eax) 0)])] 2368 [(fp-unsigned ,bits) 2369 (case bits 2370 [(64) (values (reg-list %eax %edx) 0)] 2371 [else (values (reg-list %eax) 0)])] 2372 [(fp-void) (values '() 0)] 2373 [else (values (reg-list %eax) 0)])])) 2374 (define (add-deactivate adjust-active? fill-result-here? t0 result-type e) 2375 (cond 2376 [adjust-active? 2377 (let-values ([(result-regs result-fp-count) (get-result-registers fill-result-here? result-type)]) 2378 (let ([save-and-restore 2379 (lambda (regs fp-count e) 2380 (cond 2381 [(and (null? regs) (fx= 0 fp-count)) e] 2382 [else (%seq 2383 ,(push-registers regs fp-count 0) 2384 ,e 2385 ,(pop-registers regs fp-count 0))]))]) 2386 (%seq 2387 (set! ,%edx ,t0) 2388 ,(save-and-restore (list %edx) 0 (%inline deactivate-thread)) 2389 ,e 2390 ,(save-and-restore result-regs result-fp-count `(set! ,%eax ,(%inline activate-thread))))))] 2391 [else e])) 2392 (define (add-cleanup-compensate result-type e) 2393 ;; The convention for the calle to pop the return-pointer argument makes a mess, 2394 ;; especially for alignment, so counteract it right away 2395 (if (callee-pops-result-pointer? result-type) 2396 (%seq 2397 ,e 2398 (set! ,%sp ,(%inline - ,%sp ,(%constant ptr-bytes)))) 2399 e)) 2400 (define returnem 2401 (lambda (conv* orig-frame-size locs result-type ccall r-loc) 2402 (let ([frame-size (constant-case machine-type-name 2403 ; maintain 16-byte alignment not including the return address pushed 2404 ; by the call instruction, which counts as part of callee's frame 2405 [(i3nt ti3nt) orig-frame-size] 2406 [else (fxlogand (fx+ orig-frame-size 15) -16)])]) 2407 (values (lambda () 2408 (if (fx= frame-size 0) 2409 `(nop) 2410 `(set! ,%sp ,(%inline - ,%sp (immediate ,frame-size))))) 2411 (reverse locs) 2412 ccall 2413 r-loc 2414 ; Windows __stdcall convention requires callee to clean up 2415 (lambda () 2416 (if (or (fx= frame-size 0) (memq 'i3nt-stdcall conv*) (memq 'i3nt-com conv*)) 2417 `(nop) 2418 `(set! ,%sp ,(%inline + ,%sp (immediate ,frame-size))))))))) 2419 (lambda (info) 2420 (safe-assert (reg-callee-save? %tc)) ; no need to save-restore 2421 (let ([conv* (info-foreign-conv* info)] 2422 [arg-type* (info-foreign-arg-type* info)] 2423 [result-type (info-foreign-result-type info)]) 2424 (with-values (do-stack arg-type* '() 0 result-type) 2425 (lambda (frame-size locs) 2426 (returnem conv* frame-size locs result-type 2427 (lambda (t0 not-varargs?) 2428 (let* ([fill-result-here? (fill-result-pointer-from-registers? result-type)] 2429 [adjust-active? (if-feature pthreads (memq 'adjust-active conv*) #f)] 2430 [t (if adjust-active? %edx t0)] ; need a register if `adjust-active?` 2431 [live* (add-caller-save-registers (reg-list %eax %edx))] 2432 [call 2433 (add-deactivate adjust-active? fill-result-here? t0 result-type 2434 (add-cleanup-compensate result-type 2435 (cond 2436 [(memq 'i3nt-com conv*) 2437 (when (null? arg-type*) 2438 ($oops 'foreign-procedure 2439 "__com convention requires instance argument")) 2440 ;; jump indirect 2441 (%seq 2442 (set! ,%eax ,(%mref ,%sp 0)) 2443 (set! ,%eax ,(%mref ,%eax 0)) 2444 (set! ,%eax ,(%inline + ,%eax ,t)) 2445 (inline ,(make-info-kill*-live* live* '()) ,%c-call ,(%mref ,%eax 0)))] 2446 [else 2447 `(inline ,(make-info-kill*-live* live* '()) ,%c-call ,t)])))]) 2448 (cond 2449 [fill-result-here? 2450 (let* ([ftd (nanopass-case (Ltype Type) result-type 2451 [(fp-ftd& ,ftd) ftd])] 2452 [size ($ftd-size ftd)]) 2453 (%seq 2454 ,call 2455 (set! ,%ecx ,(%mref ,%sp ,(fx- frame-size (constant ptr-bytes)))) 2456 ,(case size 2457 [(1) 2458 `(inline ,(make-info-load 'integer-8 #f) ,%store 2459 ,%ecx ,%zero (immediate ,0) ,%eax)] 2460 [(2) 2461 `(inline ,(make-info-load 'integer-16 #f) ,%store 2462 ,%ecx ,%zero (immediate ,0) ,%eax)] 2463 [(4) 2464 (cond 2465 [(and (if-feature windows (not ($ftd-compound? ftd)) #t) 2466 (equal? '((float 4 0)) ($ftd->members ftd))) 2467 `(set! ,(%mref ,%ecx ,%zero 0 fp) ,(%inline fstps))] 2468 [else 2469 `(set! ,(%mref ,%ecx 0) ,%eax)])] 2470 [(8) 2471 (cond 2472 [(and (if-feature windows (not ($ftd-compound? ftd)) #t) 2473 (equal? '((float 8 0)) ($ftd->members ftd))) 2474 `(set! ,(%mref ,%ecx ,%zero 0 fp) ,(%inline fstpl))] 2475 [else 2476 `(seq 2477 (set! ,(%mref ,%ecx 0) ,%eax) 2478 (set! ,(%mref ,%ecx 4) ,%edx))])])))] 2479 [else call]))) 2480 (nanopass-case (Ltype Type) result-type 2481 [(fp-double-float) 2482 (lambda (x) ; unboxed 2483 `(set! ,x ,(%inline fstpl)))] 2484 [(fp-single-float) 2485 (lambda (x) ; unboxed 2486 `(set! ,x ,(%inline fstpl)))] 2487 [(fp-integer ,bits) 2488 (case bits 2489 [(8) (lambda (lvalue) `(set! ,lvalue ,(%inline sext8 ,%eax)))] 2490 [(16) (lambda (lvalue) `(set! ,lvalue ,(%inline sext16 ,%eax)))] 2491 [(32) (lambda (lvalue) `(set! ,lvalue ,%eax))] 2492 [(64) (lambda (lvlow lvhigh) 2493 ; right now we are using ac0 (edx) for our low value and ac1 (pseudo-reg) 2494 ; for the high value. As a result we need to be careful to clear edx (ac0) 2495 ; before we set ac0 (edx) 2496 `(seq 2497 (set! ,lvhigh ,%edx) 2498 (set! ,lvlow ,%eax)))] 2499 [else ($oops 'assembler-internal 2500 "unexpected asm-foreign-procedures fp-integer size ~s" 2501 bits)])] 2502 [(fp-unsigned ,bits) 2503 (case bits 2504 [(8) (lambda (lvalue) `(set! ,lvalue ,(%inline zext8 ,%eax)))] 2505 [(16) (lambda (lvalue) `(set! ,lvalue ,(%inline zext16 ,%eax)))] 2506 [(32) (lambda (lvalue) `(set! ,lvalue ,%eax))] 2507 [(64) (lambda (lvlow lvhigh) 2508 ; right now we are using ac0 (edx) for our low value and ac1 (pseudo-reg) 2509 ; for the high value. As a result we need to be careful to clear edx (ac0) 2510 ; before we set ac0 (edx) 2511 `(seq 2512 (set! ,lvhigh ,%edx) 2513 (set! ,lvlow ,%eax)))] 2514 [else ($oops 'assembler-internal 2515 "unexpected asm-foreign-procedures fp-integer size ~s" 2516 bits)])] 2517 [else (lambda (lvalue) `(set! ,lvalue ,%eax))]))))))))) 2518 2519 (define asm-foreign-callable 2520 #| 2521 Frame Layout 2522 +---------------------------+ 2523 | | 2524 | incoming stack args | 2525 sp+X+Y+Z: | | 2526 +---------------------------+ <- i3nt/ti3nt: 4-byte boundary. other: 16-byte boundary 2527 | incoming return address | one word 2528 +---------------------------+ 2529 | | 2530 | callee-save registers | EBP, ESI, EDI, EBX (4 words) 2531 sp+X+Y: | | 2532 +---------------------------+ 2533 sp+X: | unactivate mode | 0 words or 1 word 2534 +---------------------------+ 2535 | indirect result space | i3nt/ti3nt: 2 words 2536 | (for & results via regs) | other: 3 words 2537 sp+0: +---------------------------+<- i3nt/ti3nt: 4-byte boundary. other: 16-byte boundary 2538 |# 2539 2540 2541 (with-output-language (L13 Effect) 2542 (let () 2543 (define load-double-stack 2544 (lambda (offset) 2545 (lambda (x) ; boxed (always a var) 2546 `(set! ,(%mref ,x ,%zero ,(constant flonum-data-disp) fp) 2547 ,(%mref ,%sp ,%zero ,offset fp))))) 2548 (define load-single-stack 2549 (lambda (offset) 2550 (lambda (x) ; boxed (always a var) 2551 `(set! ,(%mref ,x ,%zero ,(constant flonum-data-disp) fp) 2552 ,(%inline load-single->double ,(%mref ,%sp ,%zero ,offset fp)))))) 2553 (define load-stack 2554 (lambda (type offset) 2555 (lambda (lvalue) ; requires lvalue 2556 (nanopass-case (Ltype Type) type 2557 [(fp-integer ,bits) 2558 (case bits 2559 [(8) `(set! ,lvalue (inline ,(make-info-load 'integer-8 #f) ,%load 2560 ,%sp ,%zero (immediate ,offset)))] 2561 [(16) `(set! ,lvalue (inline ,(make-info-load 'integer-16 #f) ,%load 2562 ,%sp ,%zero (immediate ,offset)))] 2563 [(32) `(set! ,lvalue ,(%mref ,%sp ,offset))] 2564 [else ($oops 'assembler-internal 2565 "unexpected load-int-stack fp-integer size ~s" 2566 bits)])] 2567 [(fp-unsigned ,bits) 2568 (case bits 2569 [(8) `(set! ,lvalue (inline ,(make-info-load 'unsigned-8 #f) ,%load 2570 ,%sp ,%zero (immediate ,offset)))] 2571 [(16) `(set! ,lvalue (inline ,(make-info-load 'unsigned-16 #f) ,%load 2572 ,%sp ,%zero (immediate ,offset)))] 2573 [(32) `(set! ,lvalue ,(%mref ,%sp ,offset))] 2574 [else ($oops 'assembler-internal 2575 "unexpected load-int-stack fp-unsigned size ~s" 2576 bits)])] 2577 [else `(set! ,lvalue ,(%mref ,%sp ,offset))])))) 2578 (define load-stack-address 2579 (lambda (offset) 2580 (lambda (lvalue) ; requires lvalue 2581 `(set! ,lvalue ,(%inline + ,%sp (immediate ,offset)))))) 2582 (define load-stack64 2583 (lambda (type offset) 2584 (lambda (lolvalue hilvalue) ; requires lvalue 2585 (%seq 2586 (set! ,lolvalue ,(%mref ,%sp ,offset)) 2587 (set! ,hilvalue ,(%mref ,%sp ,(fx+ offset 4))))))) 2588 (define do-stack 2589 (lambda (types locs n) 2590 (if (null? types) 2591 (values n locs) 2592 (nanopass-case (Ltype Type) (car types) 2593 [(fp-double-float) 2594 (do-stack (cdr types) 2595 (cons (load-double-stack n) locs) 2596 (fx+ n 8))] 2597 [(fp-single-float) 2598 (do-stack (cdr types) 2599 (cons (load-single-stack n) locs) 2600 (fx+ n 4))] 2601 [(fp-ftd& ,ftd) 2602 (do-stack (cdr types) 2603 (cons (load-stack-address n) locs) 2604 (fx+ n (fxlogand (fx+ ($ftd-size ftd) 3) -4)))] 2605 [else 2606 (if (nanopass-case (Ltype Type) (car types) 2607 [(fp-integer ,bits) (fx= bits 64)] 2608 [(fp-unsigned ,bits) (fx= bits 64)] 2609 [else #f]) 2610 (do-stack (cdr types) 2611 (cons (load-stack64 (car types) n) locs) 2612 (fx+ n 8)) 2613 (do-stack (cdr types) 2614 (cons (load-stack (car types) n) locs) 2615 (fx+ n 4)))])))) 2616 (define (do-result result-type init-stack-offset indirect-result-to-registers?) 2617 (nanopass-case (Ltype Type) result-type 2618 [(fp-ftd& ,ftd) 2619 (cond 2620 [indirect-result-to-registers? 2621 (cond 2622 [(and (if-feature windows (not ($ftd-compound? ftd)) #t) 2623 (equal? '((float 4 0)) ($ftd->members ftd))) 2624 (values (lambda () 2625 (%inline flds ,(%mref ,%sp 0))) 2626 '() 2627 1)] 2628 [(and (if-feature windows (not ($ftd-compound? ftd)) #t) 2629 (equal? '((float 8 0)) ($ftd->members ftd))) 2630 (values (lambda () 2631 (%inline fldl ,(%mref ,%sp ,%zero 0 fp))) 2632 '() 2633 1)] 2634 [(fx= ($ftd-size ftd) 8) 2635 (values (lambda () 2636 `(seq 2637 (set! ,%eax ,(%mref ,%sp 0)) 2638 (set! ,%edx ,(%mref ,%sp 4)))) 2639 (list %eax %edx) 2640 0)] 2641 [else 2642 (values (lambda () 2643 `(set! ,%eax ,(%mref ,%sp 0))) 2644 (list %eax) 2645 0)])] 2646 [else 2647 (values (lambda () 2648 ;; Return pointer that was filled; destination was the first argument 2649 `(set! ,%eax ,(%mref ,%sp ,init-stack-offset))) 2650 (list %eax) 2651 0)])] 2652 [(fp-double-float) 2653 (values (lambda (x) ; boxed (always a var) 2654 (%inline fldl ,(%mref ,x ,%zero ,(constant flonum-data-disp) fp))) 2655 '() 2656 1)] 2657 [(fp-single-float) 2658 (values (lambda (x) ; boxed (always a var) 2659 (%inline fldl ,(%mref ,x ,%zero ,(constant flonum-data-disp) fp))) 2660 '() 2661 1)] 2662 [(fp-void) 2663 (values (lambda () `(nop)) 2664 '() 2665 0)] 2666 [else 2667 (cond 2668 [(nanopass-case (Ltype Type) result-type 2669 [(fp-integer ,bits) (fx= bits 64)] 2670 [(fp-unsigned ,bits) (fx= bits 64)] 2671 [else #f]) 2672 (values (lambda (lorhs hirhs) ; requires rhs 2673 (%seq 2674 (set! ,%eax ,lorhs) 2675 (set! ,%edx ,hirhs))) 2676 (list %eax %edx) 2677 0)] 2678 [else 2679 (values (lambda (x) 2680 `(set! ,%eax ,x)) 2681 (list %eax) 2682 0)])])) 2683 (define (unactivate result-regs result-num-fp-regs) 2684 (let* ([push-size (push-registers-size result-regs result-num-fp-regs 1)] 2685 [e (%seq 2686 (set! ,%eax ,(%mref ,%sp ,(+ 8 push-size))) 2687 ,(%inline push ,%eax) 2688 ,(%inline unactivate-thread) 2689 (set! ,%eax ,(%inline pop)))]) 2690 (if (and (null? result-regs) (fx= 0 result-num-fp-regs) (fx= 0 push-size)) 2691 e 2692 (%seq 2693 ,(push-registers result-regs result-num-fp-regs 1) 2694 ,e 2695 ,(pop-registers result-regs result-num-fp-regs 1))))) 2696 (lambda (info) 2697 (let* ([conv* (info-foreign-conv* info)] 2698 [adjust-active? (if-feature pthreads (memq 'adjust-active conv*) #f)] 2699 [arg-type* (info-foreign-arg-type* info)] 2700 [result-type (info-foreign-result-type info)] 2701 [indirect-result-space (constant-case machine-type-name 2702 [(i3nt ti3nt) (if adjust-active? 12 8)] 2703 [else 2704 ;; maintain 16-bit alignment, taking into account 2705 ;; 16 bytes pushed above + 4 for RA pushed by asmCcall; 2706 ;; 8 of these bytes are used for &-return space, if needed; 2707 ;; the extra 4 bytes may be used for the unactivate mode 2708 12])] 2709 [init-stack-offset (fx+ 20 indirect-result-space)] 2710 [indirect-result-to-registers? (fill-result-pointer-from-registers? result-type)]) 2711 (let-values ([(get-result result-regs result-num-fp-regs) 2712 (do-result result-type init-stack-offset indirect-result-to-registers?)]) 2713 (with-values (do-stack (if indirect-result-to-registers? 2714 (cdr arg-type*) 2715 arg-type*) 2716 '() 2717 init-stack-offset) 2718 (lambda (frame-size locs) 2719 (values 2720 (lambda () 2721 (%seq 2722 ,(%inline push ,%ebp) 2723 ,(%inline push ,%esi) 2724 ,(%inline push ,%edi) 2725 ,(%inline push ,%ebx) 2726 (set! ,%sp ,(%inline - ,%sp (immediate ,indirect-result-space))) 2727 ,(if-feature pthreads 2728 ((lambda (e) 2729 (if adjust-active? 2730 (%seq 2731 (set! ,%eax ,(%inline activate-thread)) 2732 (set! ,(%mref ,%sp ,8) ,%eax) 2733 ,e) 2734 e)) 2735 `(seq 2736 (set! ,%eax ,(%inline get-tc)) 2737 (set! ,%tc ,%eax))) 2738 `(set! ,%tc (literal ,(make-info-literal #f 'entry (lookup-c-entry thread-context) 0)))))) 2739 (let ([locs (reverse locs)]) 2740 (if indirect-result-to-registers? 2741 (cons (load-stack-address 0) ; use the &-return space 2742 locs) 2743 locs)) 2744 get-result 2745 (lambda () 2746 (define callee-save-regs (list %ebx %edi %esi %ebp)) 2747 (in-context Tail 2748 ((lambda (e) 2749 (if adjust-active? 2750 (%seq 2751 ,(unactivate result-regs result-num-fp-regs) 2752 ,e) 2753 e)) 2754 (%seq 2755 (set! ,%sp ,(%inline + ,%sp (immediate ,indirect-result-space))) 2756 (set! ,%ebx ,(%inline pop)) 2757 (set! ,%edi ,(%inline pop)) 2758 (set! ,%esi ,(%inline pop)) 2759 (set! ,%ebp ,(%inline pop)) 2760 ; Windows __stdcall convention requires callee to clean up 2761 ,((lambda (e) 2762 (if (or (memq 'i3nt-stdcall conv*) (memq 'i3nt-com conv*)) 2763 (let ([arg-size (fx- frame-size init-stack-offset)]) 2764 (if (fx> arg-size 0) 2765 (%seq 2766 (set! 2767 ,(%mref ,%sp ,arg-size) 2768 ,(%mref ,%sp 0)) 2769 (set! ,%sp ,(%inline + ,%sp (immediate ,arg-size))) 2770 ,e) 2771 e)) 2772 e)) 2773 `(asm-c-return ,(if (callee-pops-result-pointer? result-type) 2774 ;; remove the pointer argument provided by the caller 2775 ;; after popping the return address 2776 (make-info-c-return 4) 2777 null-info) 2778 ,callee-save-regs ... 2779 ,result-regs ...))))))))))))))) 2780 ) 2781