Newer
Older
;;; -*- Package: C -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the Spice Lisp project at
;;; Carnegie-Mellon University, and has been placed in the public domain.
;;; If you want to use this code or any part of Spice Lisp, please contact
;;; Scott Fahlman (FAHLMAN@CMUC).
;;; **********************************************************************
;;;
;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/alloc.lisp,v 1.2 1990/02/27 11:30:27 wlott Exp $
;;;
;;; Allocation VOPs for the MIPS port.
;;;
;;; Written by William Lott.
;;;
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
(define-vop (list-or-list*)
(:args (things :more t))
(:temporary (:scs (descriptor-reg) :type list) ptr)
(:temporary (:scs (descriptor-reg)) temp)
(:temporary (:scs (descriptor-reg) :type list :to (:result 0) :target result)
res)
(:temporary (:scs (non-descriptor-reg) :type random) ndescr)
(:info num)
(:results (result :scs (descriptor-reg)))
(:variant-vars star)
(:policy :safe)
(:generator 0
(cond ((zerop num)
(move result null-tn))
((and star (= num 1))
(move result (tn-ref-tn things)))
(t
(macrolet
((store-car (tn list &optional (slot vm:cons-car-slot))
`(let ((reg
(sc-case ,tn
((any-reg descriptor-reg) ,tn)
(zero zero-tn)
(null null-tn)
(control-stack
(load-stack-tn temp ,tn)
temp))))
(storew reg ,list ,slot vm:list-pointer-type))))
(let ((cons-cells (if star (1- num) num)))
(pseudo-atomic (ndescr)
(inst addiu res alloc-tn vm:list-pointer-type)
(inst addiu alloc-tn alloc-tn
(* (vm:pad-data-block vm:cons-size) cons-cells)))
(move ptr res)
(dotimes (i (1- cons-cells))
(store-car (tn-ref-tn things) ptr)
(setf things (tn-ref-across things))
(inst addiu ptr ptr (vm:pad-data-block vm:cons-size))
(storew ptr ptr
(- vm:cons-cdr-slot (vm:pad-data-block vm:cons-size))
vm:list-pointer-type))
(store-car (tn-ref-tn things) ptr)
(cond (star
(setf things (tn-ref-across things))
(store-car (tn-ref-tn things) ptr vm:cons-cdr-slot))
(t
(storew null-tn ptr
vm:cons-cdr-slot vm:list-pointer-type)))
(assert (null (tn-ref-across things)))
(move result res)))))))
(define-vop (list list-or-list*)
(:variant nil))
(define-vop (list* list-or-list*)
(:variant t))