Raymond Toy pushed to branch rtoy-amd64-p1 at cmucl / cmucl

Commits:

5 changed files:

Changes:

  • src/compiler/amd64/sse2-array.lisp
    1 
    +;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*-
    2 
    +;;;
    3 
    +;;; **********************************************************************
    4 
    +;;; This code was written as part of the CMU Common Lisp project at
    5 
    +;;; Carnegie Mellon University, and has been placed in the public domain.
    6 
    +;;; If you want to use this code or any part of CMU Common Lisp, please contact
    7 
    +;;; Scott Fahlman or slisp-group@cs.cmu.edu.
    8 
    +;;;
    9 
    +(ext:file-comment
    10 
    + "$Header: src/compiler/x86/sse2-array.lisp $")
    11 
    +;;;
    12 
    +;;; **********************************************************************
    13 
    +;;;
    14 
    +;;;    This file contains the x86 definitions for array operations.
    15 
    +;;;
    16 
    +
    17 
    +(in-package :amd64)
    18 
    +(intl:textdomain "cmucl-sse2")
    19 
    +
    20 
    +(macrolet
    21 
    +    ((frob (type move copy scale)
    22 
    +       (let ((ref-name (symbolicate "DATA-VECTOR-REF/SIMPLE-ARRAY-" type "-FLOAT"))
    23 
    +	     (c-ref-name (symbolicate "DATA-VECTOR-REF-C/SIMPLE-ARRAY-" type "-FLOAT"))
    24 
    +	     (set-name (symbolicate "DATA-VECTOR-SET/SIMPLE-ARRAY-" type "-FLOAT"))
    25 
    +	     (c-set-name (symbolicate "DATA-VECTOR-SET-C/SIMPLE-ARRAY-" type "-FLOAT"))
    26 
    +	     (result-sc (symbolicate type "-REG"))
    27 
    +	     (result-type (symbolicate type "-FLOAT"))
    28 
    +	     (array-sc (symbolicate "SIMPLE-ARRAY-" type "-FLOAT")))
    29 
    +	 `(progn
    30 
    +	    (define-vop (,ref-name)
    31 
    +	      (:note "inline array access")
    32 
    +	      (:translate data-vector-ref)
    33 
    +	      (:policy :fast-safe)
    34 
    +	      (:args (object :scs (descriptor-reg))
    35 
    +		     (index :scs (any-reg)))
    36 
    +	      (:arg-types ,array-sc positive-fixnum)
    37 
    +	      (:results (value :scs (,result-sc)))
    38 
    +	      (:result-types ,result-type)
    39 
    +	      (:guard (backend-featurep :sse2))
    40 
    +	      (:generator 5
    41 
    +		(inst ,move value
    42 
    +		      (make-ea :dword :base object :index index :scale ,scale
    43 
    +			       :disp (- (* vm:vector-data-offset vm:word-bytes)
    44 
    +					vm:other-pointer-type)))))
    45 
    +	    (define-vop (,c-ref-name)
    46 
    +	      (:note "inline array access")
    47 
    +	      (:translate data-vector-ref)
    48 
    +	      (:policy :fast-safe)
    49 
    +	      (:args (object :scs (descriptor-reg)))
    50 
    +	      (:info index)
    51 
    +	      (:arg-types ,array-sc (:constant (signed-byte 30)))
    52 
    +	      (:results (value :scs (,result-sc)))
    53 
    +	      (:result-types ,result-type)
    54 
    +	      (:guard (backend-featurep :sse2))
    55 
    +	      (:generator 4
    56 
    +		(inst ,move value
    57 
    +		      (make-ea :dword :base object
    58 
    +			       :disp (- (+ (* vm:vector-data-offset vm:word-bytes)
    59 
    +					   (* ,(* 4 scale) index))
    60 
    +					vm:other-pointer-type)))))
    61 
    +	    (define-vop (,set-name)
    62 
    +	      (:note "inline array store")
    63 
    +	      (:translate data-vector-set)
    64 
    +	      (:policy :fast-safe)
    65 
    +	      (:args (object :scs (descriptor-reg))
    66 
    +		     (index :scs (any-reg))
    67 
    +		     (value :scs (,result-sc) :target result))
    68 
    +	      (:arg-types ,array-sc positive-fixnum ,result-type)
    69 
    +	      (:results (result :scs (,result-sc)))
    70 
    +	      (:result-types ,result-type)
    71 
    +	      (:guard (backend-featurep :sse2))
    72 
    +	      (:generator 5
    73 
    +		(inst ,move (make-ea :dword :base object :index index :scale ,scale
    74 
    +				     :disp (- (* vm:vector-data-offset vm:word-bytes)
    75 
    +					      vm:other-pointer-type))
    76 
    +		      value)
    77 
    +		(unless (location= result value)
    78 
    +		  (inst ,copy result value))))
    79 
    +
    80 
    +	    (define-vop (,c-set-name)
    81 
    +	      (:note "inline array store")
    82 
    +	      (:translate data-vector-set)
    83 
    +	      (:policy :fast-safe)
    84 
    +	      (:args (object :scs (descriptor-reg))
    85 
    +		     (value :scs (,result-sc) :target result))
    86 
    +	      (:info index)
    87 
    +	      (:arg-types ,array-sc (:constant (signed-byte 30))
    88 
    +			  ,result-type)
    89 
    +	      (:results (result :scs (,result-sc)))
    90 
    +	      (:result-types ,result-type)
    91 
    +	      (:guard (backend-featurep :sse2))
    92 
    +	      (:generator 4
    93 
    +		(inst ,move (make-ea :dword :base object
    94 
    +				     :disp (- (+ (* vm:vector-data-offset
    95 
    +						    vm:word-bytes)
    96 
    +						 (* ,(* 4 scale) index))
    97 
    +					      vm:other-pointer-type))
    98 
    +		      value)
    99 
    +		(unless (location= result value)
    100 
    +		  (inst ,copy result value))))))))
    101 
    +  (frob single movss movss 1)
    102 
    +  (frob double movsd movsd 2)
    103 
    +  (frob complex-single movlps movaps 2)
    104 
    +  (frob complex-double movupd movapd 4))
    105 
    +
    106 
    +
    107 
    +#+double-double
    108 
    +(progn
    109 
    +(define-vop (data-vector-ref/simple-array-double-double-float)
    110 
    +  (:note "inline array access")
    111 
    +  (:translate data-vector-ref)
    112 
    +  (:policy :fast-safe)
    113 
    +  (:args (object :scs (descriptor-reg) :to :result)
    114 
    +	 (index :scs (any-reg)))
    115 
    +  (:arg-types simple-array-double-double-float positive-fixnum)
    116 
    +  (:results (value :scs (double-double-reg)))
    117 
    +  (:result-types double-double-float)
    118 
    +  (:guard (backend-featurep :sse2))
    119 
    +  (:generator 7
    120 
    +    (let ((hi-tn (double-double-reg-hi-tn value)))
    121 
    +      (inst movsd hi-tn
    122 
    +	    (make-ea :dword :base object :index index :scale 4
    123 
    +		     :disp (- (* vm:vector-data-offset vm:word-bytes)
    124 
    +			      vm:other-pointer-type))))
    125 
    +    (let ((lo-tn (double-double-reg-lo-tn value)))
    126 
    +      (inst movsd lo-tn (make-ea :dword :base object :index index :scale 4
    127 
    +				 :disp (- (+ (* vm:vector-data-offset vm:word-bytes)
    128 
    +					     8)
    129 
    +					  vm:other-pointer-type))))))
    130 
    +
    131 
    +(define-vop (data-vector-ref-c/simple-array-double-double-float)
    132 
    +  (:note "inline array access")
    133 
    +  (:translate data-vector-ref)
    134 
    +  (:policy :fast-safe)
    135 
    +  (:args (object :scs (descriptor-reg) :to :result))
    136 
    +  (:arg-types simple-array-double-double-float (:constant index))
    137 
    +  (:info index)
    138 
    +  (:results (value :scs (double-double-reg)))
    139 
    +  (:result-types double-double-float)
    140 
    +  (:guard (backend-featurep :sse2))
    141 
    +  (:generator 5
    142 
    +    (let ((hi-tn (double-double-reg-hi-tn value)))
    143 
    +      (inst movsd hi-tn
    144 
    +	    (make-ea :dword :base object
    145 
    +		     :disp (- (+ (* vm:vector-data-offset vm:word-bytes)
    146 
    +				 (* 16 index))
    147 
    +			      vm:other-pointer-type))))
    148 
    +    (let ((lo-tn (double-double-reg-lo-tn value)))
    149 
    +      (inst movsd lo-tn
    150 
    +	    (make-ea :dword :base object
    151 
    +		     :disp (- (+ (* vm:vector-data-offset vm:word-bytes)
    152 
    +				 (* 16 index)
    153 
    +				 8)
    154 
    +			      vm:other-pointer-type))))))
    155 
    +
    156 
    +(define-vop (data-vector-set/simple-array-double-double-float)
    157 
    +  (:note "inline array store")
    158 
    +  (:translate data-vector-set)
    159 
    +  (:policy :fast-safe)
    160 
    +  (:args (object :scs (descriptor-reg) :to :result)
    161 
    +	 (index :scs (any-reg))
    162 
    +	 (value :scs (double-double-reg) :target result))
    163 
    +  (:arg-types simple-array-double-double-float positive-fixnum
    164 
    +	      double-double-float)
    165 
    +  (:results (result :scs (double-double-reg)))
    166 
    +  (:result-types double-double-float)
    167 
    +  (:guard (backend-featurep :sse2))
    168 
    +  (:generator 20
    169 
    +    (let ((value-real (double-double-reg-hi-tn value))
    170 
    +	  (result-real (double-double-reg-hi-tn result)))
    171 
    +      (inst movsd (make-ea :dword :base object :index index :scale 4
    172 
    +			   :disp (- (* vm:vector-data-offset
    173 
    +				       vm:word-bytes)
    174 
    +				    vm:other-pointer-type))
    175 
    +	    value-real)
    176 
    +      (inst movsd result-real value-real))
    177 
    +    (let ((value-imag (double-double-reg-lo-tn value))
    178 
    +	  (result-imag (double-double-reg-lo-tn result)))
    179 
    +      (inst movsd (make-ea :dword :base object :index index :scale 4
    180 
    +			   :disp (- (+ (* vm:vector-data-offset vm:word-bytes)
    181 
    +				       8)
    182 
    +				    vm:other-pointer-type))
    183 
    +	    value-imag)
    184 
    +      (inst movsd result-imag value-imag))))
    185 
    +
    186 
    +(define-vop (data-vector-set-c/simple-array-double-double-float)
    187 
    +  (:note "inline array store")
    188 
    +  (:translate data-vector-set)
    189 
    +  (:policy :fast-safe)
    190 
    +  (:args (object :scs (descriptor-reg) :to :result)
    191 
    +	 (value :scs (double-double-reg) :target result))
    192 
    +  (:arg-types simple-array-double-double-float
    193 
    +	      (:constant index)
    194 
    +	      double-double-float)
    195 
    +  (:info index)
    196 
    +  (:results (result :scs (double-double-reg)))
    197 
    +  (:result-types double-double-float)
    198 
    +  (:guard (backend-featurep :sse2))
    199 
    +  (:generator 20
    200 
    +    (let ((value-real (double-double-reg-hi-tn value))
    201 
    +	  (result-real (double-double-reg-hi-tn result)))
    202 
    +      (inst movsd (make-ea :dword :base object
    203 
    +			   :disp (- (+ (* vm:vector-data-offset
    204 
    +					  vm:word-bytes)
    205 
    +				       (* 16 index))
    206 
    +				    vm:other-pointer-type))
    207 
    +	    value-real)
    208 
    +      (inst movsd result-real value-real))
    209 
    +    (let ((value-imag (double-double-reg-lo-tn value))
    210 
    +	  (result-imag (double-double-reg-lo-tn result)))
    211 
    +      (inst movsd (make-ea :dword :base object
    212 
    +			   :disp (- (+ (* vm:vector-data-offset vm:word-bytes)
    213 
    +				       (* 16 index)
    214 
    +				       8)
    215 
    +				    vm:other-pointer-type))
    216 
    +	    value-imag)
    217 
    +      (inst movsd result-imag value-imag))))
    218 
    +
    219 
    +(define-vop (data-vector-ref/simple-array-complex-double-double-float)
    220 
    +  (:note "inline array access")
    221 
    +  (:translate data-vector-ref)
    222 
    +  (:policy :fast-safe)
    223 
    +  (:args (object :scs (descriptor-reg) :to :result)
    224 
    +	 (index :scs (any-reg)))
    225 
    +  (:arg-types simple-array-complex-double-double-float positive-fixnum)
    226 
    +  (:results (value :scs (complex-double-double-reg)))
    227 
    +  (:result-types complex-double-double-float)
    228 
    +  (:guard (backend-featurep :sse2))
    229 
    +  (:generator 7
    230 
    +    (let ((real-tn (complex-double-double-reg-real-hi-tn value)))
    231 
    +      (inst movsd real-tn
    232 
    +	    (make-ea :dword :base object :index index :scale 8
    233 
    +		     :disp (- (* vm:vector-data-offset vm:word-bytes)
    234 
    +			      vm:other-pointer-type))))
    235 
    +    (let ((real-tn (complex-double-double-reg-real-lo-tn value)))
    236 
    +      (inst movsd real-tn
    237 
    +	    (make-ea :dword :base object :index index :scale 8
    238 
    +		     :disp (- (+ (* vm:vector-data-offset vm:word-bytes)
    239 
    +				 8)
    240 
    +			      vm:other-pointer-type))))
    241 
    +    (let ((imag-tn (complex-double-double-reg-imag-hi-tn value)))
    242 
    +      (inst movsd imag-tn
    243 
    +	    (make-ea :dword :base object :index index :scale 8
    244 
    +		     :disp (- (+ (* vm:vector-data-offset vm:word-bytes)
    245 
    +				 16)
    246 
    +			      vm:other-pointer-type))))
    247 
    +    (let ((imag-tn (complex-double-double-reg-imag-lo-tn value)))
    248 
    +      (inst movsd imag-tn
    249 
    +	    (make-ea :dword :base object :index index :scale 8
    250 
    +		     :disp (- (+ (* vm:vector-data-offset vm:word-bytes)
    251 
    +				 24)
    252 
    +			      vm:other-pointer-type))))))
    253 
    +
    254 
    +(define-vop (data-vector-ref-c/simple-array-complex-double-double-float)
    255 
    +  (:note "inline array access")
    256 
    +  (:translate data-vector-ref)
    257 
    +  (:policy :fast-safe)
    258 
    +  (:args (object :scs (descriptor-reg) :to :result))
    259 
    +  (:arg-types simple-array-complex-double-double-float (:constant index))
    260 
    +  (:info index)
    261 
    +  (:results (value :scs (complex-double-double-reg)))
    262 
    +  (:result-types complex-double-double-float)
    263 
    +  (:guard (backend-featurep :sse2))
    264 
    +  (:generator 5
    265 
    +    (let ((real-tn (complex-double-double-reg-real-hi-tn value)))
    266 
    +      (inst movsd real-tn
    267 
    +	    (make-ea :dword :base object
    268 
    +		     :disp (- (+ (* vm:vector-data-offset vm:word-bytes)
    269 
    +				 (* 32 index))
    270 
    +			      vm:other-pointer-type))))
    271 
    +    (let ((real-tn (complex-double-double-reg-real-lo-tn value)))
    272 
    +      (inst movsd real-tn
    273 
    +	    (make-ea :dword :base object
    274 
    +		     :disp (- (+ (* vm:vector-data-offset vm:word-bytes)
    275 
    +				 (* 32 index)
    276 
    +				 8)
    277 
    +			      vm:other-pointer-type))))
    278 
    +    (let ((imag-tn (complex-double-double-reg-imag-hi-tn value)))
    279 
    +      (inst movsd imag-tn
    280 
    +	    (make-ea :dword :base object
    281 
    +		     :disp (- (+ (* vm:vector-data-offset vm:word-bytes)
    282 
    +				 (* 32 index)
    283 
    +				 16)
    284 
    +			      vm:other-pointer-type))))
    285 
    +    (let ((imag-tn (complex-double-double-reg-imag-lo-tn value)))
    286 
    +      (inst movsd imag-tn
    287 
    +	    (make-ea :dword :base object
    288 
    +		     :disp (- (+ (* vm:vector-data-offset vm:word-bytes)
    289 
    +				 (* 32 index)
    290 
    +				 24)
    291 
    +			      vm:other-pointer-type))))))
    292 
    +
    293 
    +(define-vop (data-vector-set/simple-array-complex-double-double-float)
    294 
    +  (:note "inline array store")
    295 
    +  (:translate data-vector-set)
    296 
    +  (:policy :fast-safe)
    297 
    +  (:args (object :scs (descriptor-reg) :to :result)
    298 
    +	 (index :scs (any-reg))
    299 
    +	 (value :scs (complex-double-double-reg) :target result))
    300 
    +  (:arg-types simple-array-complex-double-double-float positive-fixnum
    301 
    +	      complex-double-double-float)
    302 
    +  (:results (result :scs (complex-double-double-reg)))
    303 
    +  (:result-types complex-double-double-float)
    304 
    +  (:guard (backend-featurep :sse2))
    305 
    +  (:generator 20
    306 
    +    (let ((value-real (complex-double-double-reg-real-hi-tn value))
    307 
    +	  (result-real (complex-double-double-reg-real-hi-tn result)))
    308 
    +      (inst movsd (make-ea :dword :base object :index index :scale 8
    309 
    +			   :disp (- (* vm:vector-data-offset
    310 
    +				       vm:word-bytes)
    311 
    +				    vm:other-pointer-type))
    312 
    +	    value-real)
    313 
    +      (inst movsd result-real value-real))
    314 
    +    (let ((value-real (complex-double-double-reg-real-lo-tn value))
    315 
    +	  (result-real (complex-double-double-reg-real-lo-tn result)))
    316 
    +      (inst movsd (make-ea :dword :base object :index index :scale 8
    317 
    +			   :disp (- (+ (* vm:vector-data-offset
    318 
    +					  vm:word-bytes)
    319 
    +				       8)
    320 
    +				    vm:other-pointer-type))
    321 
    +	    value-real)
    322 
    +      (inst movsd result-real value-real))
    323 
    +    (let ((value-imag (complex-double-double-reg-imag-hi-tn value))
    324 
    +	  (result-imag (complex-double-double-reg-imag-hi-tn result)))
    325 
    +      (inst movsd (make-ea :dword :base object :index index :scale 8
    326 
    +			   :disp (- (+ (* vm:vector-data-offset vm:word-bytes)
    327 
    +				       16)
    328 
    +				    vm:other-pointer-type))
    329 
    +	    value-imag)
    330 
    +      (inst movsd result-imag value-imag))
    331 
    +    (let ((value-imag (complex-double-double-reg-imag-lo-tn value))
    332 
    +	  (result-imag (complex-double-double-reg-imag-lo-tn result)))
    333 
    +      (inst movsd (make-ea :dword :base object :index index :scale 8
    334 
    +			   :disp (- (+ (* vm:vector-data-offset vm:word-bytes)
    335 
    +				       24)
    336 
    +				    vm:other-pointer-type))
    337 
    +	    value-imag)
    338 
    +      (inst movsd result-imag value-imag))))
    339 
    +
    340 
    +(define-vop (data-vector-set-c/simple-array-complex-double-double-float)
    341 
    +  (:note "inline array store")
    342 
    +  (:translate data-vector-set)
    343 
    +  (:policy :fast-safe)
    344 
    +  (:args (object :scs (descriptor-reg) :to :result)
    345 
    +	 (value :scs (complex-double-double-reg) :target result))
    346 
    +  (:arg-types simple-array-complex-double-double-float
    347 
    +	      (:constant index)
    348 
    +	      complex-double-double-float)
    349 
    +  (:info index)
    350 
    +  (:results (result :scs (complex-double-double-reg)))
    351 
    +  (:result-types complex-double-double-float)
    352 
    +  (:guard (backend-featurep :sse2))
    353 
    +  (:generator 20
    354 
    +    (let ((value-real (complex-double-double-reg-real-hi-tn value))
    355 
    +	  (result-real (complex-double-double-reg-real-hi-tn result)))
    356 
    +      (inst movsd (make-ea :dword :base object
    357 
    +			   :disp (- (+ (* vm:vector-data-offset
    358 
    +					  vm:word-bytes)
    359 
    +				       (* 32 index))
    360 
    +				    vm:other-pointer-type))
    361 
    +	    value-real)
    362 
    +      (inst movsd result-real value-real))
    363 
    +    (let ((value-real (complex-double-double-reg-real-lo-tn value))
    364 
    +	  (result-real (complex-double-double-reg-real-lo-tn result)))
    365 
    +      (inst movsd (make-ea :dword :base object
    366 
    +			   :disp (- (+ (* vm:vector-data-offset
    367 
    +					  vm:word-bytes)
    368 
    +				       (* 32 index)
    369 
    +				       8)
    370 
    +				    vm:other-pointer-type))
    371 
    +	    value-real)
    372 
    +      (inst movsd result-real value-real))
    373 
    +    (let ((value-imag (complex-double-double-reg-imag-hi-tn value))
    374 
    +	  (result-imag (complex-double-double-reg-imag-hi-tn result)))
    375 
    +      (inst movsd (make-ea :dword :base object
    376 
    +			   :disp (- (+ (* vm:vector-data-offset vm:word-bytes)
    377 
    +				       (* 32 index)
    378 
    +				       16)
    379 
    +				    vm:other-pointer-type))
    380 
    +	    value-imag)
    381 
    +      (inst movsd result-imag value-imag))
    382 
    +    (let ((value-imag (complex-double-double-reg-imag-lo-tn value))
    383 
    +	  (result-imag (complex-double-double-reg-imag-lo-tn result)))
    384 
    +      (inst movsd (make-ea :dword :base object
    385 
    +			   :disp (- (+ (* vm:vector-data-offset vm:word-bytes)
    386 
    +				       (* 32 index)
    387 
    +				       24)
    388 
    +				    vm:other-pointer-type))
    389 
    +	    value-imag)
    390 
    +      (inst movsd result-imag value-imag))))
    391 
    +
    392 
    +)

  • src/compiler/amd64/sse2-c-call.lisp
    1 
    +;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*-
    2 
    +;;;
    3 
    +;;; **********************************************************************
    4 
    +;;; This code was written as part of the CMU Common Lisp project at
    5 
    +;;; Carnegie Mellon University, and has been placed in the public domain.
    6 
    +;;; If you want to use this code or any part of CMU Common Lisp, please contact
    7 
    +;;; Scott Fahlman or slisp-group@cs.cmu.edu.
    8 
    +;;;
    9 
    +(ext:file-comment
    10 
    + "$Header: src/compiler/x86/sse2-c-call.lisp $")
    11 
    +;;;
    12 
    +;;; **********************************************************************
    13 
    +;;;
    14 
    +;;; This file contains the VOPs and other necessary machine specific support
    15 
    +;;; routines for call-out to C.
    16 
    +;;;
    17 
    +
    18 
    +(in-package :amd64)
    19 
    +(use-package :alien)
    20 
    +(use-package :alien-internals)
    21 
    +(intl:textdomain "cmucl-sse2")
    22 
    +
    23 
    +;; Note: other parts of the compiler depend on vops having exactly
    24 
    +;; these names.  Don't change them, unless you also change the other
    25 
    +;; parts of the compiler.
    26 
    +
    27 
    +(define-vop (call-out)
    28 
    +  (:args (function :scs (sap-reg))
    29 
    +	 (args :more t))
    30 
    +  (:results (results :more t))
    31 
    +  (:temporary (:sc unsigned-reg :offset rax-offset
    32 
    +		   :from :eval :to :result) rax)
    33 
    +  (:temporary (:sc unsigned-reg :offset rcx-offset
    34 
    +		   :from :eval :to :result) rcx)
    35 
    +  (:temporary (:sc unsigned-reg :offset rdx-offset
    36 
    +		   :from :eval :to :result) 5dx)
    37 
    +  (:temporary (:sc single-stack) temp-single)
    38 
    +  (:temporary (:sc double-stack) temp-double)
    39 
    +  (:node-var node)
    40 
    +  (:vop-var vop)
    41 
    +  (:save-p t)
    42 
    +  (:ignore args rcx rdx)
    43 
    +  (:guard (backend-featurep :sse2))
    44 
    +  (:generator 0
    45 
    +    (cond ((policy node (> space speed))
    46 
    +	   (move rax function)
    47 
    +	   (inst call (make-fixup (extern-alien-name "call_into_c") :foreign)))
    48 
    +	  (t
    49 
    +	   (inst call function)
    50 
    +	   ;; To give the debugger a clue. XX not really internal-error?
    51 
    +	   (note-this-location vop :internal-error)))
    52 
    +    ;; FIXME: check that a float result is returned when expected. If
    53 
    +    ;; we don't, we'll either get a NaN when doing the fstp or we'll
    54 
    +    ;; leave an entry on the FPU and we'll eventually overflow the FPU
    55 
    +    ;; stack.
    56 
    +    (when (and results
    57 
    +	       (location= (tn-ref-tn results) xmm0-tn))
    58 
    +      ;; If there's a float result, it would have been returned
    59 
    +      ;; in ST(0) according to the ABI. We want it in xmm0.
    60 
    +      (sc-case (tn-ref-tn results)
    61 
    +	(single-reg
    62 
    +	 (inst fstp (ea-for-sf-stack temp-single))
    63 
    +	 (inst movss xmm0-tn (ea-for-sf-stack temp-single)))
    64 
    +	(double-reg
    65 
    +	 (inst fstpd (ea-for-df-stack temp-double))
    66 
    +	 (inst movsd xmm0-tn (ea-for-df-stack temp-double)))))))
    67 
    +
    68 
    +(define-vop (alloc-number-stack-space)
    69 
    +  (:info amount)
    70 
    +  (:results (result :scs (sap-reg any-reg)))
    71 
    +  (:generator 0
    72 
    +    (assert (location= result rsp-tn))
    73 
    +
    74 
    +    (unless (zerop amount)
    75 
    +      (let ((delta (logandc2 (+ amount 3) 3)))
    76 
    +	(inst sub rsp-tn delta)))
    77 
    +    ;; Align the stack to a 16-byte boundary.  This is required an
    78 
    +    ;; Darwin and should be harmless everywhere else.
    79 
    +    (inst and esp-tn #xfffffff0)
    80 
    +    (move result rsp-tn)))
    81 
    +
    82 
    +(define-vop (dealloc-number-stack-space)
    83 
    +  (:info amount)
    84 
    +  (:generator 0
    85 
    +    (unless (zerop amount)
    86 
    +      (let ((delta (logandc2 (+ amount 3) 3)))
    87 
    +	(inst add rsp-tn delta)))))

  • src/compiler/amd64/sse2-sap.lisp
    1 
    +1;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*-
    2 
    +;;;
    3 
    +;;; **********************************************************************
    4 
    +;;; This code was written as part of the CMU Common Lisp project at
    5 
    +;;; Carnegie Mellon University, and has been placed in the public domain.
    6 
    +;;; If you want to use this code or any part of CMU Common Lisp, please contact
    7 
    +;;; Scott Fahlman or slisp-group@cs.cmu.edu.
    8 
    +;;;
    9 
    +(ext:file-comment
    10 
    + "$Header: src/compiler/x86/sse2-sap.lisp $")
    11 
    +;;;
    12 
    +;;; **********************************************************************
    13 
    +;;;
    14 
    +;;; This file contains the x86 VM definition of SAP operations.
    15 
    +;;;
    16 
    +
    17 
    +(in-package :amd64)
    18 
    +(intl:textdomain "cmucl-sse2")
    19 
    +
    20 
    +(macrolet
    21 
    +    ((frob (name type inst)
    22 
    +       (let ((sc-type (symbolicate type "-REG"))
    23 
    +	     (res-type (symbolicate type "-FLOAT")))
    24 
    +	 `(progn
    25 
    +	    (define-vop (,(symbolicate "SAP-REF-" name))
    26 
    +	      (:translate ,(symbolicate "SAP-REF-" name))
    27 
    +	      (:policy :fast-safe)
    28 
    +	      (:args (sap :scs (sap-reg))
    29 
    +		     (offset :scs (signed-reg)))
    30 
    +	      (:arg-types system-area-pointer signed-num)
    31 
    +	      (:results (result :scs (,sc-type)))
    32 
    +	      (:result-types ,res-type)
    33 
    +	      (:generator 5
    34 
    +		(inst ,inst result (make-ea :dword :base sap :index offset))))
    35 
    +	    (define-vop (,(symbolicate "SAP-REF-" type "-C"))
    36 
    +		(:translate ,(symbolicate "SAP-REF-" type))
    37 
    +	      (:policy :fast-safe)
    38 
    +	      (:args (sap :scs (sap-reg)))
    39 
    +	      (:arg-types system-area-pointer (:constant (signed-byte 32)))
    40 
    +	      (:info offset)
    41 
    +	      (:results (result :scs (,sc-type)))
    42 
    +	      (:result-types ,res-type)
    43 
    +	      (:generator 4
    44 
    +		(inst ,inst result (make-ea :dword :base sap :disp offset))))
    45 
    +	    (define-vop (,(symbolicate "%SET-SAP-REF-" type))
    46 
    +	      (:translate ,(symbolicate "%SET-SAP-REF-" type))
    47 
    +	      (:policy :fast-safe)
    48 
    +	      (:args (sap :scs (sap-reg) :to (:eval 0))
    49 
    +		     (offset :scs (signed-reg) :to (:eval 0))
    50 
    +		     (value :scs (,sc-type)))
    51 
    +	      (:arg-types system-area-pointer signed-num ,res-type)
    52 
    +	      (:results (result :scs (,sc-type)))
    53 
    +	      (:result-types ,res-type)
    54 
    +	      (:generator 5
    55 
    +		(inst ,inst (make-ea :dword :base sap :index offset) value)
    56 
    +		(unless (location= result value)
    57 
    +		  (inst ,inst result value))))
    58 
    +	    (define-vop (,(symbolicate "%SET-SAP-REF-" type "-C"))
    59 
    +	      (:translate ,(symbolicate "%SET-SAP-REF-" type))
    60 
    +	      (:policy :fast-safe)
    61 
    +	      (:args (sap :scs (sap-reg) :to (:eval 0))
    62 
    +		     (value :scs (,sc-type)))
    63 
    +	      (:arg-types system-area-pointer (:constant (signed-byte 32))
    64 
    +			  ,res-type)
    65 
    +	      (:info offset)
    66 
    +	      (:results (result :scs (,sc-type)))
    67 
    +	      (:result-types ,res-type)
    68 
    +	      (:generator 4
    69 
    +		(inst ,inst (make-ea :dword :base sap :disp offset) value)
    70 
    +		(unless (location= result value)
    71 
    +		  (inst ,inst result value))))))))
    72 
    +  (frob double double movsd)
    73 
    +  (frob single single movss)
    74 
    +  ;; Not really right since these aren't long floats
    75 
    +  (frob long   double movsd))

  • src/tools/comcom.lisp
    ... ... @@ -180,7 +180,7 @@
    180 180 
     	  (vmdir "target:compiler/float"))
    181 181 
           :byte-compile *byte-compile*)
    182 182 
     (comf (vmdir "target:compiler/sap") :byte-compile *byte-compile*)
    183 
    -(when (c:target-featurep :x86)
    183 
    +(when (c:target-featurep :sse2)
    184 184 
       (comf (vmdir "target:compiler/sse2-sap")
    185 185 
     	:byte-compile *byte-compile*))
    186 186 
     (comf (vmdir "target:compiler/system") :byte-compile *byte-compile*)
    ... ... @@ -192,7 +192,7 @@
    192 192
    193 193 
     (comf (vmdir "target:compiler/debug") :byte-compile *byte-compile*)
    194 194 
     (comf (vmdir "target:compiler/c-call") :byte-compile *byte-compile*)
    195 
    -(when (c:target-featurep :x86)
    195 
    +(when (c:target-featurep :sse2)
    196 196 
       (comf (vmdir "target:compiler/sse2-c-call")
    197 197 
     	:byte-compile *byte-compile*))
    198 198 
     (when (c:target-featurep :alien-callback)
    ... ... @@ -206,7 +206,7 @@
    206 206
    207 207 
     ;; Must come before array.lisp because array.lisp wants to use some
    208 208 
     ;; vops as templates.
    209 
    -(when (c:target-featurep :x86)
    209 
    +(when (c:target-featurep :sse2)
    210 210 
       (comf (vmdir "target:compiler/sse2-array")
    211 211 
     	:byte-compile *byte-compile*))
    212 212

  • src/tools/cross-scripts/cross-x86-amd64.lisp
    ... ... @@ -273,6 +273,7 @@
    273 273
    274 274 
     (in-package :cl-user)
    275 275
    276 
    +(print "***Comcom")
    276 277 
     (load "target:tools/comcom")
    277 278
    278 279 
     ;;; Load the new backend.
    ... ... @@ -284,7 +285,7 @@
    284 285 
           '("target:assembly/" "target:assembly/amd64/"))
    285 286
    286 287 
     ;; Load the backend of the compiler.
    287 
    -
    288 
    +(print "***Load backend")
    288 289 
     (in-package "C")
    289 290
    290 291 
     (load "vm:vm-fndb")
    ... ... @@ -299,6 +300,7 @@
    299 300 
     (load "target:compiler/srctran")
    300 301 
     (load "vm:vm-typetran")
    301 302 
     (load "target:compiler/float-tran")
    303 
    +(load "target:compiler/float-tran-dd")
    302 304 
     (load "target:compiler/saptran")
    303 305
    304 306 
     (load "vm:macros")
    ... ... @@ -309,9 +311,10 @@
    309 311 
     (load "vm:primtype")
    310 312 
     (load "vm:move")
    311 313 
     (load "vm:sap")
    314 
    +(load "vm:sse2-sap")
    312 315 
     (load "vm:system")
    313 316 
     (load "vm:char")
    314 
    -(load "vm:float")
    317 
    +(load "vm:float-sse2")
    315 318
    316 319 
     (load "vm:memory")
    317 320 
     (load "vm:static-fn")
    ... ... @@ -319,12 +322,13 @@
    319 322 
     (load "vm:cell")
    320 323 
     (load "vm:subprim")
    321 324 
     (load "vm:debug")
    322 
    -(load "vm:c-call")
    325 
    +(load "vm:sse2-c-call")
    323 326 
     (load "vm:print")
    324 327 
     (load "vm:alloc")
    325 328 
     (load "vm:call")
    326 329 
     (load "vm:nlx")
    327 330 
     (load "vm:values")
    331 
    +(load "vm:sse2-array")
    328 332 
     (load "vm:array")
    329 333 
     (load "vm:pred")
    330 334 
     (load "vm:type-vops")

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.common-lisp.net. If you'd like to receive fewer emails, you can adjust your notification settings.