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
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
|
;;; This generates code for vars defined in an interface. This looks at
;;; annotations and fills in the slots of the var definition.
(define (haskell-codegen/interface mods)
(codegen/interface (car mods)))
(define (codegen/interface mod)
(let ((code '()))
(dolist (d (module-decls mod))
(when (not (signdecl? d))
(error 'bad-decl))
(dolist (var (signdecl-vars d))
(let ((v (var-ref-var var)))
(setf (var-type v) (var-signature v))
(setf (var-toplevel? v) '#t)
(let ((a (lookup-annotation v '|Complexity|)))
(when (not (eq? a '#f))
(setf (var-complexity v)
(car (annotation-value-args a)))))
(let ((a (lookup-annotation v '|LispName|)))
(when (not (eq? a '#f))
(let ((lisp-entry (generate-lisp-entry v a)))
(push lisp-entry code)
(when (memq 'codegen (dynamic *printers*))
(pprint* lisp-entry))))))))
`(begin ,@code)))
(define (generate-lisp-entry v a)
(let ((lisp-name (read-lisp-object (car (annotation-value-args a))))
(type (maybe-expand-io-type (gtype-type (var-type v)))))
(setf (var-optimized-entry v) lisp-name)
(if (arrow-type? type)
(codegen-lisp-fn v (gather-arg-types type))
(codegen-lisp-const v type))))
(define (codegen-lisp-fn var arg-types)
(let* ((aux-definition '())
(wrapper? (foreign-fn-needs-wrapper? var arg-types))
(strictness-annotation (lookup-annotation var '|Strictness|))
(strictness (determine-strictness strictness-annotation arg-types))
(temps (gen-temp-names strictness)))
(setf (var-strict? var) '#t)
(setf (var-arity var) (length strictness))
(setf (var-strictness var) strictness)
(when wrapper?
(mlet (((code name)
(make-wrapper-fn var (var-optimized-entry var) arg-types)))
(setf (var-optimized-entry var) name)
(setf aux-definition (list code))))
`(begin ,@aux-definition
(define ,(fullname var)
,(maybe-make-box-value
(codegen-curried-fn
(if wrapper?
`(function ,(var-optimized-entry var))
`(lambda ,temps
(,(var-optimized-entry var) ,@temps)))
(var-strictness var))
'#t)))))
(define (determine-strictness a args)
(if (eq? a '#f)
(map (lambda (x) (declare (ignore x)) '#t) (cdr args))
(parse-strictness (car (annotation-value-args a)))))
(define (codegen-lisp-const var type)
(let ((conversion-fn (output-conversion-fn type)))
(setf (var-strict? var) '#f)
(setf (var-arity var) 0)
(setf (var-strictness var) '())
`(define ,(fullname var)
(delay
,(if (eq? conversion-fn '#f)
(var-optimized-entry var)
`(,@conversion-fn ,(var-optimized-entry var)))))))
(define (maybe-expand-io-type ty)
(cond ((and (ntycon? ty)
(eq? (ntycon-tycon ty) (core-symbol "IO")))
(**ntycon (core-symbol "Arrow")
(list (**ntycon (core-symbol "SystemState") '())
(**ntycon (core-symbol "IOResult")
(ntycon-args ty)))))
((arrow-type? ty)
(**ntycon (core-symbol "Arrow")
(list (car (ntycon-args ty))
(maybe-expand-io-type (cadr (ntycon-args ty))))))
(else ty)))
(define (gather-arg-types type)
(if (arrow-type? type)
(let ((a (ntycon-args type)))
(cons (car a) (gather-arg-types (cadr a))))
(list type)))
(define (input-conversion-fn ty)
(if (ntycon? ty)
(let ((tycon (ntycon-tycon ty)))
(cond ((eq? tycon (core-symbol "String"))
(lambda (x) `(haskell-string->string ,x)))
((eq? tycon (core-symbol "List")) ; needs to convert elements
(let ((var (gensym "X"))
(inner-fn (input-conversion-fn (car (ntycon-args ty)))))
(lambda (x) `(haskell-list->list
(lambda (,var)
,(if (eq? inner-fn '#f)
var
(funcall inner-fn var)))
,x))))
((eq? tycon (core-symbol "Char"))
(lambda (x) `(integer->char ,x)))
(else '#f)))
'#f))
(define (output-conversion-fn ty)
(if (ntycon? ty)
(let ((tycon (ntycon-tycon ty)))
(cond ((eq? tycon (core-symbol "String"))
(lambda (x) `(make-haskell-string ,x)))
((eq? tycon (core-symbol "List"))
(let ((var (gensym "X"))
(inner-fn (output-conversion-fn (car (ntycon-args ty)))))
(lambda (x) `(list->haskell-list
(lambda (,var)
,(if (eq? inner-fn '#f)
var
(funcall inner-fn var)))
,x))))
((eq? tycon (core-symbol "UnitType"))
(lambda (x) `(insert-unit-value ,x)))
((eq? tycon (core-symbol "IOResult"))
(lambda (x)
(let ((c1 (output-conversion-fn (car (ntycon-args ty)))))
`(box ,(apply-conversion c1 x)))))
(else '#f)))
'#f))
(define (apply-conversion fn x)
(if (eq? fn '#f)
x
(funcall fn x)))
(define (foreign-fn-needs-wrapper? var args)
(if (lookup-annotation var '|NoConversion|)
'#f
(ffnw-1 args)))
(define (ffnw-1 args)
(if (null? (cdr args))
(not (eq? (output-conversion-fn (car args)) '#f))
(or (not (eq? (input-conversion-fn (car args)) '#f))
(systemstate? (car args))
(ffnw-1 (cdr args)))))
(define (make-wrapper-fn var fn args)
(mlet ((new-fn (symbol-append (fullname var) '|/wrapper|))
(avars (gen-temp-names (cdr args)))
(ignore-state? (systemstate? (cadr (reverse args))))
((arg-conversions res-conversion)
(collect-conversion-fns avars args)))
(values
`(define (,new-fn ,@avars)
,@(if ignore-state? `((declare (ignore ,(car (last avars)))))
'())
,@arg-conversions
,(apply-conversion res-conversion
`(,fn ,@(if ignore-state?
(butlast avars)
avars))))
new-fn)))
(define (collect-conversion-fns avars args)
(if (null? avars)
(values '() (output-conversion-fn (car args)))
(mlet ((fn (input-conversion-fn (car args)))
((c1 r) (collect-conversion-fns (cdr avars) (cdr args))))
(values (if (eq? fn '#f)
c1
`((setf ,(car avars) ,(funcall fn (car avars))) ,@c1))
r))))
(define (arrow-type? x)
(and (ntycon? x)
(eq? (ntycon-tycon x) (core-symbol "Arrow"))))
(define (systemstate? x)
(and (ntycon? x)
(eq? (ntycon-tycon x) (core-symbol "SystemState"))))
(define (gen-temp-names l)
(gen-temp-names-1 l '(A B C D E F G H I J K L M N O P)))
(define (gen-temp-names-1 l1 l2)
(if (null? l1)
'()
(if (null? l2)
(gen-temp-names-1 l1 (list (gensym "T")))
(cons (car l2) (gen-temp-names-1 (cdr l1) (cdr l2))))))
|
