mirror of
https://github.com/justinethier/cyclone.git
synced 2025-05-23 20:15:05 +02:00
70 lines
2.1 KiB
Scheme
70 lines
2.1 KiB
Scheme
;; Some notes:
|
|
;; Need a new pass to identify all variables that contribute to each computed variable. Maybe write this as a separate program again, will need to flesh this out.
|
|
;;
|
|
;; Need another pass to flag all vars that cannot be inlined (or just add this to current checks). I think if any contribution var is mutated or passed to a function outside the module being compiled, then the var cannot be inlined. It is probably possible to be a bit smarter?
|
|
;;
|
|
;; Will have to assess how badly this hurts performance.
|
|
;;
|
|
(import
|
|
(scheme base)
|
|
(scheme write)
|
|
)
|
|
(inline
|
|
my-string<=?
|
|
my-not)
|
|
|
|
(define (my-string<=? str1 str2) (<= (string-cmp str1 str2) 0))
|
|
(define (my-not x) (if x #f #t))
|
|
|
|
(define (queue-empty) (cons '() '()))
|
|
(define objects-dumped (queue-empty))
|
|
(define object-queue (queue-empty))
|
|
(define (queue->list queue) (car queue))
|
|
(define (queue-put! queue x)
|
|
(let ((entry (cons x '())))
|
|
(if (null? (car queue))
|
|
(set-car! queue entry)
|
|
(set-cdr! (cdr queue) entry))
|
|
(set-cdr! queue entry)
|
|
x))
|
|
|
|
(define (pos-in-list x l)
|
|
(let loop ((l l) (i 0))
|
|
(cond ((not (pair? l)) #f)
|
|
((eq? (car l) x) i)
|
|
(else (loop (cdr l) (+ i 1))))))
|
|
|
|
(define (proc-obj-code obj) (vector-ref obj 3))
|
|
|
|
(define (proc-obj? x)
|
|
(and (vector? x)
|
|
(> (vector-length x) 0)
|
|
(eq? (vector-ref x 0) proc-obj-tag)))
|
|
|
|
(define proc-obj-tag (list 'proc-obj))
|
|
|
|
(define (test obj)
|
|
(if (and (proc-obj? obj) (not (proc-obj-code obj)))
|
|
#f
|
|
(let ((n (pos-in-list obj (queue->list objects-dumped))))
|
|
(if n
|
|
n
|
|
(let ((m (length (queue->list objects-dumped))))
|
|
(queue-put! objects-dumped obj)
|
|
(queue-put! object-queue obj)
|
|
m)))))
|
|
|
|
|
|
;(define (test obj)
|
|
; (let ((m (length (queue->list objects-dumped))))
|
|
; (queue-put! objects-dumped obj)
|
|
; (queue-put! object-queue obj)
|
|
; m)
|
|
;)
|
|
|
|
(queue-put! objects-dumped 'a)
|
|
(queue-put! objects-dumped 'b)
|
|
(write (queue->list objects-dumped))
|
|
(write (test 'c))
|
|
(write (my-not (test 'd)))
|
|
;(write (my-string<=? (symbol->string (car objects-dumped))))
|