From 14c276387a7dc4d39e20c939ebb981278ffc2c52 Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Fri, 28 Dec 2018 06:03:57 -0500 Subject: [PATCH] Initial files --- cps-opt-analyze-call-graph-test.scm | 36 +++++++ cps-opt-analyze-call-graph.scm | 156 ++++++++++++++++++++++++++++ 2 files changed, 192 insertions(+) create mode 100644 cps-opt-analyze-call-graph-test.scm create mode 100644 cps-opt-analyze-call-graph.scm diff --git a/cps-opt-analyze-call-graph-test.scm b/cps-opt-analyze-call-graph-test.scm new file mode 100644 index 00000000..cfb5472a --- /dev/null +++ b/cps-opt-analyze-call-graph-test.scm @@ -0,0 +1,36 @@ +;; 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) +) + +(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 (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)) diff --git a/cps-opt-analyze-call-graph.scm b/cps-opt-analyze-call-graph.scm new file mode 100644 index 00000000..a65f0a4e --- /dev/null +++ b/cps-opt-analyze-call-graph.scm @@ -0,0 +1,156 @@ +;;;; Cyclone Scheme +;;;; https://github.com/justinethier/cyclone +;;;; +;;;; Copyright (c) 2014-2019, Justin Ethier +;;;; All rights reserved. +;;;; +;;;; This file is part of the cps-optimizations module. +;;;; + +(cond-expand + (program + (import (scheme base) + (scheme write) + (scheme cyclone ast) + (scheme cyclone primitives) + (scheme cyclone util) + (scheme cyclone pretty-print)))) + +;; TODO: +;; analyze call graph. not exactly sure how this is going to work yet, but the goal is to be able to figure out which +;; variables a primitive call is dependent upon. We then need to be able to query if any of those variables are mutated +;; (ideally in fnc body) in which case we cannot inline the prim call. +;; +#;(define (analyze:build-call-graph sexp) + (define (scan exp) + ;(write `(DEBUG scan ,exp)) (newline) + (cond + ((ast:lambda? exp) + (ast:%make-lambda + (ast:lambda-id exp) + (ast:lambda-args exp) + (map scan (ast:lambda-body exp)) + (ast:lambda-has-cont exp))) + ((quote? exp) exp) + ((const? exp) exp) + ((ref? exp) exp) + ((define? exp) + `(define + ,(define->var exp) + ,@(map scan (define->exp exp)))) + ((set!? exp) + `(set! + ,(scan (set!->var exp)) + ,(scan (set!->exp exp)))) + ((if? exp) + `(if ,(scan (if->condition exp)) + ,(scan (if->then exp)) + ,(scan (if->else exp)))) + ((app? exp) + (cond + ((and + (list? exp) + (ast:lambda? (car exp)) + (equal? (length exp) 2) + (ast:lambda? (cadr exp)) + (list? (ast:lambda-args (cadr exp))) + (equal? 1 (length (ast:lambda-args (cadr exp)))) + (lvr:local-tail-call-only? + (ast:lambda-body (car exp)) + (car (ast:lambda-args (car exp)))) + ;(tagged-list? 'Cyc-seq (car (ast:lambda-body (cadr exp)))) ;; TODO: DEBUG line, remove this once it works! + ) + ;;(write `(tail-call-only? passed for ,exp)) (newline) + ;;(write `(replace with ,(lvr:tail-calls->values + ;; (car (ast:lambda-body (car exp))) + ;; (car (ast:lambda-args (car exp)))))) + ;;(newline) +;TODO: need to revisit this, may need to replace values with assignments to the "let" variable. +;would need to be able to carry that through to cgen and assign properly over there... + (let* ((value (lvr:tail-calls->values + (car (ast:lambda-body (car exp))) + (car (ast:lambda-args (car exp))) + (car (ast:lambda-args (cadr exp))) + )) + (var (car (ast:lambda-args (cadr exp)))) + (body (ast:lambda-body (cadr exp))) + (av (cond-expand + (program #f) + (else (adb:get/default var #f)))) + (ref-count + (if av + (cond-expand + (program #f) + (else (adbv:ref-count av))) + 1)) ;; Dummy value + ) + (if (and (> ref-count 0) ;; 0 ==> local var is never used + value) + `(let ((,var ,value)) + ,@body) + (map scan exp)) ;; failsafe + )) + (else + (map scan exp)))) + (else (error "unknown expression type: " exp)) + )) + (scan sexp)) + + +(cond-expand + (program + (define sexp +'( + + (define test + (lambda + (k$38 obj$5$11) + (queue->list + (lambda + (r$42) + ((lambda + (r$39) + ((lambda + (m$6$12) + (queue-put! + (lambda + (r$40) + (queue-put! + (lambda (r$41) (k$38 m$6$12)) + object-queue + obj$5$11)) + objects-dumped + obj$5$11)) + r$39)) + (length r$42))) + objects-dumped))) + + ;; Doesn't really matter, but lets leave this for now + (define slot-set! + (lambda + (k$7170 + name$2424$3603 + obj$2425$3604 + idx$2426$3605 + val$2427$3606) + ((lambda + (vec$2428$3607) + ((lambda + (r$7171) + (k$7170 + (vector-set! r$7171 idx$2426$3605 val$2427$3606))) + (vector-ref vec$2428$3607 2))) + obj$2425$3604))) + ) + +) + + (pretty-print + (ast:ast->pp-sexp + (ast:sexp->ast sexp))) + + ;(pretty-print + ; (ast:ast->pp-sexp + ; (opt:local-var-reduction (ast:sexp->ast sexp))) + ;) +))