Fcalva/cyclone
1
0
Fork 0
mirror of https://github.com/justinethier/cyclone.git synced 2025-05-23 20:15: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

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

@ -9,62 +9,78 @@
(scheme base)
(scheme write)
)
(inline
my-string<=?
my-not)
;(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))))
(define (my-string<=? str1 str2) (<= (string-cmp str1 str2) 0))
(define (my-not x) (if x #f #t))
(define current-fs 2)
(define pointer-size 4)
(define (add-n-to-loc68 x y)
;; TODO: these should be 4 15, NOT 0
(write `(add-n-to-loc68 ,x ,y))
(newline))
(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 (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)))
(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))))
(write (resize-frame 1))