source: project/release/3/crunch/trunk/crunch-compiler.scm @ 13387

Last change on this file since 13387 was 13387, checked in by felix winkelmann, 12 years ago

uses format instead of format-modular

File size: 27.7 KB
Line 
1;;;; crunch-compiler.scm
2;
3; Copyright (c) 2007, Felix L. Winkelmann
4; All rights reserved.
5;
6; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
7; conditions are met:
8;
9;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
10;     disclaimer.
11;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
12;     disclaimer in the documentation and/or other materials provided with the distribution.
13;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
14;     products derived from this software without specific prior written permission.
15;
16; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
17; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
18; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
19; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
20; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
21; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
22; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
23; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
24; POSSIBILITY OF SUCH DAMAGE.
25;
26; Send bugs, suggestions and ideas to:
27;
28; felix@call-with-current-continuation.org
29;
30; Felix L. Winkelmann
31; Unter den Gleichen 1
32; 37130 Gleichen
33; Germany
34
35
36(use codewalk format srfi-1 miscmacros defstruct srfi-4 srfi-69
37     crunch-expander)
38
39
40#+compiling
41(declare
42  (fixnum)
43  (export crunch-export->foreign-lambda
44          crunch-foreign-type
45          crunch-register-primitive
46          crunch-register-special-form
47          crunch-compile) )
48
49
50(define *functions*)                     ; ((ID . LAMBDA) ...)
51(define *globals* (make-hash-table eq?)) ; NAME -> BINDING
52(define *output*)                        ; PORT
53(define *environment*)                   ; (BINDING ...)
54(define *function-environment*)
55(define *types*)
56(define *substitutions*)
57(define *header-path* "")
58(define *literals*)
59(define *export-prefix* "static ")
60(define *integer-types* '(int long short))
61(define *floating-point-types* '(float double))
62(define *number-types* (append *integer-types* *floating-point-types*))
63(define *xcontext* (expansion-context))
64(define *lexical-environment* '())
65(define *indent* "")
66(define *resolution* 0)
67(define *context* '())
68(define *special-forms* (make-hash-table eq?))
69(define *verbatim* '())
70
71(define-macro (with-context c . body)
72  `(fluid-let ((*context* (cons ,c *context*)))
73     ,@body))
74
75(define (get-context)
76  (let ((c (filter identity *context*)))
77    (if (null? c)
78        ""
79        (format 
80         #f "~2%  context:~%~{\t~a~}" 
81         (map (lambda (c)
82                (with-output-to-string
83                  (lambda ()
84                    (##sys#with-print-length-limit 
85                     256 
86                     (lambda ()
87                       (pp c) ) ) ) ) )
88              (reverse c))))))
89
90(define *crunch-debug*
91  (cond ((feature? 'crunch-debug-total) 3)
92        ((feature? 'crunch-debug-expand) 2)
93        ((feature? 'crunch-debug) 1)
94        ((and (feature? 'compiling) ##compiler#verbose-mode) 1)
95        (else #f)))
96
97(define *type-specifiers*
98  '(bool int char string double float void short long
99         c-string blob c-pointer
100         u8vector s8vector u16vector s16vector
101         u32vector s32vector f32vector f64vector))
102
103(defstruct binding
104  name                                  ; SYMBOL
105  real-name                             ; STRING | #f
106  id                                    ; SYMBOL
107  (type (make-typevar name))            ; TYPE
108  assigned?                             ; BOOLEAN | * | +
109  referenced?                           ; BOOLEAN | *
110  primitive?                            ; BOOLEAN
111  callback?                             ; BOOLEAN
112  (calls '())                           ; (BINDING ...)
113  refreturn?                            ; BOOLEAN
114  loop)                                 ; (ID ...) | #f
115
116(define-record-printer (binding b p)
117  (format p "#<binding ~s>" (binding-name b)))
118
119(define (binding-c-name b)
120  (or (binding-id b)
121      (binding-real-name b)
122      (cify-name (binding-name b))))
123
124(define (binding-display-name b)
125  (if (binding? b)
126      (binding-name b)
127      b) )
128
129(define (binding-global? b)
130  (not (binding-id b)))
131
132(define (binding-assign! b top)
133  (cond ((binding-assigned? b) (binding-assigned?-set! b '*))
134        (else (binding-assigned?-set! b (if top '+ #t)))))
135
136(define (binding-reference! b)
137  (cond ((binding-referenced? b) (binding-referenced?-set! b '*))
138        (else (binding-referenced?-set! b #t))))
139
140(define (binding-update! b t)
141  (binding-type-set! 
142   b 
143   (let* ((t0 (binding-type b))
144          (t (if t0 
145                 (unify t t0)
146                 t0) ) )
147     (dribble2 "(binding updated) ~s -> ~s" b t) 
148     t) ) )
149
150(define (binding-update-calls! b cb)
151  (binding-calls-set! 
152   b
153   (lset-adjoin eq? (binding-calls b) cb) ) )
154
155(defstruct typevar id context type)
156
157(define-record-printer (typevar tv p)
158  (format p "#<~a" (typevar-id tv) )
159  (and-let* ((t (typevar-type tv)))
160    (format p " ~s" t) )
161  (and-let* ((c (typevar-context tv))
162             ((pair? c)))
163    (display " = " p)
164    (##sys#with-print-length-limit
165     20
166     (lambda () (write (car c) p)) ) )
167  (write-char #\> p) )
168
169(define (type->string t)
170  (cond ((typevar? t) (->string (typevar-id t)))
171        (else (->string (native-type t)))))
172
173(define make-typevar
174  (let ((make-typevar make-typevar))
175    (lambda (#!optional context1)
176      (let ((tv (make-typevar id: (gensym 'type) context: (cons context1 *context*))))
177        (push! tv *types*)
178        tv) ) ) )
179
180(define (emit fstr . xs)
181  (format *output* "\n~?" fstr xs) )
182
183(define (temp) (gensym 't))
184
185(define (dribble2 fstr . args)
186  (when (and (number? *crunch-debug*) (> *crunch-debug* 2))
187    (format #t "[crunch]~a ~?~%" *indent* fstr args) ) )
188
189(define (dribble fstr . args)
190  (when *crunch-debug*
191    (format #t "[crunch]~a ~?~%" *indent* fstr args) ) )
192
193(define (complain loc msg . args)
194  (when (enable-warnings)
195    (format #t "[crunch] Warning: ~@[(in ~s) ~]~?~%" (binding-display-name loc) msg args) ) )
196
197(define (bomb loc msg . args)
198  (error (format #f "[crunch] ~@[(in ~s) ~]~?~a" (binding-display-name loc) msg args
199                 (get-context))))
200
201(define (cify-name name)
202  (string-intersperse
203   (map (lambda (c)
204          (if (or (char-alphabetic? c)
205                  (char-numeric? c) )
206              (string c)
207              (format #f "_~2,'0x" (char->integer c))) )
208        (string->list (->string name)))
209   ""))
210
211(define (lookup v)
212  (or (find (lambda (b) (eq? v (binding-name b))) *environment*)
213      (hash-table-ref/default *globals* v #f)
214      (let ((b (make-binding name: v id: (gensym 'g))))
215        (hash-table-set! *globals* v b)
216        b)))
217
218(define (resolve t0 #!optional (miss (cut bomb #f <> <...>)) (done '()))
219  (define (merge t1 t2)
220    (define (fail)
221      (miss "can not unify with both ~a and ~a: ~s" t1 t2 t0))
222    (dribble2 "merging ~a with ~a" t1 t2)
223    (let ((mt (cond ((typevar? t1) (merge (walk t1) t2))
224                    ((typevar? t2) (merge t2 t1))
225                    ((merge-simple-types t1 t2))
226                    (else
227                     (match t1
228                       (((args1 ...) '-> result1)
229                        (match t2
230                          (((args2 ...) '-> result2)
231                           (if (= (length args1) (length args2))
232                               (list (map merge args1 args2) 
233                                     '-> 
234                                     (merge result1 result2))
235                               (bomb #f "procedure arities do not match: ~s + ~s" t1 t2)) )
236                          (_ (fail)) ) )
237                       (_ (fail) ) ) ) ) ) )
238      (dribble2 "  merged: ~a" mt)
239      mt) )
240  (define (walk t)
241    (dribble2 "resolve: ~s" t)
242    (match t
243      ((? typevar?)
244       (when (memq t done)
245         (miss "circular substitution: ~s" t))
246       (push! t done)
247       (or (typevar-type t)
248           (let ((fs (filter (lambda (s) (eq? (car s) t)) *substitutions*)))
249             (cond ((null? fs) 
250                    (miss "unresolvable type: ~s" t) )
251                   (else
252                    (dribble2 "resolve set: ~s" fs)
253                    (let ((set (filter-map
254                                (lambda (t)
255                                  (let ((t (cdr t)))
256                                    (call/cc
257                                     (lambda (k)
258                                       (resolve 
259                                        t
260                                        (lambda (fstr . args)
261                                          (dribble2 "  resolve failed: ~s (~?)" t fstr args)
262                                          (k #f))
263                                        done)))))
264                                fs) ) )
265                      (dribble2 "merge set: ~s" set)
266                      (let ((t2 (walk (reduce 
267                                       (cut merge <> <>) 
268                                       #f
269                                       (let ((ts (remove typevar? set))) 
270                                         (if (null? ts)
271                                             (miss "no resolution for set ~s of ~s" set t)
272                                             ts))))))
273                        (when (and t2 (not (typevar? t2)) (not (eq? (typevar-type t) t2)))
274                          (when (<= *resolution* 1)
275                            (typevar-type-set! t t2)
276                            (dribble2 "updated ~s" t) ) )
277                        t2) ) ) ) ) ) )
278      (((args ...) '-> result)
279       (list (map walk args) '-> (walk result)))
280      (_ t) ) )
281  (fluid-let ((*indent* (string-append *indent* " "))
282              (*context* (if (typevar? t0)
283                             (append (typevar-context t0) *context*)
284                             *context*))
285              (*resolution* (add1 *resolution*)))
286    (walk t0) ) )
287
288(define (extend tv t)
289  (dribble2 "(extend) ~s => ~s" tv t)
290  (push! (cons tv t) *substitutions*) )
291
292(define (merge-simple-types t1 t2)
293  (cond ((equal? t1 t2) t1)
294        ((or (eq? t1 'void) (eq? t2 'void))
295         'void)
296        ((eq? t1 '*) t2)
297        ((eq? t2 '*) t1)
298        ((eq? t1 'bool) t2)
299        ((eq? t2 'bool) t1)
300        ((eq? t1 'number) 
301         (and (memq t2 *number-types*)
302              t2) )
303        ((eq? t2 'number) 
304         (and (memq t1 *number-types*)
305              t1) )
306        ((eq? 'double t1)
307         (and (or (eq? t2 'float) (memq t2 *integer-types*))
308              t1) )
309        ((eq? 'double t2)
310         (and (or (eq? t1 'float) (memq t1 *integer-types*))
311              t2) )
312        ((memq t1 *floating-point-types*)
313         (and (memq t2 *integer-types*)
314              t1) )
315        ((memq t2 *floating-point-types*)
316         (and (memq t1 *integer-types*)
317              t2) )
318        (else #f) ) )
319
320(define (unify t1 t2)
321  (define (un-n*type result args)
322    (case result
323      ((number*)
324       (let ((t (make-typevar)))
325         (for-each (cut unify t <>) args)
326         t) )
327      (else result) ) )
328  (dribble2 "(unify) ~s == ~s" t1 t2)
329  (let ((u (cond
330            ((typevar? t1)
331             (extend t1 t2)
332             (when (typevar? t2) (extend t2 t1))
333             t2)
334            ((typevar? t2) 
335             (extend t2 t1)
336             t1)
337            ((merge-simple-types t1 t2))
338            (else
339             (match t1
340               ((args1 '-> result1)
341                (match t2
342                  ((args2 '-> result2)
343                   (when (not (= (length args1) (length args2)))
344                     (bomb #f "number of arguments in procedure call does not match"))
345                   (let ((args3 (map unify args1 args2)))
346                     (list
347                      args3
348                      '-> 
349                      (unify (un-n*type result1 args3) (un-n*type result2 args3) ) ) ) )
350                  (_ (bomb #f "can not unify ~a and ~a" t1 t2)) ) )
351               (_ (bomb #f "can not unify ~a and ~a" t1 t2)) ) ) ) ) )
352    (dribble2 "(unified)   ==> ~s" u)
353    u) )
354
355(define (result-type t args)
356  (match t
357    ((? typevar? t)
358     (let ((rt (make-typevar)))
359       (unify t `(,(map make-typevar args) -> ,rt))
360       rt) )
361    ((_ '-> rt) rt)
362    (_ (bomb #f "unable to compute result type: ~a" t))))
363
364(define (literal-type lit)
365  (cond ((string? lit) 'string)
366        ((fixnum? lit) 'int)
367        ((number? lit) 'double)
368        ((char? lit) 'char)
369        ((boolean? lit) 'bool)
370        ((u8vector? lit) 'u8vector)
371        ((s8vector? lit) 's8vector)
372        ((u16vector? lit) 'u16vector)
373        ((s16vector? lit) 's16vector)
374        ((u32vector? lit) 'u32vector)
375        ((s32vector? lit) 's32vector)
376        ((f32vector? lit) 'f32vector)
377        ((f64vector? lit) 'f64vector)
378        (else (bomb #f "invalid literal: ~s" lit))))
379
380(define (case-literal? x)
381  (or (boolean? x) (number? x) (char? x)))
382
383(define (literal-text x)
384  (cond ((number? x) (number->string x))
385        ((char? x) (format #f "'\\~3,'0o\'" (char->integer x)))
386        ((boolean? x) (if x "true" "false"))
387        (else (bomb #f "invalid literal: ~s" x))))
388
389(define (compile-literal x)
390  (let ((t (temp))
391        (lt (literal-type x)) )
392    (cond ((number? x)
393           (emit "~a ~a = ~a;" (type->string lt) t x) )
394          ((char? x)
395           (emit "~a ~a = '\\~3,'0o\';" (type->string lt) t (char->integer x)) )
396          ((boolean? x)
397           (emit "~a ~a =~:[false~;true~];" (native-type 'bool) t x))
398          (else
399           (let ((id (gensym 'c)))
400             (push! (list id lt x) *literals*)
401             (emit "~a ~a = ~a;" (type->string lt) t id) ) ) )
402    (cons t lt) ) )
403
404(define (crunch-register-special-form name proc)
405  (hash-table-set! *special-forms* name proc) )
406
407(define (crunch-expr x c w e m top? tail? dest loc)
408  (dribble2 "(compile) ~s" x)
409  ;; (dribble "(compile) ~s  (tail: ~s, top: ~s, dest: ~s, loc: ~s" x tail? top? (binding-display-name dest)
410  ;;          (binding-display-name loc))
411  (case c
412    ((ref)
413     (let ((t (temp))
414           (b (lookup x)) )
415       (cond ((binding-primitive? b)
416              (let ((vars (list-tabulate (length (car (binding-type b))) (lambda _ (gensym 'a)))))
417                (w `(lambda ,vars (,x ,@vars)) top? tail? dest loc)) )
418             ((and (binding-global? b)
419                   (any (cut memq x <>) *lexical-environment*))
420              (bomb loc "reference to lexical binding: ~s" x))
421             (else
422              (when (and loc (binding-global? b)) (binding-update-calls! loc b))
423              (binding-reference! b)
424              (emit "~a = ~a;\t// ~s"
425                    (c-type (binding-type b) t)
426                    (binding-c-name b)
427                    x)
428              (cons t (binding-type b)))) ) )
429    ((literal) (compile-literal x))
430    ((quoted-literal) (compile-literal (second x)))
431    ((if)
432     (with-context 
433      `(if ,(second x) ...)
434      (let ((v (w (second x) top? #f #f loc))
435            (t (temp))
436            (tv (make-typevar x) ) )
437        (emit "~a;" (c-type tv t))
438        (emit "if(~a(~a).f) {" (native-type 'bool) (car v))
439        (let ((x1 (w (third x) top? tail? dest loc)))
440          (emit "~a = ~a; }\nelse {" t (car x1))
441          (let ((x2 (w (if (pair? (cdddr x)) (fourth x) '(void)) top? tail? dest loc)))
442            (emit "~a = ~a; }" t (car x2))
443            (cons
444             t
445             (unify tv (unify (cdr x1) (cdr x2)) ) ) ) ) ) ) )
446    ((set!)
447     (let-values (((var type) (vartype (second x))))
448       (with-context 
449        `(set! ,(second x) ...)
450        (let* ((b (lookup var))
451               (v (w (third x) top? #f b loc))
452               (tmp (temp)) )
453          (when (binding-primitive? b)
454            (bomb loc "assignment to primitive binding: ~s" var))
455          (binding-assign! b top?)
456          (binding-update! b (unify type (cdr v)))
457          (emit "~a = ~a;\t// set! ~s" (binding-c-name b) (car v) var)
458          (emit "~a ~a;" (native-type 'void) tmp)
459          (cons tmp 'void))) ) )
460    ((let)
461     (with-context
462      `(let ,(second x) ...)
463      (if (null? (second x))
464          (w (third x) top? tail? dest loc)
465          (let* ((bs (map (lambda (b)
466                            (let-values (((var type) (vartype (car b))))
467                              (make-binding name: var id: (gensym 'v) type: type)))
468                          (second x) ) )
469                 (vs (map (lambda (b bi) 
470                            (let ((v (w (second b) top? #f bi loc)))
471                              (cons (car v) (unify (binding-type bi) (cdr v))) ) )
472                          (second x) bs) ) 
473                 (t (temp))
474                 (tv (make-typevar x)))
475            (emit "~a;~%{" (c-type tv t))
476            (for-each
477             (lambda (b v)
478               (emit "~a = ~a;\t// ~s" (c-type (binding-type b) (binding-id b)) (car v)
479                     (binding-name b)) )
480             bs vs)
481            (fluid-let ((*environment* (append bs *environment*)))
482              (let ((r (w (third x) top? tail? dest loc) ))
483                (emit "~a = ~a; }" t (car r))
484                (cons t (unify tv (cdr r)))))))) )
485    ((undefined)
486     (let ((t (temp)))
487       (emit "~a ~a;" (native-type 'void) t)
488       (cons t 'void)))
489    ((begin)
490     (cond ((null? (cdr x))
491            (let ((tmp (temp)))
492              (emit "~a ~a;" (native-type 'void) tmp)
493              (cons tmp 'void) ) )
494           (else
495            (let ((r #f))
496              (pair-for-each
497               (lambda (x) 
498                 (set! r (w (car x) top? (null? (cdr x)) 
499                            (if (null? (cdr x)) dest #f)
500                            loc) ) )
501               (cdr x))
502              r) ) ) )
503    ((app)
504     (cond
505      ((hash-table-ref/default *special-forms* (car x) #f) =>
506       (lambda (sf)
507         (sf x c w e m top? tail? dest loc) ) )
508      ((and (pair? (car x)) (eq? 'lambda (caar x)))
509       (w `(let ,(zip (cadar x) (cdr x)) ,@(cddar x)) top? #f dest loc))
510      (else
511       (with-context
512        x
513        (let* ((fx (car x))
514               (vs (map (cut w <> top? #f #f loc) (cdr x))))
515          (cond ((and (symbol? fx)
516                      loc
517                      (binding? loc)
518                      (eq? fx (binding-name loc)) 
519                      tail?)
520                 ;; self-call in tail position
521                 (let ((bound (lookup fx)))
522                   (binding-reference! bound)
523                   (when (binding-global? bound)
524                     (binding-update-calls! loc bound)))
525                 (let* ((ts (map (lambda _ (temp)) vs))
526                        (ft1 (list (map cdr vs) '-> (make-typevar x))) 
527                        (ft (unify ft1 (binding-type loc))))
528                   (emit "~{~a = ~a;~%~}~{~a = ~a;~%~}goto crunch_loop;"
529                         (append-map (lambda (v t) (list (c-type (cdr v) t) (car v))) vs ts)
530                         (append-map (lambda (b t) (list (binding-c-name b) t))
531                                     *function-environment* ts) )
532                   (let ((r (temp)))
533                     (emit "~a;" (c-type (third ft) r))
534                     (cons r (third ft)) ) ) )
535                ((and (symbol? fx) (lookup fx))
536                 (lambda (b) (and b (binding-loop b))) =>
537                 (lambda (b)
538                   ;; call to loop variable
539                   (when (and loc (binding-global? b))
540                     (binding-update-calls! loc b))
541                   (unless tail?
542                     (bomb loc "call to loop variable not in tail position: ~s" fx))
543                   (dribble2 "looping: ~s" fx)
544                   (match-let (((vars ...) (binding-loop b)))
545                     (let ((temps (map (lambda (v)
546                                         (let ((t (temp)))
547                                           (emit "~a = ~a;" (c-type (cdr v) t) (car v)) 
548                                           t) )
549                                       vs) ) 
550                           (tr (temp)))
551                       (for-each
552                        (lambda (var val tmp)
553                          (let ((b (lookup var)))
554                            (binding-assign! b top?)
555                            (binding-update! b (cdr val))
556                            (emit "~a = ~a;" (binding-c-name b) tmp) ) )
557                        vars vs temps)
558                       (emit "goto ~a;" (binding-id b))
559                       (emit "~a ~a;" (native-type 'void) tr)
560                       (cons tr 'void)))))
561                (else
562                 ;; normal call
563                 (let* ((ft (list (map cdr vs) '-> (make-typevar x))) 
564                        (bound (and (symbol? fx) (lookup fx)) )
565                        (finfo (cond ((and bound (binding-global? bound))
566                                      (binding-reference! bound)
567                                      (when loc (binding-update-calls! loc bound))
568                                      (cons (binding-c-name bound)
569                                            (unify
570                                             (binding-type bound)
571                                             ft) ) )
572                                     (else
573                                      (when tail? 
574                                        (complain loc "call in tail position is not iterative: ~s" x))
575                                      (let ((fv (w fx top? #f #f loc)))
576                                        (cons (car fv) (unify ft (cdr fv)))))))
577                        (t (temp))
578                        (rt (result-type ft (cdr x))) )
579                   (cond ((and bound (binding-refreturn? bound))
580                          (emit "~a;" (c-type rt t))
581                          (emit "~a(~{~a~^, ~}, ~a);\t// ~s" 
582                                (car finfo) (unzip1 vs) t
583                                fx) )
584                         (else
585                          (emit "~a = ~a(~{~a~^, ~});\t// ~s" 
586                                (c-type rt t)
587                                (car finfo) (unzip1 vs)
588                                fx) ) )
589                   (cons t rt) ) ) ) ) ) ) ) )
590    ((lambda)
591     (with-context
592      `(lambda ,(second x) ...)
593      (let-values (((llist args) (parse-llist (second x) x loc)))
594        (let ((f (gensym 'f))
595              (t (list args '-> (make-typevar x))) )
596          ;; use inner let to force local definitions (since we expand the
597          ;; lambda body manually):
598          (push! (vector
599                  (binding-display-name dest)
600                  f t
601                  `(lambda ,llist (let () ,@(cddr x))) 
602                  dest e)
603                 *functions*)
604          (cons f t) ) ) ) )
605    ((special) (w x top? tail? dest loc))
606    (else
607     (let ((t (temp)))
608       (emit "~a ~a;" (native-type 'void) t)
609       (cons t 'void)))))
610
611(define-macro (define-special-form head . body)
612  `(crunch-register-special-form ',(car head) (lambda ,(cdr head) ,@body)))
613
614(define-special-form (crunch:switch x c w e m top? tail? dest loc)
615  (with-context
616   `(case ,(second x) ...)
617   (let* ((v (w (second x) top? #f #f loc))
618          (tval (cdr v))
619          (t (temp))
620          (tv (make-typevar x) ) )
621     (emit "~a;" (c-type tv t))
622     (emit "switch(~a) {" (car v))
623     (do ((cases (cddr x) (cdr cases)))
624         ((null? cases) 
625          (emit "}")
626          (cons t tv))
627       (match (car cases)
628         (('crunch:case vals+body ...)
629          (let loop ((vb vals+body))
630            (match vb
631              (() (bomb loc "empty body in `case' clause: ~s" x))
632              ((body)
633               (emit "{")
634               (let ((v (w body top? tail? dest loc)))
635                 (emit "~a = ~a; break; }" t (car v))
636                 (set! tv (unify tv (cdr v)))) )
637              (((or (? case-literal? lit) ('quote (? case-literal? lit))) . more)
638               (emit "case ~a: // ~a" (literal-text lit) lit)
639               (unify tval (literal-type lit))
640               (loop more) ) 
641              ((lit . _)
642               (bomb loc "invalid literal type in `case' clause: ~s" lit) ) ) ) )
643         (('crunch:default . body)
644          (emit "default:")
645          (let ((v (w `(begin ,@body) top? tail? dest loc)))
646            (emit "~a = ~a; break;" t (car v))
647            (set! tv (unify tv (cdr v)))))
648         (else (bomb loc "invalid `crunch:case' syntax: ~s" x)) ) ) ) ) )
649
650(define-special-form (crunch:loop x c w e m top? tail? dest loc)
651  (let* ((label (gensym 'crunch_loop))
652         (lvar (caadr x))
653         (b (make-binding id: label name: lvar type: #f loop: (cdadr x))))
654    (emit "~a:;" label)
655    (fluid-let ((*environment* (cons b *environment*)))
656      (w `(begin ,@(cddr x)) top? #f dest loc))))
657
658(define-special-form (crunch:verbatim x c w e m top? tail? dest loc)
659  (set! *verbatim* 
660    (append-reverse
661     (map (lambda (s)
662            (if (string? s)
663                s
664                (bomb loc "verbatim argument is not a string" s) ) )
665          (cdr x) )
666     *verbatim*) )
667  (w '(##core#undefined) top? tail? dest loc))
668
669(define (c-type t name)
670  (match t
671    (((args ...) '-> result)
672     (format #f "~a (*~a)(~{~a~^, ~})" (c-type result "") name (map (cut c-type <> "") args)))
673    (t (format #f "~a~@[ ~a~]" (type->string t) name))))
674
675(define (emit-types port)
676  (dribble2 "(substitutions) ~{~%~s~}~%" *substitutions*)
677  (for-each
678   (lambda (tv)
679     (format 
680      port "typedef ~a;~%" 
681      (c-type (resolve tv) (typevar-id tv))) )
682   *types*) )
683
684(define (emit-literal lit port)
685  (define (nvec lst)
686    (format port "{ ~{~s~^, ~} }" lst) )
687  (match lit
688    ((id type x)
689     (format port "static ~a::eltype l~a[] = " (c-type type #f) id)
690     (cond ((string? x) (format port "\"~{\\~3,'0o~}\"" (map char->integer (string->list x))))
691           ((u8vector? x) (nvec (u8vector->list x)))
692           ((s8vector? x) (nvec (s8vector->list x)))
693           ((u16vector? x) (nvec (u16vector->list x)))
694           ((s16vector? x) (nvec (s16vector->list x)))
695           ((u32vector? x) (nvec (u32vector->list x)))
696           ((s32vector? x) (nvec (s32vector->list x)))
697           ((f32vector? x) (nvec (f32vector->list x)))
698           ((f64vector? x) (nvec (f64vector->list x)))
699           (else (bomb #f "invalid literal: ~s" x)))
700     (format port ";~%static ~a(l~a);~%" (c-type type id) id))))
701
702(define (crunch-compile expr #!optional (port (current-output-port)) (arena #f)
703                        #!key (debug *crunch-debug*) entry-point)
704  (fluid-let ((*crunch-debug* debug)
705              (*types* '())) ; bind first because of call to `make-typevar' below
706    (let ((f (gensym 'f))
707          (expr (crunch-expand expr))
708          (t0 (make-typevar))
709          (protos '()) )
710      (when (and *crunch-debug* (> *crunch-debug* 1))
711        (dribble2 "expanded:")
712        (pp expr) )
713      (fluid-let ((*functions* 
714                   (list
715                    (vector
716                     '*TOPLEVEL*
717                     f
718                     `(() -> ,t0)
719                     `(lambda () ,expr)
720                     (make-binding name: 'TOPLEVEL type: t0)
721                     '())) )
722                  (*output* (open-output-string))
723                  (*substitutions* '())
724                  (*literals* '())
725                  (*verbatim* '())
726                  (*globals* (hash-table-copy *globals*)))
727        (when entry-point
728          (hash-table-set! 
729           *globals* entry-point
730           (make-binding name: entry-point real-name: (symbol->string entry-point))))
731        (do () ((null? *functions*))
732          (match-let ((#(name id (argtypes '-> rtype) (_ vs body) loc e) (pop! *functions*)))
733            (dribble "compiling ~s ..." name)
734            (fluid-let ((*environment* 
735                         (map (lambda (v at) 
736                                (make-binding name: v id: (gensym 'a) type: at))
737                              vs argtypes) ) 
738                        (*context* (cons `(define ,name ...) *context*))
739                        (*lexical-environment* e) )
740               (fluid-let ((*function-environment* *environment*))
741                 (let* ((ts (c-type rtype id))
742                        (args (map
743                               (lambda (b at) 
744                                 (c-type at (binding-id b)))
745                               *environment* argtypes) )
746                        (hdr (format #f "crunch_local ~a(~{~a~^, ~})" ts args)))
747                   (push! (format #f "~a;\t// ~s" hdr (or name "?")) protos)
748                   (emit "~a {\t// ~s~%crunch_loop:" hdr (or name "?"))
749                   (let ((v (expand/context
750                             body
751                             *xcontext*
752                             crunch-expr 
753                             #t #t #f loc) ) )
754                     (unify rtype (cdr v))
755                     (emit "return ~a; }\n" (car v)) ) ) ) ) ) )
756        (display "// ---------- CRUNCH ----------\n\n" port)
757        (format port "~{~a~2%~}" (reverse *verbatim*))
758        (if arena (format port "#define CRUNCH_USE_ARENA 1\n"))
759        (format port "#include \"~acrunch.h\"~2%" *header-path*)
760        (hash-table-walk
761         *globals*
762         (lambda (v b)
763           (unless (binding-primitive? b)
764             (dribble2 "global: ~s (assigned: ~s, referenced: ~s)" 
765                       (binding-display-name b)
766                       (binding-assigned? b)
767                       (binding-referenced? b))
768             (when (and (not (binding-assigned? b))
769                        (binding-referenced? b))
770               (bomb #f "undefined global variable: ~s" (binding-display-name b))))) )
771        (emit-types port)
772        (newline port)
773        (for-each (cut format port "~a~%" <>) protos)
774        (newline port)
775        (for-each (cut emit-literal <> port) *literals*)
776        (let ((exports '())
777              (cb #f) )
778          (hash-table-walk
779           *globals*
780           (lambda (v b)
781             (with-context
782              v
783             (when (and (not (binding-primitive? b))
784                        (or (binding-assigned? b) 
785                            (binding-referenced? b)))
786               (dribble2 "resolve global: ~s = ~s" b (binding-type b))
787               (let ((cname (binding-c-name b))
788                     (t (resolve (binding-type b))))
789                 (format port "~a~a;\t// ~s~%" *export-prefix* 
790                         (c-type t cname) (binding-display-name b))
791                 (dribble "global: ~s\t= ~s" v t)
792                 (let ((calls (binding-calls b)))
793                   (when (pair? calls)
794                     (dribble " references: ~{~s ~}" (map binding-name calls))
795                     (set! cb (check-for-callback calls)) 
796                     (when cb (dribble "  (calls back)")) ) )
797                 (when (and (eq? '+ (binding-assigned? b)) (list? t))
798                   (push! (cons* (binding-name b) cname cb (third t) (first t)) exports)))))))
799          (display (get-output-string *output*) port)
800          (display "\n// ---------- END CRUNCH ----------\n" port)
801          (values f exports) ) ) ) ) )
802
803(define (check-for-callback calls)      ; doesn't work for eta-expanded callbacks!
804  (let loop ((calls calls) (done calls))
805    (any (lambda (b) 
806           (and (not (memq b done))
807                (or (binding-callback? b)
808                    (loop (binding-calls b) (append calls done)))))
809         calls) ) )
810
811(define (->symbol x)
812  (cond ((symbol? x) x)
813        ((string? x) (string->symbol x))
814        (else (string->symbol (->string x)))))
815
816(define (crunch-export->foreign-lambda exp)
817  (match exp
818    ((name cname cb result args ...)
819     `(define ,(->symbol name)
820        (,(if cb 'foreign-safe-lambda 'foreign-lambda) ,(translate-type result) ,cname
821          ,@(map translate-type args) ) ) ) ) )
822
823(define (parse-llist llist0 expr loc)
824  (let loop ((llist llist0) (vars '()) (types '()))
825    (cond ((null? llist) (values (reverse vars) (reverse types)))
826          ((not-pair? llist)
827           (bomb loc "rest arguments not supported: ~s" expr) )
828          ((symbol? (car llist))
829           (let-values (((v t) (vartype (car llist))))
830             (loop (cdr llist) (cons v vars) (cons t types))))
831          (else (bomb loc "invalid lambda-list syntax" llist0)))))
832
833(define (vartype sym)
834  (let* ((s (symbol->string sym))
835         (i (substring-index "::" s)))
836    (if i
837        (values
838         sym
839         (basic-type (string->symbol (substring s (+ i 2)))))
840        (values sym (make-typevar sym)))))
841
842(define (basic-type t)
843  (if (memq t *type-specifiers*)
844      t
845      (bomb #f "invalid type specifier: ~s" t)))
846
847(define (translate-type t)
848  (case t
849    ((number) 'int)
850    ((string) 'c-string*)
851    (else
852     (if (memq t *type-specifiers*)
853         t
854         (bomb #f "invalid foreign type: ~s" t)))))
855
856(define (crunch-foreign-type t)
857  (case t
858    ((int) 'number)
859    ((blob) 'c-pointer)
860    ((number*) 'number)
861    (else
862     (if (memq t *type-specifiers*)
863         t
864         (bomb #f "invalid foreign type: ~s" t)))))
865
866(define (native-type t)
867  (case t
868    ((int) "int")
869    ((long) "long")
870    ((short) "short")
871    ((char) "char")
872    ((float) "float")
873    ((double) "double")
874    ((bool) "crunch_bool")
875    ((number) "int")
876    ((blob) "crunch_blob")
877    ((c-string string) "crunch_string")
878    ((pointer c-pointer) "void *")
879    ((u8vector)   "crunch_u8vector")
880    ((s8vector)   "crunch_s8vector")
881    ((u16vector)  "crunch_u16vector")
882    ((s16vector)  "crunch_s16vector")
883    ((u32vector)  "crunch_u32vector")
884    ((s32vector)  "crunch_s32vector")
885    ((f32vector)  "crunch_f32vector")
886    ((f64vector)  "crunch_f64vector")
887    ((void)       "crunch_unspecified")
888    (else (bomb #f "invalid native type: ~a" t))))
889
890(define (crunch-register-primitive name args result realname #!optional callback refreturn)
891  (hash-table-set!
892   *globals* name 
893   (make-binding
894    name: name
895    real-name: realname
896    type: (list args '-> result)
897    callback?: callback
898    refreturn?: refreturn
899    primitive?: #t) ) )
900
901(include "primitives.scm")
Note: See TracBrowser for help on using the repository browser.