;; vehicle choosing phase for closures ;; (c) 1996-1997 Sebastian Good ;; (c) 1997-2001 PLT ; Assign closures to ``vehicles'', and collect information for ; Racket about the closures. ; A vehicle is a C function that implements the body of a ; closure. Multiple closures may be assigned to a single ; vehicle to improve the performance of tail calls. ; The relate-lambdas! procedure is used to put procedure ; code into equivalence sets. If A contains a tail-call to ; B, they're put in the same equivalence class, and then ; they'll be implemented in the same vehicle, so A's call ; to B can be implemented as a goto. ;;; Annotatitons: ---------------------------------------------- ;; lambda: `code' structure UPDATED: label and ;; vehicle are set ;;; ------------------------------------------------------------ (module vehicle mzscheme (require mzlib/unit) (require syntax/zodiac-sig) (require "sig.ss") (require "../sig.ss") (provide vehicle@) (define-unit vehicle@ (import (prefix compiler:option: compiler:option^) compiler:library^ compiler:cstructs^ (prefix zodiac: zodiac^) compiler:zlayer^ compiler:const^ compiler:known^ compiler:closure^ compiler:driver^) (export compiler:vehicle^) ;; Used for union-find for lambda vehicles: (define (get-vehicle-top code) (let loop ([code code]) (let ([c (closure-code-vehicle code)]) (if (code? c) (let ([top (loop c)]) (set-closure-code-vehicle! code top) top) code)))) (define-struct vehicle (total-labels lambdas max-arity)) (define-struct (procedure-vehicle vehicle) (max-args)) (define vehicle:procedure 'vehicle:procedure) (define vehicles:automatic 'vehicles:automatic) (define vehicles:functions 'vehicles:functions) (define vehicles:monolithic 'vehicles:monolithic) (define (make-empty-vehicle type) (case type [(vehicle:procedure) (make-procedure-vehicle 0 null 0 0)])) (define (vehicle-is-type? v type) (case type [(vehicle:procedure) (procedure-vehicle? v)])) (define compiler:vehicles #f) (define compiler:total-vehicles 0) (define vehicle:add-lambda! (lambda (v type l) (let ([old-v (hash-table-get compiler:vehicles v (lambda () (make-empty-vehicle type)))]) (unless (vehicle-is-type? old-v type) (compiler:internal-error #f "can't use vehicle ~a as type ~a" old-v type)) (set-vehicle-lambdas! old-v (cons l (vehicle-lambdas old-v))) (hash-table-put! compiler:vehicles v old-v)))) (define vehicle:register-max-arity! (lambda (v n) (set-vehicle-max-arity! v (max n (vehicle-max-arity v))))) (define vehicle:register-max-args! (lambda (v n) (set-procedure-vehicle-max-args! v (max n (procedure-vehicle-max-args v))))) ;; These lists are built up backwards, so reverse it before outputting the list (define compiler:case-lambdas null) (define (compiler:get-vehicles) compiler:vehicles) (define (compiler:get-total-vehicles) compiler:total-vehicles) (define (compiler:get-case-lambdas) compiler:case-lambdas) (define (compiler:init-vehicles!) (set! compiler:vehicles (make-hash-table)) (set! compiler:total-vehicles 0) (set! compiler:case-lambdas null)) (define choose-vehicles! (lambda () (when (eq? (compiler:option:vehicles) vehicles:monolithic) (set! compiler:total-vehicles (compiler:option:vehicles:monoliths))) (for-each (lambda (L) (let* ([code (get-annotation L)] [type (cond [(zodiac:case-lambda-form? L) vehicle:procedure])] [new-vehicle (lambda () (begin0 compiler:total-vehicles (set! compiler:total-vehicles (+ 1 compiler:total-vehicles))))] [vnum (case (compiler:option:vehicles) [(vehicles:automatic) (case type [(vehicle:procedure) (let* ([top (get-vehicle-top code)] [n (or (closure-code-vehicle top) (new-vehicle))]) (set-closure-code-vehicle! top n) (set-closure-code-vehicle! code n) n)])] [(vehicles:monolithic) (case type [(vehicle:procedure) (random (compiler:option:vehicles:monoliths))])] [(vehicles:functions) (new-vehicle)] [else (compiler:internal-error #f (format "bad option:vehicles - ~a" (compiler:option:vehicles)))])]) (set-closure-code-vehicle! code vnum) (vehicle:add-lambda! vnum type L) ;; assign label, too (let* ([vehicle (hash-table-get compiler:vehicles vnum (lambda () (compiler:internal-error #f "bad hash table lookup (2)\n")))] [curr-label (vehicle-total-labels vehicle)]) (vehicle:register-max-arity! vehicle (closure-code-max-arity code)) (s:register-max-arity! (closure-code-max-arity code)) (cond [(procedure-vehicle? vehicle) (vehicle:register-max-args! vehicle (apply max (cons 0 (map (lambda (a) (length (zodiac:arglist-vars a))) (zodiac:case-lambda-form-args L)))))] [else (void)]) (set-closure-code-label! code curr-label) (set-vehicle-total-labels! vehicle (+ 1 curr-label))) ;; We take this opportunity to collect other top-level info ;; that is closure-type-specific (cond [(zodiac:case-lambda-form? L) (unless (= 1 (length (zodiac:case-lambda-form-args L))) (set-procedure-code-case-arities! code (length compiler:case-lambdas)) (set! compiler:case-lambdas (cons L compiler:case-lambdas)))]))) (compiler:get-closure-list)))) (define (get-vehicle vehicle-number) (hash-table-get compiler:vehicles vehicle-number (lambda () ;; not an error because random placement ;; may leave some vehicles empty (let ([v (make-empty-vehicle vehicle:procedure)]) (hash-table-put! compiler:vehicles vehicle-number v) v)))) ;; Traverse an AST and relate closure current-lambda to Y if ;; the AST includes a tail-call to Y. (define relate-lambdas! (letrec ([same-vehicle! (lambda (a b) (let ([a-top (get-vehicle-top (get-annotation a))] [b-top (get-vehicle-top (get-annotation b))]) (unless (eq? a-top b-top) (set-closure-code-vehicle! a-top b-top))))] [relate! (lambda (current-lambda ast) (cond ;;------------------------------------------------------------------ ;; LET EXPRESSIONS ;; [(zodiac:let-values-form? ast) (relate! current-lambda (zodiac:let-values-form-body ast))] [(zodiac:letrec-values-form? ast) (relate! current-lambda (zodiac:letrec-values-form-body ast))] ;;----------------------------------------------------------------- ;; IF EXPRESSIONS ;; [(zodiac:if-form? ast) (relate! current-lambda (zodiac:if-form-then ast)) (relate! current-lambda (zodiac:if-form-else ast))] ;;------------------------------------------------------------------ ;; BEGIN EXPRESSIONS ;; [(zodiac:begin-form? ast) (let loop ([l (zodiac:begin-form-bodies ast)]) (if (null? (cdr l)) (relate! current-lambda (car l)) (loop (cdr l))))] ;;------------------------------------------------------------------ ;; WITH-CONTINUATION-MARK EXPRESSIONS ;; [(zodiac:with-continuation-mark-form? ast) (relate! current-lambda (zodiac:with-continuation-mark-form-body ast))] ;;----------------------------------------------------------------- ;; APPLICATIONS ;; ;; Check for known func & relate to this one ;; [(zodiac:app? ast) (let ([f (zodiac:app-fun ast)]) (cond [(or (zodiac:bound-varref? f) (top-level-varref/bind-from-lift? f)) (let ([known (extract-varref-known-val f)]) (and known (when (zodiac:case-lambda-form? known) (same-vehicle! current-lambda known))))] [else (void)]))] [else (void)]))]) (lambda (current-lambda ast) (relate! current-lambda ast)))) (define (vehicle:only-code-in-vehicle? code) (= (vehicle-total-labels (get-vehicle (closure-code-vehicle code))) 1))))