| 1 | ;;; -*- Mode: Lisp; Package: CCL -*- |
|---|
| 2 | ;;; |
|---|
| 3 | ;;; Copyright (C) 2006, Clozure Associates and contributors |
|---|
| 4 | ;;; This file is part of OpenMCL. |
|---|
| 5 | ;;; |
|---|
| 6 | ;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public |
|---|
| 7 | ;;; License , known as the LLGPL and distributed with OpenMCL as the |
|---|
| 8 | ;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, |
|---|
| 9 | ;;; which is distributed with OpenMCL as the file "LGPL". Where these |
|---|
| 10 | ;;; conflict, the preamble takes precedence. |
|---|
| 11 | ;;; |
|---|
| 12 | ;;; OpenMCL is referenced in the preamble as the "LIBRARY." |
|---|
| 13 | ;;; |
|---|
| 14 | ;;; The LLGPL is also available online at |
|---|
| 15 | ;;; http://opensource.franz.com/preamble.html |
|---|
| 16 | |
|---|
| 17 | (in-package "CCL") |
|---|
| 18 | |
|---|
| 19 | ;;; Use the offsets in a function's self-reference table to replace |
|---|
| 20 | ;;; the :self in (movl ($ :self) (% fn)) wih the function's actual |
|---|
| 21 | ;;; address. |
|---|
| 22 | (defx8632lapfunction %update-self-references ((fun arg_z)) |
|---|
| 23 | (movzwl (@ x8632::misc-data-offset (% fun)) (% imm0)) ;imm word count |
|---|
| 24 | (btr ($ 15) (% imm0)) |
|---|
| 25 | (jnc @proceed) |
|---|
| 26 | (imm-word-count fun imm0 temp0) |
|---|
| 27 | (subl ($ '2) (% temp0)) |
|---|
| 28 | (jmp @load-offset) |
|---|
| 29 | @proceed |
|---|
| 30 | (subl ($ 2) (% imm0)) |
|---|
| 31 | (box-fixnum imm0 temp0) ;byte offset of first self-ref offset |
|---|
| 32 | (jmp @load-offset) |
|---|
| 33 | @loop |
|---|
| 34 | (movl (% fun) (@ x8632::misc-header-offset (% fun) (% imm0))) |
|---|
| 35 | (subl ($ '1) (% temp0)) |
|---|
| 36 | @load-offset |
|---|
| 37 | (movl (@ x8632::misc-data-offset (% fun) (% temp0)) (% imm0)) |
|---|
| 38 | (test (% imm0) (% imm0)) |
|---|
| 39 | (jne @loop) |
|---|
| 40 | (single-value-return)) |
|---|
| 41 | |
|---|
| 42 | (defx8632lapfunction %function-code-words ((fun arg_z)) |
|---|
| 43 | (trap-unless-typecode= fun x8632::subtag-function) |
|---|
| 44 | (movzwl (@ x8632::misc-data-offset (% fun)) (% imm0)) |
|---|
| 45 | (btr ($ 15) (% imm0)) |
|---|
| 46 | (jnc @proceed) |
|---|
| 47 | (imm-word-count fun imm0 temp0) |
|---|
| 48 | (movl (% temp0) (% arg_z)) |
|---|
| 49 | (single-value-return) |
|---|
| 50 | @proceed |
|---|
| 51 | (box-fixnum imm0 arg_z) |
|---|
| 52 | (single-value-return)) |
|---|
| 53 | |
|---|
| 54 | (defx8632lapfunction %nth-immediate ((fun arg_y) (n arg_z)) |
|---|
| 55 | (trap-unless-typecode= fun x8632::subtag-function) |
|---|
| 56 | (movzwl (@ x8632::misc-data-offset (% fun)) (% imm0)) |
|---|
| 57 | (btr ($ 15) (% imm0)) |
|---|
| 58 | (jnc @proceed) |
|---|
| 59 | (imm-word-count fun imm0 temp0) |
|---|
| 60 | (unbox-fixnum temp0 imm0) |
|---|
| 61 | @proceed |
|---|
| 62 | (lea (@ (% n) (% imm0) 4) (% imm0)) |
|---|
| 63 | (movl (@ x8632::misc-data-offset (% fun) (% imm0)) (% arg_z)) |
|---|
| 64 | (single-value-return)) |
|---|
| 65 | |
|---|
| 66 | (defx8632lapfunction %set-nth-immediate ((fun 4) #|(ra 0)|# (n arg_y) (new arg_z)) |
|---|
| 67 | (popl (@ 8 (% esp))) |
|---|
| 68 | (popl (% temp0)) |
|---|
| 69 | (addl ($ 4) (% esp)) |
|---|
| 70 | (trap-unless-typecode= temp0 x8632::subtag-function) |
|---|
| 71 | (movzwl (@ x8632::misc-data-offset (% temp0)) (% imm0)) |
|---|
| 72 | (lea (@ (% n) (% imm0) 4) (% arg_y)) |
|---|
| 73 | ;; expects gvector in temp0 |
|---|
| 74 | (jmp-subprim .SPgvset)) |
|---|
| 75 | |
|---|
| 76 | (defx8632lapfunction %function-code-byte ((fun arg_y) (pc arg_z)) |
|---|
| 77 | (unbox-fixnum pc imm0) |
|---|
| 78 | (movzbl (@ (% fun) (% imm0)) (% imm0)) |
|---|
| 79 | (box-fixnum imm0 arg_z) |
|---|
| 80 | (single-value-return)) |
|---|
| 81 | |
|---|
| 82 | (defx8632lapfunction %function-register-usage ((f arg_z)) |
|---|
| 83 | (check-nargs 1) |
|---|
| 84 | (trap-unless-typecode= f x8632::subtag-function) |
|---|
| 85 | (movl (% esp) (% temp0)) |
|---|
| 86 | (pushl ($ nil)) |
|---|
| 87 | (pushl ($ nil)) |
|---|
| 88 | (jmp-subprim .SPvalues)) |
|---|
| 89 | |
|---|
| 90 | ;;; XXX probably should unify these next two with the x8664 versions. |
|---|
| 91 | |
|---|
| 92 | ;;; Make a new function, with PROTO's code and the specified immediates. |
|---|
| 93 | ;;; IMMEDIATES should contain lfun-bits as the last element. |
|---|
| 94 | (defun %clone-x86-function (proto &rest immediates) |
|---|
| 95 | (declare (dynamic-extent immediates)) |
|---|
| 96 | (let* ((protov (function-to-function-vector proto)) |
|---|
| 97 | (code-words (%function-code-words proto)) |
|---|
| 98 | (numimms (length immediates)) |
|---|
| 99 | (newv (allocate-typed-vector :function (the fixnum (+ code-words numimms))))) |
|---|
| 100 | (declare (fixnum code-words numimms)) |
|---|
| 101 | (%copy-ivector-to-ivector protov 0 newv 0 (the fixnum (ash code-words target::word-shift))) |
|---|
| 102 | #|| |
|---|
| 103 | ;; XXX bootstrapping |
|---|
| 104 | (setf (ldb (byte 16 0) (uvref newv 0)) (logior #x8000 numimms)) |
|---|
| 105 | ||# |
|---|
| 106 | (%update-self-references newv) |
|---|
| 107 | (do* ((k code-words (1+ k)) |
|---|
| 108 | (imms immediates (cdr imms))) |
|---|
| 109 | ((null imms) (function-vector-to-function newv)) |
|---|
| 110 | (declare (fixnum k) (list imms)) |
|---|
| 111 | (setf (%svref newv k) (car imms))))) |
|---|
| 112 | |
|---|
| 113 | (defun %copy-function (proto &optional target) |
|---|
| 114 | (let* ((protov (function-to-function-vector proto)) |
|---|
| 115 | (code-words (%function-code-words proto)) |
|---|
| 116 | (total-words (uvsize protov)) |
|---|
| 117 | (newv (if target |
|---|
| 118 | (function-to-function-vector target) |
|---|
| 119 | (allocate-typed-vector :function total-words)))) |
|---|
| 120 | (declare (fixnum code-words total-words)) |
|---|
| 121 | (when target |
|---|
| 122 | (unless (and (eql code-words (%function-code-words target)) |
|---|
| 123 | (eql total-words (uvsize newv))) |
|---|
| 124 | (error "Wrong size target ~s" target))) |
|---|
| 125 | (%copy-ivector-to-ivector protov 0 newv 0 (the fixnum (ash code-words target::word-shift))) |
|---|
| 126 | (loop for k fixnum from code-words below total-words |
|---|
| 127 | do (setf (%svref newv k) (%svref protov k))) |
|---|
| 128 | #|| |
|---|
| 129 | (setf (ldb (byte 16 0) (uvref newv 0)) |
|---|
| 130 | (logior #x8000 (- total-words code-words))) |
|---|
| 131 | ||# |
|---|
| 132 | (%update-self-references (function-vector-to-function newv)))) |
|---|
| 133 | |
|---|
| 134 | (defun replace-function-code (target proto) |
|---|
| 135 | (let* ((target-words (%function-code-words target)) |
|---|
| 136 | (proto-words (%function-code-words proto))) |
|---|
| 137 | (declare (fixnum target-words proto-words)) |
|---|
| 138 | (if (= target-words proto-words) |
|---|
| 139 | (progn |
|---|
| 140 | (%copy-ivector-to-ivector (function-to-function-vector proto) |
|---|
| 141 | 0 |
|---|
| 142 | (function-to-function-vector target) |
|---|
| 143 | 0 |
|---|
| 144 | (the fixnum (ash target-words |
|---|
| 145 | target::word-shift))) |
|---|
| 146 | (%update-self-references target) |
|---|
| 147 | target) |
|---|
| 148 | (error "Code size mismatch: target = ~s, proto = ~s" |
|---|
| 149 | target-words proto-words)))) |
|---|
| 150 | |
|---|
| 151 | (defx8632lapfunction %get-kernel-global-from-offset ((offset arg_z)) |
|---|
| 152 | (check-nargs 1) |
|---|
| 153 | (unbox-fixnum offset imm0) |
|---|
| 154 | (movl (@ (target-nil-value) (% imm0)) (% arg_z)) |
|---|
| 155 | (single-value-return)) |
|---|
| 156 | |
|---|
| 157 | (defx8632lapfunction %set-kernel-global-from-offset ((offset arg_y) |
|---|
| 158 | (new-value arg_z)) |
|---|
| 159 | (check-nargs 2) |
|---|
| 160 | (unbox-fixnum offset imm0) |
|---|
| 161 | (movl (% arg_z) (@ (target-nil-value) (% imm0))) |
|---|
| 162 | (single-value-return)) |
|---|
| 163 | |
|---|
| 164 | (defx8632lapfunction %get-kernel-global-ptr-from-offset ((offset arg_y) |
|---|
| 165 | (ptr arg_z)) |
|---|
| 166 | (check-nargs 2) |
|---|
| 167 | (unbox-fixnum offset imm0) |
|---|
| 168 | (movl (@ (target-nil-value) (% imm0)) (% imm0)) |
|---|
| 169 | (movl (% imm0) (@ x8632::macptr.address (% ptr))) |
|---|
| 170 | (single-value-return)) |
|---|
| 171 | |
|---|
| 172 | (defx8632lapfunction %fixnum-ref ((fixnum arg_y) #| &optional |# (offset arg_z)) |
|---|
| 173 | (:arglist (fixnum &optional offset)) |
|---|
| 174 | (check-nargs 1 2) |
|---|
| 175 | (cmpl ($ x8632::fixnumone) (% nargs)) |
|---|
| 176 | (jne @2-args) |
|---|
| 177 | (movl (% offset) (% fixnum)) |
|---|
| 178 | (xorl (%l offset) (%l offset)) |
|---|
| 179 | @2-args |
|---|
| 180 | (unbox-fixnum offset imm0) |
|---|
| 181 | (movl (@ (% fixnum) (% imm0)) (% arg_z)) |
|---|
| 182 | (single-value-return)) |
|---|
| 183 | |
|---|
| 184 | (defx8632lapfunction %fixnum-ref-natural ((fixnum arg_y) #| &optional |# (offset arg_z)) |
|---|
| 185 | (:arglist (fixnum &optional offset)) |
|---|
| 186 | (check-nargs 1 2) |
|---|
| 187 | (cmpl ($ x8632::fixnumone) (% nargs)) |
|---|
| 188 | (jne @2-args) |
|---|
| 189 | (movl (% offset) (% fixnum)) |
|---|
| 190 | (xorl (%l offset) (%l offset)) |
|---|
| 191 | @2-args |
|---|
| 192 | (unbox-fixnum offset imm0) |
|---|
| 193 | (movl (@ (% fixnum) (% imm0)) (% imm0)) |
|---|
| 194 | (jmp-subprim .SPmakeu32)) |
|---|
| 195 | |
|---|
| 196 | (defx8632lapfunction %fixnum-set ((fixnum 4) #|(ra 0)|# (offset arg_y) #| &optional |# (new-value arg_z)) |
|---|
| 197 | (:arglist (fixnum offset &optional newval)) |
|---|
| 198 | (check-nargs 2 3) |
|---|
| 199 | (cmpl ($ '2) (% nargs)) |
|---|
| 200 | (jne @3-args) |
|---|
| 201 | (movl (% new-value) (% offset)) |
|---|
| 202 | (single-value-return) |
|---|
| 203 | @3-args |
|---|
| 204 | (movl (@ fixnum (% esp)) (% temp0)) |
|---|
| 205 | (unbox-fixnum offset imm0) |
|---|
| 206 | (movl (% new-value) (@ (% temp0) (% imm0))) |
|---|
| 207 | (single-value-return 3)) |
|---|
| 208 | |
|---|
| 209 | |
|---|
| 210 | (defx8632lapfunction %fixnum-set-natural ((fixnum 4) #|(ra 0)|# (offset arg_y) #| &optional |# (new-value arg_z)) |
|---|
| 211 | (:arglist (fixnum offsnet &optional newval)) |
|---|
| 212 | (check-nargs 2 3) |
|---|
| 213 | (cmpl ($ '2) (% nargs)) |
|---|
| 214 | (jne @3-args) |
|---|
| 215 | (save-simple-frame) |
|---|
| 216 | (movl (% offset) (% temp0)) |
|---|
| 217 | (xorl (% offset) (% offset)) |
|---|
| 218 | (jmp @common) |
|---|
| 219 | @3-args |
|---|
| 220 | (movl (% ebp) (@ 8 (% esp))) |
|---|
| 221 | (lea (@ 8 (% esp)) (% ebp)) |
|---|
| 222 | (popl (@ 4 (% ebp))) |
|---|
| 223 | (popl (% temp0)) |
|---|
| 224 | @common |
|---|
| 225 | (call-subprim .SPgetu32) ;puts u32 in imm0 |
|---|
| 226 | (mark-as-imm temp1) |
|---|
| 227 | (unbox-fixnum offset temp1) |
|---|
| 228 | (movl (% imm0) (@ (% temp0) (% temp1))) |
|---|
| 229 | (mark-as-node temp1) |
|---|
| 230 | (restore-simple-frame) |
|---|
| 231 | (single-value-return)) |
|---|
| 232 | |
|---|
| 233 | |
|---|
| 234 | (defx8632lapfunction %current-frame-ptr () |
|---|
| 235 | (check-nargs 0) |
|---|
| 236 | (movl (% ebp) (% arg_z)) |
|---|
| 237 | (single-value-return)) |
|---|
| 238 | |
|---|
| 239 | |
|---|
| 240 | (defx8632lapfunction %current-tsp () |
|---|
| 241 | (check-nargs 0) |
|---|
| 242 | (movl (:rcontext x8632::tcr.save-tsp) (% arg_z)) |
|---|
| 243 | (single-value-return)) |
|---|
| 244 | |
|---|
| 245 | |
|---|
| 246 | (defx8632lapfunction %%frame-backlink ((p arg_z)) |
|---|
| 247 | (check-nargs 1) |
|---|
| 248 | (movl (@ (% arg_z)) (% arg_z)) |
|---|
| 249 | (single-value-return)) |
|---|
| 250 | |
|---|
| 251 | ;;; Look for "movl $imm32,%fn at the tra; if present, then $imm32 is |
|---|
| 252 | ;;; the address of the function. |
|---|
| 253 | ;;; |
|---|
| 254 | ;;; That is: #b10111111 <imm32> |
|---|
| 255 | ;;; ^^^^ |
|---|
| 256 | ;;; operand size || register number (%fn/%edi) |
|---|
| 257 | |
|---|
| 258 | (defx8632lapfunction %return-address-function ((r arg_z)) |
|---|
| 259 | (extract-fulltag r imm0) |
|---|
| 260 | (cmpb ($ x8632::fulltag-tra) (% imm0.b)) |
|---|
| 261 | (jne @fail) |
|---|
| 262 | (cmpb ($ x8632::recover-fn-opcode-byte) (@ (% r))) |
|---|
| 263 | (jne @fail) |
|---|
| 264 | (movl (@ x8632::recover-fn-address-offset (% r)) (% arg_z)) |
|---|
| 265 | (single-value-return) |
|---|
| 266 | @fail |
|---|
| 267 | (movl ($ (target-nil-value)) (% arg_z)) |
|---|
| 268 | (single-value-return)) |
|---|
| 269 | |
|---|
| 270 | (defx8632lapfunction %return-address-offset ((r arg_z)) |
|---|
| 271 | (extract-fulltag r imm0) |
|---|
| 272 | (cmpb ($ x8632::fulltag-tra) (% imm0.b)) |
|---|
| 273 | (jne @fail) |
|---|
| 274 | (cmpb ($ x8632::recover-fn-opcode-byte) (@ (% r))) |
|---|
| 275 | (jne @fail) |
|---|
| 276 | (movl (@ x8632::recover-fn-address-offset (% r)) (% imm0)) |
|---|
| 277 | (subl (% arg_z) (% imm0)) |
|---|
| 278 | (negl (% imm0)) |
|---|
| 279 | (box-fixnum imm0 arg_z) |
|---|
| 280 | (single-value-return) |
|---|
| 281 | @fail |
|---|
| 282 | (movl ($ (target-nil-value)) (% arg_z)) |
|---|
| 283 | (single-value-return)) |
|---|
| 284 | |
|---|
| 285 | ;;; It's always been the case that the function associated with a |
|---|
| 286 | ;;; frame pointer is the caller of the function that "uses" that frame. |
|---|
| 287 | (defun %cfp-lfun (p) |
|---|
| 288 | (let* ((ra (%fixnum-ref p x8632::lisp-frame.return-address))) |
|---|
| 289 | (if (eq ra (%get-kernel-global ret1valaddr)) |
|---|
| 290 | (setq ra (%fixnum-ref p x8632::lisp-frame.xtra))) |
|---|
| 291 | (values (%return-address-function ra) (%return-address-offset ra)))) |
|---|
| 292 | |
|---|
| 293 | (defx8632lapfunction %uvector-data-fixnum ((uv arg_z)) |
|---|
| 294 | (check-nargs 1) |
|---|
| 295 | (trap-unless-fulltag= arg_z x8632::fulltag-misc) |
|---|
| 296 | (addl ($ x8632::misc-data-offset) (% arg_z)) |
|---|
| 297 | (single-value-return)) |
|---|
| 298 | |
|---|
| 299 | (defx8632lapfunction %catch-top ((tcr arg_z)) |
|---|
| 300 | (check-nargs 1) |
|---|
| 301 | (movl ($ (target-nil-value)) (% arg_y)) |
|---|
| 302 | (movl (:rcontext x8632::tcr.catch-top) (% arg_z)) |
|---|
| 303 | (testb (%b arg_z) (%b arg_z)) |
|---|
| 304 | (cmovel (% arg_y) (% arg_z)) |
|---|
| 305 | (single-value-return)) |
|---|
| 306 | |
|---|
| 307 | (defx8632lapfunction %catch-tsp ((catch arg_z)) |
|---|
| 308 | (check-nargs 1) |
|---|
| 309 | (lea (@ (- (+ x8632::fulltag-misc |
|---|
| 310 | (ash 1 (1+ x8632::word-shift)))) (% arg_z)) |
|---|
| 311 | (% arg_z)) |
|---|
| 312 | (single-value-return)) |
|---|
| 313 | |
|---|
| 314 | ;;; Same as %address-of, but doesn't cons any bignums |
|---|
| 315 | ;;; It also left shift fixnums just like everything else. |
|---|
| 316 | (defx8632lapfunction %fixnum-address-of ((x arg_z)) |
|---|
| 317 | (check-nargs 1) |
|---|
| 318 | (box-fixnum x arg_z) |
|---|
| 319 | (single-value-return)) |
|---|
| 320 | |
|---|
| 321 | (defx8632lapfunction %save-standard-binding-list ((bindings arg_z)) |
|---|
| 322 | (mark-as-imm temp0) |
|---|
| 323 | (movl (:rcontext x8632::tcr.vs-area) (% imm0)) |
|---|
| 324 | (movl (@ x8632::area.high (% imm0)) (% temp0)) |
|---|
| 325 | (subl ($ x8632::node-size) (% temp0)) |
|---|
| 326 | (movl (% bindings) (@ (% temp0))) |
|---|
| 327 | (mark-as-node temp0) |
|---|
| 328 | (single-value-return)) |
|---|
| 329 | |
|---|
| 330 | (defx8632lapfunction %saved-bindings-address () |
|---|
| 331 | (mark-as-imm temp0) |
|---|
| 332 | (movl (:rcontext x8632::tcr.vs-area) (% imm0)) |
|---|
| 333 | (movl (@ x8632::area.high (% imm0)) (% temp0)) |
|---|
| 334 | (leal (@ (- x8632::node-size) (% temp0)) (% arg_z)) |
|---|
| 335 | (mark-as-node temp0) |
|---|
| 336 | (single-value-return)) |
|---|
| 337 | |
|---|
| 338 | (defx8632lapfunction %get-object ((macptr arg_y) (offset arg_z)) |
|---|
| 339 | (check-nargs 2) |
|---|
| 340 | (trap-unless-typecode= macptr x8632::subtag-macptr) |
|---|
| 341 | (trap-unless-lisptag= offset x8632::tag-fixnum) |
|---|
| 342 | (macptr-ptr macptr imm0) |
|---|
| 343 | (mark-as-imm temp0) |
|---|
| 344 | (unbox-fixnum offset temp0) |
|---|
| 345 | (movl (@ (% imm0) (% temp0)) (% arg_z)) |
|---|
| 346 | (mark-as-node temp0) |
|---|
| 347 | (single-value-return)) |
|---|
| 348 | |
|---|
| 349 | (defx8632lapfunction %set-object ((macptr 4) #|(ra 0)|# (offset arg_y) (value arg_z)) |
|---|
| 350 | (check-nargs 3) |
|---|
| 351 | (movl (@ macptr (% esp)) (% temp1)) |
|---|
| 352 | (trap-unless-typecode= temp1 x8632::subtag-macptr) |
|---|
| 353 | (trap-unless-lisptag= offset x8632::tag-fixnum) |
|---|
| 354 | (macptr-ptr temp1 imm0) |
|---|
| 355 | (mark-as-imm temp0) |
|---|
| 356 | (unbox-fixnum offset temp0) |
|---|
| 357 | (movl (% arg_z) (@ (% imm0) (% temp0))) |
|---|
| 358 | (mark-as-node temp0) |
|---|
| 359 | (single-value-return 3)) |
|---|
| 360 | |
|---|
| 361 | (defx8632lapfunction %apply-lexpr-with-method-context ((magic 4) |
|---|
| 362 | #|(ra 0)|# |
|---|
| 363 | (function arg_y) |
|---|
| 364 | (args arg_z)) |
|---|
| 365 | ;; Somebody's called (or tail-called) us. |
|---|
| 366 | ;; * Put magic arg in %rcontext:tcr.next-method-context |
|---|
| 367 | ;; * Put function somewhere safe until we're ready to jump to it |
|---|
| 368 | ;; * Set nargs to 0, then spread "args" on stack (clobbers regs) |
|---|
| 369 | ;; * Jump to function (saved previously) |
|---|
| 370 | (popl (:rcontext x8632::tcr.save0)) ;return address |
|---|
| 371 | (popl (:rcontext x8632::tcr.next-method-context)) ;magic arg |
|---|
| 372 | (discard-reserved-frame) |
|---|
| 373 | (movl (% function) (:rcontext x8632::tcr.save1)) |
|---|
| 374 | (set-nargs 0) |
|---|
| 375 | (movl (@ (% args)) (% temp0)) ;lexpr-count |
|---|
| 376 | (movl (% temp0) (% nargs)) |
|---|
| 377 | (leal (@ x8632::node-size (% arg_z) (% temp0)) (% imm0)) |
|---|
| 378 | (subl ($ '2) (% temp0)) |
|---|
| 379 | (jbe @reg-only) |
|---|
| 380 | ;; Some args will be pushed; reserve a frame. |
|---|
| 381 | (pushl ($ x8632::reserved-frame-marker)) |
|---|
| 382 | (pushl ($ x8632::reserved-frame-marker)) |
|---|
| 383 | @pushloop |
|---|
| 384 | (pushl (@ (- x8632::node-size) (% imm0))) |
|---|
| 385 | (subl ($ x8632::node-size) (% imm0)) |
|---|
| 386 | (subl ($ x8632::node-size) (% temp0)) |
|---|
| 387 | (jne @pushloop) |
|---|
| 388 | @two |
|---|
| 389 | (movl (@ (* x8632::node-size 2) (% arg_z)) (% arg_y)) |
|---|
| 390 | @one |
|---|
| 391 | (movl (@ (* x8632::node-size 1) (% arg_z)) (% arg_z)) |
|---|
| 392 | (jmp @go) |
|---|
| 393 | @reg-only |
|---|
| 394 | (rcmp (% nargs) ($ '1)) |
|---|
| 395 | (je @one) |
|---|
| 396 | (jb @go) |
|---|
| 397 | (jmp @two) |
|---|
| 398 | @go |
|---|
| 399 | (pushl (:rcontext x8632::tcr.save0)) ;return address |
|---|
| 400 | (movl (:rcontext x8632::tcr.save1) (% temp0)) ;function |
|---|
| 401 | (movapd (% fpzero) (:rcontext x8632::tcr.save0)) ;clear spill area |
|---|
| 402 | (jmp (% temp0))) |
|---|
| 403 | |
|---|
| 404 | (defx8632lapfunction %apply-with-method-context ((magic 4) |
|---|
| 405 | #|(ra 0)|# |
|---|
| 406 | (function arg_y) |
|---|
| 407 | (args arg_z)) |
|---|
| 408 | ;; Similar to above. |
|---|
| 409 | (popl (:rcontext x8632::tcr.save0)) ;save return address |
|---|
| 410 | (popl (:rcontext x8632::tcr.next-method-context)) ; |
|---|
| 411 | (discard-reserved-frame) |
|---|
| 412 | (movl (% args) (:rcontext x8632::tcr.save2)) ;in case of error |
|---|
| 413 | (set-nargs 0) |
|---|
| 414 | (pushl ($ target::reserved-frame-marker)) ;reserve frame (might discard it |
|---|
| 415 | (pushl ($ target::reserved-frame-marker)) ;if nothing is passed on stack) |
|---|
| 416 | (cmp-reg-to-nil arg_z) |
|---|
| 417 | (je @done) |
|---|
| 418 | @loop |
|---|
| 419 | (extract-fulltag arg_z imm0) |
|---|
| 420 | (cmpb ($ x8632::fulltag-cons) (% imm0.b)) ;nil is a cons on x8632, but we |
|---|
| 421 | (jne @bad) ; checked for it already. |
|---|
| 422 | (add ($ '1) (% nargs)) ;shorter than lea (imm0 is eax) |
|---|
| 423 | (pushl (@ target::cons.car (% arg_z))) |
|---|
| 424 | (%cdr arg_z arg_z) |
|---|
| 425 | (cmp-reg-to-nil arg_z) |
|---|
| 426 | (jne @loop) |
|---|
| 427 | @done |
|---|
| 428 | ;; arg_y about to get clobbered; put function into temp0 |
|---|
| 429 | (movl (% function) (% temp0)) |
|---|
| 430 | ;; temp1 (aka nargs) contains number of args just pushed |
|---|
| 431 | (test (% nargs) (% nargs)) |
|---|
| 432 | (jne @pop) |
|---|
| 433 | @discard-and-go |
|---|
| 434 | (discard-reserved-frame) |
|---|
| 435 | (jmp @go) |
|---|
| 436 | @pop |
|---|
| 437 | (cmpl ($ '1) (% nargs)) |
|---|
| 438 | (pop (% arg_z)) |
|---|
| 439 | (je @discard-and-go) |
|---|
| 440 | (cmpl ($ '2) (% nargs)) |
|---|
| 441 | (pop (% arg_y)) |
|---|
| 442 | (je @discard-and-go) |
|---|
| 443 | @go |
|---|
| 444 | (pushl (:rcontext x8632::tcr.save0)) ;return address |
|---|
| 445 | (movapd (% fpzero) (:rcontext x8632::tcr.save0)) ;clear out spill area |
|---|
| 446 | (jmp (% temp0)) |
|---|
| 447 | @bad |
|---|
| 448 | (addl (% nargs) (% esp)) |
|---|
| 449 | (movl (:rcontext x8632::tcr.save1) (% arg_z)) ;saved args |
|---|
| 450 | (movapd (% fpzero) (:rcontext x8632::tcr.save0)) ;clear out spill area |
|---|
| 451 | (movl ($ '#.$XNOSPREAD) (% arg_y)) |
|---|
| 452 | (set-nargs 2) |
|---|
| 453 | (jmp-subprim .SPksignalerr)) |
|---|
| 454 | |
|---|
| 455 | ;;; The idea here is to call METHOD in the same stack frame in |
|---|
| 456 | ;;; which the lexpr was originally called. The lexpr can't |
|---|
| 457 | ;;; have had any required arguments, %APPLY-LEXPR-TAIL-WISE |
|---|
| 458 | ;;; must have been tail-called, and the frame built on lexpr |
|---|
| 459 | ;;; entry must be in %rbp. |
|---|
| 460 | (defx8632lapfunction %apply-lexpr-tail-wise ((method arg_y) (args arg_z)) |
|---|
| 461 | (addl ($ x8632::node-size) (% esp)) ; discard extra return address |
|---|
| 462 | (movl (% method) (% xfn)) ;temp1 |
|---|
| 463 | (movl (% args) (% esp)) |
|---|
| 464 | (popl (% imm0)) ;nargs |
|---|
| 465 | (movl (@ x8632::lisp-frame.return-address (% ebp)) (% temp0)) |
|---|
| 466 | (movl (@ 0 (% ebp)) (% ebp)) |
|---|
| 467 | (rcmpl (% imm0) ($ '2)) |
|---|
| 468 | (jbe @pop-regs) |
|---|
| 469 | ;; More than 2 args; some must have been pushed by caller, |
|---|
| 470 | ;; so retain the reserved frame. |
|---|
| 471 | (pop (% arg_z)) |
|---|
| 472 | (pop (% arg_y)) |
|---|
| 473 | (jmp @popped) |
|---|
| 474 | @pop-regs |
|---|
| 475 | (rcmpl (% imm0) ($ '1)) |
|---|
| 476 | (jb @discard) |
|---|
| 477 | (ja @pop2) |
|---|
| 478 | (pop (% arg_z)) |
|---|
| 479 | (jmp @discard) |
|---|
| 480 | @pop2 |
|---|
| 481 | (pop (% arg_z)) |
|---|
| 482 | (pop (% arg_y)) |
|---|
| 483 | @discard |
|---|
| 484 | (discard-reserved-frame) |
|---|
| 485 | @popped |
|---|
| 486 | (push (% temp0)) ;return address |
|---|
| 487 | (movl (% xfn) (% temp0)) ;temp1 is also nargs |
|---|
| 488 | (movl (% imm0) (% nargs)) |
|---|
| 489 | (jmp (% temp0))) |
|---|
| 490 | |
|---|
| 491 | (defun closure-function (fun) |
|---|
| 492 | (while (and (functionp fun) (not (compiled-function-p fun))) |
|---|
| 493 | (setq fun (%nth-immediate fun 0)) |
|---|
| 494 | (when (vectorp fun) |
|---|
| 495 | (setq fun (svref fun 0)))) |
|---|
| 496 | fun) |
|---|
| 497 | |
|---|
| 498 | ;;; For use by (setf (apply ...) ...) |
|---|
| 499 | ;;; (apply+ f butlast last) = (apply f (append butlast (list last))) |
|---|
| 500 | |
|---|
| 501 | (defun apply+ (&lap function arg1 arg2 &rest other-args) |
|---|
| 502 | (x86-lap-function apply+ () |
|---|
| 503 | (:arglist (function arg1 arg2 &rest other-args)) |
|---|
| 504 | (check-nargs 3 nil) |
|---|
| 505 | (popl (:rcontext x8632::tcr.save0)) ;save return address |
|---|
| 506 | ;; only two arg regs on x8632, so the caller will always push a frame |
|---|
| 507 | (movl (% arg_z) (% temp0)) ; last |
|---|
| 508 | (movl (% arg_y) (% arg_z)) ; butlast |
|---|
| 509 | (subl ($ '2) (% nargs)) ; remove count for butlast & last |
|---|
| 510 | (movd (% temp1) (% mm0)) ;save nargs (aka temp1) for later |
|---|
| 511 | ;; Do .SPspreadargz inline here |
|---|
| 512 | (xorl (%l temp1) (%l temp1)) |
|---|
| 513 | (movl (% arg_z) (:rcontext x8632::tcr.save1)) ; save in case of error |
|---|
| 514 | (cmp-reg-to-nil arg_z) |
|---|
| 515 | (je @done) |
|---|
| 516 | ;;(mark-as-imm temp1) |
|---|
| 517 | @loop |
|---|
| 518 | (extract-fulltag arg_z imm0) |
|---|
| 519 | (cmpb ($ x8632::fulltag-cons) (%b imm0)) |
|---|
| 520 | (jne @bad) |
|---|
| 521 | (%car arg_z arg_y) |
|---|
| 522 | (%cdr arg_z arg_z) |
|---|
| 523 | (addl ($ '1) (%l temp1)) |
|---|
| 524 | (cmp-reg-to-nil arg_z) |
|---|
| 525 | (push (% arg_y)) |
|---|
| 526 | (jne @loop) |
|---|
| 527 | @done |
|---|
| 528 | ;; nargs was at least 1 when we started spreading, and can't have gotten |
|---|
| 529 | ;; any smaller. |
|---|
| 530 | (movd (% mm0) (% arg_y)) ;nargs from before loop |
|---|
| 531 | (addl (% arg_y) (% temp1)) ;did I mention nargs is temp1? |
|---|
| 532 | (movl (% temp0) (% arg_z)) |
|---|
| 533 | (pop (% arg_y)) |
|---|
| 534 | (addl ($ '1) (% nargs)) |
|---|
| 535 | (load-constant funcall temp0) |
|---|
| 536 | (pushl (:rcontext x8632::tcr.save0)) ;return address |
|---|
| 537 | (movapd (% fpzero) (:rcontext x8632::tcr.save0)) ;clear out spill area |
|---|
| 538 | (jmp-subprim .SPfuncall) |
|---|
| 539 | @bad ;error spreading list. |
|---|
| 540 | (add (% temp1) (% esp)) ;discard whatever's been pushed |
|---|
| 541 | (movl (:rcontext x8632::tcr.save1) (% arg_z)) |
|---|
| 542 | (movapd (% fpzero) (:rcontext x8632::tcr.save0)) ;clear out spill area |
|---|
| 543 | (movl ($ '#.$XNOSPREAD) (% arg_y)) |
|---|
| 544 | (set-nargs 2) |
|---|
| 545 | (jmp-subprim .SPksignalerr) )) |
|---|
| 546 | |
|---|
| 547 | |
|---|
| 548 | |
|---|
| 549 | ;;; This needs to: |
|---|
| 550 | ;;; (a) call the .SPffcall subprimitive, which will discard the foreign |
|---|
| 551 | ;;; stack frame allocated by WITH-VARIABLE-C-FRAME in %FF-CALL |
|---|
| 552 | ;;; (b) re-establish the same foreign stack frame and store the results |
|---|
| 553 | ;;; there. |
|---|
| 554 | ;;; |
|---|
| 555 | ;;; The flags argument tells us what/where the result is: |
|---|
| 556 | ;;; |
|---|
| 557 | ;;;; flags meaning |
|---|
| 558 | ;;; 0 32-bit value in EAX |
|---|
| 559 | ;;; 1 single-float value on x87 stack |
|---|
| 560 | ;;; 2 double-float value on x87 stack |
|---|
| 561 | ;;; 3 64-bit value with low half in EAX, high half in tcr.unboxed1 |
|---|
| 562 | |
|---|
| 563 | (defx8632lapfunction %do-ff-call ((flags 4) #|(ra 0)|# (frame arg_y) (entry arg_z)) |
|---|
| 564 | (save-stackargs-frame 1) |
|---|
| 565 | (push (% arg_y)) |
|---|
| 566 | (push (% arg_z)) |
|---|
| 567 | (call-subprim .SPffcall) |
|---|
| 568 | ;; there might be an fp result on x87 stack, so don't use |
|---|
| 569 | ;; any mmx instructions until the result has been read. |
|---|
| 570 | (movd (:rcontext x8632::tcr.foreign-sp) (% xmm0)) |
|---|
| 571 | (movd (% xmm0) (@ (% frame))) |
|---|
| 572 | (movl (% frame) (:rcontext x8632::tcr.foreign-sp)) |
|---|
| 573 | (cmpl ($ 0) (@ -4 (% ebp))) |
|---|
| 574 | (jne @fp-or-doubleword) |
|---|
| 575 | (movl (% eax) (@ 4 (% frame))) |
|---|
| 576 | @done |
|---|
| 577 | (movl ($ nil) (% arg_z)) |
|---|
| 578 | (restore-simple-frame) |
|---|
| 579 | (single-value-return) |
|---|
| 580 | @fp-or-doubleword |
|---|
| 581 | (cmpl ($ '2) (@ -4 (% ebp))) |
|---|
| 582 | (jl @single) |
|---|
| 583 | (je @double) |
|---|
| 584 | ;; high 32 bits in tcr.unboxed1 (see .SPffcall) |
|---|
| 585 | (movl (% eax) (@ 4 (% frame))) |
|---|
| 586 | (movl (:rcontext x8632::tcr.unboxed1) (% eax)) |
|---|
| 587 | (movl (% eax) (@ 8 (% frame))) |
|---|
| 588 | (jmp @done) |
|---|
| 589 | @single |
|---|
| 590 | (fstps (@ 4 (% frame))) |
|---|
| 591 | (jmp @done) |
|---|
| 592 | @double |
|---|
| 593 | (fstpl (@ 4 (% frame))) |
|---|
| 594 | (jmp @done)) |
|---|
| 595 | |
|---|
| 596 | (defun %ff-call (entry &rest specs-and-vals) |
|---|
| 597 | (declare (dynamic-extent specs-and-vals)) |
|---|
| 598 | (let* ((len (length specs-and-vals)) |
|---|
| 599 | (total-words 0)) |
|---|
| 600 | (declare (fixnum len total-words)) |
|---|
| 601 | (let* ((result-spec (or (car (last specs-and-vals)) :void)) |
|---|
| 602 | (nargs (ash (the fixnum (1- len)) -1))) |
|---|
| 603 | (declare (fixnum nargs)) |
|---|
| 604 | (ecase result-spec |
|---|
| 605 | ((:address :unsigned-doubleword :signed-doubleword |
|---|
| 606 | :single-float :double-float |
|---|
| 607 | :signed-fullword :unsigned-fullword |
|---|
| 608 | :signed-halfword :unsigned-halfword |
|---|
| 609 | :signed-byte :unsigned-byte |
|---|
| 610 | :void) |
|---|
| 611 | (do* ((i 0 (1+ i)) |
|---|
| 612 | (specs specs-and-vals (cddr specs)) |
|---|
| 613 | (spec (car specs) (car specs))) |
|---|
| 614 | ((= i nargs)) |
|---|
| 615 | (declare (fixnum i)) |
|---|
| 616 | (case spec |
|---|
| 617 | (:registers |
|---|
| 618 | (error "don't know what to do with argspec ~s" spec)) |
|---|
| 619 | ((:double-float :unsigned-doubleword :signed-doubleword) |
|---|
| 620 | (incf total-words 2)) |
|---|
| 621 | ((:address :single-float |
|---|
| 622 | :signed-fullword :unsigned-fullword |
|---|
| 623 | :signed-halfword :unsigned-halfword |
|---|
| 624 | :signed-byte :unsigned-byte) |
|---|
| 625 | (incf total-words)) |
|---|
| 626 | (t (if (typep spec 'unsigned-byte) |
|---|
| 627 | (incf total-words spec) |
|---|
| 628 | (error "Invalid argument spec ~s" spec))))) |
|---|
| 629 | ;; It's necessary to ensure that the C frame is the youngest thing on |
|---|
| 630 | ;; the foreign stack here. |
|---|
| 631 | (with-macptrs ((argptr)) |
|---|
| 632 | (with-variable-c-frame |
|---|
| 633 | total-words frame |
|---|
| 634 | (%setf-macptr-to-object argptr frame) |
|---|
| 635 | (let* ((offset 8)) |
|---|
| 636 | (do* ((i 0 (1+ i)) |
|---|
| 637 | (specs specs-and-vals (cddr specs)) |
|---|
| 638 | (spec (car specs) (car specs)) |
|---|
| 639 | (val (cadr specs) (cadr specs))) |
|---|
| 640 | ((= i nargs)) |
|---|
| 641 | (declare (fixnum i)) |
|---|
| 642 | (case spec |
|---|
| 643 | (:double-float |
|---|
| 644 | (setf (%get-double-float argptr offset) val) |
|---|
| 645 | (incf offset 8)) |
|---|
| 646 | (:single-float |
|---|
| 647 | (setf (%get-single-float argptr offset) val) |
|---|
| 648 | (incf offset 4)) |
|---|
| 649 | (:signed-doubleword |
|---|
| 650 | (setf (%%get-signed-longlong argptr offset) val) |
|---|
| 651 | (incf offset 8)) |
|---|
| 652 | (:unsigned-doubleword |
|---|
| 653 | (setf (%%get-unsigned-longlong argptr offset) val) |
|---|
| 654 | (incf offset 8)) |
|---|
| 655 | (:address |
|---|
| 656 | (setf (%get-ptr argptr offset) val) |
|---|
| 657 | (incf offset 4)) |
|---|
| 658 | ((:signed-fullword :signed-halfword :signed-byte) |
|---|
| 659 | (setf (%get-signed-natural argptr offset) val) |
|---|
| 660 | (incf offset 4)) |
|---|
| 661 | ((:unsigned-fullword :unsigned-halfword :unsigned-byte) |
|---|
| 662 | (setf (%get-natural argptr offset) val) |
|---|
| 663 | (incf offset 4)) |
|---|
| 664 | (t |
|---|
| 665 | (let* ((p 0)) |
|---|
| 666 | (declare (fixnum p)) |
|---|
| 667 | (dotimes (i (the fixnum spec)) |
|---|
| 668 | (setf (%get-ptr argptr offset) (%get-ptr val p)) |
|---|
| 669 | (incf p 4) |
|---|
| 670 | (incf offset 4)))))) |
|---|
| 671 | (let ((flags (case result-spec |
|---|
| 672 | (:single-float 1) |
|---|
| 673 | (:double-float 2) |
|---|
| 674 | ((:signed-doubleword :unsigned-doubleword) 3) |
|---|
| 675 | (t 0)))) |
|---|
| 676 | (%do-ff-call flags frame entry)) |
|---|
| 677 | (ecase result-spec |
|---|
| 678 | (:void nil) |
|---|
| 679 | (:address (%get-ptr argptr 4)) |
|---|
| 680 | (:unsigned-byte (%get-unsigned-byte argptr 4)) |
|---|
| 681 | (:signed-byte (%get-signed-byte argptr 4)) |
|---|
| 682 | (:unsigned-halfword (%get-unsigned-word argptr 4)) |
|---|
| 683 | (:signed-halfword (%get-signed-word argptr 4)) |
|---|
| 684 | (:unsigned-fullword (%get-natural argptr 4)) |
|---|
| 685 | (:signed-fullword (%get-signed-natural argptr 4)) |
|---|
| 686 | (:unsigned-doubleword (%%get-unsigned-longlong argptr 4)) |
|---|
| 687 | (:signed-doubleword (%%get-signed-longlong argptr 4)) |
|---|
| 688 | (:single-float (%get-single-float argptr 4)) |
|---|
| 689 | (:double-float (%get-double-float argptr 4))))))))))) |
|---|
| 690 | |
|---|
| 691 | ;;; end of x86-def.lisp |
|---|
