1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
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
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
|
(in-package :compiler)
(defun c-key-rep (key)
(ecase key
((:object :char :int :long :float :double :fixnum :void) (string-downcase key))
(:string "char *")
(:ustring "unsigned char *")))
(defmacro defentry (n args c &optional (lt t)
&aux (tsyms (load-time-value
(mapl (lambda (x) (setf (car x) (gensym "DEFENTRY")))
(make-list call-arguments-limit)))))
(let* ((cp (consp c))
(st (and cp (eq (car c) 'static)))
(c (if st (cdr c) c))
(m (if cp (cadr c) c))
(m (if (symbolp m) (string-downcase m) m))
(rt (intern (symbol-name (if cp (car c) lt)) 'keyword))
(tps (mapcar (lambda (x) (intern (string (if (consp x) (car x) x)) 'keyword)) args))
(decl (reduce (lambda (y x)
(strcat y (if (> (length y) 0) "," "")
(c-key-rep x)))
tps :initial-value ""))
(decl (concatenate 'string (c-key-rep rt) " " m "(" decl ");"))
(decl (if st "" decl))
(syms (mapcar (lambda (x) (declare (ignore x)) (pop tsyms)) args)))
`(defun ,n ,syms
(declare (optimize (safety 2)))
,@(mapcar (lambda (x y) `(check-type ,x ,(get y 'lisp-type))) syms tps)
(lit ,(if (eq rt :void) :object rt)
"({" ,decl
,@(when (eq rt :void) `("("))
,m "("
,@(mapcon (lambda (x y z) `((,(car z) ,(car y))
,(if (cdr x) (if (consp (car x)) "+" ",") ""))) args syms tps)
")"
,@(when (eq rt :void) `(",Cnil)"))
";})"))))
(defun fm-to-string (form)
(typecase form
; (null "Cnil")
; (true "Ct")
((cons (eql vv) t) (fm-to-string (cadr form)))
((cons (member char-value fixnum-value character-value) t) (fm-to-string (caddr form)))
((eql most-negative-fixnum) #.(string-concatenate "(" (write-to-string (1+ most-negative-fixnum)) "- 1)"))
(fixnum (format nil "~a" form)); string character
(float (format nil "~10,,,,,,'eG" form))
((complex float)
(string-concatenate "(" (fm-to-string (realpart form)) " + I * " (fm-to-string (imagpart form)) ")"))))
(when (eql 32 (si::heap-report))
(setq compiler::*cmpinclude-string* (compiler::mysub compiler::*cmpinclude-string* "void *alloca(unsigned long);" "void *alloca(unsigned);")))
(defconstant +max-typed-args+ (let ((x (cdr (tp-bnds (cadr (si::sig 'c-function-argd))))))
(if (typep x 'fixnum) (1- (truncate (integer-length x) 2)) 0)))
(defun new-proclaimed-argd (args return)
(do* ((type (f-type return) (f-type (pop args)))
(i 0 (+ 2 i))
(ans type (logior ans (ash type i))))
((or (>= i #.(ash (1+ +max-typed-args+) 1)) (null args))
(the (unsigned-byte #.(1+ (ash (1+ +max-typed-args+) 1))) ans))))
(defun wt-requireds (requireds arg-types &optional first narg &aux (i -1))
(declare (ignore arg-types))
(flet ((wt (x) (wt x) (let ((*compiler-output1* *compiler-output2*)) (wt x))))
(dolist (v requireds (wt (if narg ",...)" ")")))
(setq narg (or narg (is-narg-var v)))
(let* ((gt (global-type-bump (if (< (incf i) +max-typed-args+) (var-type v) t)))
(cvar (cs-push gt t)))
(when first (wt ","))
(setq first t)
(setf (var-loc v) cvar)
(wt *volatile*)
(wt (register v))
(wt (rep-type gt))
(wt "V")
(wt cvar)))))
(defun t3defun-local-entry (fname cfun lambda-expr sp inline-info
&aux specials *reg-clv* (requireds (caaddr lambda-expr)) nargs (i -1))
(do ((vl requireds (cdr vl))
(types (cadr inline-info) (cdr types)))
((endp vl))
(cond ((eq (var-kind (car vl)) 'special)
(push (cons (car vl) (var-loc (car vl))) specials))
((var-cb (car vl)) (push (list (eq 'clb (var-loc (car vl))) (car vl)) *reg-clv*))
; ((var-cb (car vl)) (push (car vl) *reg-clv*))
((setf (var-kind (car vl))
(or (when (< (incf i) +max-typed-args+)
(car (member (promoted-c-type (var-type (car vl))) +c-local-arg-types+)))
'object))))
(setf (var-loc (car vl)) (cs-push (var-type (car vl)) t)))
(when (is-narg-le lambda-expr)
(setq nargs (car (last requireds)))
(setf (var-register nargs) 0))
(let* ((s (function-string fname))
(g (when (stringp cfun) (char= #\G (char cfun 0)))))
(wt-comment (strcat (if g "global" "local") " entry for function ") s))
(wt-h "static " (declaration-type (rep-type (caddr inline-info))) (c-function-name "LI" cfun fname) "(")
(wt-nl1 "static " (declaration-type (rep-type (caddr inline-info))) (c-function-name "LI" cfun fname) "(")
(wt-requireds requireds (cadr inline-info) nil nargs)
(wt-h ";")
(let* ((cm *reservation-cmacro*))
;; (tri (tail-recursion-info fname nil lambda-expr))
;; (*unwind-exit* (if tri (cons 'tail-recursion-mark *unwind-exit*) *unwind-exit*)))
(wt-nl1 "{ ")
(wt " VMB" cm " VMS" cm " VMV" cm)
(when nargs (wt-nl "va_list ap;")(wt-nl "va_start(ap,V" (var-loc nargs) ");"))
(when sp (wt-nl "bds_check;"))
(when *compiler-push-events* (wt-nl "ihs_check;"))
; (dolist (v clv) (setf (var-ref v) (list 'cvar (var-loc v))) (c2bind v))
(dolist (v specials)
(setq *bds-used* t)
(wt-nl "bds_bind(" (vv-str (cdr v)) "," `(gen-loc :object (cvar ,(var-loc (car v)))) ");")
(push 'bds-bind *unwind-exit*)
(setf (var-kind (car v)) 'SPECIAL)
(setf (var-loc (car v)) (cdr v)))
(let ((*mv-var* (mv-var lambda-expr)))
(c2expr (caddr (cddr lambda-expr)))
(wt-V*-macros cm (caddr inline-info)))
;;; Make sure to return object if necessary
; (if (equal "object " (rep-type (caddr inline-info))) (wt-nl "return Cnil;"))
(when nargs (wt-nl "va_end(ap);"))
(wt-nl1 "}")))
|
