From 922cd6c8be4193edbb8c5bab0d0fcc1e8181b603 Mon Sep 17 00:00:00 2001 From: Andrew Whatson Date: Tue, 2 Aug 2022 20:49:00 +1000 Subject: [PATCH] Port the cps-util interface --- TODO.org | 4 +- ps-compiler/front/cps.scm | 139 ++++++++++++++++++++++++++++++++++++++ 2 files changed, 141 insertions(+), 2 deletions(-) create mode 100644 ps-compiler/front/cps.scm diff --git a/TODO.org b/TODO.org index b4c081d..9d3fa53 100644 --- a/TODO.org +++ b/TODO.org @@ -38,7 +38,7 @@ involve: - rewrite macros from explicit renaming to syntax-case - ... and many more unforeseen challenges... -** ps-compiler/package-defs.scm [20/30] +** ps-compiler/package-defs.scm [21/30] *** [X] node *** [X] variable *** [X] primop @@ -51,7 +51,7 @@ involve: *** [X] node-vector *** [X] front *** [X] front-debug -*** [ ] cps-util +*** [X] cps-util *** [X] jump *** [X] simplify *** [ ] simplify-internal diff --git a/ps-compiler/front/cps.scm b/ps-compiler/front/cps.scm new file mode 100644 index 0000000..2f3f3a9 --- /dev/null +++ b/ps-compiler/front/cps.scm @@ -0,0 +1,139 @@ +;;; Ported from Scheme 48 1.9. See file COPYING for notices and license. +;;; +;;; Port Author: Andrew Whatson +;;; +;;; Original Authors: Richard Kelsey +;;; +;;; scheme48-1.9.2/ps-compiler/front/cps.scm +;;; +;;; (cps-call ) -> +;;; + + +;;; +;;; (cps-sequence ) -> + + +;;; +;;; ( ) -> + + + +(define-module (ps-compiler front cps) + #:use-module (srfi srfi-9) + #:use-module (prescheme scheme48) + #:use-module (ps-compiler node arch) + #:use-module (ps-compiler node node) + #:use-module (ps-compiler node node-util) + #:use-module (ps-compiler node primop) + #:use-module (ps-compiler util util) + #:export (cps-call cps-sequence)) + +(define (cps-call primop exits first-arg-index args cps) + (let ((call (make-call-node primop + (+ (length args) first-arg-index) + exits)) + (arguments (make-arg-nodes args first-arg-index cps))) + (let loop ((args arguments) (first #f) (last #f)) + (if (null? args) + (values call first last) + (let ((arg (car args))) + (attach call (arg-index arg) (arg-value arg)) + (if (and last (arg-first arg)) + (attach-body last (arg-first arg))) + (loop (cdr args) + (or first (arg-first arg)) + (or (arg-last arg) last))))))) + +;; Record to hold information about arguments to calls. + +(define-record-type :arg + (make-arg index rank value first last) + arg? + (index arg-index) ;; The index of this argument in the call. + (rank arg-rank) ;; The estimated cost of executing this node at run time. + (value arg-value) ;; What CPS returned for this argument. + (first arg-first) + (last arg-last)) + +;; Convert the elements of EXP into nodes (if they aren't already) and put +;; them into an ARG record. Returns the list of ARG records sorted +;; by ARG-RANK. + +(define (make-arg-nodes exp start cps) + (do ((index start (+ index 1)) + (args exp (cdr args)) + (vals '() (cons (receive (value first last) + (cps (car args)) + (make-arg index (node-rank first) value first last)) + vals))) + ((null? args) + (sort-list vals + (lambda (v1 v2) + (> (arg-rank v1) (arg-rank v2))))))) + +;; Complexity analysis used to order argument evaluation. More complex +;; arguments are to be evaluated first. This just counts reference nodes. +;; It is almost certainly a waste of time. + +(define (node-rank first) + (if (not first) + 0 + (complexity-analyze-vector (call-args first)))) + +(define (complexity-analyze node) + (cond ((empty? node) + 0) + ((reference-node? node) + 1) + ((lambda-node? node) + (if (not (empty? (lambda-body node))) + (complexity-analyze-vector (call-args (lambda-body node))) + 0)) + ((call-node? node) + (complexity-analyze-vector (call-args node))) + (else + 0))) + +(define (complexity-analyze-vector vec) + (do ((i 0 (+ i 1)) + (q 0 (+ q (complexity-analyze (vector-ref vec i))))) + ((>= i (vector-length vec)) + q))) + +;;---------------------------------------------------------------- +;; (cps-sequence ) -> +;; + + +;; is the same as the used above, except that it returns +;; a list of value nodes instead of exactly one. + +(define (cps-sequence nodes values-cps) + (if (null? nodes) + (bug "CPS: empty sequence")) + (let loop ((nodes nodes) (first #f) (last #f)) + (if (null? (cdr nodes)) + (values (car nodes) first last) + (receive (exp-first exp-last) + (cps-sequent (car nodes) values-cps) + (if (and last exp-first) + (attach-body last exp-first)) + (loop (cdr nodes) (or first exp-first) (or exp-last last)))))) + +(define (cps-sequent node values-cps) + (receive (vals exp-first exp-last) + (values-cps node) + (receive (calls other) + (partition-list call-node? vals) + (map erase other) + (if (null? calls) + (values exp-first exp-last) + (insert-let calls exp-first exp-last))))) + +(define (insert-let calls exp-first exp-last) + (let* ((vars (map (lambda (call) + (make-variable 'v (trivial-call-return-type call))) + calls)) + (cont (make-lambda-node 'c 'cont vars)) + (call (make-call-node (get-primop (enum primop-enum let)) + (+ 1 (length calls)) + 1))) + (attach-call-args call (cons cont calls)) + (cond (exp-first + (attach-body exp-last call) + (values exp-first cont)) + (else + (values call cont)))))