Fcalva/cyclone
1
0
Fork 0
mirror of https://github.com/justinethier/cyclone.git synced 2025-05-25 13:05:05 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

Found new test case from compiler benchmark

Browse source
This commit is contained in:
Justin Ethier 2019-01-10 22:02:57 -05:00
parent 8648e66ca6
commit 43c39abc8a
1 changed files with 72 additions and 56 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

124
cps-opt-analyze-call-graph-test.scm
View file

@ -9,62 +9,78 @@
(scheme base) (scheme base)
(scheme write) (scheme write)
) )
(inline ;(inline
my-string<=? ; my-string<=?
my-not) ; my-not)
;
(define (my-string<=? str1 str2) (<= (string-cmp str1 str2) 0)) ; (define (my-string<=? str1 str2) (<= (string-cmp str1 str2) 0))
(define (my-not x) (if x #f #t)) ; (define (my-not x) (if x #f #t))
;
(define (queue-empty) (cons '() '())) ;(define (queue-empty) (cons '() '()))
(define objects-dumped (queue-empty)) ;(define objects-dumped (queue-empty))
(define object-queue (queue-empty)) ;(define object-queue (queue-empty))
(define (queue->list queue) (car queue)) ;(define (queue->list queue) (car queue))
(define (queue-put! queue x) ;(define (queue-put! queue x)
(let ((entry (cons x '()))) ; (let ((entry (cons x '())))
(if (null? (car queue)) ; (if (null? (car queue))
(set-car! queue entry) ; (set-car! queue entry)
(set-cdr! (cdr queue) entry)) ; (set-cdr! (cdr queue) entry))
(set-cdr! queue entry) ; (set-cdr! queue entry)
x)) ; x))
;
(define (pos-in-list x l) ;(define (pos-in-list x l)
(let loop ((l l) (i 0)) ; (let loop ((l l) (i 0))
(cond ((not (pair? l)) #f) ; (cond ((not (pair? l)) #f)
((eq? (car l) x) i) ; ((eq? (car l) x) i)
(else (loop (cdr l) (+ i 1)))))) ; (else (loop (cdr l) (+ i 1))))))
;
(define (proc-obj-code obj) (vector-ref obj 3)) ;(define (proc-obj-code obj) (vector-ref obj 3))
;
(define (proc-obj? x) ;(define (proc-obj? x)
(and (vector? x) ; (and (vector? x)
(> (vector-length x) 0) ; (> (vector-length x) 0)
(eq? (vector-ref x 0) proc-obj-tag))) ; (eq? (vector-ref x 0) proc-obj-tag)))
;
(define proc-obj-tag (list 'proc-obj)) ;(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) ; (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)))) ; (let ((m (length (queue->list objects-dumped))))
; (queue-put! objects-dumped obj) ; (queue-put! objects-dumped obj)
; (queue-put! object-queue obj) ; (queue-put! object-queue obj)
; m) ; 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))))
(queue-put! objects-dumped 'a) (define current-fs 2)
(queue-put! objects-dumped 'b) (define pointer-size 4)
(write (queue->list objects-dumped)) (define (add-n-to-loc68 x y)
(write (test 'c)) ;; TODO: these should be 4 15, NOT 0
(write (my-not (test 'd))) (write `(add-n-to-loc68 ,x ,y))
;(write (my-string<=? (symbol->string (car objects-dumped)))) (newline))
(define (adjust-current-fs n) (set! current-fs (+ current-fs n)))
(define (resize-frame n)
(write `(resize-frame ,n ,current-fs)) (newline)
(let ((x (- n current-fs)))
(adjust-current-fs x)
(add-n-to-loc68 (* (- pointer-size) x) 15)))
(write (resize-frame 1))