;;; LaHaShem HaAretz U'Mloah ;;; Stalin 0.11 - A global optimizing compiler for Scheme ;;; Copyright 1993, 1994, and 1995 University of Toronto. All rights reserved. ;;; Copyright 1996 Technion. All rights reserved. ;;; Copyright 1996 and 1997 University of Vermont. All rights reserved. ;;; Copyright 1997, 1998, 1999, 2000, and 2001 NEC Research Institute, Inc. All ;;; rights reserved. ;;; Copyright 2002, 2003, 2004, 2005, and 2006 Purdue University. All rights ;;; reserved. ;;; This program is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU General Public License ;;; as published by the Free Software Foundation; either version 2 ;;; of the License, or (at your option) any later version. ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; You should have received a copy of the GNU General Public License ;;; along with this program; if not, write to the Free Software ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. ;;; written by: ;;; Jeffrey Mark Siskind ;;; School of Electrical and Computer Engineering ;;; Purdue University ;;; Electrical Engineering Building, Room 330 ;;; 465 Northwestern Avenue ;;; West Lafayette IN 47907-2035 USA ;;; voice: 765/496-3197 ;;; fax: 765/494-6440 ;;; qobi@purdue.edu ;;; http://www.ece.purdue.edu/~qobi #+(not csi) (include "QobiScheme") (include "architectures.scm") ;;; GENSYM (define (gensym string) (string->uninterned-symbol (string-copy string))) (define (no-cursor) #f) (define (no-version) #f) (define (notify format-string . args) ;; conventions: FORMAT-STRING ARGS (let ((string (apply format #f format-string args))) (display string) (newline))) (define (split-into-lines s) ;; conventions: S (let loop ((characters (string->list s)) (lines '(""))) ;; conventions: CHARACTERS LINES (cond ((null? characters) (reverse lines)) ((char=? (first characters) #\newline) (loop (rest characters) (cons "" lines))) (else (loop (rest characters) (cons (string-append (first lines) (string (first characters))) (rest lines))))))) (define (notify-pp format-string . args) ;; conventions: FORMAT-STRING ARGS (let ((pretty? (write-pretty))) ;; conventions: PRETTY? (set-write-pretty! #t) (apply format #t format-string args) (set-write-pretty! pretty?)) (newline)) (define (notify-pp3 format-string . args) ;; conventions: FORMAT-STRING ARGS (let ((level (write-level)) (pretty? (write-pretty))) ;; conventions: LEVEL PRETTY? (set-write-level! 3) (set-write-pretty! #t) (apply format #t format-string args) (set-write-level! level) (set-write-pretty! pretty?)) (newline)) (define (terminate) (exit -1)) ;;; Structure definitions (define-structure s-expression ;; The slots EXPANSION and MACROEXPAND-BODY are just for efficiency. version ;version cursor ;cursor pathname ;string #f line-position ;integer character-position ;integer character-position-within-line ;integer comments ;strings expansion ;s #f macroexpand-body ;s #f datum) ;q (define-structure program-point before? ;#t #f expression) ;e (define-structure expression kind ;symbol version ;version cursor ;cursor pathname ;string #f line-position ;integer character-position ;integer character-position-within-line ;integer index ;i link ;x #t #f environment ;e #f type-set ;w parent ;x #f constant ;q lambda-environment ;e parameters ;(union null g (pair g ^2)) body ;x #f variable ;g source ;x antecedent ;x consequent ;x alternate ;x callee ;x arguments ;xs original-expression ;x #f result ;r type-allocation-alist ;(list* u-(e|'stack|'heap)) continuation-type ;continuation-type #f string-type ;string-type #f structure-types ;structure-types headed-vector-types ;headed-vector-types nonheaded-vector-types ;nonheaded-vector-types booleans) (define-structure result kind ;symbol environment ;e type-set ;w c ;c l1 ;c l2 ;c l0) ;c (define-structure internal-symbol-type name ;symbol index ;i use-count ;integer types-and-type-sets-that-directly-point-to ;u/ws booleans) (define-structure external-symbol-type displaced-string-type ;string-type link ;external-symbol-type index ;i use-count ;integer types-and-type-sets-that-directly-point-to ;u/ws booleans) (define-structure primitive-procedure-type name ;symbol arguments ;(list* object) index ;i use-count ;integer types-and-type-sets-that-directly-point-to ;u/ws booleans) (define-structure native-procedure-type call-site-environment-alist ;(list* (union y #f)-e) narrow-prototype ;e #f index ;i use-count ;integer types-and-type-sets-that-directly-point-to ;u/ws booleans) (define-structure foreign-procedure-type name ;string ;; The next entry is somewhat misnamed because it is not a list of variables. parameters ;fs ;; The next entry is somewhat misnamed because it is not a result. result ;f include ;string #f index ;i use-count ;integer types-and-type-sets-that-directly-point-to ;u/ws booleans) (define-structure continuation-type allocating-expression ;x #f index ;i use-count ;integer call-sites ;ys types-and-type-sets-that-directly-point-to ;u/ws booleans) (define-structure string-type allocating-expressions ;(list+ (union x #f)) link ;string-type index ;i use-count ;integer types-and-type-sets-that-directly-point-to ;u/ws external-symbol-type ;external-symbol-type #f booleans) (define-structure structure-type name ;symbol slots ;ws allocating-expressions ;xs link ;structure-type index ;i use-count ;integer types-and-type-sets-that-directly-point-to ;u/ws structure-ref-accessed? ;(list* (union #t #f)) booleans) (define-structure headed-vector-type element ;w allocating-expressions ;xs link ;headed-vector-type index ;i use-count ;integer types-and-type-sets-that-directly-point-to ;u/ws displaced-vector-type ;displaced-vector-type #f booleans) (define-structure nonheaded-vector-type element ;w allocating-expressions ;(list+ (union x #f)) link ;nonheaded-vector-type index ;i use-count ;integer types-and-type-sets-that-directly-point-to ;u/ws displaced-vector-type ;displaced-vector-type #f booleans) (define-structure displaced-vector-type displaced-vector-type ;vector-type link ;displaced-vector-type index ;i use-count ;integer types-and-type-sets-that-directly-point-to ;u/ws booleans) (define-structure red-black-tree-node type key left right red?) (define-structure type-set location ;x g u #f red-black-tree-node ;#f red-black-tree-node link ;w minimal-alignment ;integer index ;i booleans) (define-structure variable version ;version cursor ;cursor pathname ;string #f line-position ;integer character-position ;integer character-position-within-line ;integer index ;i name ;symbol environment ;e type-set ;w accesses ;xs assignments ;xs references ;xs booleans) (define-structure environment ;; needs work: The following comment is out of date. ;; The slots QUICK-PARENT, PARENT-PARAMETER, PARENT-SLOT, ANCESTORS, ;; DESCENDENTS, and IN-LINED-ENVIRONMENTS, inter alia, are just for ;; efficiency. index ;i expression ;x name ;string split ;#t #f 'never call-sites ;(list* (union y #f)) allocation ;e 'stack 'heap distance-from-root ;integer free-variables ;gs quick-parent ;e #f parent-parameter ;e #f parent-slot ;e #f ancestors ;es descendents ;es properly-in-lined-environments ;es narrow-prototype ;e narrow-clones ;es wide-prototype ;e direct-tail-callers ;es direct-non-tail-callers ;es direct-tail-callees ;es direct-non-tail-callees ;es blocked-environments ;es expressions ;xs continuation-calls ;xs escaping-types ;us non-self-tail-call-sites ;ys booleans) (define-structure call-site expression ;x offsets) ;(list* symbol) ;;; GENSYM ;;; Global variables (define *types-frozen?* #f) (define *during-closure-conversion?* #f) (define *again?* #f) (define (unused) 'unused) (define (unspecified) 'unspecified) ;;; S-Expression creation (define (create-s-expression pathname line-position character-position character-position-within-line comments datum) (make-s-expression (no-version) (no-cursor) pathname line-position character-position character-position-within-line comments #f #f datum)) (define (create-anonymous-s-expression datum) (create-s-expression #f (unused) (unused) (unused) '() datum)) (define (create-october-s-expression version cursor datum) (make-s-expression version cursor #f #f #f #f '() #f #f datum)) ;;; Expression creation (define *xi* #f) (define *xs* #f) (define *calls* #f) (define *accesses* #f) (define *assignments* #f) (define *references* #f) (define *x* #f) (define *x1* #f) (define (initialize-expressions!) (set! *xi* 0) (set! *xs* '()) (set! *calls* '()) (set! *accesses* '()) (set! *assignments* '()) (set! *references* '()) (set! *x1* #f)) (define (create-expression kind s/x q) (let ((x (cond ((s-expression? s/x) (make-expression kind (s-expression-version s/x) (s-expression-cursor s/x) (s-expression-pathname s/x) (s-expression-line-position s/x) (s-expression-character-position s/x) (s-expression-character-position-within-line s/x) *xi* #f (unspecified) (unspecified) (unspecified) q (unused) (unused) (unused) (unused) (unused) (unused) (unused) (unused) (unused) (unused) #f (unspecified) '() #f #f '() '() '() 0)) ((expression? s/x) (make-expression kind (expression-version s/x) (expression-cursor s/x) (expression-pathname s/x) (expression-line-position s/x) (expression-character-position s/x) (expression-character-position-within-line s/x) *xi* #f (unspecified) (unspecified) (unspecified) q (unused) (unused) (unused) (unused) (unused) (unused) (unused) (unused) (unused) (unused) s/x (unspecified) '() #f #f '() '() '() 0)) (else (make-expression kind (no-version) (no-cursor) #f #f #f #f *xi* #f (unspecified) (unspecified) (unspecified) q (unused) (unused) (unused) (unused) (unused) (unused) (unused) (unused) (unused) (unused) #f (unspecified) '() #f #f '() '() '() 0))))) (set! *xi* (+ *xi* 1)) (set! *xs* (cons x *xs*)) x)) (define (create-call-expression s/x callee arguments) (let ((x (cond ((s-expression? s/x) (make-expression 'call (s-expression-version s/x) (s-expression-cursor s/x) (s-expression-pathname s/x) (s-expression-line-position s/x) (s-expression-character-position s/x) (s-expression-character-position-within-line s/x) *xi* #f (unspecified) (unspecified) (unspecified) (unused) (unused) (unused) (unused) (unused) (unused) (unused) (unused) (unused) callee arguments #f (unspecified) '() #f #f '() '() '() 0)) ((expression? s/x) (make-expression 'call (expression-version s/x) (expression-cursor s/x) (expression-pathname s/x) (expression-line-position s/x) (expression-character-position s/x) (expression-character-position-within-line s/x) *xi* #f (unspecified) (unspecified) (unspecified) (unused) (unused) (unused) (unused) (unused) (unused) (unused) (unused) (unused) callee arguments s/x (unspecified) '() #f #f '() '() '() 0)) (else (make-expression 'call (no-version) (no-cursor) #f #f #f #f *xi* #f (unspecified) (unspecified) (unspecified) (unused) (unused) (unused) (unused) (unused) (unused) (unused) (unused) (unused) callee arguments #f (unspecified) '() #f #f '() '() '() 0))))) (set! *xi* (+ *xi* 1)) (set! *xs* (cons x *xs*)) (set! *calls* (cons x *calls*)) x)) (define (create-converted-call-expression s/x callee arguments) (let ((x (cond ((s-expression? s/x) (make-expression 'converted-call (s-expression-version s/x) (s-expression-cursor s/x) (s-expression-pathname s/x) (s-expression-line-position s/x) (s-expression-character-position s/x) (s-expression-character-position-within-line s/x) *xi* #f (unspecified) (unspecified) (unspecified) (unused) (unused) (unused) (unused) (unused) (unused) (unused) (unused) (unused) callee arguments #f (unspecified) '() #f #f '() '() '() 0)) ((expression? s/x) (make-expression 'converted-call (expression-version s/x) (expression-cursor s/x) (expression-pathname s/x) (expression-line-position s/x) (expression-character-position s/x) (expression-character-position-within-line s/x) *xi* #f (unspecified) (unspecified) (unspecified) (unused) (unused) (unused) (unused) (unused) (unused) (unused) (unused) (unused) callee arguments s/x (unspecified) '() #f #f '() '() '() 0)) (else (make-expression 'converted-call (no-version) (no-cursor) #f #f #f #f *xi* #f (unspecified) (unspecified) (unspecified) (unused) (unused) (unused) (unused) (unused) (unused) (unused) (unused) (unused) callee arguments #f (unspecified) '() #f #f '() '() '() 0))))) (set! *xi* (+ *xi* 1)) (set! *xs* (cons x *xs*)) (set! *calls* (cons x *calls*)) x)) (define (create-access-expression s/x variable) (let ((x (cond ((s-expression? s/x) (make-expression 'access (s-expression-version s/x) (s-expression-cursor s/x) (s-expression-pathname s/x) (s-expression-line-position s/x) (s-expression-character-position s/x) (s-expression-character-position-within-line s/x) *xi* #f (unspecified) (unspecified) (unspecified) (unused) (unused) (unused) (unused) variable (unused) (unused) (unused) (unused) (unused) (unused) #f (unspecified) '() #f #f '() '() '() 0)) ((expression? s/x) (make-expression 'access (expression-version s/x) (expression-cursor s/x) (expression-pathname s/x) (expression-line-position s/x) (expression-character-position s/x) (expression-character-position-within-line s/x) *xi* #f (unspecified) (unspecified) (unspecified) (unused) (unused) (unused) (unused) variable (unused) (unused) (unused) (unused) (unused) (unused) s/x (unspecified) '() #f #f '() '() '() 0)) (else (make-expression 'access (no-version) (no-cursor) #f #f #f #f *xi* #f (unspecified) (unspecified) (unspecified) (unused) (unused) (unused) (unused) variable (unused) (unused) (unused) (unused) (unused) (unused) #f (unspecified) '() #f #f '() '() '() 0))))) (set! *xi* (+ *xi* 1)) (set! *xs* (cons x *xs*)) (set! *accesses* (cons x *accesses*)) (set! *references* (cons x *references*)) x)) (define (create-lambda-expression s/x lambda-environment parameters expression) (let ((x (cond ((s-expression? s/x) (make-expression 'lambda (s-expression-version s/x) (s-expression-cursor s/x) (s-expression-pathname s/x) (s-expression-line-position s/x) (s-expression-character-position s/x) (s-expression-character-position-within-line s/x) *xi* #f (unspecified) (unspecified) (unspecified) (unused) lambda-environment parameters expression (unused) (unused) (unused) (unused) (unused) (unused) (unused) #f (unspecified) '() #f #f '() '() '() 0)) ((expression? s/x) (make-expression 'lambda (expression-version s/x) (expression-cursor s/x) (expression-pathname s/x) (expression-line-position s/x) (expression-character-position s/x) (expression-character-position-within-line s/x) *xi* #f (unspecified) (unspecified) (unspecified) (unused) lambda-environment parameters expression (unused) (unused) (unused) (unused) (unused) (unused) (unused) s/x (unspecified) '() #f #f '() '() '() 0)) (else (make-expression 'lambda (no-version) (no-cursor) #f #f #f #f *xi* #f (unspecified) (unspecified) (unspecified) (unused) lambda-environment parameters expression (unused) (unused) (unused) (unused) (unused) (unused) (unused) #f (unspecified) '() #f #f '() '() '() 0))))) (set-environment-expression! lambda-environment x) (set! *xi* (+ *xi* 1)) (set! *xs* (cons x *xs*)) x)) (define (create-converted-lambda-expression s/x lambda-environment parameters expression) (let ((x (cond ((s-expression? s/x) (make-expression 'converted-lambda (s-expression-version s/x) (s-expression-cursor s/x) (s-expression-pathname s/x) (s-expression-line-position s/x) (s-expression-character-position s/x) (s-expression-character-position-within-line s/x) *xi* #f (unspecified) (unspecified) (unspecified) (unused) lambda-environment parameters expression (unused) (unused) (unused) (unused) (unused) (unused) (unused) #f (unspecified) '() #f #f '() '() '() 0)) ((expression? s/x) (make-expression 'converted-lambda (expression-version s/x) (expression-cursor s/x) (expression-pathname s/x) (expression-line-position s/x) (expression-character-position s/x) (expression-character-position-within-line s/x) *xi* #f (unspecified) (unspecified) (unspecified) (unused) lambda-environment parameters expression (unused) (unused) (unused) (unused) (unused) (unused) (unused) s/x (unspecified) '() #f #f '() '() '() 0)) (else (make-expression 'converted-lambda (no-version) (no-cursor) #f #f #f #f *xi* #f (unspecified) (unspecified) (unspecified) (unused) lambda-environment parameters expression (unused) (unused) (unused) (unused) (unused) (unused) (unused) #f (unspecified) '() #f #f '() '() '() 0))))) (set-environment-expression! lambda-environment x) (set! *xi* (+ *xi* 1)) (set! *xs* (cons x *xs*)) x)) (define (create-converted-continuation-expression s/x lambda-environment parameters expression) (let ((x (cond ((s-expression? s/x) (make-expression 'converted-continuation (s-expression-version s/x) (s-expression-cursor s/x) (s-expression-pathname s/x) (s-expression-line-position s/x) (s-expression-character-position s/x) (s-expression-character-position-within-line s/x) *xi* #f (unspecified) (unspecified) (unspecified) (unused) lambda-environment parameters expression (unused) (unused) (unused) (unused) (unused) (unused) (unused) #f (unspecified) '() #f #f '() '() '() 0)) ((expression? s/x) (make-expression 'converted-continuation (expression-version s/x) (expression-cursor s/x) (expression-pathname s/x) (expression-line-position s/x) (expression-character-position s/x) (expression-character-position-within-line s/x) *xi* #f (unspecified) (unspecified) (unspecified) (unused) lambda-environment parameters expression (unused) (unused) (unused) (unused) (unused) (unused) (unused) s/x (unspecified) '() #f #f '() '() '() 0)) (else (make-expression 'converted-continuation (no-version) (no-cursor) #f #f #f #f *xi* #f (unspecified) (unspecified) (unspecified) (unused) lambda-environment parameters expression (unused) (unused) (unused) (unused) (unused) (unused) (unused) #f (unspecified) '() #f #f '() '() '() 0))))) (set-environment-expression! lambda-environment x) (set! *xi* (+ *xi* 1)) (set! *xs* (cons x *xs*)) x)) (define (create-set!-expression s/x variable source) (let ((x (cond ((s-expression? s/x) (make-expression 'set! (s-expression-version s/x) (s-expression-cursor s/x) (s-expression-pathname s/x) (s-expression-line-position s/x) (s-expression-character-position s/x) (s-expression-character-position-within-line s/x) *xi* #f (unspecified) (unspecified) (unspecified) (unused) (unused) (unused) (unused) variable source (unused) (unused) (unused) (unused) (unused) #f (unspecified) '() #f #f '() '() '() 0)) ((expression? s/x) (make-expression 'set! (expression-version s/x) (expression-cursor s/x) (expression-pathname s/x) (expression-line-position s/x) (expression-character-position s/x) (expression-character-position-within-line s/x) *xi* #f (unspecified) (unspecified) (unspecified) (unused) (unused) (unused) (unused) variable source (unused) (unused) (unused) (unused) (unused) s/x (unspecified) '() #f #f '() '() '() 0)) (else (make-expression 'set! (no-version) (no-cursor) #f #f #f #f *xi* #f (unspecified) (unspecified) (unspecified) (unused) (unused) (unused) (unused) variable source (unused) (unused) (unused) (unused) (unused) #f (unspecified) '() #f #f '() '() '() 0))))) (set! *xi* (+ *xi* 1)) (set! *xs* (cons x *xs*)) (set! *assignments* (cons x *assignments*)) (set! *references* (cons x *references*)) x)) (define (create-if-expression s/x antecedent consequent alternate) (let ((x (cond ((s-expression? s/x) (make-expression 'if (s-expression-version s/x) (s-expression-cursor s/x) (s-expression-pathname s/x) (s-expression-line-position s/x) (s-expression-character-position s/x) (s-expression-character-position-within-line s/x) *xi* #f (unspecified) (unspecified) (unspecified) (unused) (unused) (unused) (unused) (unused) (unused) antecedent consequent alternate (unused) (unused) #f (unspecified) '() #f #f '() '() '() 0)) ((expression? s/x) (make-expression 'if (expression-version s/x) (expression-cursor s/x) (expression-pathname s/x) (expression-line-position s/x) (expression-character-position s/x) (expression-character-position-within-line s/x) *xi* #f (unspecified) (unspecified) (unspecified) (unused) (unused) (unused) (unused) (unused) (unused) antecedent consequent alternate (unused) (unused) s/x (unspecified) '() #f #f '() '() '() 0)) (else (make-expression 'if (no-version) (no-cursor) #f #f #f #f *xi* #f (unspecified) (unspecified) (unspecified) (unused) (unused) (unused) (unused) (unused) (unused) antecedent consequent alternate (unused) (unused) #f (unspecified) '() #f #f '() '() '() 0))))) (set! *xi* (+ *xi* 1)) (set! *xs* (cons x *xs*)) x)) ;;; Expression properties (define (expression-reached? x) (not (zero? (bit-and (expression-booleans x) 64)))) (define (set-expression-reached?! x p?) (unless (boolean? p?) (fuck-up)) (set-expression-booleans! x (if p? (bit-or (expression-booleans x) 64) (bit-and (expression-booleans x) (bit-not 64))))) (define (expression-inferred? x) (not (zero? (bit-and (expression-booleans x) 32)))) (define (set-expression-inferred?! x p?) (unless (boolean? p?) (fuck-up)) (set-expression-booleans! x (if p? (bit-or (expression-booleans x) 32) (bit-and (expression-booleans x) (bit-not 32))))) (define (expression-accessed? x) (not (zero? (bit-and (expression-booleans x) 16)))) (define (set-expression-accessed?! x p?) (unless (boolean? p?) (fuck-up)) (set-expression-booleans! x (if p? (bit-or (expression-booleans x) 16) (bit-and (expression-booleans x) (bit-not 16))))) (define (expression-needs-conversion-to-CPS? x) (not (zero? (bit-and (expression-booleans x) 8)))) (define (set-expression-needs-conversion-to-CPS?! x p?) (unless (boolean? p?) (fuck-up)) (set-expression-booleans! x (if p? (bit-or (expression-booleans x) 8) (bit-and (expression-booleans x) (bit-not 8))))) (define (expression-needs-stop-conversion-to-CPS? x) (not (zero? (bit-and (expression-booleans x) 4)))) (define (set-expression-needs-stop-conversion-to-CPS?! x p?) (unless (boolean? p?) (fuck-up)) (set-expression-booleans! x (if p? (bit-or (expression-booleans x) 4) (bit-and (expression-booleans x) (bit-not 4))))) (define (expression-continues? x) (not (zero? (bit-and (expression-booleans x) 2)))) (define (set-expression-continues?! x p?) (unless (boolean? p?) (fuck-up)) (set-expression-booleans! x (if p? (bit-or (expression-booleans x) 2) (bit-and (expression-booleans x) (bit-not 2))))) (define (expression-returns? x) (not (zero? (bit-and (expression-booleans x) 1)))) (define (set-expression-returns?! x p?) (unless (boolean? p?) (fuck-up)) (set-expression-booleans! x (if p? (bit-or (expression-booleans x) 1) (bit-and (expression-booleans x) (bit-not 1))))) (define (reached? x) (if *during-closure-conversion?* (case *closure-conversion-method* ((baseline conventional) #t) ((lightweight) (expression-reached? x)) (else (fuck-up))) (expression-reached? x))) (define (executed? x) (if *during-closure-conversion?* (case *closure-conversion-method* ((baseline conventional) #t) ((lightweight) (case (expression-kind x) ((set!) (expression-returns? (expression-source x))) ((call converted-call) (and (expression-returns? (expression-callee x)) (every expression-returns? (expression-arguments x)))) (else (fuck-up)))) (else (fuck-up))) (case (expression-kind x) ((set!) (expression-returns? (expression-source x))) ((call converted-call) (and (expression-returns? (expression-callee x)) (every expression-returns? (expression-arguments x)))) (else (fuck-up))))) (define (free-reference? x) (and (not (eq? (expression-environment x) (variable-environment (expression-variable x)))) (nontrivial-reference? x))) (define (nontrivial-reference? x) ;; needs work: This is not memoized but should be. (case (expression-kind x) ((access) (and (reached? x) (not (fictitious? (expression-type-set x))))) ((set!) (and (executed? x) (accessed? (expression-variable x)) (not (fictitious? (variable-type-set (expression-variable x)))) (not (hidden? (expression-variable x))) ;; This implies that the source returns. (not (void? (expression-type-set (expression-source x)))))) (else (fuck-up)))) (define (must-be-self-tail-call? x) (and (or (eq? (expression-kind x) 'call) (eq? (expression-kind x) 'converted-call)) (must-be? (lambda (u) (or (not ((compatible-call? x) u)) (and (native-procedure-type? u) (let ((e (callee-environment u (create-call-site x)))) ;; This assumes that the IN-LINED-IN? relation is reflexive. (and (tail-call? (create-call-site x) e) (in-lined-in? x e)))))) (expression-type-set (expression-callee x))))) ;;; Expression functions (define (continuation-argument x) (unless (eq? (expression-kind x) 'converted-call) (fuck-up)) (first (expression-arguments x))) (define (first-argument x) (case (expression-kind x) ((call) (first (expression-arguments x))) ((converted-call) (second (expression-arguments x))) (else (fuck-up)))) (define (second-argument x) (case (expression-kind x) ((call) (second (expression-arguments x))) ((converted-call) (third (expression-arguments x))) (else (fuck-up)))) (define (third-argument x) (case (expression-kind x) ((call) (third (expression-arguments x))) ((converted-call) (fourth (expression-arguments x))) (else (fuck-up)))) ;;; Expression environment relations (define (tail-call? y e) ;; needs work: This is not memoized but should be. ;; needs work: A SET! to a non-accessed, fictitious, or hidden variable can be ;; a tail call if its source is a tail call. ;; note: The argument E is needed to prevent infinite recursion on in-lined ;; self tail calls. ;; APPLY and CALL-WITH-CURRENT-CONTINUATION tail call their first argument if ;; they themselves are tail calls. Implicit continuation calls are always ;; tail calls. FORK does not tail call its first or second argument and MUTEX ;; does not tail call its first argument. (or (continuation-argument-call-site? y) (and (or (explicit-call-site? y) (and (first-argument-call-site? y) ;; needs work: It is conceivable that a first-argument call site ;; be called both by either APPLY or ;; CALL-WITH-CURRENT-CONTINUATION and by either FORK or ;; MUTEX. In this situation, the former could be tail ;; calls while the latter could not be. The current ;; representation of call sites cannot distinguish ;; between argument call sites of different primitive ;; procedures. So we err on the safe side and make such ;; call sites non tail. (not (can-be? (lambda (u) (or ((primitive-procedure-type-named? 'fork) u) ((primitive-procedure-type-named? 'mutex) u))) (expression-type-set (expression-callee (call-site-expression y))))))) (let ((x (call-site-expression y))) (or (and (eq? (expression-kind (expression-parent x)) 'if) (or (eq? x (expression-consequent (expression-parent x))) (eq? x (expression-alternate (expression-parent x)))) (tail-call? (create-call-site (expression-parent x)) e)) (and (or (eq? (expression-kind (expression-parent x)) 'lambda) (eq? (expression-kind (expression-parent x)) 'converted-lambda) (eq? (expression-kind (expression-parent x)) 'converted-continuation)) (or (eq? (expression-environment x) e) (not (unique-call-site? (expression-environment x))) (tail-call? (unique-call-site (expression-environment x)) e)))))))) ;;; Result creation (define (create-accessor-result type-set c) (make-result 'accessor (unused) type-set c (unused) (unused) (unused))) (define (create-discard-result) (make-result 'discard (unused) (unused) (unused) (unused) (unused) (unused))) (define (create-return-result environment type-set) (make-result 'return environment type-set (c:r environment) (unused) (unused) (unused))) (define (create-antecedent-result type-set l1 l2 l0) (make-result 'antecedent (unused) type-set (unused) l1 l2 l0)) ;;; Result properties (define (accessor? r) (eq? (result-kind r) 'accessor)) (define (return? r) (eq? (result-kind r) 'return)) (define (discard? r) (eq? (result-kind r) 'discard)) (define (antecedent? r) (eq? (result-kind r) 'antecedent)) ;;; Type creation (define *ui* #f) (define #f) (define *null-type-used?* #f) (define *null-type-use-count* #f) (define #f) (define *true-type-used?* #f) (define *true-type-use-count* #f) (define #f) (define *false-type-used?* #f) (define *false-type-use-count* #f) (define #f) (define *char-type-used?* #f) (define *char-type-use-count* #f) (define #f) (define *fixnum-type-used?* #f) (define *fixnum-type-use-count* #f) (define #f) (define *flonum-type-used?* #f) (define *flonum-type-use-count* #f) (define #f) (define *rectangular-type-used?* #f) (define *rectangular-type-use-count* #f) (define #f) (define *input-port-type-used?* #f) (define *input-port-type-use-count* #f) (define #f) (define *output-port-type-used?* #f) (define *output-port-type-use-count* #f) (define #f) (define *eof-object-type-used?* #f) (define *eof-object-type-use-count* #f) (define #f) (define *pointer-type-used?* #f) (define *pointer-type-use-count* #f) (define *internal-symbol-types* #f) (define *external-symbol-types* #f) (define *primitive-procedure-types* #f) (define *native-procedure-types* #f) (define *foreign-procedure-types* #f) (define *continuation-types* #f) (define *string-types* #f) (define #f) (define *structure-types* #f) (define *headed-vector-types* #f) (define *nonheaded-vector-types* #f) (define #f) (define *displaced-vector-types* #f) (define (initialize-types!) (set! *ui* 11) (set! *native-procedure-types* '())) (define (create-internal-symbol-type name) (when *types-frozen?* (fuck-up)) (let* ((u (make-internal-symbol-type name *ui* 0 (unspecified) 0))) (set! *ui* (+ *ui* 1)) (set! *internal-symbol-types* (cons u *internal-symbol-types*)) u)) (define ( v) ;; conventions: V (when *types-frozen?* (fuck-up)) (or (find-if (internal-symbol-type-named? v) *internal-symbol-types*) (create-internal-symbol-type v))) (define (create-external-symbol-type displaced-string-type) (when *types-frozen?* (fuck-up)) (let* ((u (make-external-symbol-type displaced-string-type (unspecified) *ui* 0 (unspecified) 0))) (set-external-symbol-type-link! u u) (set! *ui* (+ *ui* 1)) (set! *external-symbol-types* (cons u *external-symbol-types*)) (set-string-type-external-symbol-type! displaced-string-type u) u)) (define ( u) (when *types-frozen?* (fuck-up)) (or (string-type-external-symbol-type u) (create-external-symbol-type u))) (define (create-primitive-procedure-type name arguments) (when *types-frozen?* (fuck-up)) (let* ((u (make-primitive-procedure-type name arguments *ui* 0 (unspecified) 0))) (set! *ui* (+ *ui* 1)) (set! *primitive-procedure-types* (cons u *primitive-procedure-types*)) u)) (define ( v vs) ;; conventions: V (when *types-frozen?* (fuck-up)) (or (find-if (lambda (u) (and ((primitive-procedure-type-named? v) u) (equal? (primitive-procedure-type-arguments u) vs))) *primitive-procedure-types*) (create-primitive-procedure-type v vs))) (define (create-native-procedure-type e) (when *types-frozen?* (fuck-up)) (unless (eq? e (narrow-prototype e)) (fuck-up)) (let* ((u (make-native-procedure-type '() e *ui* 0 (unspecified) 0))) (set-native-procedure-type-atomic?! u #t) (set-native-procedure-type-fictitious?! u #t) (set! *ui* (+ *ui* 1)) (set! *native-procedure-types* (cons u *native-procedure-types*)) u)) (define ( e) (when *types-frozen?* (fuck-up)) (let ((e (narrow-prototype e))) (or (find-if (lambda (u) (eq? e (narrow-prototype u))) *native-procedure-types*) (create-native-procedure-type e)))) (define (create-foreign-procedure-type name parameters result include) (when *types-frozen?* (fuck-up)) (let* ((u (make-foreign-procedure-type name parameters result include *ui* 0 (unspecified) 0))) (set! *ui* (+ *ui* 1)) (set! *foreign-procedure-types* (cons u *foreign-procedure-types*)) u)) (define ( v fs f v0) ;; conventions: V V0 (when *types-frozen?* (fuck-up)) (or (find-if (lambda (u) (string=? (foreign-procedure-type-name u) v)) *foreign-procedure-types*) (create-foreign-procedure-type v fs f v0))) (define (create-continuation-type allocating-expression) (when *types-frozen?* (fuck-up)) (let* ((u (make-continuation-type allocating-expression *ui* 0 (unspecified) (unspecified) 0))) (set-continuation-type-fictitious?! u #t) (set! *ui* (+ *ui* 1)) (set! *continuation-types* (cons u *continuation-types*)) (when allocating-expression (set-expression-continuation-type! allocating-expression u)) u)) (define ( x) ;; This and CREATE-ANONYMOUS-TYPE-SET are the only type and type-set creators ;; that can be called when types are frozen. (or (expression-continuation-type x) (create-continuation-type x))) (define (create-string-type allocating-expression) (when *types-frozen?* (fuck-up)) (let* ((u (make-string-type '() (unspecified) *ui* 0 (unspecified) #f 0))) (set-string-type-link! u u) (set! *ui* (+ *ui* 1)) (set! *string-types* (cons u *string-types*)) (when allocating-expression (set-expression-string-type! allocating-expression u)) u)) (define ( x) (when *types-frozen?* (fuck-up)) (let ((u (or (if x (if *index-allocated-string-types-by-expression?* (expression-string-type x) (and (not (null? *string-types*)) (first *string-types*))) ) (create-string-type x)))) (unless (memq x (string-type-allocating-expressions u)) (set-string-type-allocating-expressions! u (cons x (string-type-allocating-expressions u)))) u)) (define (create-structure-type name j allocating-expression) ;; conventions: J (when *types-frozen?* (fuck-up)) (let* ((u (make-structure-type name (unspecified) '() (unspecified) *ui* 0 (unspecified) (map-n (lambda (i) #f) j) 0))) (set-structure-type-immediate?! u *immediate-structures?*) (set-structure-type-atomic?! u #t) (set-structure-type-slots! u (map-n (lambda (i) (create-type-set u)) j)) (set-structure-type-link! u u) (set! *ui* (+ *ui* 1)) (set! *structure-types* (cons u *structure-types*)) (set-expression-structure-types! allocating-expression (cons u (expression-structure-types allocating-expression))) u)) (define ( v j uss x) ;; conventions: V J (when *types-frozen?* (fuck-up)) (let ((u (or (find-if (lambda (u) (and ((structure-type-named? v) u) (or (not (if (eq? (expression-kind x) 'pair-constant) *index-constant-structure-types-by-slot-types?* *index-allocated-structure-types-by-slot-types?*)) (every (lambda (us w) (every (lambda (u) (member? u w)) us)) uss (structure-type-slots u))))) (if (if (eq? (expression-kind x) 'pair-constant) *index-constant-structure-types-by-expression?* *index-allocated-structure-types-by-expression?*) (expression-structure-types x) *structure-types*)) (create-structure-type v j x)))) (unless (memq x (structure-type-allocating-expressions u)) (set-structure-type-allocating-expressions! u (cons x (structure-type-allocating-expressions u)))) (for-each (lambda (us w) (for-each (lambda (u) (assert-member! u w)) us)) uss (structure-type-slots u)) u)) (define ( us1 us2 x) ( 'pair 2 (list us1 us2) x)) (define ( uss us x) (cond ((null? uss) (fuck-up)) ((null? (rest uss)) ( (first uss) us x)) (else ( (first uss) (list ( (rest uss) us x)) x)))) (define (create-headed-vector-type allocating-expression) (when *types-frozen?* (fuck-up)) (let* ((u (make-headed-vector-type (unspecified) '() (unspecified) *ui* 0 (unspecified) #f 0))) (set-headed-vector-type-atomic?! u #t) (set-headed-vector-type-element! u (create-type-set u)) (set-headed-vector-type-link! u u) (set! *ui* (+ *ui* 1)) (set! *headed-vector-types* (cons u *headed-vector-types*)) (set-expression-headed-vector-types! allocating-expression (cons u (expression-headed-vector-types allocating-expression))) u)) (define ( us x) (when *types-frozen?* (fuck-up)) (let ((u (or (find-if (lambda (u) (or (not (if (eq? (expression-kind x) 'vector-constant) *index-constant-headed-vector-types-by-element-type?* *index-allocated-headed-vector-types-by-element-type?*)) (every (lambda (u1) (member? u1 (headed-vector-type-element u))) us))) (if (if (eq? (expression-kind x) 'vector-constant) *index-constant-headed-vector-types-by-expression?* *index-allocated-headed-vector-types-by-expression?*) (expression-headed-vector-types x) *headed-vector-types*)) (create-headed-vector-type x)))) (unless (memq x (headed-vector-type-allocating-expressions u)) (set-headed-vector-type-allocating-expressions! u (cons x (headed-vector-type-allocating-expressions u)))) (for-each (lambda (u1) (assert-member! u1 (headed-vector-type-element u))) us) u)) (define (create-nonheaded-vector-type allocating-expression) (when *types-frozen?* (fuck-up)) (let* ((u (make-nonheaded-vector-type (unspecified) '() (unspecified) *ui* 0 (unspecified) #f 0))) (set-nonheaded-vector-type-atomic?! u #t) (set-nonheaded-vector-type-element! u (create-type-set u)) (set-nonheaded-vector-type-link! u u) (set! *ui* (+ *ui* 1)) (set! *nonheaded-vector-types* (cons u *nonheaded-vector-types*)) (when allocating-expression (set-expression-nonheaded-vector-types! allocating-expression (cons u (expression-nonheaded-vector-types allocating-expression)))) u)) (define ( us x) (when *types-frozen?* (fuck-up)) (let ((u (or (if x (find-if (lambda (u) (or (not (if (eq? (expression-kind x) 'vector-constant) *index-constant-nonheaded-vector-types-by-element-type?* *index-allocated-nonheaded-vector-types-by-element-type?*)) (every (lambda (u1) (member? u1 (nonheaded-vector-type-element u))) us))) (if (if (eq? (expression-kind x) 'vector-constant) *index-constant-nonheaded-vector-types-by-expression?* *index-allocated-nonheaded-vector-types-by-expression?*) (expression-nonheaded-vector-types x) *nonheaded-vector-types*)) ) (create-nonheaded-vector-type x)))) (unless (memq x (nonheaded-vector-type-allocating-expressions u)) (set-nonheaded-vector-type-allocating-expressions! u (cons x (nonheaded-vector-type-allocating-expressions u)))) (for-each (lambda (u1) (assert-member! u1 (nonheaded-vector-type-element u))) us) u)) (define (create-displaced-vector-type displaced-vector-type) (when *types-frozen?* (fuck-up)) (let* ((u (make-displaced-vector-type displaced-vector-type (unspecified) *ui* 0 (unspecified) 0))) (set-displaced-vector-type-link! u u) (set! *ui* (+ *ui* 1)) (set! *displaced-vector-types* (cons u *displaced-vector-types*)) (cond ((headed-vector-type? displaced-vector-type) (set-headed-vector-type-displaced-vector-type! displaced-vector-type u)) ((nonheaded-vector-type? displaced-vector-type) (set-nonheaded-vector-type-displaced-vector-type! displaced-vector-type u)) (else (fuck-up))) u)) (define ( u) (when *types-frozen?* (fuck-up)) (if (displaced-vector-type? u) ( (displaced-vector-type-displaced-vector-type u)) (or (cond ((headed-vector-type? u) (headed-vector-type-displaced-vector-type u)) ((nonheaded-vector-type? u) (nonheaded-vector-type-displaced-vector-type u)) (else (fuck-up))) (create-displaced-vector-type u)))) ;;; Type properties (define (internal-symbol-type-type-tag-accessed? u) (not (zero? (bit-and (internal-symbol-type-booleans u) 16)))) (define (set-internal-symbol-type-type-tag-accessed?! u p?) (unless (boolean? p?) (fuck-up)) (set-internal-symbol-type-booleans! u (if p? (bit-or (internal-symbol-type-booleans u) 16) (bit-and (internal-symbol-type-booleans u) (bit-not 16))))) (define (internal-symbol-type-eq?-accessed? u) (not (zero? (bit-and (internal-symbol-type-booleans u) 8)))) (define (set-internal-symbol-type-eq?-accessed?! u p?) (unless (boolean? p?) (fuck-up)) (set-internal-symbol-type-booleans! u (if p? (bit-or (internal-symbol-type-booleans u) 8) (bit-and (internal-symbol-type-booleans u) (bit-not 8))))) (define (internal-symbol-type-symbol->string-accessed? u) (not (zero? (bit-and (internal-symbol-type-booleans u) 4)))) (define (set-internal-symbol-type-symbol->string-accessed?! u p?) (unless (boolean? p?) (fuck-up)) (set-internal-symbol-type-booleans! u (if p? (bit-or (internal-symbol-type-booleans u) 4) (bit-and (internal-symbol-type-booleans u) (bit-not 4))))) (define (internal-symbol-type-marked? u) (not (zero? (bit-and (internal-symbol-type-booleans u) 2)))) (define (set-internal-symbol-type-marked?! u p?) (unless (boolean? p?) (fuck-up)) (set-internal-symbol-type-booleans! u (if p? (bit-or (internal-symbol-type-booleans u) 2) (bit-and (internal-symbol-type-booleans u) (bit-not 2))))) (define (internal-symbol-type-used? u) (not (zero? (bit-and (internal-symbol-type-booleans u) 1)))) (define (set-internal-symbol-type-used?! u p?) (unless (boolean? p?) (fuck-up)) (set-internal-symbol-type-booleans! u (if p? (bit-or (internal-symbol-type-booleans u) 1) (bit-and (internal-symbol-type-booleans u) (bit-not 1))))) (define (external-symbol-type-type-tag-accessed? u) (not (zero? (bit-and (external-symbol-type-booleans u) 16)))) (define (set-external-symbol-type-type-tag-accessed?! u p?) (unless (boolean? p?) (fuck-up)) (set-external-symbol-type-booleans! u (if p? (bit-or (external-symbol-type-booleans u) 16) (bit-and (external-symbol-type-booleans u) (bit-not 16))))) (define (external-symbol-type-eq?-accessed? u) (not (zero? (bit-and (external-symbol-type-booleans u) 8)))) (define (set-external-symbol-type-eq?-accessed?! u p?) (unless (boolean? p?) (fuck-up)) (set-external-symbol-type-booleans! u (if p? (bit-or (external-symbol-type-booleans u) 8) (bit-and (external-symbol-type-booleans u) (bit-not 8))))) (define (external-symbol-type-symbol->string-accessed? u) (not (zero? (bit-and (external-symbol-type-booleans u) 4)))) (define (set-external-symbol-type-symbol->string-accessed?! u p?) (unless (boolean? p?) (fuck-up)) (set-external-symbol-type-booleans! u (if p? (bit-or (external-symbol-type-booleans u) 4) (bit-and (external-symbol-type-booleans u) (bit-not 4))))) (define (external-symbol-type-marked? u) (not (zero? (bit-and (external-symbol-type-booleans u) 2)))) (define (set-external-symbol-type-marked?! u p?) (unless (boolean? p?) (fuck-up)) (set-external-symbol-type-booleans! u (if p? (bit-or (external-symbol-type-booleans u) 2) (bit-and (external-symbol-type-booleans u) (bit-not 2))))) (define (external-symbol-type-used? u) (not (zero? (bit-and (external-symbol-type-booleans u) 1)))) (define (set-external-symbol-type-used?! u p?) (unless (boolean? p?) (fuck-up)) (set-external-symbol-type-booleans! u (if p? (bit-or (external-symbol-type-booleans u) 1) (bit-and (external-symbol-type-booleans u) (bit-not 1))))) (define (primitive-procedure-type-type-tag-accessed? u) (not (zero? (bit-and (primitive-procedure-type-booleans u) 8)))) (define (set-primitive-procedure-type-type-tag-accessed?! u p?) (unless (boolean? p?) (fuck-up)) (set-primitive-procedure-type-booleans! u (if p? (bit-or (primitive-procedure-type-booleans u) 8) (bit-and (primitive-procedure-type-booleans u) (bit-not 8))))) (define (primitive-procedure-type-eq?-accessed? u) (not (zero? (bit-and (primitive-procedure-type-booleans u) 4)))) (define (set-primitive-procedure-type-eq?-accessed?! u p?) (unless (boolean? p?) (fuck-up)) (set-primitive-procedure-type-booleans! u (if p? (bit-or (primitive-procedure-type-booleans u) 4) (bit-and (primitive-procedure-type-booleans u) (bit-not 4))))) (define (primitive-procedure-type-marked? u) (not (zero? (bit-and (primitive-procedure-type-booleans u) 2)))) (define (set-primitive-procedure-type-marked?! u p?) (unless (boolean? p?) (fuck-up)) (set-primitive-procedure-type-booleans! u (if p? (bit-or (primitive-procedure-type-booleans u) 2) (bit-and (primitive-procedure-type-booleans u) (bit-not 2))))) (define (primitive-procedure-type-used? u) (not (zero? (bit-and (primitive-procedure-type-booleans u) 1)))) (define (set-primitive-procedure-type-used?! u p?) (unless (boolean? p?) (fuck-up)) (set-primitive-procedure-type-booleans! u (if p? (bit-or (primitive-procedure-type-booleans u) 1) (bit-and (primitive-procedure-type-booleans u) (bit-not 1))))) (define (native-procedure-type-alignment? u) (not (zero? (bit-and (native-procedure-type-booleans u) 512)))) (define (set-native-procedure-type-alignment?! u p?) (unless (boolean? p?) (fuck-up)) (set-native-procedure-type-booleans! u (if p? (bit-or (native-procedure-type-booleans u) 512) (bit-and (native-procedure-type-booleans u) (bit-not 512))))) (define (native-procedure-type-alignment&? u) (not (zero? (bit-and (native-procedure-type-booleans u) 256)))) (define (set-native-procedure-type-alignment&?! u p?) (unless (boolean? p?) (fuck-up)) (set-native-procedure-type-booleans! u (if p? (bit-or (native-procedure-type-booleans u) 256) (bit-and (native-procedure-type-booleans u) (bit-not 256))))) (define (native-procedure-type-size? u) (not (zero? (bit-and (native-procedure-type-booleans u) 128)))) (define (set-native-procedure-type-size?! u p?) (unless (boolean? p?) (fuck-up)) (set-native-procedure-type-booleans! u (if p? (bit-or (native-procedure-type-booleans u) 128) (bit-and (native-procedure-type-booleans u) (bit-not 128))))) (define (native-procedure-type-type-tag-accessed? u) (not (zero? (bit-and (native-procedure-type-booleans u) 64)))) (define (set-native-procedure-type-type-tag-accessed?! u p?) (unless (boolean? p?) (fuck-up)) (set-native-procedure-type-booleans! u (if p? (bit-or (native-procedure-type-booleans u) 64) (bit-and (native-procedure-type-booleans u) (bit-not 64))))) (define (native-procedure-type-eq?-accessed? u) (not (zero? (bit-and (native-procedure-type-booleans u) 32)))) (define (set-native-procedure-type-eq?-accessed?! u p?) (unless (boolean? p?) (fuck-up)) (set-native-procedure-type-booleans! u (if p? (bit-or (native-procedure-type-booleans u) 32) (bit-and (native-procedure-type-booleans u) (bit-not 32))))) (define (native-procedure-type-marked? u) (not (zero? (bit-and (native-procedure-type-booleans u) 16)))) (define (set-native-procedure-type-marked?! u p?) (unless (boolean? p?) (fuck-up)) (set-native-procedure-type-booleans! u (if p? (bit-or (native-procedure-type-booleans u) 16) (bit-and (native-procedure-type-booleans u) (bit-not 16))))) (define (native-procedure-type-used? u) (not (zero? (bit-and (native-procedure-type-booleans u) 8)))) (define (set-native-procedure-type-used?! u p?) (unless (boolean? p?) (fuck-up)) (set-native-procedure-type-booleans! u (if p? (bit-or (native-procedure-type-booleans u) 8) (bit-and (native-procedure-type-booleans u) (bit-not 8))))) (define (native-procedure-type-necessarily-fictitious? u) (not (zero? (bit-and (native-procedure-type-booleans u) 4)))) (define (set-native-procedure-type-necessarily-fictitious?! u p?) (unless (boolean? p?) (fuck-up)) (set-native-procedure-type-booleans! u (if p? (bit-or (native-procedure-type-booleans u) 4) (bit-and (native-procedure-type-booleans u) (bit-not 4))))) (define (native-procedure-type-fictitious? u) (not (zero? (bit-and (native-procedure-type-booleans u) 2)))) (define (set-native-procedure-type-fictitious?! u p?) (unless (boolean? p?) (fuck-up)) (set-native-procedure-type-booleans! u (if p? (bit-or (native-procedure-type-booleans u) 2) (bit-and (native-procedure-type-booleans u) (bit-not 2))))) (define (native-procedure-type-atomic? u) (not (zero? (bit-and (native-procedure-type-booleans u) 1)))) (define (set-native-procedure-type-atomic?! u p?) (unless (boolean? p?) (fuck-up)) (set-native-procedure-type-booleans! u (if p? (bit-or (native-procedure-type-booleans u) 1) (bit-and (native-procedure-type-booleans u) (bit-not 1))))) (define (foreign-procedure-type-called? u) (not (zero? (bit-and (foreign-procedure-type-booleans u) 16)))) (define (set-foreign-procedure-type-called?! u p?) (unless (boolean? p?) (fuck-up)) (set-foreign-procedure-type-booleans! u (if p? (bit-or (foreign-procedure-type-booleans u) 16) (bit-and (foreign-procedure-type-booleans u) (bit-not 16))))) (define (foreign-procedure-type-type-tag-accessed? u) (not (zero? (bit-and (foreign-procedure-type-booleans u) 8)))) (define (set-foreign-procedure-type-type-tag-accessed?! u p?) (unless (boolean? p?) (fuck-up)) (set-foreign-procedure-type-booleans! u (if p? (bit-or (foreign-procedure-type-booleans u) 8) (bit-and (foreign-procedure-type-booleans u) (bit-not 8))))) (define (foreign-procedure-type-eq?-accessed? u) (not (zero? (bit-and (foreign-procedure-type-booleans u) 4)))) (define (set-foreign-procedure-type-eq?-accessed?! u p?) (unless (boolean? p?) (fuck-up)) (set-foreign-procedure-type-booleans! u (if p? (bit-or (foreign-procedure-type-booleans u) 4) (bit-and (foreign-procedure-type-booleans u) (bit-not 4))))) (define (foreign-procedure-type-marked? u) (not (zero? (bit-and (foreign-procedure-type-booleans u) 2)))) (define (set-foreign-procedure-type-marked?! u p?) (unless (boolean? p?) (fuck-up)) (set-foreign-procedure-type-booleans! u (if p? (bit-or (foreign-procedure-type-booleans u) 2) (bit-and (foreign-procedure-type-booleans u) (bit-not 2))))) (define (foreign-procedure-type-used? u) (not (zero? (bit-and (foreign-procedure-type-booleans u) 1)))) (define (set-foreign-procedure-type-used?! u p?) (unless (boolean? p?) (fuck-up)) (set-foreign-procedure-type-booleans! u (if p? (bit-or (foreign-procedure-type-booleans u) 1) (bit-and (foreign-procedure-type-booleans u) (bit-not 1))))) (define (continuation-type-type-tag-accessed? u) (not (zero? (bit-and (continuation-type-booleans u) 32)))) (define (set-continuation-type-type-tag-accessed?! u p?) (unless (boolean? p?) (fuck-up)) (set-continuation-type-booleans! u (if p? (bit-or (continuation-type-booleans u) 32) (bit-and (continuation-type-booleans u) (bit-not 32))))) (define (continuation-type-eq?-accessed? u) (not (zero? (bit-and (continuation-type-booleans u) 16)))) (define (set-continuation-type-eq?-accessed?! u p?) (unless (boolean? p?) (fuck-up)) (set-continuation-type-booleans! u (if p? (bit-or (continuation-type-booleans u) 16) (bit-and (continuation-type-booleans u) (bit-not 16))))) (define (continuation-type-continuation-accessed? u) (not (zero? (bit-and (continuation-type-booleans u) 8)))) (define (set-continuation-type-continuation-accessed?! u p?) (unless (boolean? p?) (fuck-up)) (set-continuation-type-booleans! u (if p? (bit-or (continuation-type-booleans u) 8) (bit-and (continuation-type-booleans u) (bit-not 8))))) (define (continuation-type-marked? u) (not (zero? (bit-and (continuation-type-booleans u) 4)))) (define (set-continuation-type-marked?! u p?) (unless (boolean? p?) (fuck-up)) (set-continuation-type-booleans! u (if p? (bit-or (continuation-type-booleans u) 4) (bit-and (continuation-type-booleans u) (bit-not 4))))) (define (continuation-type-used? u) (not (zero? (bit-and (continuation-type-booleans u) 2)))) (define (set-continuation-type-used?! u p?) (unless (boolean? p?) (fuck-up)) (set-continuation-type-booleans! u (if p? (bit-or (continuation-type-booleans u) 2) (bit-and (continuation-type-booleans u) (bit-not 2))))) (define (continuation-type-fictitious? u) (not (zero? (bit-and (continuation-type-booleans u) 1)))) (define (set-continuation-type-fictitious?! u p?) (unless (boolean? p?) (fuck-up)) (set-continuation-type-booleans! u (if p? (bit-or (continuation-type-booleans u) 1) (bit-and (continuation-type-booleans u) (bit-not 1))))) (define (string-type-never-allocated-on-the-heap? u) (not (zero? (bit-and (string-type-booleans u) 64)))) (define (set-string-type-never-allocated-on-the-heap?! u p?) (unless (boolean? p?) (fuck-up)) (set-string-type-booleans! u (if p? (bit-or (string-type-booleans u) 64) (bit-and (string-type-booleans u) (bit-not 64))))) (define (string-type-type-tag-accessed? u) (not (zero? (bit-and (string-type-booleans u) 32)))) (define (set-string-type-type-tag-accessed?! u p?) (unless (boolean? p?) (fuck-up)) (set-string-type-booleans! u (if p? (bit-or (string-type-booleans u) 32) (bit-and (string-type-booleans u) (bit-not 32))))) (define (string-type-eq?-accessed? u) (not (zero? (bit-and (string-type-booleans u) 16)))) (define (set-string-type-eq?-accessed?! u p?) (unless (boolean? p?) (fuck-up)) (set-string-type-booleans! u (if p? (bit-or (string-type-booleans u) 16) (bit-and (string-type-booleans u) (bit-not 16))))) (define (string-type-string-length-accessed? u) (not (zero? (bit-and (string-type-booleans u) 8)))) (define (set-string-type-string-length-accessed?! u p?) (unless (boolean? p?) (fuck-up)) (set-string-type-booleans! u (if p? (bit-or (string-type-booleans u) 8) (bit-and (string-type-booleans u) (bit-not 8))))) (define (string-type-string-ref-accessed? u) (not (zero? (bit-and (string-type-booleans u) 4)))) (define (set-string-type-string-ref-accessed?! u p?) (unless (boolean? p?) (fuck-up)) (set-string-type-booleans! u (if p? (bit-or (string-type-booleans u) 4) (bit-and (string-type-booleans u) (bit-not 4))))) (define (string-type-marked? u) (not (zero? (bit-and (string-type-booleans u) 2)))) (define (set-string-type-marked?! u p?) (unless (boolean? p?) (fuck-up)) (set-string-type-booleans! u (if p? (bit-or (string-type-booleans u) 2) (bit-and (string-type-booleans u) (bit-not 2))))) (define (string-type-used? u) (not (zero? (bit-and (string-type-booleans u) 1)))) (define (set-string-type-used?! u p?) (unless (boolean? p?) (fuck-up)) (set-string-type-booleans! u (if p? (bit-or (string-type-booleans u) 1) (bit-and (string-type-booleans u) (bit-not 1))))) (define (structure-type-immediate? u) (not (zero? (bit-and (structure-type-booleans u) 1024)))) (define (set-structure-type-immediate?! u p?) (unless (boolean? p?) (fuck-up)) (set-structure-type-booleans! u (if p? (bit-or (structure-type-booleans u) 1024) (bit-and (structure-type-booleans u) (bit-not 1024))))) (define (structure-type-alignment? u) (not (zero? (bit-and (structure-type-booleans u) 512)))) (define (set-structure-type-alignment?! u p?) (unless (boolean? p?) (fuck-up)) (set-structure-type-booleans! u (if p? (bit-or (structure-type-booleans u) 512) (bit-and (structure-type-booleans u) (bit-not 512))))) (define (structure-type-alignment&? u) (not (zero? (bit-and (structure-type-booleans u) 256)))) (define (set-structure-type-alignment&?! u p?) (unless (boolean? p?) (fuck-up)) (set-structure-type-booleans! u (if p? (bit-or (structure-type-booleans u) 256) (bit-and (structure-type-booleans u) (bit-not 256))))) (define (structure-type-size? u) (not (zero? (bit-and (structure-type-booleans u) 128)))) (define (set-structure-type-size?! u p?) (unless (boolean? p?) (fuck-up)) (set-structure-type-booleans! u (if p? (bit-or (structure-type-booleans u) 128) (bit-and (structure-type-booleans u) (bit-not 128))))) (define (structure-type-never-allocated-on-the-heap? u) (not (zero? (bit-and (structure-type-booleans u) 64)))) (define (set-structure-type-never-allocated-on-the-heap?! u p?) (unless (boolean? p?) (fuck-up)) (set-structure-type-booleans! u (if p? (bit-or (structure-type-booleans u) 64) (bit-and (structure-type-booleans u) (bit-not 64))))) (define (structure-type-type-tag-accessed? u) (not (zero? (bit-and (structure-type-booleans u) 32)))) (define (set-structure-type-type-tag-accessed?! u p?) (unless (boolean? p?) (fuck-up)) (set-structure-type-booleans! u (if p? (bit-or (structure-type-booleans u) 32) (bit-and (structure-type-booleans u) (bit-not 32))))) (define (structure-type-eq?-accessed? u) (not (zero? (bit-and (structure-type-booleans u) 16)))) (define (set-structure-type-eq?-accessed?! u p?) (unless (boolean? p?) (fuck-up)) (set-structure-type-booleans! u (if p? (bit-or (structure-type-booleans u) 16) (bit-and (structure-type-booleans u) (bit-not 16))))) (define (structure-type-marked? u) (not (zero? (bit-and (structure-type-booleans u) 8)))) (define (set-structure-type-marked?! u p?) (unless (boolean? p?) (fuck-up)) (set-structure-type-booleans! u (if p? (bit-or (structure-type-booleans u) 8) (bit-and (structure-type-booleans u) (bit-not 8))))) (define (structure-type-used? u) (not (zero? (bit-and (structure-type-booleans u) 4)))) (define (set-structure-type-used?! u p?) (unless (boolean? p?) (fuck-up)) (set-structure-type-booleans! u (if p? (bit-or (structure-type-booleans u) 4) (bit-and (structure-type-booleans u) (bit-not 4))))) (define (structure-type-fictitious? u) (not (zero? (bit-and (structure-type-booleans u) 2)))) (define (set-structure-type-fictitious?! u p?) (unless (boolean? p?) (fuck-up)) (set-structure-type-booleans! u (if p? (bit-or (structure-type-booleans u) 2) (bit-and (structure-type-booleans u) (bit-not 2))))) (define (structure-type-atomic? u) (not (zero? (bit-and (structure-type-booleans u) 1)))) (define (set-structure-type-atomic?! u p?) (unless (boolean? p?) (fuck-up)) (set-structure-type-booleans! u (if p? (bit-or (structure-type-booleans u) 1) (bit-and (structure-type-booleans u) (bit-not 1))))) (define (headed-vector-type-alignment? u) (not (zero? (bit-and (headed-vector-type-booleans u) 1024)))) (define (set-headed-vector-type-alignment?! u p?) (unless (boolean? p?) (fuck-up)) (set-headed-vector-type-booleans! u (if p? (bit-or (headed-vector-type-booleans u) 1024) (bit-and (headed-vector-type-booleans u) (bit-not 1024))))) (define (headed-vector-type-alignment&? u) (not (zero? (bit-and (headed-vector-type-booleans u) 512)))) (define (set-headed-vector-type-alignment&?! u p?) (unless (boolean? p?) (fuck-up)) (set-headed-vector-type-booleans! u (if p? (bit-or (headed-vector-type-booleans u) 512) (bit-and (headed-vector-type-booleans u) (bit-not 512))))) (define (headed-vector-type-size? u) (not (zero? (bit-and (headed-vector-type-booleans u) 256)))) (define (set-headed-vector-type-size?! u p?) (unless (boolean? p?) (fuck-up)) (set-headed-vector-type-booleans! u (if p? (bit-or (headed-vector-type-booleans u) 256) (bit-and (headed-vector-type-booleans u) (bit-not 256))))) (define (headed-vector-type-never-allocated-on-the-heap? u) (not (zero? (bit-and (headed-vector-type-booleans u) 128)))) (define (set-headed-vector-type-never-allocated-on-the-heap?! u p?) (unless (boolean? p?) (fuck-up)) (set-headed-vector-type-booleans! u (if p? (bit-or (headed-vector-type-booleans u) 128) (bit-and (headed-vector-type-booleans u) (bit-not 128))))) (define (headed-vector-type-type-tag-accessed? u) (not (zero? (bit-and (headed-vector-type-booleans u) 64)))) (define (set-headed-vector-type-type-tag-accessed?! u p?) (unless (boolean? p?) (fuck-up)) (set-headed-vector-type-booleans! u (if p? (bit-or (headed-vector-type-booleans u) 64) (bit-and (headed-vector-type-booleans u) (bit-not 64))))) (define (headed-vector-type-eq?-accessed? u) (not (zero? (bit-and (headed-vector-type-booleans u) 32)))) (define (set-headed-vector-type-eq?-accessed?! u p?) (unless (boolean? p?) (fuck-up)) (set-headed-vector-type-booleans! u (if p? (bit-or (headed-vector-type-booleans u) 32) (bit-and (headed-vector-type-booleans u) (bit-not 32))))) (define (headed-vector-type-vector-length-accessed? u) (not (zero? (bit-and (headed-vector-type-booleans u) 16)))) (define (set-headed-vector-type-vector-length-accessed?! u p?) (unless (boolean? p?) (fuck-up)) (set-headed-vector-type-booleans! u (if p? (bit-or (headed-vector-type-booleans u) 16) (bit-and (headed-vector-type-booleans u) (bit-not 16))))) (define (headed-vector-type-vector-ref-accessed? u) (not (zero? (bit-and (headed-vector-type-booleans u) 8)))) (define (set-headed-vector-type-vector-ref-accessed?! u p?) (unless (boolean? p?) (fuck-up)) (set-headed-vector-type-booleans! u (if p? (bit-or (headed-vector-type-booleans u) 8) (bit-and (headed-vector-type-booleans u) (bit-not 8))))) (define (headed-vector-type-marked? u) (not (zero? (bit-and (headed-vector-type-booleans u) 4)))) (define (set-headed-vector-type-marked?! u p?) (unless (boolean? p?) (fuck-up)) (set-headed-vector-type-booleans! u (if p? (bit-or (headed-vector-type-booleans u) 4) (bit-and (headed-vector-type-booleans u) (bit-not 4))))) (define (headed-vector-type-used? u) (not (zero? (bit-and (headed-vector-type-booleans u) 2)))) (define (set-headed-vector-type-used?! u p?) (unless (boolean? p?) (fuck-up)) (set-headed-vector-type-booleans! u (if p? (bit-or (headed-vector-type-booleans u) 2) (bit-and (headed-vector-type-booleans u) (bit-not 2))))) (define (headed-vector-type-atomic? u) (not (zero? (bit-and (headed-vector-type-booleans u) 1)))) (define (set-headed-vector-type-atomic?! u p?) (unless (boolean? p?) (fuck-up)) (set-headed-vector-type-booleans! u (if p? (bit-or (headed-vector-type-booleans u) 1) (bit-and (headed-vector-type-booleans u) (bit-not 1))))) (define (nonheaded-vector-type-alignment? u) (not (zero? (bit-and (nonheaded-vector-type-booleans u) 512)))) (define (set-nonheaded-vector-type-alignment?! u p?) (unless (boolean? p?) (fuck-up)) (set-nonheaded-vector-type-booleans! u (if p? (bit-or (nonheaded-vector-type-booleans u) 512) (bit-and (nonheaded-vector-type-booleans u) (bit-not 512))))) (define (nonheaded-vector-type-size? u) (not (zero? (bit-and (nonheaded-vector-type-booleans u) 256)))) (define (set-nonheaded-vector-type-size?! u p?) (unless (boolean? p?) (fuck-up)) (set-nonheaded-vector-type-booleans! u (if p? (bit-or (nonheaded-vector-type-booleans u) 256) (bit-and (nonheaded-vector-type-booleans u) (bit-not 256))))) (define (nonheaded-vector-type-never-allocated-on-the-heap? u) (not (zero? (bit-and (nonheaded-vector-type-booleans u) 128)))) (define (set-nonheaded-vector-type-never-allocated-on-the-heap?! u p?) (unless (boolean? p?) (fuck-up)) (set-nonheaded-vector-type-booleans! u (if p? (bit-or (nonheaded-vector-type-booleans u) 128) (bit-and (nonheaded-vector-type-booleans u) (bit-not 128))))) (define (nonheaded-vector-type-type-tag-accessed? u) (not (zero? (bit-and (nonheaded-vector-type-booleans u) 64)))) (define (set-nonheaded-vector-type-type-tag-accessed?! u p?) (unless (boolean? p?) (fuck-up)) (set-nonheaded-vector-type-booleans! u (if p? (bit-or (nonheaded-vector-type-booleans u) 64) (bit-and (nonheaded-vector-type-booleans u) (bit-not 64))))) (define (nonheaded-vector-type-eq?-accessed? u) (not (zero? (bit-and (nonheaded-vector-type-booleans u) 32)))) (define (set-nonheaded-vector-type-eq?-accessed?! u p?) (unless (boolean? p?) (fuck-up)) (set-nonheaded-vector-type-booleans! u (if p? (bit-or (nonheaded-vector-type-booleans u) 32) (bit-and (nonheaded-vector-type-booleans u) (bit-not 32))))) (define (nonheaded-vector-type-vector-length-accessed? u) (not (zero? (bit-and (nonheaded-vector-type-booleans u) 16)))) (define (set-nonheaded-vector-type-vector-length-accessed?! u p?) (unless (boolean? p?) (fuck-up)) (set-nonheaded-vector-type-booleans! u (if p? (bit-or (nonheaded-vector-type-booleans u) 16) (bit-and (nonheaded-vector-type-booleans u) (bit-not 16))))) (define (nonheaded-vector-type-vector-ref-accessed? u) (not (zero? (bit-and (nonheaded-vector-type-booleans u) 8)))) (define (set-nonheaded-vector-type-vector-ref-accessed?! u p?) (unless (boolean? p?) (fuck-up)) (set-nonheaded-vector-type-booleans! u (if p? (bit-or (nonheaded-vector-type-booleans u) 8) (bit-and (nonheaded-vector-type-booleans u) (bit-not 8))))) (define (nonheaded-vector-type-marked? u) (not (zero? (bit-and (nonheaded-vector-type-booleans u) 4)))) (define (set-nonheaded-vector-type-marked?! u p?) (unless (boolean? p?) (fuck-up)) (set-nonheaded-vector-type-booleans! u (if p? (bit-or (nonheaded-vector-type-booleans u) 4) (bit-and (nonheaded-vector-type-booleans u) (bit-not 4))))) (define (nonheaded-vector-type-used? u) (not (zero? (bit-and (nonheaded-vector-type-booleans u) 2)))) (define (set-nonheaded-vector-type-used?! u p?) (unless (boolean? p?) (fuck-up)) (set-nonheaded-vector-type-booleans! u (if p? (bit-or (nonheaded-vector-type-booleans u) 2) (bit-and (nonheaded-vector-type-booleans u) (bit-not 2))))) (define (nonheaded-vector-type-atomic? u) (not (zero? (bit-and (nonheaded-vector-type-booleans u) 1)))) (define (set-nonheaded-vector-type-atomic?! u p?) (unless (boolean? p?) (fuck-up)) (set-nonheaded-vector-type-booleans! u (if p? (bit-or (nonheaded-vector-type-booleans u) 1) (bit-and (nonheaded-vector-type-booleans u) (bit-not 1))))) (define (displaced-vector-type-alignment? u) (not (zero? (bit-and (displaced-vector-type-booleans u) 128)))) (define (set-displaced-vector-type-alignment?! u p?) (unless (boolean? p?) (fuck-up)) (set-displaced-vector-type-booleans! u (if p? (bit-or (displaced-vector-type-booleans u) 128) (bit-and (displaced-vector-type-booleans u) (bit-not 128))))) (define (displaced-vector-type-size? u) (not (zero? (bit-and (displaced-vector-type-booleans u) 64)))) (define (set-displaced-vector-type-size?! u p?) (unless (boolean? p?) (fuck-up)) (set-displaced-vector-type-booleans! u (if p? (bit-or (displaced-vector-type-booleans u) 64) (bit-and (displaced-vector-type-booleans u) (bit-not 64))))) (define (displaced-vector-type-type-tag-accessed? u) (not (zero? (bit-and (displaced-vector-type-booleans u) 32)))) (define (set-displaced-vector-type-type-tag-accessed?! u p?) (unless (boolean? p?) (fuck-up)) (set-displaced-vector-type-booleans! u (if p? (bit-or (displaced-vector-type-booleans u) 32) (bit-and (displaced-vector-type-booleans u) (bit-not 32))))) (define (displaced-vector-type-eq?-accessed? u) (not (zero? (bit-and (displaced-vector-type-booleans u) 16)))) (define (set-displaced-vector-type-eq?-accessed?! u p?) (unless (boolean? p?) (fuck-up)) (set-displaced-vector-type-booleans! u (if p? (bit-or (displaced-vector-type-booleans u) 16) (bit-and (displaced-vector-type-booleans u) (bit-not 16))))) (define (displaced-vector-type-vector-length-accessed? u) (not (zero? (bit-and (displaced-vector-type-booleans u) 8)))) (define (set-displaced-vector-type-vector-length-accessed?! u p?) (unless (boolean? p?) (fuck-up)) (set-displaced-vector-type-booleans! u (if p? (bit-or (displaced-vector-type-booleans u) 8) (bit-and (displaced-vector-type-booleans u) (bit-not 8))))) (define (displaced-vector-type-vector-ref-accessed? u) (not (zero? (bit-and (displaced-vector-type-booleans u) 4)))) (define (set-displaced-vector-type-vector-ref-accessed?! u p?) (unless (boolean? p?) (fuck-up)) (set-displaced-vector-type-booleans! u (if p? (bit-or (displaced-vector-type-booleans u) 4) (bit-and (displaced-vector-type-booleans u) (bit-not 4))))) (define (displaced-vector-type-marked? u) (not (zero? (bit-and (displaced-vector-type-booleans u) 2)))) (define (set-displaced-vector-type-marked?! u p?) (unless (boolean? p?) (fuck-up)) (set-displaced-vector-type-booleans! u (if p? (bit-or (displaced-vector-type-booleans u) 2) (bit-and (displaced-vector-type-booleans u) (bit-not 2))))) (define (displaced-vector-type-used? u) (not (zero? (bit-and (displaced-vector-type-booleans u) 1)))) (define (set-displaced-vector-type-used?! u p?) (unless (boolean? p?) (fuck-up)) (set-displaced-vector-type-booleans! u (if p? (bit-or (displaced-vector-type-booleans u) 1) (bit-and (displaced-vector-type-booleans u) (bit-not 1))))) (define (set-type-type-tag-accessed?! u p?) (cond ((null-type? u) #f) ((true-type? u) #f) ((false-type? u) #f) ((char-type? u) #f) ((fixnum-type? u) #f) ((flonum-type? u) #f) ((rectangular-type? u) #f) ((input-port-type? u) #f) ((output-port-type? u) #f) ((eof-object-type? u) #f) ((pointer-type? u) #f) ((internal-symbol-type? u) (set-internal-symbol-type-type-tag-accessed?! u p?)) ((external-symbol-type? u) (set-external-symbol-type-type-tag-accessed?! u p?)) ((primitive-procedure-type? u) (set-primitive-procedure-type-type-tag-accessed?! u p?)) ((native-procedure-type? u) (set-native-procedure-type-type-tag-accessed?! u p?)) ((foreign-procedure-type? u) (set-foreign-procedure-type-type-tag-accessed?! u p?)) ((continuation-type? u) (set-continuation-type-type-tag-accessed?! u p?)) ((string-type? u) (set-string-type-type-tag-accessed?! u p?)) ((structure-type? u) (set-structure-type-type-tag-accessed?! u p?)) ((headed-vector-type? u) (set-headed-vector-type-type-tag-accessed?! u p?)) ((nonheaded-vector-type? u) (set-nonheaded-vector-type-type-tag-accessed?! u p?)) ((displaced-vector-type? u) (set-displaced-vector-type-type-tag-accessed?! u p?)) (else (fuck-up)))) (define (set-type-eq?-accessed?! u p?) (cond ((null-type? u) #f) ((true-type? u) #f) ((false-type? u) #f) ((char-type? u) #f) ((fixnum-type? u) #f) ((flonum-type? u) #f) ((rectangular-type? u) #f) ((input-port-type? u) #f) ((output-port-type? u) #f) ((eof-object-type? u) #f) ((pointer-type? u) #f) ((internal-symbol-type? u) (set-internal-symbol-type-eq?-accessed?! u p?)) ((external-symbol-type? u) (set-external-symbol-type-eq?-accessed?! u p?)) ((primitive-procedure-type? u) (set-primitive-procedure-type-eq?-accessed?! u p?)) ((native-procedure-type? u) (set-native-procedure-type-eq?-accessed?! u p?)) ((foreign-procedure-type? u) (set-foreign-procedure-type-eq?-accessed?! u p?)) ((continuation-type? u) (set-continuation-type-eq?-accessed?! u p?)) ((string-type? u) (set-string-type-eq?-accessed?! u p?)) ((structure-type? u) (set-structure-type-eq?-accessed?! u p?)) ((headed-vector-type? u) (set-headed-vector-type-eq?-accessed?! u p?)) ((nonheaded-vector-type? u) (set-nonheaded-vector-type-eq?-accessed?! u p?)) ((displaced-vector-type? u) (set-displaced-vector-type-eq?-accessed?! u p?)) (else (fuck-up)))) (define (null-type? u) (eq? u 'null)) (define (true-type? u) (eq? u 'true)) (define (false-type? u) (eq? u 'false)) (define (boolean-type? u) (or (true-type? u) (false-type? u))) (define (char-type? u) (eq? u 'char)) (define (fixnum-type? u) (eq? u 'fixnum)) (define (flonum-type? u) (eq? u 'flonum)) (define (nonrectangular-number-type? u) (or (fixnum-type? u) (flonum-type? u))) (define (rectangular-type? u) (eq? u 'rectangular)) (define (number-type? u) (or (fixnum-type? u) (flonum-type? u) (rectangular-type? u))) (define (exact-type? u) (unless (number-type? u) (fuck-up)) (fixnum-type? u)) (define (inexact-type? u) (unless (number-type? u) (fuck-up)) (or (flonum-type? u) (rectangular-type? u))) (define (input-port-type? u) (eq? u 'input-port)) (define (output-port-type? u) (eq? u 'output-port)) (define (eof-object-type? u) (eq? u 'eof-object)) (define (pointer-type? u) (eq? u 'pointer)) (define (internal-symbol-type-named? name) ;; conventions: NAME (lambda (u) (and (internal-symbol-type? u) (eq? (internal-symbol-type-name u) name)))) (define (symbol-type? u) (or (internal-symbol-type? u) (external-symbol-type? u))) (define (primitive-procedure-type-named? name) ;; conventions: NAME (lambda (u) (and (primitive-procedure-type? u) (eq? (primitive-procedure-type-name u) name)))) (define (continuation-type-to? x) (lambda (u) (and (continuation-type? u) (eq? (continuation-type-allocating-expression u) x)))) (define (procedure-type? u) (or (primitive-procedure-type? u) (native-procedure-type? u) (foreign-procedure-type? u) (continuation-type? u))) (define (nonreclaimable-string-type? u) (and (string-type? u) (memq #f (string-type-allocating-expressions u)))) (define (structure-type-named? name) ;; conventions: NAME (lambda (u) (and (structure-type? u) (eq? (structure-type-name u) name)))) (define (pair-type? u) ((structure-type-named? 'pair) u)) (define (pair+-type? uss us x) (lambda (u) (when (null? uss) (fuck-up)) (and (pair-type? u) (memq x (structure-type-allocating-expressions u)) (every (lambda (u1) (member? u1 (pair-type-car u))) (first uss)) (if (null? (rest uss)) (every (lambda (u1) (member? u1 (pair-type-cdr u))) us) (can-be? (pair+-type? (rest uss) us x) (pair-type-cdr u)))))) (define (list-type-of? m) (define (list-type-of? m us) (lambda (u) (or (memq u us) (null-type? u) (and (pair-type? u) (can-be? m (pair-type-car u)) (can-be? (list-type-of? m (cons u us)) (pair-type-cdr u)))))) (list-type-of? m '())) (define (list-type? u) ((list-type-of? type?) u)) (define (list-type-of-length? j) ;; conventions: J (lambda (u) (and (not (negative? j)) (if (zero? j) (null-type? u) (and (pair-type? u) (can-be? (list-type-of-length? (- j 1)) (pair-type-cdr u))))))) (define (list-type-of-length-at-least? j) ;; conventions: J (lambda (u) (if (positive? j) (and (pair-type? u) (can-be? (list-type-of-length-at-least? (- j 1)) (pair-type-cdr u))) (list-type? u)))) (define (top-level-nonheaded-vector-type? u) (and (nonheaded-vector-type? u) (memq #f (nonheaded-vector-type-allocating-expressions u)))) (define (vector-type? u) (or (headed-vector-type? u) (nonheaded-vector-type? u) (displaced-vector-type? u))) (define (vector-type-eq?-accessed? u) (cond ((headed-vector-type? u) (headed-vector-type-eq?-accessed? u)) ((nonheaded-vector-type? u) (nonheaded-vector-type-eq?-accessed? u)) ((displaced-vector-type? u) (displaced-vector-type-eq?-accessed? u)) (else (fuck-up)))) (define (vector-ref-accessed? u) (cond ((headed-vector-type? u) (headed-vector-type-vector-ref-accessed? u)) ((nonheaded-vector-type? u) (nonheaded-vector-type-vector-ref-accessed? u)) ((displaced-vector-type? u) (displaced-vector-type-vector-ref-accessed? u)) (else (fuck-up)))) (define (degenerate-vector-type? u) (and (vector-type? u) (fictitious? (vector-type-element u)))) (define (type? u) (or (null-type? u) (true-type? u) (false-type? u) (char-type? u) (fixnum-type? u) (flonum-type? u) (rectangular-type? u) (input-port-type? u) (output-port-type? u) (eof-object-type? u) (pointer-type? u) (internal-symbol-type? u) (external-symbol-type? u) (primitive-procedure-type? u) (native-procedure-type? u) (foreign-procedure-type? u) (continuation-type? u) (string-type? u) (structure-type? u) (headed-vector-type? u) (nonheaded-vector-type? u) (displaced-vector-type? u))) (define (never-allocated-on-the-heap? u) (cond ((null-type? u) #t) ((true-type? u) #t) ((false-type? u) #t) ((char-type? u) #t) ((fixnum-type? u) #t) ((flonum-type? u) #t) ((rectangular-type? u) #t) ((input-port-type? u) #t) ((output-port-type? u) #t) ((eof-object-type? u) #t) ((pointer-type? u) #t) ((internal-symbol-type? u) #t) ((external-symbol-type? u) #t) ((primitive-procedure-type? u) #t) ((native-procedure-type? u) #t) ((foreign-procedure-type? u) #t) ((continuation-type? u) #t) ((string-type? u) (string-type-never-allocated-on-the-heap? u)) ((structure-type? u) (structure-type-never-allocated-on-the-heap? u)) ((headed-vector-type? u) (headed-vector-type-never-allocated-on-the-heap? u)) ((nonheaded-vector-type? u) (nonheaded-vector-type-never-allocated-on-the-heap? u)) ((displaced-vector-type? u) #t) (else (fuck-up)))) (define (type-marked? u) (cond ((null-type? u) (fuck-up)) ((true-type? u) (fuck-up)) ((false-type? u) (fuck-up)) ((char-type? u) (fuck-up)) ((fixnum-type? u) (fuck-up)) ((flonum-type? u) (fuck-up)) ((rectangular-type? u) (fuck-up)) ((input-port-type? u) (fuck-up)) ((output-port-type? u) (fuck-up)) ((eof-object-type? u) (fuck-up)) ((pointer-type? u) (fuck-up)) ((internal-symbol-type? u) (internal-symbol-type-marked? u)) ((external-symbol-type? u) (external-symbol-type-marked? u)) ((primitive-procedure-type? u) (primitive-procedure-type-marked? u)) ((native-procedure-type? u) (native-procedure-type-marked? u)) ((foreign-procedure-type? u) (foreign-procedure-type-marked? u)) ((continuation-type? u) (continuation-type-marked? u)) ((string-type? u) (string-type-marked? u)) ((structure-type? u) (structure-type-marked? u)) ((headed-vector-type? u) (headed-vector-type-marked? u)) ((nonheaded-vector-type? u) (nonheaded-vector-type-marked? u)) ((displaced-vector-type? u) (displaced-vector-type-marked? u)) (else (fuck-up)))) (define (set-type-marked?! u p?) ;; needs work: This is not really a type property. (cond ((null-type? u) (fuck-up)) ((true-type? u) (fuck-up)) ((false-type? u) (fuck-up)) ((char-type? u) (fuck-up)) ((fixnum-type? u) (fuck-up)) ((flonum-type? u) (fuck-up)) ((rectangular-type? u) (fuck-up)) ((input-port-type? u) (fuck-up)) ((output-port-type? u) (fuck-up)) ((eof-object-type? u) (fuck-up)) ((pointer-type? u) (fuck-up)) ((internal-symbol-type? u) (set-internal-symbol-type-marked?! u p?)) ((external-symbol-type? u) (set-external-symbol-type-marked?! u p?)) ((primitive-procedure-type? u) (set-primitive-procedure-type-marked?! u p?)) ((native-procedure-type? u) (set-native-procedure-type-marked?! u p?)) ((foreign-procedure-type? u) (set-foreign-procedure-type-marked?! u p?)) ((continuation-type? u) (set-continuation-type-marked?! u p?)) ((string-type? u) (set-string-type-marked?! u p?)) ((structure-type? u) (set-structure-type-marked?! u p?)) ((headed-vector-type? u) (set-headed-vector-type-marked?! u p?)) ((nonheaded-vector-type? u) (set-nonheaded-vector-type-marked?! u p?)) ((displaced-vector-type? u) (set-displaced-vector-type-marked?! u p?)) (else (fuck-up)))) (define (type-used? u) (cond ((null-type? u) #t) ((true-type? u) #t) ((false-type? u) #t) ((char-type? u) #t) ((fixnum-type? u) #t) ((flonum-type? u) #t) ((rectangular-type? u) #t) ((input-port-type? u) #t) ((output-port-type? u) #t) ((eof-object-type? u) #t) ((pointer-type? u) #t) ((internal-symbol-type? u) (internal-symbol-type-used? u)) ((external-symbol-type? u) (external-symbol-type-used? u)) ((primitive-procedure-type? u) (primitive-procedure-type-used? u)) ((native-procedure-type? u) (native-procedure-type-used? u)) ((foreign-procedure-type? u) (foreign-procedure-type-used? u)) ((continuation-type? u) (continuation-type-used? u)) ((string-type? u) (string-type-used? u)) ((structure-type? u) (structure-type-used? u)) ((headed-vector-type? u) (headed-vector-type-used? u)) ((nonheaded-vector-type? u) (nonheaded-vector-type-used? u)) ((displaced-vector-type? u) (displaced-vector-type-used? u)) (else (fuck-up)))) (define (compatible-procedure? ws w y) (if (converted? y) (lambda (u) (or (and (primitive-procedure-type? u) ((primitive-procedure-compatible-procedure? (cdr (assq (primitive-procedure-type-name u) *primitive-procedure-handlers*))) u (rest ws) w)) (and (native-procedure-type? u) ;; What a kludge! (or (not *types-frozen?*) (callee-environment? u y)) (let ((e (callee-environment u y))) (if (rest? e) (if (converted? e) (can-be? (list-type-of-length-at-least? (- (- (length (variables e)) 1) (length ws))) w) (can-be? (list-type-of-length-at-least? (- (length (variables e)) (length ws))) w)) (if (converted? e) (can-be? (list-type-of-length? (- (length (variables e)) (length ws))) w) (can-be? (list-type-of-length? (- (+ (length (variables e)) 1) (length ws))) w))))) (and (foreign-procedure-type? u) (can-be? (list-type-of-length? (- (+ (length (foreign-procedure-type-parameters u)) 1) (length ws))) w)) (and (continuation-type? u) (can-be? (list-type-of-length? (- 2 (length ws))) w)))) (lambda (u) (or (and (primitive-procedure-type? u) ((primitive-procedure-compatible-procedure? (cdr (assq (primitive-procedure-type-name u) *primitive-procedure-handlers*))) u ws w)) (and (native-procedure-type? u) ;; What a kludge! (or (not *types-frozen?*) (callee-environment? u y)) (let ((e (callee-environment u y))) ;; note: I'm not sure that this is the right thing to do but ;; it is now needed for test21.sc since I changed MAP and ;; APPLY. (and (not (converted? e)) (if (rest? e) (can-be? (list-type-of-length-at-least? (- (- (length (variables e)) 1) (length ws))) w) (can-be? (list-type-of-length? (- (length (variables e)) (length ws))) w))))) (and (foreign-procedure-type? u) (can-be? (list-type-of-length? (- (length (foreign-procedure-type-parameters u)) (length ws))) w)) (and (continuation-type? u) (can-be? (list-type-of-length? (- 1 (length ws))) w)))))) (define (compatible-call? x) (compatible-procedure? (map expression-type-set (expression-arguments x)) *null* (create-call-site x))) (define (compatible-call-via-apply? x) (compatible-procedure? (map expression-type-set (if (converted? x) (cons (continuation-argument x) (but-last (rest (rest (expression-arguments x))))) (but-last (rest (expression-arguments x))))) (expression-type-set (last (expression-arguments x))) (recreate-call-site (create-call-site x) 'first-argument))) (define (compatible-call-via-call-with-current-continuation? x) (compatible-procedure? (if (converted? x) (list (expression-type-set (continuation-argument x)) (expression-type-set (continuation-argument x))) (list (create-anonymous-type-set ( x)))) *null* (recreate-call-site (create-call-site x) 'first-argument))) (define (compatible-call-via-fork1? x) (compatible-procedure? (if (converted? x) (list (expression-type-set (continuation-argument x))) '()) *null* (recreate-call-site (create-call-site x) 'first-argument))) (define (compatible-call-via-fork2? x) (compatible-procedure? (if (converted? x) (list (expression-type-set (continuation-argument x))) '()) *null* (recreate-call-site (create-call-site x) 'second-argument))) (define (compatible-call-via-mutex? x) (compatible-procedure? (if (converted? x) (list (expression-type-set (continuation-argument x))) '()) *null* (recreate-call-site (create-call-site x) 'first-argument))) (define (truly-compatible-procedure? ws w y) ;; note: The reason that we have both COMPATIBLE-PROCEDURE? and ;; TRULY-COMPATIBLE-PROCEDURE? is that if a call site to a primitive ;; procedure is not compatible we generate a call_error where as if it ;; is compatible but not truly compatible we actually call the ;; PRIMITIVE-PROCEDURE-COMPILE-CALL to generate the error. (if (converted? y) (lambda (u) (or (and (primitive-procedure-type? u) ((primitive-procedure-compatible-procedure? (cdr (assq (primitive-procedure-type-name u) *primitive-procedure-handlers*))) u (rest ws) w) (((primitive-procedure-truly-compatible-procedure? (cdr (assq (primitive-procedure-type-name u) *primitive-procedure-handlers*))) y u (first ws)) (rest ws) w)) (and (native-procedure-type? u) ;; What a kludge! (or (not *types-frozen?*) (callee-environment? u y)) (let ((e (callee-environment u y))) (if (rest? e) (if (converted? e) (can-be? (list-type-of-length-at-least? (- (- (length (variables e)) 1) (length ws))) w) (can-be? (list-type-of-length-at-least? (- (length (variables e)) (length ws))) w)) (if (converted? e) (can-be? (list-type-of-length? (- (length (variables e)) (length ws))) w) (can-be? (list-type-of-length? (- (+ (length (variables e)) 1) (length ws))) w))))) (and (foreign-procedure-type? u) (let loop? ((fs (foreign-procedure-type-parameters u)) (ws (rest ws)) (w w)) (if (null? fs) (and (null? ws) (can-be? null-type? w)) (or (and (not (null? ws)) (can-be? (foreign-type? (first fs)) (first ws)) (loop? (rest fs) (rest ws) w)) (and (null? ws) (can-be? (lambda (u) (and (pair-type? u) (can-be? (foreign-type? (first fs)) (pair-type-car u)) (loop? (rest fs) ws (pair-type-cdr u)))) w)))))) (and (continuation-type? u) (can-be? (list-type-of-length? (- 2 (length ws))) w)))) (lambda (u) (or (and (primitive-procedure-type? u) ((primitive-procedure-compatible-procedure? (cdr (assq (primitive-procedure-type-name u) *primitive-procedure-handlers*))) u ws w) (((primitive-procedure-truly-compatible-procedure? (cdr (assq (primitive-procedure-type-name u) *primitive-procedure-handlers*))) y u #f) ws w)) (and (native-procedure-type? u) ;; What a kludge! (or (not *types-frozen?*) (callee-environment? u y)) (let ((e (callee-environment u y))) ;; note: I'm not sure that this is the right thing to do but ;; it is now needed for test21.sc since I changed MAP and ;; APPLY. (and (not (converted? e)) (if (rest? e) (can-be? (list-type-of-length-at-least? (- (- (length (variables e)) 1) (length ws))) w) (can-be? (list-type-of-length? (- (length (variables e)) (length ws))) w))))) (and (foreign-procedure-type? u) (let loop? ((fs (foreign-procedure-type-parameters u)) (ws ws) (w w)) (if (null? fs) (and (null? ws) (can-be? null-type? w)) (or (and (not (null? ws)) (can-be? (foreign-type? (first fs)) (first ws)) (loop? (rest fs) (rest ws) w)) (and (null? ws) (can-be? (lambda (u) (and (pair-type? u) (can-be? (foreign-type? (first fs)) (pair-type-car u)) (loop? (rest fs) ws (pair-type-cdr u)))) w)))))) (and (continuation-type? u) (can-be? (list-type-of-length? (- 1 (length ws))) w)))))) (define (truly-compatible-call? x) (truly-compatible-procedure? (map expression-type-set (expression-arguments x)) *null* (create-call-site x))) (define (truly-compatible-call-via-apply? x) (truly-compatible-procedure? (map expression-type-set (if (converted? x) (cons (continuation-argument x) (but-last (rest (rest (expression-arguments x))))) (but-last (rest (expression-arguments x))))) (expression-type-set (last (expression-arguments x))) (recreate-call-site (create-call-site x) 'first-argument))) (define (truly-compatible-call-via-call-with-current-continuation? x) (truly-compatible-procedure? (if (converted? x) (list (expression-type-set (continuation-argument x)) (expression-type-set (continuation-argument x))) (list (create-anonymous-type-set ( x)))) *null* (recreate-call-site (create-call-site x) 'first-argument))) (define (truly-compatible-call-via-fork1? x) (truly-compatible-procedure? (if (converted? x) (list (expression-type-set (continuation-argument x))) '()) *null* (recreate-call-site (create-call-site x) 'first-argument))) (define (truly-compatible-call-via-fork2? x) (truly-compatible-procedure? (if (converted? x) (list (expression-type-set (continuation-argument x))) '()) *null* (recreate-call-site (create-call-site x) 'second-argument))) (define (truly-compatible-call-via-mutex? x) (truly-compatible-procedure? (if (converted? x) (list (expression-type-set (continuation-argument x))) '()) *null* (recreate-call-site (create-call-site x) 'first-argument))) ;;; Type functions (define (pair-type-car u) (unless (pair-type? u) (fuck-up)) (first (structure-type-slots u))) (define (pair-type-cdr u) (unless (pair-type? u) (fuck-up)) (second (structure-type-slots u))) (define (vector-type-element u) (cond ((headed-vector-type? u) (headed-vector-type-element u)) ((nonheaded-vector-type? u) (nonheaded-vector-type-element u)) ((displaced-vector-type? u) (vector-type-element (displaced-vector-type-displaced-vector-type u))) (else (fuck-up)))) (define (type-index u) (cond ((null-type? u) 0) ((true-type? u) 1) ((false-type? u) 2) ((char-type? u) 3) ((fixnum-type? u) 4) ((flonum-type? u) 5) ((rectangular-type? u) 6) ((input-port-type? u) 7) ((output-port-type? u) 8) ((eof-object-type? u) 9) ((pointer-type? u) 10) ((internal-symbol-type? u) (internal-symbol-type-index u)) ((external-symbol-type? u) (external-symbol-type-index u)) ((primitive-procedure-type? u) (primitive-procedure-type-index u)) ((native-procedure-type? u) (native-procedure-type-index u)) ((foreign-procedure-type? u) (foreign-procedure-type-index u)) ((continuation-type? u) (continuation-type-index u)) ((string-type? u) (string-type-index u)) ((structure-type? u) (structure-type-index u)) ((headed-vector-type? u) (headed-vector-type-index u)) ((nonheaded-vector-type? u) (nonheaded-vector-type-index u)) ((displaced-vector-type? u) (displaced-vector-type-index u)) (else (fuck-up)))) (define (type-use-count u) (cond ((null-type? u) *null-type-use-count*) ((true-type? u) *true-type-use-count*) ((false-type? u) *false-type-use-count*) ((char-type? u) *char-type-use-count*) ((fixnum-type? u) *fixnum-type-use-count*) ((flonum-type? u) *flonum-type-use-count*) ((rectangular-type? u) *rectangular-type-use-count*) ((input-port-type? u) *input-port-type-use-count*) ((output-port-type? u) *output-port-type-use-count*) ((eof-object-type? u) *eof-object-type-use-count*) ((pointer-type? u) *pointer-type-use-count*) ((internal-symbol-type? u) (internal-symbol-type-use-count u)) ((external-symbol-type? u) (external-symbol-type-use-count u)) ((primitive-procedure-type? u) (primitive-procedure-type-use-count u)) ((native-procedure-type? u) (native-procedure-type-use-count u)) ((foreign-procedure-type? u) (foreign-procedure-type-use-count u)) ((continuation-type? u) (continuation-type-use-count u)) ((string-type? u) (string-type-use-count u)) ((structure-type? u) (structure-type-use-count u)) ((headed-vector-type? u) (headed-vector-type-use-count u)) ((nonheaded-vector-type? u) (nonheaded-vector-type-use-count u)) ((displaced-vector-type? u) (displaced-vector-type-use-count u)) (else (fuck-up)))) (define (types-and-type-sets-that-directly-point-to u) (cond ((null-type? u) (fuck-up)) ((true-type? u) (fuck-up)) ((false-type? u) (fuck-up)) ((char-type? u) (fuck-up)) ((fixnum-type? u) (fuck-up)) ((flonum-type? u) (fuck-up)) ((rectangular-type? u) (fuck-up)) ((input-port-type? u) (fuck-up)) ((output-port-type? u) (fuck-up)) ((eof-object-type? u) (fuck-up)) ((pointer-type? u) (fuck-up)) ((internal-symbol-type? u) (internal-symbol-type-types-and-type-sets-that-directly-point-to u)) ((external-symbol-type? u) (external-symbol-type-types-and-type-sets-that-directly-point-to u)) ((primitive-procedure-type? u) (primitive-procedure-type-types-and-type-sets-that-directly-point-to u)) ((native-procedure-type? u) (native-procedure-type-types-and-type-sets-that-directly-point-to u)) ((foreign-procedure-type? u) (foreign-procedure-type-types-and-type-sets-that-directly-point-to u)) ((continuation-type? u) (continuation-type-types-and-type-sets-that-directly-point-to u)) ((string-type? u) (string-type-types-and-type-sets-that-directly-point-to u)) ((structure-type? u) (structure-type-types-and-type-sets-that-directly-point-to u)) ((headed-vector-type? u) (headed-vector-type-types-and-type-sets-that-directly-point-to u)) ((nonheaded-vector-type? u) (nonheaded-vector-type-types-and-type-sets-that-directly-point-to u)) ((displaced-vector-type? u) (displaced-vector-type-types-and-type-sets-that-directly-point-to u)) (else (fuck-up)))) (define (set-types-and-type-sets-that-directly-point-to! u u/ws) ;; needs work: This is not really a type function. (cond ((null-type? u) (fuck-up)) ((true-type? u) (fuck-up)) ((false-type? u) (fuck-up)) ((char-type? u) (fuck-up)) ((fixnum-type? u) (fuck-up)) ((flonum-type? u) (fuck-up)) ((rectangular-type? u) (fuck-up)) ((input-port-type? u) (fuck-up)) ((output-port-type? u) (fuck-up)) ((eof-object-type? u) (fuck-up)) ((pointer-type? u) (fuck-up)) ((internal-symbol-type? u) (set-internal-symbol-type-types-and-type-sets-that-directly-point-to! u u/ws)) ((external-symbol-type? u) (set-external-symbol-type-types-and-type-sets-that-directly-point-to! u u/ws)) ((primitive-procedure-type? u) (set-primitive-procedure-type-types-and-type-sets-that-directly-point-to! u u/ws)) ((native-procedure-type? u) (set-native-procedure-type-types-and-type-sets-that-directly-point-to! u u/ws)) ((foreign-procedure-type? u) (set-foreign-procedure-type-types-and-type-sets-that-directly-point-to! u u/ws)) ((continuation-type? u) (set-continuation-type-types-and-type-sets-that-directly-point-to! u u/ws)) ((string-type? u) (set-string-type-types-and-type-sets-that-directly-point-to! u u/ws)) ((structure-type? u) (set-structure-type-types-and-type-sets-that-directly-point-to! u u/ws)) ((headed-vector-type? u) (set-headed-vector-type-types-and-type-sets-that-directly-point-to! u u/ws)) ((nonheaded-vector-type? u) (set-nonheaded-vector-type-types-and-type-sets-that-directly-point-to! u u/ws)) ((displaced-vector-type? u) (set-displaced-vector-type-types-and-type-sets-that-directly-point-to! u u/ws)) (else (fuck-up)))) ;;; Type type relations (define (wide-clones? u1 u2) ;; This is only used by PRINT-NUMBER-OF-CALL-SITES-THAT-DISPATCH-ON-CLONES. (and (native-procedure-type? u1) (native-procedure-type? u2) (eq? (wide-prototype u1) (wide-prototype u2)))) ;;; Type type-set relations (define (member? u w) (let ((i (type-index u))) (let loop ((node (type-set-red-black-tree-node w))) ;; conventions: NODE (and node (or (= i (red-black-tree-node-key node)) (if (< i (red-black-tree-node-key node)) (loop (red-black-tree-node-left node)) (loop (red-black-tree-node-right node)))))))) ;;; Type type-set procedures (define (insert-member! u w) (define (left-rotate node) ;; conventions: NODE (make-red-black-tree-node (red-black-tree-node-type (red-black-tree-node-right node)) (red-black-tree-node-key (red-black-tree-node-right node)) (make-red-black-tree-node (red-black-tree-node-type node) (red-black-tree-node-key node) (red-black-tree-node-left node) (red-black-tree-node-left (red-black-tree-node-right node)) (red-black-tree-node-red? node)) (red-black-tree-node-right (red-black-tree-node-right node)) (red-black-tree-node-red? (red-black-tree-node-right node)))) (define (right-rotate node) ;; conventions: NODE (make-red-black-tree-node (red-black-tree-node-type (red-black-tree-node-left node)) (red-black-tree-node-key (red-black-tree-node-left node)) (red-black-tree-node-left (red-black-tree-node-left node)) (make-red-black-tree-node (red-black-tree-node-type node) (red-black-tree-node-key node) (red-black-tree-node-right (red-black-tree-node-left node)) (red-black-tree-node-right node) (red-black-tree-node-red? node)) (red-black-tree-node-red? (red-black-tree-node-left node)))) (let ((i (type-index u))) (set-type-set-red-black-tree-node! w (if (type-set-red-black-tree-node w) (let loop ((node (type-set-red-black-tree-node w))) ;; conventions: NODE (cond ((= i (red-black-tree-node-key node)) node) (else (if (< i (red-black-tree-node-key node)) (set-red-black-tree-node-left! node (if (red-black-tree-node-left node) (loop (red-black-tree-node-left node)) (make-red-black-tree-node u i #f #f #t))) (set-red-black-tree-node-right! node (if (red-black-tree-node-right node) (loop (red-black-tree-node-right node)) (make-red-black-tree-node u i #f #f #t)))) (cond ;; Both children are red and one grandchild is red. ((and (red-black-tree-node-left node) (red-black-tree-node-red? (red-black-tree-node-left node)) (red-black-tree-node-right node) (red-black-tree-node-red? (red-black-tree-node-right node)) (or (and (red-black-tree-node-left (red-black-tree-node-left node)) (red-black-tree-node-red? (red-black-tree-node-left (red-black-tree-node-left node)))) (and (red-black-tree-node-right (red-black-tree-node-left node)) (red-black-tree-node-red? (red-black-tree-node-right (red-black-tree-node-left node)))) (and (red-black-tree-node-left (red-black-tree-node-right node)) (red-black-tree-node-red? (red-black-tree-node-left (red-black-tree-node-right node)))) (and (red-black-tree-node-right (red-black-tree-node-right node)) (red-black-tree-node-red? (red-black-tree-node-right (red-black-tree-node-right node)))))) (when (red-black-tree-node-red? node) (fuck-up)) (set-red-black-tree-node-red?! node #t) (set-red-black-tree-node-red?! (red-black-tree-node-left node) #f) (set-red-black-tree-node-red?! (red-black-tree-node-right node) #f) node) (else (cond ;; The left child and its right child are red. ((and (red-black-tree-node-left node) (red-black-tree-node-red? (red-black-tree-node-left node)) (red-black-tree-node-right (red-black-tree-node-left node)) (red-black-tree-node-red? (red-black-tree-node-right (red-black-tree-node-left node)))) (when (red-black-tree-node-red? node) (fuck-up)) (set-red-black-tree-node-left! node (left-rotate (red-black-tree-node-left node)))) ;; The right child and its left child are red. ((and (red-black-tree-node-right node) (red-black-tree-node-red? (red-black-tree-node-right node)) (red-black-tree-node-left (red-black-tree-node-right node)) (red-black-tree-node-red? (red-black-tree-node-left (red-black-tree-node-right node)))) (when (red-black-tree-node-red? node) (fuck-up)) (set-red-black-tree-node-right! node (right-rotate (red-black-tree-node-right node))))) (cond ;; The left child and its left child are red. ((and (red-black-tree-node-left node) (red-black-tree-node-red? (red-black-tree-node-left node)) (red-black-tree-node-left (red-black-tree-node-left node)) (red-black-tree-node-red? (red-black-tree-node-left (red-black-tree-node-left node)))) (when (red-black-tree-node-red? node) (fuck-up)) (set-red-black-tree-node-red?! (red-black-tree-node-left node) #f) (set-red-black-tree-node-red?! node #t) (right-rotate node)) ;; The right child and its right child are red. ((and (red-black-tree-node-right node) (red-black-tree-node-red? (red-black-tree-node-right node)) (red-black-tree-node-right (red-black-tree-node-right node)) (red-black-tree-node-red? (red-black-tree-node-right (red-black-tree-node-right node)))) (when (red-black-tree-node-red? node) (fuck-up)) (set-red-black-tree-node-red?! (red-black-tree-node-right node) #f) (set-red-black-tree-node-red?! node #t) (left-rotate node)) (else node))))))) (make-red-black-tree-node u i #f #f #t)))) (let ((node (type-set-red-black-tree-node w))) (when (and (red-black-tree-node-red? node) (or (and (red-black-tree-node-left node) (red-black-tree-node-red? (red-black-tree-node-left node))) (and (red-black-tree-node-right node) (red-black-tree-node-red? (red-black-tree-node-right node))))) (set-red-black-tree-node-red?! node #f)))) ;;; Type environment relations (define (escapes? u e) ;; It is possible to tighten the notion of escaping by requiring that U be ;; frobbed in the continuation of some call to E. For the types in question, ;; the notion of frobbing is: ;; (EQ? X1 X2) frobs all members of the type sets of X1 and X2 ;; (STRING-LENGTH X) frobs all string members of the type set of X ;; (STRING-REF X1 X2) frobs all string members of the type set of X1 ;; (STRING-SET! X1 X2 X3) frobs all string members of the type set of X1 ;; (VECTOR-LENGTH X) frobs all nondegenerate headed vector members of the ;; type set of X ;; (VECTOR-REF X1 X2) frobs all nondegenerate vector members of X1 ;; (VECTOR-SET! X1 X2 X3) frobs all nondegenerate vector members of X1 ;; ((PRIMITIVE-PROCEDURE STRUCTURE-REF FOO I) X) frobs all structure ;; members named FOO of the type set of X that have value ;; ((PRIMITIVE-PROCEDURE STRUCTURE-SET! FOO I) X1 X2) frobs all structure ;; members named FOO of the type set of X1 that have value ;; (C X) frobs all continuation members of the type set of C that have value ;; (X0 X1 ... XN) frobs all native procedure members of the type set of X0 ;; that have value and that can take N arguments. (not (not (memq u (environment-escaping-types e))))) ;;; Type-set creation (define *wi* #f) (define *ws* #f) (define *w1* #f) (define *w* #f) (define *void* #f) (define *null* #f) (define *input-port* #f) (define *output-port* #f) (define *foreign-char-type-set* #f) (define *foreign-fixnum-type-set* #f) (define *foreign-flonum-type-set* #f) (define *foreign-string-type-set* #f) (define *foreign-input-port-type-set* #f) (define *foreign-output-port-type-set* #f) (define *foreign-pointer-type-set* #f) (define (reinitialize-types-and-type-sets!) (set! *wi* 0) (set! *ws* '()) (for-each (lambda (x) (set-expression-continuation-type! x #f) (set-expression-string-type! x #f) (set-expression-structure-types! x '()) (set-expression-headed-vector-types! x '()) (set-expression-nonheaded-vector-types! x '())) *xs*) (set! 'null) (set! *null-type-used?* #f) (set! *null-type-use-count* 0) (set! 'true) (set! *true-type-used?* #f) (set! *true-type-use-count* 0) (set! 'false) (set! *false-type-used?* #f) (set! *false-type-use-count* 0) (set! 'char) (set! *char-type-used?* #f) (set! *char-type-use-count* 0) (set! 'fixnum) (set! *fixnum-type-used?* #f) (set! *fixnum-type-use-count* 0) (set! 'flonum) (set! *flonum-type-used?* #f) (set! *flonum-type-use-count* 0) (set! 'rectangular) (set! *rectangular-type-used?* #f) (set! *rectangular-type-use-count* 0) (set! 'input-port) (set! *input-port-type-used?* #f) (set! *input-port-type-use-count* 0) (set! 'output-port) (set! *output-port-type-used?* #f) (set! *output-port-type-use-count* 0) (set! 'eof-object) (set! *eof-object-type-used?* #f) (set! *eof-object-type-use-count* 0) (set! 'pointer) (set! *pointer-type-used?* #f) (set! *pointer-type-use-count* 0) (set! *internal-symbol-types* '()) (set! *external-symbol-types* '()) (set! *primitive-procedure-types* '()) (for-each (lambda (u) (set-native-procedure-type-used?! u #f)) *native-procedure-types*) (set! *foreign-procedure-types* '()) (set! *continuation-types* '()) (set! *string-types* '()) ;; The following is needed to reset the index cache. (set! #f) (set! ( #f)) (set! *structure-types* '()) (set! *headed-vector-types* '()) (set! *nonheaded-vector-types* '()) ;; The following is needed to reset the index cache. (set! #f) (set! ( (list ) #f)) (set! *displaced-vector-types* '()) ;; needs work: To enforce that ;; (NONHEADED-VECTOR-TYPE-ELEMENT ) ;; is never widened since ARGV will be passed a nonheaded vector ;; of strings. (set! *w1* (create-anonymous-type-set )) (set! *w* (create-anonymous-type-set)) (set! *void* (create-anonymous-type-set)) (set! *null* (create-anonymous-type-set )) (set! *input-port* (create-anonymous-type-set )) (set! *output-port* (create-anonymous-type-set )) (set! *foreign-char-type-set* (create-anonymous-type-set )) (set! *foreign-fixnum-type-set* (create-anonymous-type-set )) (set! *foreign-flonum-type-set* (create-anonymous-type-set )) (set! *foreign-string-type-set* (create-anonymous-type-set )) (set! *foreign-input-port-type-set* (create-anonymous-type-set )) (set! *foreign-output-port-type-set* (create-anonymous-type-set )) (set! *foreign-pointer-type-set* (create-anonymous-type-set ))) (define (create-type-set location) (when *types-frozen?* (fuck-up)) (let ((w (make-type-set location #f (unspecified) 0 *wi* 0))) (set-type-set-fictitious?! w #t) (set-type-set-link! w w) (set! *wi* (+ *wi* 1)) (set! *ws* (cons w *ws*)) w)) (define (create-anonymous-type-set . types) ;; This and are the only type and type-set creators that can ;; be called when types are frozen. (let ((w (make-type-set #f #f (unspecified) 0 (unused) 0))) ;; This is a real kludge. (set-type-set-fictitious?! w (and (<= (length types) 1) (every fictitious? types))) (for-each (lambda (u) (insert-member! u w)) types) w)) ;;; Type-set properties (define (type-set-alignment? w) (not (zero? (bit-and (type-set-booleans w) 64)))) (define (set-type-set-alignment?! w p?) (unless (boolean? p?) (fuck-up)) (set-type-set-booleans! w (if p? (bit-or (type-set-booleans w) 64) (bit-and (type-set-booleans w) (bit-not 64))))) (define (type-set-size? w) (not (zero? (bit-and (type-set-booleans w) 32)))) (define (set-type-set-size?! w p?) (unless (boolean? p?) (fuck-up)) (set-type-set-booleans! w (if p? (bit-or (type-set-booleans w) 32) (bit-and (type-set-booleans w) (bit-not 32))))) (define (type-set-marked? w) (not (zero? (bit-and (type-set-booleans w) 16)))) (define (set-type-set-marked?! w p?) (unless (boolean? p?) (fuck-up)) (set-type-set-booleans! w (if p? (bit-or (type-set-booleans w) 16) (bit-and (type-set-booleans w) (bit-not 16))))) (define (type-set-used? w) (not (zero? (bit-and (type-set-booleans w) 8)))) (define (set-type-set-used?! w p?) (unless (boolean? p?) (fuck-up)) (set-type-set-booleans! w (if p? (bit-or (type-set-booleans w) 8) (bit-and (type-set-booleans w) (bit-not 8))))) (define (type-set-squeezable? w) (not (zero? (bit-and (type-set-booleans w) 4)))) (define (set-type-set-squeezable?! w p?) (unless (boolean? p?) (fuck-up)) (set-type-set-booleans! w (if p? (bit-or (type-set-booleans w) 4) (bit-and (type-set-booleans w) (bit-not 4))))) (define (type-set-squishable? w) (not (zero? (bit-and (type-set-booleans w) 2)))) (define (set-type-set-squishable?! w p?) (unless (boolean? p?) (fuck-up)) (set-type-set-booleans! w (if p? (bit-or (type-set-booleans w) 2) (bit-and (type-set-booleans w) (bit-not 2))))) (define (type-set-fictitious? w) (not (zero? (bit-and (type-set-booleans w) 1)))) (define (set-type-set-fictitious?! w p?) (unless (boolean? p?) (fuck-up)) (set-type-set-booleans! w (if p? (bit-or (type-set-booleans w) 1) (bit-and (type-set-booleans w) (bit-not 1))))) (define (can-be? m w) (let loop ((node (type-set-red-black-tree-node w))) ;; conventions: NODE (and node (or (m (red-black-tree-node-type node)) (loop (red-black-tree-node-left node)) (loop (red-black-tree-node-right node)))))) (define (can-be-non? m w) (can-be? (lambda (u) (not (m u))) w)) (define (must-be? m w) (not (can-be-non? m w))) (define (void? w) (not (type-set-red-black-tree-node w))) (define (monomorphic? w) ;; This really shouldn't be called until after APPLY-CLOSED-WORLD-ASSUMPTION! ;; is called since all of the multiple members might turn out to be the same. (and (type-set-red-black-tree-node w) (not (red-black-tree-node-left (type-set-red-black-tree-node w))) (not (red-black-tree-node-right (type-set-red-black-tree-node w))))) (define (multimorphic? w) ;; This really shouldn't be called until after APPLY-CLOSED-WORLD-ASSUMPTION! ;; is called since all of the multiple members might turn out to be the same. (and (type-set-red-black-tree-node w) (or (red-black-tree-node-left (type-set-red-black-tree-node w)) (red-black-tree-node-right (type-set-red-black-tree-node w))))) (define (fake? w) (and (or (void? w) (monomorphic? w)) (must-be? fictitious? w))) ;;; Type-set functions (define (the-member w) (unless (monomorphic? w) (fuck-up)) (red-black-tree-node-type (type-set-red-black-tree-node w))) (define (the-member-that m w) (let ((us (members-that m w))) (unless (= (length us) 1) (fuck-up)) (first us))) (define (members w) (let ((us '())) (let loop ((node (type-set-red-black-tree-node w))) ;; conventions: NODE (when node (loop (red-black-tree-node-right node)) (set! us (cons (red-black-tree-node-type node) us)) (loop (red-black-tree-node-left node)))) us)) (define (members-that m w) (remove-if-not m (members w))) ;;; Type-set procedures (define (for-each-member p w) (let loop ((node (type-set-red-black-tree-node w))) ;; conventions: NODE (when node (p (red-black-tree-node-type node)) (loop (red-black-tree-node-left node)) (loop (red-black-tree-node-right node))))) (define (set-members! w us) (set-type-set-red-black-tree-node! w #f) (for-each (lambda (u) (insert-member! u w)) us)) ;;; Type-set type-set relations (define (subtype-set? w1 w2) (must-be? (lambda (u1) (member? u1 w2)) w1)) ;;; Variable creation (define *gi* #f) (define *gs* #f) (define (initialize-variables!) (set! *gi* 0) (set! *gs* '())) (define (create-variable s/g) (let ((g (cond ((s-expression? s/g) (make-variable (s-expression-version s/g) (s-expression-cursor s/g) (s-expression-pathname s/g) (s-expression-line-position s/g) (s-expression-character-position s/g) (s-expression-character-position-within-line s/g) *gi* (s-expression-datum s/g) (unspecified) (unspecified) '() '() '() 0)) ((variable? s/g) (make-variable (variable-version s/g) (variable-cursor s/g) (variable-pathname s/g) (variable-line-position s/g) (variable-character-position s/g) (variable-character-position-within-line s/g) *gi* (variable-name s/g) (unspecified) (unspecified) '() '() '() 0)) (else (fuck-up))))) (set! *gi* (+ *gi* 1)) (set! *gs* (cons g *gs*)) g)) ;;; Variable properties (define (variable-accessed? g) (not (zero? (bit-and (variable-booleans g) 32)))) (define (set-variable-accessed?! g p?) (unless (boolean? p?) (fuck-up)) (set-variable-booleans! g (if p? (bit-or (variable-booleans g) 32) (bit-and (variable-booleans g) (bit-not 32))))) (define (variable-assigned? g) (not (zero? (bit-and (variable-booleans g) 16)))) (define (set-variable-assigned?! g p?) (unless (boolean? p?) (fuck-up)) (set-variable-booleans! g (if p? (bit-or (variable-booleans g) 16) (bit-and (variable-booleans g) (bit-not 16))))) (define (variable-local? g) (not (zero? (bit-and (variable-booleans g) 8)))) (define (set-variable-local?! g p?) (unless (boolean? p?) (fuck-up)) (set-variable-booleans! g (if p? (bit-or (variable-booleans g) 8) (bit-and (variable-booleans g) (bit-not 8))))) (define (variable-global? g) (not (zero? (bit-and (variable-booleans g) 4)))) (define (set-variable-global?! g p?) (unless (boolean? p?) (fuck-up)) (set-variable-booleans! g (if p? (bit-or (variable-booleans g) 4) (bit-and (variable-booleans g) (bit-not 4))))) (define (variable-hidden? g) (not (zero? (bit-and (variable-booleans g) 2)))) (define (set-variable-hidden?! g p?) (unless (boolean? p?) (fuck-up)) (set-variable-booleans! g (if p? (bit-or (variable-booleans g) 2) (bit-and (variable-booleans g) (bit-not 2))))) (define (variable-slotted? g) (not (zero? (bit-and (variable-booleans g) 1)))) (define (set-variable-slotted?! g p?) (unless (boolean? p?) (fuck-up)) (set-variable-booleans! g (if p? (bit-or (variable-booleans g) 1) (bit-and (variable-booleans g) (bit-not 1))))) (define (variable-used? g) (called? (variable-environment g))) (define (defined-at-top-level? g) (or (and (not (empty? (parent (variable-environment g)))) (empty? (parent (parent (variable-environment g)))) (let? (variable-environment g))) (and (not (empty? (parent (variable-environment g)))) (not (empty? (parent (parent (variable-environment g))))) (empty? (parent (parent (parent (variable-environment g))))) (let? (variable-environment g)) (let? (parent (variable-environment g)))) (and (not (empty? (parent (variable-environment g)))) (not (empty? (parent (parent (variable-environment g))))) (not (empty? (parent (parent (parent (variable-environment g)))))) (empty? (parent (parent (parent (parent (variable-environment g)))))) (let? (variable-environment g)) (let? (parent (variable-environment g))) (let? (parent (parent (variable-environment g))))) (and (not (empty? (parent (variable-environment g)))) (not (empty? (parent (parent (variable-environment g))))) (not (empty? (parent (parent (parent (variable-environment g)))))) (not (empty? (parent (parent (parent (parent (variable-environment g))))))) (empty? (parent (parent (parent (parent (parent (variable-environment g))))))) (let? (variable-environment g)) (let? (parent (variable-environment g))) (let? (parent (parent (variable-environment g)))) (let? (parent (parent (parent (variable-environment g)))))))) (define (accessed? g) (if *during-closure-conversion?* (case *closure-conversion-method* ((baseline) #t) ((conventional) (or (defined-at-top-level? g) (not (null? (accesses g))))) ((lightweight) (variable-accessed? g)) (else (fuck-up))) (variable-accessed? g))) (define (assigned? g) (if *during-closure-conversion?* (case *closure-conversion-method* ((baseline) #t) ((conventional) (or (defined-at-top-level? g) (not (null? (assignments g))))) ((lightweight) (variable-assigned? g)) (else (fuck-up))) (variable-assigned? g))) (define (accesses g) (remove-if-not reached? (variable-accesses g))) (define (assignments g) ;; needs work: Should this be EXECUTED?? (remove-if-not reached? (variable-assignments g))) (define (references g) ;; needs work: Should this be EXECUTED? for assignments? (remove-if-not reached? (variable-references g))) (define (must-alias? g/u) ;; needs work: This is not memoized but should be. (cond ((variable? g/u) (and (not (and (accessed? g/u) ;This is just an optimization. ;; (\exists e\in A\cup S) (some (lambda (x) (and ;; \NONTRIVIALREFERENCE{e} (nontrivial-reference? x) ;; (\exists p\in P) (let loop? ((e (expression-environment x))) ;; \PROPERLYNESTEDIN{p}{p(x)} (and (not (eq? e (variable-environment g/u))) (or ;; This can't require (NOT (FICTITIOUS? (ENVIRONMENT-TYPE E))) ;; because then X{645} in test32.sc unsoundly becomes local ;; and Y{645} in test33.sc and Y{647} in test34.sc unsoundly ;; become global. ;; \ESCAPES{p}{p(x)} (escapes? (environment-type e) (variable-environment g/u)) ;; \NESTEDIN{p(e)}{p} (loop? (parent e))))))) ;; x(e)=x (references g/u)))) (not (and (accessed? g/u) ;This is just an optimization. ;; \PROPERLYCALLS{p(x)}{p(x)} (recursive? (variable-environment g/u)) (begin (for-each (lambda (e) (set-environment-marked1?! e #f)) *es*) (unmark-types-and-type-sets!) ;; \NESTEDIN{p(x)}{p(x(e'))} (let loop ((e (variable-environment g/u))) (unless (empty? e) (set-environment-marked1?! e #t) (loop (parent e)))) ;; \NESTEDIN{p(e')}{p(x)} (let loop ((e (variable-environment g/u))) (for-each (lambda (x) (case (expression-kind x) ;; (\exists e'\in A) ((access) (when (environment-marked1? (variable-environment (expression-variable x))) ;; \POINTSTO{\alpha(e')}{p} ;; This is done just for side effect, to set the MARKED? ;; bits. (for-each-pointed-to-type (lambda (u) #f) (expression-type-set x)))) ((lambda converted-lambda converted-continuation) (when (environment-used? (expression-lambda-environment x)) (loop (expression-lambda-environment x)))))) (environment-expressions e))) ;; This is done just for side effect, to set the MARKED1? bits. ;; \PROPERLYCALLS{p(x)}{p} (some-proper-callee (lambda (e) #f) environment-marked1? set-environment-marked1?! (variable-environment g/u)) ;; (\exists e\in A\cup S) (some (lambda (x) (and ;; \NONTRIVIALREFERENCE{e} (nontrivial-reference? x) ;; (\exists p\in P) (let loop? ((e (expression-environment x))) (and ;; \PROPERLYNESTEDIN{p}{p(x(e))} (not (eq? e (variable-environment g/u))) ;; \PROPERLYCALLS{p(x)}{p} (environment-marked1? e) ;; (\exists e'\in A) ;; \NESTEDIN{p(e')}{\NESTEDIN{p(x)}{p(x(e'))}} (or ;; \POINTSTO{\alpha(e')}{p} (native-procedure-type-marked? (environment-type e)) ;; \NESTEDIN{p(e)}{p} (loop? (parent e))))))) ;; x(e)=x (references g/u))))))) ((native-procedure-type? g/u) (and (not (some (lambda (e) (and ;; note: We don't have \TYPEPREDICATEACCESSED{p}. ;; \PROCEDUREACCESSED{p} (environment-accessed? e) ;; \ESCAPES{p}{\PARENTPARAMETER{p}} (some (lambda (e) (escapes? g/u e)) (ancestors e)))) (narrow-clones g/u))) (not (and ;; This is just an optimization. (some (lambda (u/w) (and (type-set? u/w) (monomorphic? u/w) (variable? (type-set-location u/w)) (accessed? (type-set-location u/w)))) (types-and-type-sets-that-directly-point-to g/u)) (not (fictitious? g/u)) ;This is just an optimization. ;; \POINTSTO{\alpha(e')}{p} (let ((xs '())) (unmark-types-and-type-sets!) (let loop ((u g/u)) (unless (type-marked? u) (set-type-marked?! u #t) (for-each (lambda (u/w) (cond ((type-set? u/w) (unless (type-set-marked? u/w) (set-type-set-marked?! u/w #t) (cond ((type? (type-set-location u/w)) (loop (type-set-location u/w))) ((and (expression? (type-set-location u/w)) ;; e'\in A (eq? (expression-kind (type-set-location u/w)) 'access)) (set! xs (cons (type-set-location u/w) xs)))))) ((type? u/w) (loop u/w)) (else (fuck-up)))) (types-and-type-sets-that-directly-point-to u)))) (some (lambda (e) (and (environment-used? e) ;This is just an optimization. ;; (\exists e\in C) (some (lambda (y) (or ;; For now, punt on any procedure with an implicit call site and ;; treat it as if it were referenced recursively. This won't ;; affect the top-level call site because the top-level procedure ;; is never bound to a variable and thus never bound to a hidden ;; variable. This will, however, mean that any variables that are ;; bound to a procedure that has first-argument and ;; continuation-argument call sites will not be hidden. (not (explicit-call-site? y)) (begin ;; This is done just for side effect, to set the MARKED1? bits. ;; \CALLS{p'}{p(e)} (some-caller (lambda (e) #f) environment-marked1? set-environment-marked1?! (expression-environment (call-site-expression y))) ;; (\exists e'\in A) (some (lambda (x) ;; (\exists p'\in P) (let loop? ((e1 (expression-environment x))) (and ;; \PROPERLYCALLS{p'}{p'} (recursive? e1) (or (and ;; \CALLS{p'}{p(e)} (environment-marked1? e1) ;; \NESTEDIN{\PARENTPARAMETER{p}}{p'} (begin (for-each (lambda (e) (set-environment-marked2?! e #f)) *es*) (let loop ((e e1)) (when (environment-used? e) (set-environment-marked2?! e #t) (for-each (lambda (x) (case (expression-kind x) ((lambda converted-lambda converted-continuation) (loop (expression-lambda-environment x))))) (environment-expressions e)))) (some (lambda (e) (and (environment-used? e) (some environment-marked2? (ancestors e)))) (narrow-clones g/u)))) (and ;; \NESTEDIN{p'}{p(x(e'))} (not (eq? e1 (variable-environment (expression-variable x)))) ;; \NESTEDIN{p(e')}{p'} (loop? (parent e1))))))) ;; \POINTSTO{\alpha(e')}{p} xs)))) ;; \DIRECTLYCALLS{e}{p} (call-sites e)))) (narrow-clones g/u))))))) ((continuation-type? g/u) (and (not (and ;; note: We don't have \TYPEPREDICATEACCESSED{\sigma}. ;; \CONTINUATIONACCESSED{\sigma} (continuation-type-continuation-accessed? g/u) ;; (\exists\CANBE{\alpha(\ARGUMENT{1}{e(\sigma)})}{p}) (can-be? (lambda (u1) (and ;; p\in P (native-procedure-type? u1) (some (lambda (e) ;; needs work: Doesn't handle varargs. (when (rest? e) (unimplemented #f "unimplemented")) (and ;; \CANBE{\alpha(\PARAMETER{1}{p})}{\sigma} (member? g/u (first-parameter-type-set (environment-expression e))) ;; \ESCAPES{\sigma}{p} (escapes? g/u e))) (narrow-clones u1)))) (expression-type-set (first-argument (continuation-type-allocating-expression g/u)))))) (not (and ;; note: We don't have \TYPEPREDICATEACCESSES{e}{\sigma}. ;; This is just an optimization. (continuation-type-continuation-accessed? g/u) (begin ;; This is done just for side effect, to set the MARKED2? bits. ;; \PROPERLYCALLS{p(e(\sigma))}{p} (some-proper-callee (lambda (e) #f) environment-marked1? set-environment-marked1?! (expression-environment (continuation-type-allocating-expression g/u))) ;; \PROPERLYCALLS{p}{p(e(\sigma)){p}} (some-proper-caller (lambda (e) #f) environment-marked2? set-environment-marked2?! (expression-environment (continuation-type-allocating-expression g/u))) ;; \PROPERLYCALLS{p}{\PROPERLYCALLS{p(e(\sigma))}{p}} (for-each (lambda (e) (unless (environment-marked1? e) (set-environment-marked2?! e #f))) *es*) (let ((xs '())) ;; \NESTEDIN{p(e(\sigma))}{p(x(e'))} (let loop ((e (expression-environment (continuation-type-allocating-expression g/u)))) (unless (empty? e) (for-each (lambda (g) (for-each (lambda (x) ;; \POINTSTO{\alpha(e')}{\sigma} (when (points-to? (expression-type-set x) g/u) (set! xs (cons x xs)))) ;; (\exists e'\in A) (accesses g))) (variables e)) (loop (parent e)))) ;; (\exists e\in C) (some (lambda (y) ;; needs work: Doesn't handle implicit continuation calls. (unless (explicit-call-site? y) (unimplemented y "unimplemented")) ;; (\exists\CANBE{\alpha(\ARGUMENT{1}{e(\sigma)})}{p}) (some (lambda (e) (and (environment-marked2? e) (member? (environment-type e) (expression-type-set (first-argument (continuation-type-allocating-expression g/u)))) (some (lambda (x) ;; \PROPERLYNESTEDIN{p}{p(x(e'))} (properly-nested-in? e (variable-environment (expression-variable x)))) xs))) ;; \CALLS{p}{p(e)} (callers (expression-environment (call-site-expression y))))) ;; \CONTINUATIONACCESSES{e}{\sigma} (continuation-type-call-sites g/u)))))))) (else (fuck-up)))) (define (localizable? g) ;; needs work: This is not memoized but should be. (case *closure-conversion-method* ((baseline) #f) ((conventional) (not (some free-reference? (references g)))) ((lightweight) (and (or (not (accessed? g)) ;This is just an optimization. (every (lambda (x) (or (not (nontrivial-reference? x)) (in-lined-in? x (variable-environment g)))) (references g))) (must-alias? g))) (else (fuck-up)))) (define (globalizable? g) ;; needs work: This is not memoized but should be. (case *closure-conversion-method* ((baseline) #f) ((conventional) (and (or (not (empty? (parent (variable-environment g)))) (= (length (variables (variable-environment g))) 1) (not (eq? g (first (variables (variable-environment g)))))) (let loop ((e (variable-environment g))) (or (empty? (parent e)) (and (let? e) (loop (parent e))))))) ((lightweight) (or (not (called-more-than-once? (variable-environment g))) (and (not (reentrant? (variable-environment g))) (must-alias? g)))) (else (fuck-up)))) (define (hideable? g) ;; needs work: This is not memoized but should be. (case *closure-conversion-method* ((baseline conventional) #f) ((lightweight) (and (accessed? g) ;This is just an optimization. (monomorphic? (variable-type-set g)) (native-procedure-type? (the-member (variable-type-set g))) ;; The paper doesn't contain this. This is here because we don't ;; compute ANCESTOR? for unused environments. (environment-used? (the-member (variable-type-set g))) (every (lambda (x) (or (not (nontrivial-reference? x)) (every (lambda (e1) ;; The paper doesn't contain this. This is here because ;; we don't compute ANCESTOR? for unused environments. (or (not (environment-used? e1)) (every (lambda (e2) (nested-in? (expression-environment x) e2)) (ancestors e1)))) (narrow-clones (the-member (variable-type-set g)))))) (accesses g)) (must-alias? (the-member (variable-type-set g))))) (else (fuck-up)))) (define (local? g) (variable-local? g)) (define (determine-whether-local? g) (if *globals?* (and (accessed? g) (not (fictitious? (variable-type-set g))) (localizable? g) (not (global? g))) (and (accessed? g) (not (fictitious? (variable-type-set g))) (localizable? g)))) (define (infer-all-whether-local?! p?) (when *p7?* (notify "Determining whether variables are local")) (for-each (lambda (g) (cond ((local? g) (when (and p? (not (determine-whether-local? g))) (fuck-up))) ((determine-whether-local? g) (set-variable-local?! g #t) (when *p7?* (notify " ~a{~s} is local" (variable-name g) (variable-index g))) (set! *again?* #t)))) *gs*)) (define (global? g) (variable-global? g)) (define (determine-whether-global? g) (if *globals?* (and (accessed? g) (not (fictitious? (variable-type-set g))) (globalizable? g)) (and (accessed? g) (not (fictitious? (variable-type-set g))) (globalizable? g) (not (local? g))))) (define (infer-all-whether-global?! p?) (when *p7?* (notify "Determining whether variables are global")) (for-each (lambda (g) (cond ((global? g) (when (and p? (not (determine-whether-global? g))) (fuck-up))) ((determine-whether-global? g) (set-variable-global?! g #t) (when *p7?* (notify " ~a{~s} is global" (variable-name g) (variable-index g))) (set! *again?* #t)))) *gs*)) (define (hidden? g) (variable-hidden? g)) (define (determine-whether-hidden? g) (and (accessed? g) (not (fictitious? (variable-type-set g))) (hideable? g) (not (local? g)) (not (global? g)))) (define (infer-all-whether-hidden?! p?) (when *p7?* (notify "Determining whether variables are hidden")) (for-each (lambda (g) (cond ((hidden? g) (when (and p? (not (determine-whether-hidden? g))) (fuck-up))) ((determine-whether-hidden? g) (set-variable-hidden?! g #t) (when *p7?* (notify " ~a{~s} is hidden" (variable-name g) (variable-index g))) (set! *again?* #t)))) *gs*)) (define (slotted? g) (variable-slotted? g)) (define (determine-whether-slotted? g) (and (accessed? g) (not (fictitious? (variable-type-set g))) (not (local? g)) (not (global? g)) (not (hidden? g)))) (define (infer-all-whether-slotted?! p?) (when *p7?* (notify "Determining whether variables are slotted")) (for-each (lambda (g) (cond ((slotted? g) (when (and p? (not (determine-whether-slotted? g))) (fuck-up))) ((determine-whether-slotted? g) (set-variable-slotted?! g #t) (when *p7?* (notify " ~a{~s} is slotted" (variable-name g) (variable-index g))) (set! *again?* #t)))) *gs*)) ;;; Environment creation (define *ei* #f) (define *es* #f) (define *es0* #f) (define (initialize-environments!) (set! *ei* 0) (set! *es* '()) (set! *es0* '())) (define (create-environment v f) ;; conventions: V F (let ((e (make-environment *ei* (unspecified) (if v (if (symbol? v) (string-append (symbol->string v) "[" (number->string *ei*) "]") (string-append "[clone " v " " (number->string *ei*) "]")) (string-append "[inside " f " " (number->string *ei*) "]")) #f '() (unspecified) (unspecified) (unspecified) (unspecified) (unspecified) (unspecified) (unspecified) (unspecified) (unspecified) (unspecified) (unspecified) (unspecified) (unspecified) (unspecified) (unspecified) (unspecified) (unspecified) (unspecified) (unspecified) (unspecified) (unspecified) 0))) (set! *ei* (+ *ei* 1)) (set! *es* (cons e *es*)) (set-environment-narrow-prototype! e e) (set-environment-narrow-clones! e (list e)) (set-environment-wide-prototype! e e) e)) ;;; Environment properties (define (environment-marked1? e) (not (zero? (bit-and (environment-booleans e) 1024)))) (define (set-environment-marked1?! e p?) (unless (boolean? p?) (fuck-up)) (set-environment-booleans! e (if p? (bit-or (environment-booleans e) 1024) (bit-and (environment-booleans e) (bit-not 1024))))) (define (environment-marked2? e) (not (zero? (bit-and (environment-booleans e) 512)))) (define (set-environment-marked2?! e p?) (unless (boolean? p?) (fuck-up)) (set-environment-booleans! e (if p? (bit-or (environment-booleans e) 512) (bit-and (environment-booleans e) (bit-not 512))))) (define (environment-passes-parameters-globally? e) (not (zero? (bit-and (environment-booleans e) 256)))) (define (set-environment-passes-parameters-globally?! e p?) (unless (boolean? p?) (fuck-up)) (set-environment-booleans! e (if p? (bit-or (environment-booleans e) 256) (bit-and (environment-booleans e) (bit-not 256))))) (define (environment-has-region? e) (not (zero? (bit-and (environment-booleans e) 128)))) (define (set-environment-has-region?! e p?) (unless (boolean? p?) (fuck-up)) (set-environment-booleans! e (if p? (bit-or (environment-booleans e) 128) (bit-and (environment-booleans e) (bit-not 128))))) (define (environment-has-nonatomic-region? e) (not (zero? (bit-and (environment-booleans e) 64)))) (define (set-environment-has-nonatomic-region?! e p?) (unless (boolean? p?) (fuck-up)) (set-environment-booleans! e (if p? (bit-or (environment-booleans e) 64) (bit-and (environment-booleans e) (bit-not 64))))) (define (environment-recursive? e) (not (zero? (bit-and (environment-booleans e) 32)))) (define (set-environment-recursive?! e p?) (unless (boolean? p?) (fuck-up)) (set-environment-booleans! e (if p? (bit-or (environment-booleans e) 32) (bit-and (environment-booleans e) (bit-not 32))))) (define (environment-reentrant? e) (not (zero? (bit-and (environment-booleans e) 16)))) (define (set-environment-reentrant?! e p?) (unless (boolean? p?) (fuck-up)) (set-environment-booleans! e (if p? (bit-or (environment-booleans e) 16) (bit-and (environment-booleans e) (bit-not 16))))) (define (environment-called-more-than-once? e) (not (zero? (bit-and (environment-booleans e) 8)))) (define (set-environment-called-more-than-once?! e p?) (unless (boolean? p?) (fuck-up)) (set-environment-booleans! e (if p? (bit-or (environment-booleans e) 8) (bit-and (environment-booleans e) (bit-not 8))))) (define (environment-has-external-self-tail-call? e) (not (zero? (bit-and (environment-booleans e) 4)))) (define (set-environment-has-external-self-tail-call?! e p?) (unless (boolean? p?) (fuck-up)) (set-environment-booleans! e (if p? (bit-or (environment-booleans e) 4) (bit-and (environment-booleans e) (bit-not 4))))) (define (environment-has-external-continuation-call? e) (not (zero? (bit-and (environment-booleans e) 2)))) (define (set-environment-has-external-continuation-call?! e p?) (unless (boolean? p?) (fuck-up)) (set-environment-booleans! e (if p? (bit-or (environment-booleans e) 2) (bit-and (environment-booleans e) (bit-not 2))))) (define (environment-has-closure? e) (not (zero? (bit-and (environment-booleans e) 1)))) (define (set-environment-has-closure?! e p?) (unless (boolean? p?) (fuck-up)) (set-environment-booleans! e (if p? (bit-or (environment-booleans e) 1) (bit-and (environment-booleans e) (bit-not 1))))) (define (environment-used? e) (and (called? e) (not (noop? e)))) (define (environment-accessed? e) (environment-used? e)) (define (has-region? e) (when (or (empty? e) (not (environment-used? e))) (fuck-up)) (environment-has-region? e)) (define (has-nonatomic-region? e) (when (or (empty? e) (not (environment-used? e))) (fuck-up)) (environment-has-nonatomic-region? e)) (define (recursive? e) (when (or (empty? e) (not (environment-used? e))) (fuck-up)) (environment-recursive? e)) (define (reentrant? e) (when (or (empty? e) (not (environment-used? e))) (fuck-up)) (environment-reentrant? e)) (define (called-more-than-once? e) (when (or (empty? e) (not (environment-used? e))) (fuck-up)) (environment-called-more-than-once? e)) (define (has-external-self-tail-call? e) (when (or (empty? e) (not (environment-used? e))) (fuck-up)) (environment-has-external-self-tail-call? e)) (define (has-external-continuation-call? e) (when (or (empty? e) (not (environment-used? e))) (fuck-up)) (environment-has-external-continuation-call? e)) (define (has-closure? e) (when (empty? e) (fuck-up)) (environment-has-closure? e)) (define (determine-whether-has-closure? e) ;; note: It should never happen that an environment doesn't have a closure ;; yet has hidden variables that hide as that environment. (some slotted? (variables e))) (define (infer-all-whether-has-closure?! p?) (when *p7?* (notify "Determining whether environments have closures")) (for-each (lambda (e) (cond ((has-closure? e) (when (and p? (not (determine-whether-has-closure? e))) (fuck-up))) ((determine-whether-has-closure? e) (set-environment-has-closure?! e #t) (when *p7?* (notify " ~a has a closure" (environment-name e))) (set! *again?* #t)))) *es*)) (define (empty? e) (eq? e #f)) (define (in-lined-in-recursive? e) (or (recursive? e) (and (unique-call-site? e) (in-lined-in-recursive? (expression-environment (call-site-expression (unique-call-site e))))))) (define (has-parent-slot? e) (not (empty? (parent-slot e)))) (define (unique-call-site? e) (when (or (empty? e) (not (environment-used? e))) (fuck-up)) (and (= (length (environment-non-self-tail-call-sites e)) 1) (not (top-level-call-site? (unique-call-site e))))) (define (has-self-tail-call? e) (some (lambda (y) (and (not (top-level-call-site? y)) (can-be-self-tail-call-to? y e))) (call-sites e))) (define (converted-continuation? e) (eq? (expression-kind (environment-expression e)) 'converted-continuation)) (define (has-alloca? e) ;; note: This might not be the correct way to write this. I've been away from ;; this code for a while I don't remember what the correct way is. (when (unique-call-site? e) (fuck-up)) (or (some (lambda (x) (and (executed? x) (in-lined-in? (expression-environment x) e) (some (lambda (u-e) (and (type-used? (car u-e)) (stack-allocation? (cdr u-e)))) (expression-type-allocation-alist x)))) *calls*) (case *closure-representation* ((immediate-flat) (unimplemented #f "Immediate flat closures are not (yet) implemented")) ((immediate-display) (unimplemented #f "Immediate display closures are not (yet) implemented")) ((indirect-flat) (unimplemented #f "Indirect flat closures are not (yet) implemented")) ((indirect-display) (unimplemented #f "Indirect display closures are not (yet) implemented")) ((linked) (some (lambda (e1) (and (called? e1) (in-lined-in? e1 e) (stack-allocation? (allocation e1)))) *es*)) (else (fuck-up))))) (define (has-setjmp? e) ;; note: This might not be the correct way to write this. I've been away from ;; this code for a while I don't remember what the correct way is. (when (unique-call-site? e) (fuck-up)) (some (lambda (x) (and (environment-used? (expression-environment x)) (in-lined-in? (expression-environment x) e) ;; needs work: This doesn't handle calls to CALL/CC via CALL/CC, ;; APPLY, FORK, or MUTEX. And it doesn't handle ;; CALL/CC calling a continuation. (or (and (eq? (expression-kind x) 'call) (= (length (expression-arguments x)) 1)) (and (eq? (expression-kind x) 'converted-call) (= (length (expression-arguments x)) 2))) (can-be? (primitive-procedure-type-named? 'call-with-current-continuation) (expression-type-set (expression-callee x))) (can-be? (lambda (u) (and (native-procedure-type? u) (callee-environment? u (recreate-call-site (create-call-site x) 'first-argument)) (can-be-non? fictitious? (first-parameter-type-set (callee-environment u (recreate-call-site (create-call-site x) 'first-argument)))))) (expression-type-set (first-argument x))))) *calls*)) ;;; Environment functions (define (call-sites e) (when (empty? e) (fuck-up)) (environment-call-sites e)) (define (allocation e) (when (or (empty? e) (not (environment-used? e))) (fuck-up)) (environment-allocation e)) (define (distance-from-root e) (when (or (empty? e) (not (environment-used? e))) (fuck-up)) (environment-distance-from-root e)) (define (free-variables e) (when (or (empty? e) (not (environment-used? e))) (fuck-up)) (environment-free-variables e)) (define (quick-parent e) (when (or (empty? e) (not (called? e))) (fuck-up)) (environment-quick-parent e)) (define (parent-slot e) (when (or (empty? e) (not (environment-used? e))) (fuck-up)) (environment-parent-slot e)) (define (descendents e) (when (or (empty? e) (not (environment-used? e))) (fuck-up)) (environment-descendents e)) (define (in-lined-environments e) (when (or (empty? e) (not (environment-used? e))) (fuck-up)) (cons e (environment-properly-in-lined-environments e))) (define (properly-in-lined-environments e) (when (or (empty? e) (not (environment-used? e))) (fuck-up)) (environment-properly-in-lined-environments e)) (define (unique-call-site e) (when (or (empty? e) (not (environment-used? e)) (not (= (length (environment-non-self-tail-call-sites e)) 1))) (fuck-up)) (first (environment-non-self-tail-call-sites e))) (define (infer-all-unique-call-site!) (when *p7?* (notify "Determining unique call sites")) (for-each (lambda (e) (when (environment-used? e) (let* ((ys0 (environment-non-self-tail-call-sites e)) (ys1 (remove-if-not (lambda (y) (or (top-level-call-site? y) (not (can-be-self-tail-call-to? y e)))) ys0))) (when (< (length ys1) (length ys0)) (set-environment-non-self-tail-call-sites! e ys1) (when (and *p7?* (= (length ys1) 1)) (notify " Determined the unique call site of ~a" (environment-name e))) (set! *again?* #t))))) *es*)) (define (parent e) (expression-environment (environment-expression e))) (define (first-parameter-type-set e) (when (rest? e) (fuck-up)) (if (converted? e) ;; needs work: I'm not sure this is correct. (variable-type-set (second (variables e))) (variable-type-set (first (variables e))))) (define (return-type-set e) (when (empty? e) (fuck-up)) ;; note: Nonconverted continuations never return. (if (noop? e) *void* (expression-type-set (expression-body (environment-expression e))))) (define (environment-type e) (the-member (expression-type-set (environment-expression e)))) (define (home e) (if (unique-call-site? e) (home (expression-environment (call-site-expression (unique-call-site e)))) e)) (define (lexical-nesting-depth e) (if (empty? (parent e)) 0 (+ (lexical-nesting-depth (parent e)) 1))) (define (non-let-lexical-nesting-depth e) (cond ((empty? (parent e)) 0) ((let? (parent e)) (non-let-lexical-nesting-depth (parent e))) (else (+ (non-let-lexical-nesting-depth (parent e)) 1)))) ;;; Environment environment relations (define (ancestor? e1 e2) (when (or (empty? e1) (not (environment-used? e1)) (empty? e2) (not (environment-used? e2))) (fuck-up)) (not (not (memq e1 (ancestors e2))))) (define (determine-whether-ancestor? e1 e2) (or (some (lambda (g) (or (and (eq? e1 (variable-environment g)) (slotted? g)) (and (hidden? g) (some (lambda (e) (and ;; The paper doesn't contain this. This is here ;; because we don't compute ANCESTOR? for unused ;; environments. (environment-used? e) (ancestor? e1 e))) (narrow-clones (the-member (variable-type-set g))))))) (free-variables e2)) (some (lambda (g) (and (hidden? g) (some (lambda (e) (and ;; The paper doesn't contain this. This is here because we ;; don't compute ANCESTOR? for unused environments. (environment-used? e) (ancestor? e1 e))) (narrow-clones (the-member (variable-type-set g)))))) (variables e2)))) (define (infer-all-whether-ancestor?! p?) (when *p7?* (notify "Determining whether environments are ancestors of other environments")) (for-each (lambda (e2) (when (environment-used? e2) (let loop ((e1 (quick-parent e2))) (unless (empty? e1) (cond ((ancestor? e1 e2) (when (and p? (not (determine-whether-ancestor? e1 e2))) (fuck-up))) ((determine-whether-ancestor? e1 e2) (set-environment-ancestors! e2 (cons e1 (ancestors e2))) (when #f ;debugging (when *p7?* (notify " ~a is an ancestor of ~a" (environment-name e1) (environment-name e2)))) (set! *again?* #t))) (loop (quick-parent e1)))))) *es*)) (define (nested-in? e1 e2) ;; The NESTED-IN? relation is reflexive. (or (eq? e1 e2) (and (not (empty? e1)) (nested-in? (parent e1) e2)))) (define (properly-nested-in? e1 e2) ;; The PROPERLY-NESTED-IN? relation is irreflexive. (and (not (eq? e1 e2)) (nested-in? e1 e2))) ;;; Call-site creation (define *y* #f) (define *ys* #f) (define (create-call-site expression) (unless expression (fuck-up)) (make-call-site expression '())) (define (recreate-call-site y p) ;; conventions: P (unless (and (not (top-level-call-site? y)) (or (eq? p 'first-argument) (eq? p 'second-argument) (eq? p 'continuation-argument)) (or (null? (call-site-offsets y)) (eq? (first (call-site-offsets y)) 'first-argument) (eq? (first (call-site-offsets y)) 'second-argument))) (fuck-up)) (make-call-site (call-site-expression y) (cons p (call-site-offsets y)))) ;;; Call-site properties (define (top-level-call-site? y) (eq? y *y*)) (define (explicit-call-site? y) (and (not (top-level-call-site? y)) (null? (call-site-offsets y)))) (define (first-argument-call-site? y) (and (not (top-level-call-site? y)) (not (explicit-call-site? y)) (eq? (first (call-site-offsets y)) 'first-argument))) (define (second-argument-call-site? y) (and (not (top-level-call-site? y)) (not (explicit-call-site? y)) (eq? (first (call-site-offsets y)) 'second-argument))) (define (continuation-argument-call-site? y) (and (not (top-level-call-site? y)) (not (explicit-call-site? y)) (eq? (first (call-site-offsets y)) 'continuation-argument))) (define (purely-tail-call-site? y) ;; Common wisdom is that the notion of tail call is syntactic, i.e. a call in ;; tail position. But this contradicts the common wisdom that calls to ;; continuations are tail calls. Because a call to a continuation might be ;; from a non-tail position. And such a call site might be multimorphic so ;; might be both a tail-call site and a non-tail-call site. So much for common ;; wisdom. ;; APPLY and CALL-WITH-CURRENT-CONTINUATION tail call their first argument if ;; they themselves are tail calls. And implicit continuation calls are always ;; tail calls. ;; needs work: Calls to the first and second arguments of FORK and the first ;; argument of MUTEX are not tail calls. (or (top-level-call-site? y) (continuation-argument-call-site? y) (let ((x (call-site-expression y))) (and (or (eq? (expression-kind x) 'call) (eq? (expression-kind x) 'converted-call)) ;; needs work: A call in the source of a SET! to a non-accessed, ;; fictitious, or hidden variable can be a pure tail call if ;; the SET! is in tail position. (or (must-be? (lambda (u) (or (continuation-type? u) (not (executed? x)) (not ((truly-compatible-call? x) u)))) (expression-type-set (expression-callee x))) (let loop? ((x x)) (or (and (eq? (expression-kind (expression-parent x)) 'if) (or (eq? x (expression-consequent (expression-parent x))) (eq? x (expression-alternate (expression-parent x)))) (loop? (expression-parent x))) (or (eq? (expression-kind (expression-parent x)) 'lambda) (eq? (expression-kind (expression-parent x)) 'converted-lambda) (eq? (expression-kind (expression-parent x)) 'converted-continuation))))))))) (define (nonmerged-tail-recursive-purely-tail-call-site? y) (and (purely-tail-call-site? y) (some (lambda (e) (and (environment-marked1? e) (can-be-call-to? y e) (or (not (unique-call-site? e)) (not (same-call-site? y (unique-call-site e)))) (not (can-be-self-tail-call-to? y e)))) (proper-tail-callers (expression-environment (call-site-expression y)))))) ;;; Call-site functions (define (nonmerged-tail-recursive-purely-tail-call-site-callees y) (remove-if-not (lambda (e) (and (can-be-call-to? y e) (or (not (unique-call-site? e)) (not (same-call-site? y (unique-call-site e)))) (not (can-be-self-tail-call-to? y e)))) (proper-tail-callers (expression-environment (call-site-expression y))))) (define (call-site-callee y) (when (> (length (call-site-offsets y)) 1) (unimplemented y "unimplemented")) (cond ((explicit-call-site? y) (expression-callee (call-site-expression y))) ((first-argument-call-site? y) (first-argument (call-site-expression y))) ((second-argument-call-site? y) (second-argument (call-site-expression y))) ((continuation-argument-call-site? y) (continuation-argument (call-site-expression y))) (else (fuck-up)))) ;;; Call-site call-site relations (define (same-call-site? y1 y2) (or (and (top-level-call-site? y1) (top-level-call-site? y2)) (and (not (top-level-call-site? y1)) (not (top-level-call-site? y2)) (eq? (call-site-expression y1) (call-site-expression y2)) (equal? (call-site-offsets y1) (call-site-offsets y2))))) ;;; Call-site environment relations (define (can-be-call-to? y e) (not (not (memp same-call-site? y (call-sites e))))) (define (can-be-self-tail-call-to? y e) ;; needs work: This is not memoized but should be. ;; note: Self tail calls need not be just to the immediately enclosing ;; procedure but to any procedure that that is in-lined in. (and (not (noop? e)) (can-be-call-to? y e) (tail-call? y e) ;; This assumes that the IN-LINED-IN? relation is reflexive. (in-lined-in? (call-site-expression y) e))) ;;; Call-site type relations (define (goto? y u) (and (in-lined-in? (expression-environment (call-site-expression y)) (expression-environment (continuation-type-allocating-expression u))) (must-alias? u))) ;;; Generic properties (define (fictitious? u/w) (cond ((null-type? u/w) #t) ((true-type? u/w) #t) ((false-type? u/w) #t) ((char-type? u/w) #f) ((fixnum-type? u/w) #f) ((flonum-type? u/w) #f) ((rectangular-type? u/w) #f) ((input-port-type? u/w) #f) ((output-port-type? u/w) #f) ((eof-object-type? u/w) #t) ((pointer-type? u/w) #f) ((internal-symbol-type? u/w) #t) ((external-symbol-type? u/w) #f) ((primitive-procedure-type? u/w) #t) ((native-procedure-type? u/w) (native-procedure-type-fictitious? u/w)) ((foreign-procedure-type? u/w) #t) ((continuation-type? u/w) (continuation-type-fictitious? u/w)) ((string-type? u/w) #f) ((structure-type? u/w) (structure-type-fictitious? u/w)) ((headed-vector-type? u/w) #f) ((nonheaded-vector-type? u/w) #f) ((displaced-vector-type? u/w) #f) ((type-set? u/w) (type-set-fictitious? u/w)) (else (fuck-up)))) (define (determine-whether-native-procedure-type-fictitious? u) (case *closure-conversion-method* ((baseline conventional) #f) ((lightweight) (or (not (environment-accessed? u)) (every (lambda (e) (or (not (environment-used? e)) (let loop? ((e1 (quick-parent e))) (or (empty? e1) (and (not (ancestor? e1 e)) (loop? (quick-parent e1))))))) (narrow-clones u)))) (else (fuck-up)))) (define (determine-whether-continuation-type-fictitious? u) (case *closure-conversion-method* ((baseline conventional) #f) ((lightweight) (or (not (continuation-type-continuation-accessed? u)) (and (every (lambda (y) (in-lined-in? (expression-environment (call-site-expression y)) (expression-environment (continuation-type-allocating-expression u)))) (continuation-type-call-sites u)) (must-alias? u)))) (else (fuck-up)))) (define (determine-whether-structure-type-fictitious? u) (case *closure-conversion-method* ((baseline conventional) #f) ((lightweight) (every fictitious? (structure-type-slots u))) (else (fuck-up)))) (define (infer-all-whether-type-fictitious?! p?) (when *p7?* (notify "Determining whether types are fictitious")) (for-each (lambda (u) (cond ((fictitious? u) (unless (determine-whether-native-procedure-type-fictitious? u) (set-native-procedure-type-fictitious?! u #f) (when *p7?* (notify " U~s is not fictitious" (type-index u))) (set! *again?* #t))) ((and p? (determine-whether-native-procedure-type-fictitious? u)) (fuck-up)))) *native-procedure-types*) (for-each (lambda (u) (cond ((fictitious? u) (unless (determine-whether-continuation-type-fictitious? u) (set-continuation-type-fictitious?! u #f) (when *p7?* (notify " U~s is not fictitious" (type-index u))) (set! *again?* #t))) ((and p? (determine-whether-continuation-type-fictitious? u)) (fuck-up)))) *continuation-types*) (for-each (lambda (u) (cond ((fictitious? u) (unless (determine-whether-structure-type-fictitious? u) (set-structure-type-fictitious?! u #f) (when *p7?* (notify " U~s is not fictitious" (type-index u))) (set! *again?* #t))) ((and p? (determine-whether-structure-type-fictitious? u)) (fuck-up)))) *structure-types*)) (define (determine-whether-type-set-fictitious? w) ;; needs work: This really won't work until APPLY-CLOSED-WORLD-ASSUMPTION! is ;; called since all of the multiple members might turn out to be ;; the same. But don't worry, this errs on the conservative side. (case *closure-conversion-method* ((baseline conventional) #f) ((lightweight) (or (void? w) (and (not (multimorphic? w)) (must-be? fictitious? w)))) (else (fuck-up)))) (define (infer-all-whether-type-set-fictitious?! p?) (when *p7?* (notify "Determining whether type sets are fictitious")) (for-each (lambda (w) (cond ((fictitious? w) (unless (determine-whether-type-set-fictitious? w) (set-type-set-fictitious?! w #f) (when *p7?* (notify " W~s is not fictitious" (type-set-index w))) (set! *again?* #t))) ((and p? (determine-whether-type-set-fictitious? w)) (fuck-up)))) *ws*)) (define (has-parent-parameter? u/e) ;; Different narrow clones can have different ancestor sets. Narrow clones ;; can differ in whether they need a parent parameter. This was discovered ;; with the matrix.sc example of jbs@quiotix.com. This created problems when ;; applying PARENT-PARAMETER to a type instead of an environment and also ;; caused generation of incorrect code where one backchain was accessed as ;; the backchain of a narrow clone. Now we force all narrow clones to have ;; a parent parameter if one of them does. This might cause some procedures to ;; have a parent parameter that isn't used (i.e. reducing the amount of ;; parent-parameter elimination). So it goes. (some (lambda (e) (and (environment-used? e) (not (null? (ancestors e))))) (narrow-clones u/e))) (define (called? u/e) (cond ((native-procedure-type? u/e) (and (native-procedure-type-narrow-prototype u/e) (some called? (narrow-clones u/e)))) ((environment? u/e) (not (null? (call-sites u/e)))) (else (fuck-up)))) (define (let? u/e/x) (cond ((native-procedure-type? u/e/x) ;; needs work: This could use the wide notion of clone but that would be ;; just for error checking. (when (and (some let? (narrow-clones u/e/x)) (not (every let? (narrow-clones u/e/x)))) (fuck-up)) (let? (narrow-prototype u/e/x))) ((environment? u/e/x) ;; needs work: To say that a lambda expression that is the second argument ;; to a procedure that calls its first or second argument is a ;; let. (and (expression? (expression-parent (environment-expression u/e/x))) (or (eq? (expression-kind (expression-parent (environment-expression u/e/x))) 'call) (eq? (expression-kind (expression-parent (environment-expression u/e/x))) 'converted-call)) (eq? (expression-callee (expression-parent (environment-expression u/e/x))) (environment-expression u/e/x)))) ((expression? u/e/x) (unless (or (eq? (expression-kind u/e/x) 'call) (eq? (expression-kind u/e/x) 'converted-call)) (fuck-up)) (or (eq? (expression-kind (expression-callee u/e/x)) 'lambda) (eq? (expression-kind (expression-callee u/e/x)) 'converted-lambda) (eq? (expression-kind (expression-callee u/e/x)) 'converted-continuation))) (else (fuck-up)))) (define (noop? u/e/x) (cond ((native-procedure-type? u/e/x) ;; needs work: This could use the wide notion of clone but that would ;; be just for error checking. (when (and (some noop? (narrow-clones u/e/x)) (not (every noop? (narrow-clones u/e/x)))) (fuck-up)) (noop? (narrow-prototype u/e/x))) ((environment? u/e/x) (noop? (environment-expression u/e/x))) ((expression? u/e/x) (unless (or (eq? (expression-kind u/e/x) 'lambda) (eq? (expression-kind u/e/x) 'converted-lambda) (eq? (expression-kind u/e/x) 'converted-continuation)) (fuck-up)) (not (expression? (expression-body u/e/x)))) (else (fuck-up)))) (define (rest? u/e/x) (cond ((native-procedure-type? u/e/x) ;; needs work: This could use the wide notion of clone but that would ;; be just for error checking. (when (and (some rest? (narrow-clones u/e/x)) (not (every rest? (narrow-clones u/e/x)))) (fuck-up)) (rest? (narrow-prototype u/e/x))) ((environment? u/e/x) (rest? (environment-expression u/e/x))) ((expression? u/e/x) (unless (or (eq? (expression-kind u/e/x) 'lambda) (eq? (expression-kind u/e/x) 'converted-lambda) (eq? (expression-kind u/e/x) 'converted-continuation)) (fuck-up)) (not (list? (expression-parameters u/e/x)))) (else (fuck-up)))) (define (converted? e/x/y) ;; needs work: #F is ambiguous between the top-level call site and the empty ;; environment. (cond ((environment? e/x/y) (converted? (environment-expression e/x/y))) ((expression? e/x/y) (or (eq? (expression-kind e/x/y) 'converted-call) (eq? (expression-kind e/x/y) 'converted-lambda))) ((call-site? e/x/y) (and (not (continuation-argument-call-site? e/x/y)) ;; First argument call sites are converted if and only if their ;; expression is converted. (converted? (call-site-expression e/x/y)))) ((top-level-call-site? e/x/y) (converted? *x*)) (else (fuck-up)))) ;;; Generic functions (define (ancestors u/e) ;; note: This must use the narrow notion of clone because different wide ;; clones can have different ancestor sets. (cond ((native-procedure-type? u/e) (unless (pairwise? (lambda (e1 e2) (or (not (environment-used? e1)) (not (environment-used? e2)) (set-equalq? (ancestors e1) (ancestors e2)))) (narrow-clones u/e)) (fuck-up)) (ancestors (narrow-prototype u/e))) ((environment? u/e) (when (or (empty? u/e) (not (environment-used? u/e))) (fuck-up)) (environment-ancestors u/e)) (else (fuck-up)))) (define (parent-parameter u/e) ;; It used to be possible for two different narrow clones to have different ;; parent parameters. This was discovered with the matrix.sc example of ;; jbs@quiotix.com. This created problems when applying PARENT-PARAMETER to ;; a type instead of an environment and also caused generation of incorrect ;; code where one backchain was accessed as the backchain of a narrow clone. ;; Now we take the most-nested parent parameter of all the narrow clones. ;; This might cause some procedures to have a parent parameter that is used ;; only to indirect through a parent slot and not to access other slots (i.e. ;; reducing the amount of parent-parameter compression). So it goes. (environment-parent-parameter (narrow-prototype u/e))) (define (narrow-prototype u/e) (cond ((native-procedure-type? u/e) (unless (eq? (native-procedure-type-narrow-prototype u/e) (narrow-prototype (native-procedure-type-narrow-prototype u/e))) (fuck-up)) (native-procedure-type-narrow-prototype u/e)) ((environment? u/e) (unless (eq? (environment-narrow-prototype u/e) (environment-narrow-prototype (environment-narrow-prototype u/e))) (fuck-up)) (environment-narrow-prototype u/e)) (else (fuck-up)))) (define (wide-prototype u/e) ;; This is only used by WIDE-CLONES?, WIDE-CLONES, CLONE-EXPRESSION, ;; PRINT-MAXIMAL-CLONE-RATE, and STALIN. (cond ((native-procedure-type? u/e) (unless (pairwise? (lambda (e1 e2) (eq? (wide-prototype e1) (wide-prototype e2))) (narrow-clones u/e)) (fuck-up)) (wide-prototype (narrow-prototype u/e))) ((environment? u/e) (environment-wide-prototype u/e)) (else (fuck-up)))) (define (narrow-clones u/e) (if (and (native-procedure-type? u/e) (not (native-procedure-type-narrow-prototype u/e))) '() (environment-narrow-clones (narrow-prototype u/e)))) (define (wide-clones u/e) ;; This is only used by PRINT-CLONE-RATES. (remove-if-not (lambda (e) (eq? (wide-prototype u/e) (wide-prototype e))) *es*)) (define (variables e/x) ;; This only returns the variables of E/X itself, not things in-lined in E/X. (cond ((environment? e/x) (variables (environment-expression e/x))) ((expression? e/x) (let loop ((gs (expression-parameters e/x))) (cond ((null? gs) '()) ((pair? gs) (cons (first gs) (loop (rest gs)))) ((variable? gs) (list gs)) (else (fuck-up))))) (else (fuck-up)))) ;;; Generic relations (define (in-lined-in? e/x1 e/x2) ;; The IN-LINED-IN? relation is reflexive. (cond ((environment? e/x1) (and ;; This is just because of *CLOSURE-CONVERSION-METHOD*. (environment-used? e/x1) (cond ((environment? e/x2) (or (eq? e/x1 e/x2) (and (unique-call-site? e/x1) (in-lined-in? (call-site-expression (unique-call-site e/x1)) e/x2)))) ((expression? e/x2) (and (unique-call-site? e/x1) (in-lined-in? (call-site-expression (unique-call-site e/x1)) e/x2))) (else (fuck-up))))) ((expression? e/x1) (cond ((environment? e/x2) (and (not (empty? (expression-environment e/x1))) (in-lined-in? (expression-environment e/x1) e/x2))) ((expression? e/x2) (or (eq? e/x1 e/x2) (if (or (eq? (expression-kind e/x1) 'lambda) (eq? (expression-kind e/x1) 'converted-lambda) (eq? (expression-kind e/x1) 'converted-continuation)) (in-lined-in? (expression-lambda-environment e/x1) e/x2) (and (not (empty? (expression-parent e/x1))) (in-lined-in? (expression-parent e/x1) e/x2))))) (else (fuck-up)))) (else (fuck-up)))) (define (properly-in-lined-in? e/x1 e/x2) ;; The PROPERLY-IN-LINED-IN? relation is irreflexive. (and (not (eq? e/x1 e/x2)) (in-lined-in? e/x1 e/x2))) (define (unmark-types!) (for-each (lambda (u) (set-internal-symbol-type-marked?! u #f)) *internal-symbol-types*) (for-each (lambda (u) (set-external-symbol-type-marked?! u #f)) *external-symbol-types*) (for-each (lambda (u) (set-primitive-procedure-type-marked?! u #f)) *primitive-procedure-types*) (for-each (lambda (u) (set-native-procedure-type-marked?! u #f)) *native-procedure-types*) (for-each (lambda (u) (set-foreign-procedure-type-marked?! u #f)) *foreign-procedure-types*) (for-each (lambda (u) (set-continuation-type-marked?! u #f)) *continuation-types*) (for-each (lambda (u) (set-string-type-marked?! u #f)) *string-types*) (for-each (lambda (u) (set-structure-type-marked?! u #f)) *structure-types*) (for-each (lambda (u) (set-headed-vector-type-marked?! u #f)) *headed-vector-types*) (for-each (lambda (u) (set-nonheaded-vector-type-marked?! u #f)) *nonheaded-vector-types*) (for-each (lambda (u) (set-displaced-vector-type-marked?! u #f)) *displaced-vector-types*)) (define (unmark-types-and-type-sets!) (unmark-types!) (for-each (lambda (w) (set-type-set-marked?! w #f)) *ws*)) (define (some-pointed-to-type p? u/w1) ;; conventions: P? (let loop? ((u/w1 u/w1)) (cond ((type? u/w1) (cond ;; Internal symbols do not point to anything. ((internal-symbol-type? u/w1) (and (not (internal-symbol-type-marked? u/w1)) (begin (set-internal-symbol-type-marked?! u/w1 #t) (p? u/w1)))) ;; External symbols point to their displaced string. ((external-symbol-type? u/w1) (and (not (external-symbol-type-marked? u/w1)) (external-symbol-type-symbol->string-accessed? u/w1) (begin (set-external-symbol-type-marked?! u/w1 #t) (or (p? u/w1) (loop? (external-symbol-type-displaced-string-type u/w1)))))) ;; Primitive procedures do not point to anything. ((primitive-procedure-type? u/w1) (and (not (primitive-procedure-type-marked? u/w1)) (begin (set-primitive-procedure-type-marked?! u/w1 #t) (p? u/w1)))) ;; A native procedure points to all of the accessed variables in the ;; environments of all of its proper ancestors. It does *not* point to ;; its parent native procedure. ((native-procedure-type? u/w1) (and (not (native-procedure-type-marked? u/w1)) (begin (set-native-procedure-type-marked?! u/w1 #t) (or (p? u/w1) (some (lambda (e) (and (environment-accessed? e) (some (lambda (g) (and (accessed? g) (not (necessarily-fictitious? (variable-type-set g))) (loop? (variable-type-set g)))) (free-variables e)))) (narrow-clones u/w1)))))) ;; Foreign procedures do not point to anything. ((foreign-procedure-type? u/w1) (and (not (foreign-procedure-type-marked? u/w1)) (begin (set-foreign-procedure-type-marked?! u/w1 #t) (p? u/w1)))) ;; Continuations do not point to anything. ((continuation-type? u/w1) (and (not (continuation-type-marked? u/w1)) (begin (set-continuation-type-marked?! u/w1 #t) (p? u/w1)))) ;; Strings do not point to anything. ((string-type? u/w1) (and (not (string-type-marked? u/w1)) (begin (set-string-type-marked?! u/w1 #t) (p? u/w1)))) ;; Structures point to their slots. ((structure-type? u/w1) (and (not (structure-type-marked? u/w1)) (begin (set-structure-type-marked?! u/w1 #t) (or (p? u/w1) (some (lambda (p? w) (and p? (loop? w))) (structure-type-structure-ref-accessed? u/w1) (structure-type-slots u/w1)))))) ;; Headed vectors point to their element. ((headed-vector-type? u/w1) (and (not (headed-vector-type-marked? u/w1)) (begin (set-headed-vector-type-marked?! u/w1 #t) (or (p? u/w1) (and (headed-vector-type-vector-ref-accessed? u/w1) (loop? (headed-vector-type-element u/w1))))))) ;; Nonheaded vectors point to their element. ((nonheaded-vector-type? u/w1) (and (not (nonheaded-vector-type-marked? u/w1)) (begin (set-nonheaded-vector-type-marked?! u/w1 #t) (or (p? u/w1) (and (nonheaded-vector-type-vector-ref-accessed? u/w1) (loop? (nonheaded-vector-type-element u/w1))))))) ;; Displaced vectors point to their displaced vector. ((displaced-vector-type? u/w1) (and (not (displaced-vector-type-marked? u/w1)) (begin (set-displaced-vector-type-marked?! u/w1 #t) (or (p? u/w1) (and (displaced-vector-type-vector-ref-accessed? u/w1) (loop? (displaced-vector-type-displaced-vector-type u/w1))))))) (else (p? u/w1)))) ((type-set? u/w1) (can-be? loop? u/w1)) (else (fuck-up))))) (define (for-each-pointed-to-type p u/w1) ;; conventions: P (let loop ((u/w1 u/w1)) (cond ((type? u/w1) (cond ;; Internal symbols do not point to anything. ((internal-symbol-type? u/w1) (unless (internal-symbol-type-marked? u/w1) (set-internal-symbol-type-marked?! u/w1 #t) (p u/w1))) ;; External symbols point to their displaced string. ((external-symbol-type? u/w1) (unless (external-symbol-type-marked? u/w1) (set-external-symbol-type-marked?! u/w1 #t) (p u/w1) (loop (external-symbol-type-displaced-string-type u/w1)))) ;; Primitive procedures do not point to anything. ((primitive-procedure-type? u/w1) (unless (primitive-procedure-type-marked? u/w1) (set-primitive-procedure-type-marked?! u/w1 #t) (p u/w1))) ;; A native procedure points to all of the accessed variables in the ;; environments of all of its proper ancestors. It does *not* point ;; to its parent native procedure. ((native-procedure-type? u/w1) (unless (native-procedure-type-marked? u/w1) (set-native-procedure-type-marked?! u/w1 #t) (p u/w1) (for-each (lambda (e) (when (environment-accessed? e) (for-each (lambda (g) (when (and (accessed? g) (not (necessarily-fictitious? (variable-type-set g)))) (loop (variable-type-set g)))) (free-variables e)))) (narrow-clones u/w1)))) ;; Foreign procedures do not point to anything. ((foreign-procedure-type? u/w1) (unless (foreign-procedure-type-marked? u/w1) (set-foreign-procedure-type-marked?! u/w1 #t) (p u/w1))) ;; Continuations do not point to anything. ((continuation-type? u/w1) (unless (continuation-type-marked? u/w1) (set-continuation-type-marked?! u/w1 #t) (p u/w1))) ;; Strings do not point to anything. ((string-type? u/w1) (unless (string-type-marked? u/w1) (set-string-type-marked?! u/w1 #t) (p u/w1))) ;; Structures point to their slots. ((structure-type? u/w1) (unless (structure-type-marked? u/w1) (set-structure-type-marked?! u/w1 #t) (p u/w1) (for-each loop (structure-type-slots u/w1)))) ;; Headed vectors point to their element. ((headed-vector-type? u/w1) (unless (headed-vector-type-marked? u/w1) (set-headed-vector-type-marked?! u/w1 #t) (p u/w1) (loop (headed-vector-type-element u/w1)))) ;; Nonheaded vectors point to their element. ((nonheaded-vector-type? u/w1) (unless (nonheaded-vector-type-marked? u/w1) (set-nonheaded-vector-type-marked?! u/w1 #t) (p u/w1) (loop (nonheaded-vector-type-element u/w1)))) ;; Displaced vectors point to their displaced vector. ((displaced-vector-type? u/w1) (unless (displaced-vector-type-marked? u/w1) (set-displaced-vector-type-marked?! u/w1 #t) (p u/w1) (loop (displaced-vector-type-displaced-vector-type u/w1)))) (else (p u/w1)))) ((type-set? u/w1) (for-each-member loop u/w1)) (else (fuck-up))))) (define (points-to? u/w1 u2) ;; The POINTS-TO? relation is reflexive. (unmark-types!) (some-pointed-to-type (lambda (u1) (eq? u1 u2)) u/w1)) ;;; Polyvariance (define (clone-size e) (let loop ((x (environment-expression e)) (es '())) (case (expression-kind x) ((null-constant) 1) ((true-constant) 1) ((false-constant) 1) ((char-constant) 1) ((fixnum-constant) 1) ((flonum-constant) 1) ((rectangular-constant) 1) ((string-constant) 1) ((symbol-constant) 1) ((pair-constant) (+ 1 (loop (car (expression-constant x)) es) (loop (cdr (expression-constant x)) es))) ((vector-constant) (+ 1 (reduce-vector + (map-vector (lambda (x) (loop x es)) (expression-constant x)) 0))) ((lambda converted-lambda converted-continuation) (+ 1 (if (noop? x) 0 (loop (expression-body x) (cons (expression-lambda-environment x) es))))) ((set!) (+ 1 (loop (expression-source x) es))) ((if) (+ 1 (loop (expression-antecedent x) es) (loop (expression-consequent x) es) (loop (expression-alternate x) es))) ((primitive-procedure) 1) ((foreign-procedure) 1) ((access) 1) ((call converted-call) (+ 1 (loop (expression-callee x) es) (reduce + (map (lambda (x) (loop x es)) (expression-arguments x)) 0))) (else (fuck-up))))) (define (clone-expression x) (let loop ((x x) (gss '())) (case (expression-kind x) ((null-constant) (let ((x (create-expression 'null-constant x #f))) (set-expression-type-set! x (create-type-set x)) x)) ((true-constant) (let ((x (create-expression 'true-constant x #f))) (set-expression-type-set! x (create-type-set x)) x)) ((false-constant) (let ((x (create-expression 'false-constant x #f))) (set-expression-type-set! x (create-type-set x)) x)) ((char-constant) (let ((x (create-expression 'char-constant x (expression-constant x)))) (set-expression-type-set! x (create-type-set x)) x)) ((fixnum-constant) (let ((x (create-expression 'fixnum-constant x (expression-constant x)))) (set-expression-type-set! x (create-type-set x)) x)) ((flonum-constant) (let ((x (create-expression 'flonum-constant x (expression-constant x)))) (set-expression-type-set! x (create-type-set x)) x)) ((rectangular-constant) (let ((x (create-expression 'rectangular-constant x (expression-constant x)))) (set-expression-type-set! x (create-type-set x)) x)) ((string-constant) (let ((x (create-expression 'string-constant x (expression-constant x)))) (set-expression-type-set! x (create-type-set x)) x)) ((symbol-constant) (let ((x (create-expression 'symbol-constant x (expression-constant x)))) (set-expression-type-set! x (create-type-set x)) x)) ((pair-constant) (let ((x (create-expression 'pair-constant x (cons (loop (car (expression-constant x)) gss) (loop (cdr (expression-constant x)) gss))))) (set-expression-type-set! x (create-type-set x)) (set-expression-parent! (car (expression-constant x)) x) (set-expression-parent! (cdr (expression-constant x)) x) x)) ((vector-constant) (let ((x (create-expression 'vector-constant x (map-vector (lambda (x) (loop x gss)) (expression-constant x))))) (set-expression-type-set! x (create-type-set x)) (for-each-vector (lambda (x1) (set-expression-parent! x1 x)) (expression-constant x)) x)) ((lambda) (let ((e1 (create-environment (environment-name (narrow-prototype (expression-lambda-environment x))) #f))) (set-environment-split! e1 #t) (when #f ;debugging (unless (null? gss) (notify "Deep cloning: ~a -> ~a" (environment-name (expression-lambda-environment x)) (environment-name e1)))) (when (null? gss) (set-environment-narrow-prototype! e1 (narrow-prototype (expression-lambda-environment x))) (set-environment-narrow-clones! e1 '()) (set-environment-narrow-clones! (narrow-prototype (expression-lambda-environment x)) (cons e1 (narrow-clones (expression-lambda-environment x))))) (set-environment-wide-prototype! e1 (wide-prototype (expression-lambda-environment x))) (let* ((gs (let loop ((gs (expression-parameters x))) (cond ((null? gs) '()) ((pair? gs) (let ((g (create-variable (first gs)))) (set-variable-type-set! g (create-type-set g)) (cons g (loop (rest gs))))) ((variable? gs) (let ((g (create-variable gs))) (set-variable-type-set! g (create-type-set g)) g)) (else (fuck-up))))) (x1 (create-lambda-expression x e1 gs (if (noop? x) #f (loop (expression-body x) (cons gs gss)))))) ;; The lambda expression for narrow clones must be initialized to used ;; if the narrow prototype is used. The lambda expression for wide ;; clones will always be a narrow prototype and will be initialized to ;; used if it actually is reached. (when (null? gss) (set-expression-reached?! x1 (expression-reached? x))) (set-expression-type-set! x1 (if (null? gss) ;; The lambda expressions for narrow clones share the same type set. (expression-type-set x) ;; The lambda expressions for wide clones each have their own type ;; set. (create-type-set x1))) (unless (noop? x1) (set-expression-parent! (expression-body x1) x1)) (annotate-environment-variables-with-their-environment! e1) (annotate-environment-expressions-with-their-environment! e1) x1))) ((converted-lambda) (let ((e1 (create-environment (environment-name (narrow-prototype (expression-lambda-environment x))) #f))) (set-environment-split! e1 #t) (when #f ;debugging (unless (null? gss) (notify "Deep cloning: ~a -> ~a" (environment-name (expression-lambda-environment x)) (environment-name e1)))) (when (null? gss) (set-environment-narrow-prototype! e1 (narrow-prototype (expression-lambda-environment x))) (set-environment-narrow-clones! e1 '()) (set-environment-narrow-clones! (narrow-prototype (expression-lambda-environment x)) (cons e1 (narrow-clones (expression-lambda-environment x))))) (set-environment-wide-prototype! e1 (wide-prototype (expression-lambda-environment x))) (let* ((gs (let loop ((gs (expression-parameters x))) (cond ((null? gs) '()) ((pair? gs) (let ((g (create-variable (first gs)))) (set-variable-type-set! g (create-type-set g)) (cons g (loop (rest gs))))) ((variable? gs) (let ((g (create-variable gs))) (set-variable-type-set! g (create-type-set g)) g)) (else (fuck-up))))) (x1 (create-converted-lambda-expression x e1 gs (if (noop? x) #f (loop (expression-body x) (cons gs gss)))))) ;; The lambda expression for narrow clones must be initialized to used ;; if the narrow prototype is used. The lambda expression for wide ;; clones will always be a narrow prototype and will be initialized to ;; used if it actually is reached. (when (null? gss) (set-expression-reached?! x1 (expression-reached? x))) (set-expression-type-set! x1 (if (null? gss) ;; The lambda expressions for narrow clones share the same type set. (expression-type-set x) ;; The lambda expressions for wide clones each have their own type ;; set. (create-type-set x1))) (unless (noop? x1) (set-expression-parent! (expression-body x1) x1)) (annotate-environment-variables-with-their-environment! e1) (annotate-environment-expressions-with-their-environment! e1) x1))) ((converted-continuation) (let ((e1 (create-environment (environment-name (narrow-prototype (expression-lambda-environment x))) #f))) (set-environment-split! e1 #t) (when #f ;debugging (unless (null? gss) (notify "Deep cloning: ~a -> ~a" (environment-name (expression-lambda-environment x)) (environment-name e1)))) (when (null? gss) (set-environment-narrow-prototype! e1 (narrow-prototype (expression-lambda-environment x))) (set-environment-narrow-clones! e1 '()) (set-environment-narrow-clones! (narrow-prototype (expression-lambda-environment x)) (cons e1 (narrow-clones (expression-lambda-environment x))))) (set-environment-wide-prototype! e1 (wide-prototype (expression-lambda-environment x))) (let* ((gs (let loop ((gs (expression-parameters x))) (cond ((null? gs) '()) ((pair? gs) (let ((g (create-variable (first gs)))) (set-variable-type-set! g (create-type-set g)) (cons g (loop (rest gs))))) ((variable? gs) (let ((g (create-variable gs))) (set-variable-type-set! g (create-type-set g)) g)) (else (fuck-up))))) (x1 (create-converted-continuation-expression x e1 gs (if (noop? x) #f (loop (expression-body x) (cons gs gss)))))) ;; The lambda expression for narrow clones must be initialized to used ;; if the narrow prototype is used. The lambda expression for wide ;; clones will always be a narrow prototype and will be initialized to ;; used if it actually is reached. (when (null? gss) (set-expression-reached?! x1 (expression-reached? x))) (set-expression-type-set! x1 (if (null? gss) ;; The lambda expressions for narrow clones share the same type set. (expression-type-set x) ;; The lambda expressions for wide clones each have their own type ;; set. (create-type-set x1))) (unless (noop? x1) (set-expression-parent! (expression-body x1) x1)) (annotate-environment-variables-with-their-environment! e1) (annotate-environment-expressions-with-their-environment! e1) x1))) ((set!) (let ((x (create-set!-expression x (let outer ((gss1 gss) (e (expression-environment x))) (if (null? gss1) (expression-variable x) (let inner ((gs1 (first gss1)) (gs2 (expression-parameters (environment-expression e)))) (cond ((null? gs1) (unless (null? gs2) (fuck-up)) (outer (rest gss1) (parent e))) ((null? gs2) (fuck-up)) ((and (pair? gs1) (pair? gs2)) (if (eq? (first gs2) (expression-variable x)) (first gs1) (inner (rest gs1) (rest gs2)))) ((and (variable? gs1) (variable? gs2)) (if (eq? gs2 (expression-variable x)) gs1 (outer (rest gss1) (parent e)))) (else (fuck-up)))))) (loop (expression-source x) gss)))) (set-expression-type-set! x (create-type-set x)) (set-expression-parent! (expression-source x) x) (set-variable-assignments! (expression-variable x) (cons x (variable-assignments (expression-variable x)))) (set-variable-references! (expression-variable x) (cons x (variable-references (expression-variable x)))) x)) ((if) (let ((x (create-if-expression x (loop (expression-antecedent x) gss) (loop (expression-consequent x) gss) (loop (expression-alternate x) gss)))) (set-expression-type-set! x (create-type-set x)) (set-expression-parent! (expression-antecedent x) x) (set-expression-parent! (expression-consequent x) x) (set-expression-parent! (expression-alternate x) x) x)) ((primitive-procedure) (let ((x (create-expression 'primitive-procedure x (expression-constant x)))) (set-expression-type-set! x (create-type-set x)) x)) ((foreign-procedure) (let ((x (create-expression 'foreign-procedure x (expression-constant x)))) (set-expression-type-set! x (create-type-set x)) x)) ((access) (let ((x (create-access-expression x (let outer ((gss1 gss) (e (expression-environment x))) (if (null? gss1) (expression-variable x) (let inner ((gs1 (first gss1)) (gs2 (expression-parameters (environment-expression e)))) (cond ((null? gs1) (unless (null? gs2) (fuck-up)) (outer (rest gss1) (parent e))) ((null? gs2) (fuck-up)) ((and (pair? gs1) (pair? gs2)) (if (eq? (first gs2) (expression-variable x)) (first gs1) (inner (rest gs1) (rest gs2)))) ((and (variable? gs1) (variable? gs2)) (if (eq? gs2 (expression-variable x)) gs1 (outer (rest gss1) (parent e)))) (else (fuck-up))))))))) (set-expression-type-set! x (create-type-set x)) (set-variable-accesses! (expression-variable x) (cons x (variable-accesses (expression-variable x)))) (set-variable-references! (expression-variable x) (cons x (variable-references (expression-variable x)))) x)) ((call) (let ((x (create-call-expression x (loop (expression-callee x) gss) (map (lambda (x) (loop x gss)) (expression-arguments x))))) (set-expression-type-set! x (create-type-set x)) (set-expression-parent! (expression-callee x) x) (for-each (lambda (x1) (set-expression-parent! x1 x)) (expression-arguments x)) x)) ((converted-call) (let ((x (create-converted-call-expression x (loop (expression-callee x) gss) (map (lambda (x) (loop x gss)) (expression-arguments x))))) (set-expression-type-set! x (create-type-set x)) (set-expression-parent! (expression-callee x) x) (for-each (lambda (x1) (set-expression-parent! x1 x)) (expression-arguments x)) x)) (else (fuck-up))))) (define (clone e) (let* ((x (environment-expression (narrow-prototype e))) (x1 (clone-expression x))) (set-expression-parent! x1 (expression-parent x)) (expression-lambda-environment x1))) (define (callee-environment? u y) (assp same-call-site? y (native-procedure-type-call-site-environment-alist u))) (define (callee-environment u y) (unless (callee-environment? u y) (when *types-frozen?* (fuck-up)) (let ((e (if (and (explicit-call-site? y) (expression-original-expression (call-site-expression y))) (let ((y1 (create-call-site (expression-original-expression (call-site-expression y))))) (if (callee-environment? u y1) (let ((e (cdr (callee-environment? u y1)))) (cond ((nested-in? (expression-environment (call-site-expression y1)) e) (let loop ((e1 (expression-environment (call-site-expression y)))) (if (or (eq? e e1) (eq? (environment-expression e) (expression-original-expression (environment-expression e1)))) e1 (loop (parent e1))))) ((eq? (environment-split e) #t) (when #f ;debugging (notify "Chain cloning x~s ~a->[clone ~a ~s]" (expression-index (call-site-expression y)) (environment-name e) (environment-name (narrow-prototype e)) *ei*) (notify "~s" (undecorate (call-site-expression y)))) (clone e)) (else (narrow-prototype u)))) (narrow-prototype u))) (narrow-prototype u)))) (set-native-procedure-type-call-site-environment-alist! u (cons (cons y e) (native-procedure-type-call-site-environment-alist u))))) (cdr (callee-environment? u y))) ;;; `Necessary' procedures ;;; This procedure is necessary (sic) because it is called by ;;; DEFINE-PRIMITIVE-PROCEDURE EQ? and DETERMINE-ESCAPING-TYPES! before ;;; PERFORM-LIGHTWEIGHT-CLOSURE-CONVERSION! determines FICTITIOUS?. (define (necessarily-fictitious? u) (or (null-type? u) (true-type? u) (false-type? u) (eof-object-type? u) (internal-symbol-type? u) (primitive-procedure-type? u) (and (native-procedure-type? u) (if *types-frozen?* (native-procedure-type-necessarily-fictitious? u) (noop? u))) (foreign-procedure-type? u) ;; note: This used to count a structure type as necessarily fictitious ;; when every slot was necessarily fictitious and types were frozen. ;; But this is unsound because uniqueness is asserted after escaping ;; types are determined and uniqueness can change a type from being ;; fictitious to being nonfictitious. This happens in veto.sc. (and (structure-type? u) (null? (structure-type-slots u))))) (define (type-set-necessarily-fictitious? w) (or (void? w) (and (monomorphic? w) (necessarily-fictitious? (the-member w))))) (define (determine-necessarily-fictitious-native-procedure-types!) (for-each (lambda (u) (set-native-procedure-type-necessarily-fictitious?! u #t)) *native-procedure-types*) (let loop () (let ((again? #f)) (for-each (lambda (u) (unless (or (not (native-procedure-type-necessarily-fictitious? u)) (not (called? u)) (noop? u) (every (lambda (e) (or (not (environment-used? e)) (every (lambda (g) (or (not (accessed? g)) (type-set-necessarily-fictitious? (variable-type-set g)))) (free-variables e)))) (narrow-clones u))) (set-native-procedure-type-necessarily-fictitious?! u #f) (set! again? #t))) *native-procedure-types*) (when again? (loop))))) ;;; Program points (define (before x) (make-program-point #t x)) (define (after x) (make-program-point #f x)) (define (before? d) (program-point-before? d)) (define (after? d) (not (program-point-before? d))) (define (expression d) (program-point-expression d)) (define (same-program-point? d1 d2) (and (eq? (before? d1) (before? d2)) (eq? (expression d1) (expression d2)))) (define (all-program-points) (append (map before *xs*) (map after *xs*))) (define (control-directly-flows? d1 d2) ;; needs work: To handle calls to primitive, native, and foreign procedures ;; that don't return. (or (and (before? d1) (after? d2) (eq? (expression d1) (expression d2)) (or (eq? (expression-kind (expression d1)) 'null-constant) (eq? (expression-kind (expression d1)) 'true-constant) (eq? (expression-kind (expression d1)) 'false-constant) (eq? (expression-kind (expression d1)) 'char-constant) (eq? (expression-kind (expression d1)) 'fixnum-constant) (eq? (expression-kind (expression d1)) 'flonum-constant) (eq? (expression-kind (expression d1)) 'rectangular-constant) (eq? (expression-kind (expression d1)) 'string-constant) (eq? (expression-kind (expression d1)) 'symbol-constant) (eq? (expression-kind (expression d1)) 'pair-constant) (eq? (expression-kind (expression d1)) 'vector-constant) (eq? (expression-kind (expression d1)) 'lambda) (eq? (expression-kind (expression d1)) 'converted-lambda) (eq? (expression-kind (expression d1)) 'converted-continuation) (eq? (expression-kind (expression d1)) 'primitive-procedure) (eq? (expression-kind (expression d1)) 'foreign-procedure) (eq? (expression-kind (expression d1)) 'access))) ;; From before SET! to before source. (and (before? d1) (before? d2) (eq? (expression-kind (expression d1)) 'set!) (eq? (expression-source (expression d1)) (expression d2))) ;; From after source to after SET!. (and (after? d1) (after? d2) (eq? (expression-kind (expression d2)) 'set!) (eq? (expression-source (expression d2)) (expression d1))) ;; From before IF to before antecedent. (and (before? d1) (before? d2) (eq? (expression-kind (expression d1)) 'if) (eq? (expression-antecedent (expression d1)) (expression d2))) ;; From after antecedent to before consequent and alternate. (and (after? d1) (before? d2) (expression-parent (expression d1)) (eq? (expression-kind (expression-parent (expression d1))) 'if) (eq? (expression-antecedent (expression-parent (expression d1))) (expression d1)) (or (and (eq? (expression-consequent (expression-parent (expression d1))) (expression d2)) (can-be-non? false-type? (expression-type-set (expression-antecedent (expression-parent (expression d1)))))) (and (eq? (expression-alternate (expression-parent (expression d1))) (expression d2)) (can-be? false-type? (expression-type-set (expression-antecedent (expression-parent (expression d1)))))))) ;; From after consequent and alternate to after IF. (and (after? d1) (after? d2) (expression-parent (expression d1)) (eq? (expression-kind (expression-parent (expression d1))) 'if) (or (eq? (expression-consequent (expression-parent (expression d1))) (expression d1)) (eq? (expression-alternate (expression-parent (expression d1))) (expression d1))) (eq? (expression-parent (expression d1)) (expression d2))) ;; note: The following all assume a callee-first left-to-right argument ;; evaluation order. ;; From before call to before callee. (and (before? d1) (before? d2) (or (eq? (expression-kind (expression d1)) 'call) (eq? (expression-kind (expression d1)) 'converted-call)) (eq? (expression-callee (expression d1)) (expression d2))) ;; From after callee to before first argument. (and (after? d1) (before? d2) (expression-parent (expression d1)) (or (eq? (expression-kind (expression-parent (expression d1))) 'call) (eq? (expression-kind (expression-parent (expression d1))) 'converted-call)) (eq? (expression-callee (expression-parent (expression d1))) (expression d1)) (not (null? (expression-arguments (expression-parent (expression d1))))) (eq? (first (expression-arguments (expression-parent (expression d1)))) (expression d2))) ;; From after each argument to before next argument. (and (after? d1) (before? d2) (expression-parent (expression d1)) (or (eq? (expression-kind (expression-parent (expression d1))) 'call) (eq? (expression-kind (expression-parent (expression d1))) 'converted-call)) (memq (expression d1) (expression-arguments (expression-parent (expression d1)))) (< (positionq (expression d1) (expression-arguments (expression-parent (expression d1)))) (- (length (expression-arguments (expression-parent (expression d1)))) 1)) (eq? (list-ref (expression-arguments (expression-parent (expression d1))) (+ (positionq (expression d1) (expression-arguments (expression-parent (expression d1)))) 1)) (expression d2))) ;; From after callee or last argument to before target when target is a ;; non-noop native procedure. (and (after? d1) (before? d2) (expression-parent (expression d1)) (or (eq? (expression-kind (expression-parent (expression d1))) 'call) (eq? (expression-kind (expression-parent (expression d1))) 'converted-call)) (or (and (eq? (expression-callee (expression-parent (expression d1))) (expression d1)) (null? (expression-arguments (expression-parent (expression d1))))) (and (memq (expression d1) (expression-arguments (expression-parent (expression d1)))) (= (positionq (expression d1) (expression-arguments (expression-parent (expression d1)))) (- (length (expression-arguments (expression-parent (expression d1)))) 1)))) (expression-parent (expression d2)) (or (eq? (expression-kind (expression-parent (expression d2))) 'lambda) (eq? (expression-kind (expression-parent (expression d2))) 'converted-lambda) (eq? (expression-kind (expression-parent (expression d2))) 'converted-continuation)) (called? (expression-environment (expression d2))) (can-be? (lambda (u) (and ((truly-compatible-call? (expression-parent (expression d1))) u) (or (eq? u (environment-type (expression-environment (expression d2)))) (and ((primitive-procedure-type-named? 'apply) u) (can-be? (lambda (u) (and ((truly-compatible-call-via-apply? x) u) (eq? u (environment-type (expression-environment (expression d2)))))) (expression-type-set (first-argument (expression-parent (expression d1)))))) (and ((primitive-procedure-type-named? 'call-with-current-continuation) u) (can-be? (lambda (u) (and ((truly-compatible-call-via-call-with-current-continuation? x) u) (eq? u (environment-type (expression-environment (expression d2)))))) (expression-type-set (first-argument (expression-parent (expression d1)))))) (and ((primitive-procedure-type-named? 'fork) u) (or (can-be? (lambda (u) (and ((truly-compatible-call-via-fork1? x) u) (eq? u (environment-type (expression-environment (expression d2)))))) (expression-type-set (first-argument (expression-parent (expression d1))))) (can-be? (lambda (u) (and ((truly-compatible-call-via-fork2? x) u) (eq? u (environment-type (expression-environment (expression d2)))))) (expression-type-set (second-argument (expression-parent (expression d1))))))) (and ((primitive-procedure-type-named? 'mutex) u) (can-be? (lambda (u) (and ((truly-compatible-call-via-mutex? x) u) (eq? u (environment-type (expression-environment (expression d2)))))) (expression-type-set (first-argument (expression-parent (expression d1))))))))) (expression-type-set (expression-callee (expression-parent (expression d1)))))) ;; From after target to after call. (and (after? d1) (after? d2) (expression-parent (expression d1)) ;; needs work: The following comment might not be accurate. ;; Converted calls and calls to converted lambdas and continuations never ;; return. (eq? (expression-kind (expression-parent (expression d1))) 'lambda) (eq? (expression-kind (expression d2)) 'call) (called? (expression-environment (expression d1))) (can-be? (lambda (u) (and ((truly-compatible-call? (expression d2)) u) (or (eq? u (environment-type (expression-environment (expression d1)))) (and ((primitive-procedure-type-named? 'apply) u) (can-be? (lambda (u) (and ((truly-compatible-call-via-apply? x) u) (eq? u (environment-type (expression-environment (expression d1)))))) (expression-type-set (first-argument (expression-parent (expression d2)))))) (and ((primitive-procedure-type-named? 'call-with-current-continuation) u) (can-be? (lambda (u) (and ((truly-compatible-call-via-call-with-current-continuation? x) u) (eq? u (environment-type (expression-environment (expression d1)))))) (expression-type-set (first-argument (expression-parent (expression d2)))))) (and ((primitive-procedure-type-named? 'fork) u) (or (can-be? (lambda (u) (and ((truly-compatible-call-via-fork1? x) u) (eq? u (environment-type (expression-environment (expression d1)))))) (expression-type-set (first-argument (expression-parent (expression d2))))) (can-be? (lambda (u) (and ((truly-compatible-call-via-fork2? x) u) (eq? u (environment-type (expression-environment (expression d1)))))) (expression-type-set (second-argument (expression-parent (expression d2))))))) (and ((primitive-procedure-type-named? 'mutex) u) (can-be? (lambda (u) (and ((truly-compatible-call-via-mutex? x) u) (eq? u (environment-type (expression-environment (expression d1)))))) (expression-type-set (first-argument (expression-parent (expression d2))))))))) (expression-type-set (expression-callee (expression d2))))) ;; From after callee or last argument to after call when target is a noop, ;; primitive procedure, or foreign procedure. (and (after? d1) (after? d2) (expression-parent (expression d1)) (eq? (expression-parent (expression d1)) (expression d2)) ;; needs work: The following comment might not be accurate. ;; Converted calls and calls to converted lambdas and continuations never ;; return. (eq? (expression-kind (expression d2)) 'call) (or (and (eq? (expression-callee (expression d2)) (expression d1)) (null? (expression-arguments (expression d2)))) (and (memq (expression d1) (expression-arguments (expression d2))) (= (positionq (expression d1) (expression-arguments (expression d2))) (- (length (expression-arguments (expression d2))) 1)))) (can-be? (lambda (u) (and ((truly-compatible-call? (expression d2)) u) (or (and (native-procedure-type? u) (noop? u)) (and (primitive-procedure-type? u) (not ((primitive-procedure-type-named? 'apply) u)) (not ((primitive-procedure-type-named? 'call-with-current-continuation) u)) (not ((primitive-procedure-type-named? 'fork) u)) (not ((primitive-procedure-type-named? 'mutex) u))) (foreign-procedure-type? u) (and ((primitive-procedure-type-named? 'apply) u) (can-be? (lambda (u) (and ((truly-compatible-call-via-apply? x) u) (or (and (native-procedure-type? u) (noop? u)) (foreign-procedure-type? u)))) (expression-type-set (first-argument (expression d2))))) (and ((primitive-procedure-type-named? 'call-with-current-continuation) u) (can-be? (lambda (u) (and ((truly-compatible-call-via-call-with-current-continuation? x) u) (or (and (native-procedure-type? u) (noop? u)) (foreign-procedure-type? u)))) (expression-type-set (first-argument (expression d2))))) (and ((primitive-procedure-type-named? 'fork) u) (or (can-be? (lambda (u) (and ((truly-compatible-call-via-fork1? x) u) (or (and (native-procedure-type? u) (noop? u)) (foreign-procedure-type? u)))) (expression-type-set (first-argument (expression d2)))) (can-be? (lambda (u) (and ((truly-compatible-call-via-fork2? x) u) (or (and (native-procedure-type? u) (noop? u)) (foreign-procedure-type? u)))) (expression-type-set (second-argument (expression d2)))))) (and ((primitive-procedure-type-named? 'mutex) u) (can-be? (lambda (u) (and ((truly-compatible-call-via-mutex? x) u) (or (and (native-procedure-type? u) (noop? u)) (foreign-procedure-type? u)))) (expression-type-set (first-argument (expression d2)))))))) (expression-type-set (expression-callee (expression d2))))) ;; From after callee or last argument to after call to ;; CALL-WITH-CURRENT-CONTINUATION when target is a continuation. ;; needs work: Doesn't handle implicit continuation calls. (and (after? d1) (after? d2) (expression-parent (expression d1)) (or (eq? (expression-kind (expression-parent (expression d1))) 'call) (eq? (expression-kind (expression-parent (expression d1))) 'converted-call)) (or (and (eq? (expression-callee (expression-parent (expression d1))) (expression d1)) (null? (expression-arguments (expression-parent (expression d1))))) (and (memq (expression d1) (expression-arguments (expression-parent (expression d1)))) (= (positionq (expression d1) (expression-arguments (expression-parent (expression d1)))) (- (length (expression-arguments (expression-parent (expression d1)))) 1)))) (can-be? (lambda (u) (and (eq? (continuation-type-allocating-expression u) (expression d2)) ((truly-compatible-call? (expression-parent (expression d1))) u))) (expression-type-set (expression-callee (expression-parent (expression d1)))))))) (define (control-properly-flows? d1 d2) (let ((ds '())) (some (lambda (d) (let loop ((d d)) (or (same-program-point? d d2) (and (not (memp same-program-point? d ds)) (begin (set! ds (cons d ds)) (some loop (program-points-that-directly-flow-from d))))))) (program-points-that-directly-flow-from d1)))) (define (control-flows? d1 d2) (or (same-program-point? d1 d2) (control-properly-flows? d1 d2))) (define (program-points-that-directly-flow-to d) ;; needs work: To handle calls to primitive, native, and foreign procedures ;; that don't return. (if (before? d) (append ;; From before SET! to before source. (if (and (expression-parent (expression d)) (eq? (expression-kind (expression-parent (expression d))) 'set!)) (list (before (expression-parent (expression d)))) '()) ;; From before IF to before antecedent. (if (and (expression-parent (expression d)) (eq? (expression-kind (expression-parent (expression d))) 'if) (eq? (expression-antecedent (expression-parent (expression d))) (expression d))) (list (before (expression-parent (expression d)))) '()) ;; From after antecedent to before consequent and alternate. (if (and (expression-parent (expression d)) (eq? (expression-kind (expression-parent (expression d))) 'if) (or (and (eq? (expression-consequent (expression-parent (expression d))) (expression d)) (can-be-non? false-type? (expression-type-set (expression-antecedent (expression-parent (expression d)))))) (and (eq? (expression-alternate (expression-parent (expression d))) (expression d)) (can-be? false-type? (expression-type-set (expression-antecedent (expression-parent (expression d)))))))) (list (after (expression-antecedent (expression-parent (expression d))))) '()) ;; note: The following all assume a callee-first left-to-right argument ;; evaluation order. ;; From before call to before callee. (if (and (expression-parent (expression d)) (or (eq? (expression-kind (expression-parent (expression d))) 'call) (eq? (expression-kind (expression-parent (expression d))) 'converted-call)) (eq? (expression-callee (expression-parent (expression d))) (expression d))) (list (before (expression-parent (expression d)))) '()) ;; From after callee to before first argument. (if (and (expression-parent (expression d)) (or (eq? (expression-kind (expression-parent (expression d))) 'call) (eq? (expression-kind (expression-parent (expression d))) 'converted-call)) (not (null? (expression-arguments (expression-parent (expression d))))) (eq? (first (expression-arguments (expression-parent (expression d)))) (expression d))) (list (after (expression-callee (expression-parent (expression d))))) '()) ;; From after each argument to before next argument. (if (and (expression-parent (expression d)) (or (eq? (expression-kind (expression-parent (expression d))) 'call) (eq? (expression-kind (expression-parent (expression d))) 'converted-call)) (memq (expression d) (expression-arguments (expression-parent (expression d)))) (not (eq? (expression d) (first (expression-arguments (expression-parent (expression d))))))) (list (after (list-ref (expression-arguments (expression-parent (expression d))) (- (positionq (expression d) (expression-arguments (expression-parent (expression d)))) 1)))) '()) ;; From after callee or last argument to before target when target is a ;; non-noop native procedure. (if (and (expression-parent (expression d)) (or (eq? (expression-kind (expression-parent (expression d))) 'lambda) (eq? (expression-kind (expression-parent (expression d))) 'converted-lambda) (eq? (expression-kind (expression-parent (expression d))) 'converted-continuation)) (called? (expression-environment (expression d)))) (map (lambda (x) (after (if (null? (expression-arguments x)) (expression-callee x) (last (expression-arguments x))))) (remove-if-not (lambda (x) (can-be? (lambda (u) (and ((truly-compatible-call? x) u) (or (eq? u (environment-type (expression-environment (expression d)))) (and ((primitive-procedure-type-named? 'apply) u) (can-be? (lambda (u) (and ((truly-compatible-call-via-apply? x) u) (eq? u (environment-type (expression-environment (expression d)))))) (expression-type-set (first-argument x)))) (and ((primitive-procedure-type-named? 'call-with-current-continuation) u) (can-be? (lambda (u) (and ((truly-compatible-call-via-call-with-current-continuation? x) u) (eq? u (environment-type (expression-environment (expression d)))))) (expression-type-set (first-argument x)))) (and ((primitive-procedure-type-named? 'fork) u) (or (can-be? (lambda (u) (and ((truly-compatible-call-via-fork1? x) u) (eq? u (environment-type (expression-environment (expression d)))))) (expression-type-set (first-argument x))) (can-be? (lambda (u) (and ((truly-compatible-call-via-fork2? x) u) (eq? u (environment-type (expression-environment (expression d)))))) (expression-type-set (second-argument x))))) (and ((primitive-procedure-type-named? 'mutex) u) (can-be? (lambda (u) (and ((truly-compatible-call-via-mutex? x) u) (eq? u (environment-type (expression-environment (expression d)))))) (expression-type-set (first-argument x))))))) (expression-type-set (expression-callee x)))) *calls*)) '())) (append (if (or (eq? (expression-kind (expression d)) 'null-constant) (eq? (expression-kind (expression d)) 'true-constant) (eq? (expression-kind (expression d)) 'false-constant) (eq? (expression-kind (expression d)) 'char-constant) (eq? (expression-kind (expression d)) 'fixnum-constant) (eq? (expression-kind (expression d)) 'flonum-constant) (eq? (expression-kind (expression d)) 'rectangular-constant) (eq? (expression-kind (expression d)) 'string-constant) (eq? (expression-kind (expression d)) 'symbol-constant) (eq? (expression-kind (expression d)) 'pair-constant) (eq? (expression-kind (expression d)) 'vector-constant) (eq? (expression-kind (expression d)) 'lambda) (eq? (expression-kind (expression d)) 'converted-lambda) (eq? (expression-kind (expression d)) 'converted-continuation) (eq? (expression-kind (expression d)) 'primitive-procedure) (eq? (expression-kind (expression d)) 'foreign-procedure) (eq? (expression-kind (expression d)) 'access)) (list (before (expression d))) '()) ;; From after source to after SET!. (if (eq? (expression-kind (expression d)) 'set!) (list (after (expression-source (expression d)))) '()) ;; From after consequent and alternate to after IF. (if (eq? (expression-kind (expression d)) 'if) (list (after (expression-consequent (expression d))) (after (expression-alternate (expression d)))) '()) ;; From after target to after call. ;; needs work: The following comment might not be accurate. ;; Converted calls and calls to converted lambdas and continuations never ;; return. (if (eq? (expression-kind (expression d)) 'call) (append (map (lambda (u) (after (expression-body (environment-expression (callee-environment u (create-call-site (expression d))))))) (members-that (lambda (u) (and (native-procedure-type? u) (not (noop? u)) ((truly-compatible-call? (expression d)) u))) (expression-type-set (expression-callee (expression d))))) (if (can-be? (lambda (u) (and ((primitive-procedure-type-named? 'apply) u) ((truly-compatible-call? (expression d)) u))) (expression-type-set (expression-callee (expression d)))) (map (lambda (u) (after (expression-body (environment-expression (callee-environment u (recreate-call-site (create-call-site (expression d)) 'first-argument)))))) (members-that (lambda (u) (and (native-procedure-type? u) (not (noop? u)) ((truly-compatible-call-via-apply? (expression d)) u))) (expression-type-set (first-argument (expression d))))) '()) (if (can-be? (lambda (u) (and ((primitive-procedure-type-named? 'call-with-current-continuation) u) ((truly-compatible-call? (expression d)) u))) (expression-type-set (expression-callee (expression d)))) (map (lambda (u) (after (expression-body (environment-expression (callee-environment u (recreate-call-site (create-call-site (expression d)) 'first-argument)))))) (members-that (lambda (u) (and (native-procedure-type? u) (not (noop? u)) ((truly-compatible-call-via-call-with-current-continuation? (expression d)) u))) (expression-type-set (first-argument (expression d))))) '()) (if (can-be? (lambda (u) (and ((primitive-procedure-type-named? 'fork) u) ((truly-compatible-call? (expression d)) u))) (expression-type-set (expression-callee (expression d)))) (append (map (lambda (u) (after (expression-body (environment-expression (callee-environment u (recreate-call-site (create-call-site (expression d)) 'first-argument)))))) (members-that (lambda (u) (and (native-procedure-type? u) (not (noop? u)) ((truly-compatible-call-via-fork1? (expression d)) u))) (expression-type-set (first-argument (expression d))))) (map (lambda (u) (after (expression-body (environment-expression (callee-environment u (recreate-call-site (create-call-site (expression d)) 'second-argument)))))) (members-that (lambda (u) (and (native-procedure-type? u) (not (noop? u)) ((truly-compatible-call-via-fork2? (expression d)) u))) (expression-type-set (second-argument (expression d)))))) '()) (if (can-be? (lambda (u) (and ((primitive-procedure-type-named? 'mutex) u) ((truly-compatible-call? (expression d)) u))) (expression-type-set (expression-callee (expression d)))) (map (lambda (u) (after (expression-body (environment-expression (callee-environment u (recreate-call-site (create-call-site (expression d)) 'first-argument)))))) (members-that (lambda (u) (and (native-procedure-type? u) (not (noop? u)) ((truly-compatible-call-via-mutex? (expression d)) u))) (expression-type-set (first-argument (expression d))))) '())) '()) ;; From after callee or last argument to after call when target is a ;; noop, primitive procedure, or foreign procedure. ;; needs work: The following comment might not be accurate. ;; Converted calls and calls to converted lambdas and continuations never ;; return. (if (and (eq? (expression-kind (expression d)) 'call) (can-be? (lambda (u) (and ((truly-compatible-call? (expression d)) u) (or (and (native-procedure-type? u) (noop? u)) (and (primitive-procedure-type? u) (not ((primitive-procedure-type-named? 'apply) u)) (not ((primitive-procedure-type-named? 'call-with-current-continuation) u)) (not ((primitive-procedure-type-named? 'fork) u)) (not ((primitive-procedure-type-named? 'mutex) u))) (foreign-procedure-type? u) (and ((primitive-procedure-type-named? 'apply) u) (can-be? (lambda (u) (and ((truly-compatible-call-via-apply? (expression d)) u) (or (and (native-procedure-type? u) (noop? u)) (foreign-procedure-type? u)))) (expression-type-set (first-argument (expression d))))) (and ((primitive-procedure-type-named? 'call-with-current-continuation) u) (can-be? (lambda (u) (and ((truly-compatible-call-via-call-with-current-continuation? (expression d)) u) (or (and (native-procedure-type? u) (noop? u)) (foreign-procedure-type? u)))) (expression-type-set (first-argument (expression d))))) (and ((primitive-procedure-type-named? 'fork) u) (or (can-be? (lambda (u) (and ((truly-compatible-call-via-fork1? (expression d)) u) (or (and (native-procedure-type? u) (noop? u)) (foreign-procedure-type? u)))) (expression-type-set (first-argument (expression d)))) (can-be? (lambda (u) (and ((truly-compatible-call-via-fork2? (expression d)) u) (or (and (native-procedure-type? u) (noop? u)) (foreign-procedure-type? u)))) (expression-type-set (second-argument (expression d)))))) (and ((primitive-procedure-type-named? 'mutex) u) (can-be? (lambda (u) (and ((truly-compatible-call-via-mutex? (expression d)) u) (or (and (native-procedure-type? u) (noop? u)) (foreign-procedure-type? u)))) (expression-type-set (first-argument (expression d)))))))) (expression-type-set (expression-callee (expression d))))) (if (null? (expression-arguments (expression d))) (list (after (expression-callee (expression d)))) (list (after (last (expression-arguments (expression d)))))) '()) ;; From after callee or last argument to after call to ;; CALL-WITH-CURRENT-CONTINUATION when target is a continuation. ;; needs work: Doesn't handle implicit continuation calls. (if (and (or (eq? (expression-kind (expression d)) 'call) (eq? (expression-kind (expression d)) 'converted-call)) (can-be? (lambda (u) (and ((primitive-procedure-type-named? 'call-with-current-continuation) u) ((truly-compatible-call? (expression d)) u))) (expression-type-set (expression-callee (expression d))))) (map (lambda (x) (after (if (null? (expression-arguments x)) (expression-callee x) (last (expression-arguments x))))) (remove-if-not (lambda (x) (can-be? (lambda (u) (and (continuation-type? u) (eq? (continuation-type-allocating-expression u) (expression d)) ((truly-compatible-call? (expression d)) u))) (expression-type-set (expression-callee x)))) *calls*)) '())))) (define (program-points-that-properly-flow-to d) (let ((ds '())) (for-each (lambda (d) (let loop ((d d)) (unless (memp same-program-point? d ds) (set! ds (cons d ds)) (for-each loop (program-points-that-directly-flow-to d))))) (program-points-that-directly-flow-to d)) ds)) (define (program-points-that-flow-to d) (let ((ds (program-points-that-properly-flow-to d))) (if (memp same-program-point? d ds) ds (cons d ds)))) (define (program-points-that-directly-flow-from d) ;; needs work: To handle calls to primitive, native, and foreign procedures ;; that don't return. (if (before? d) (cond ((or (eq? (expression-kind (expression d)) 'null-constant) (eq? (expression-kind (expression d)) 'true-constant) (eq? (expression-kind (expression d)) 'false-constant) (eq? (expression-kind (expression d)) 'char-constant) (eq? (expression-kind (expression d)) 'fixnum-constant) (eq? (expression-kind (expression d)) 'flonum-constant) (eq? (expression-kind (expression d)) 'rectangular-constant) (eq? (expression-kind (expression d)) 'string-constant) (eq? (expression-kind (expression d)) 'symbol-constant) (eq? (expression-kind (expression d)) 'pair-constant) (eq? (expression-kind (expression d)) 'vector-constant) (eq? (expression-kind (expression d)) 'lambda) (eq? (expression-kind (expression d)) 'converted-lambda) (eq? (expression-kind (expression d)) 'converted-continuation) (eq? (expression-kind (expression d)) 'primitive-procedure) (eq? (expression-kind (expression d)) 'foreign-procedure) (eq? (expression-kind (expression d)) 'access)) (list (after (expression d)))) ;; From before SET! to before source. ((eq? (expression-kind (expression d)) 'set!) (list (before (expression-source (expression d))))) ;; From before IF to before antecedent. ((eq? (expression-kind (expression d)) 'if) (list (before (expression-antecedent (expression d))))) ;; note: The following all assume a callee-first left-to-right ;; argument evaluation order. ;; From before call to before callee. ((or (eq? (expression-kind (expression d)) 'call) (eq? (expression-kind (expression d)) 'converted-call)) (list (before (expression-callee (expression d))))) (else '())) (append ;; From after source to after SET!. (if (and (expression-parent (expression d)) (eq? (expression-kind (expression-parent (expression d))) 'set!)) (list (after (expression-parent (expression d)))) '()) ;; From after antecedent to before consequent and alternate. (if (and (expression-parent (expression d)) (eq? (expression-kind (expression-parent (expression d))) 'if) (eq? (expression-antecedent (expression-parent (expression d))) (expression d)) (can-be-non? false-type? (expression-type-set (expression-antecedent (expression-parent (expression d)))))) (list (before (expression-consequent (expression-parent (expression d))))) '()) (if (and (expression-parent (expression d)) (eq? (expression-kind (expression-parent (expression d))) 'if) (eq? (expression-antecedent (expression-parent (expression d))) (expression d)) (can-be? false-type? (expression-type-set (expression-antecedent (expression-parent (expression d)))))) (list (before (expression-alternate (expression-parent (expression d))))) '()) ;; From after consequent and alternate to after IF. (if (and (expression-parent (expression d)) (eq? (expression-kind (expression-parent (expression d))) 'if) (or (eq? (expression-consequent (expression-parent (expression d))) (expression d)) (eq? (expression-alternate (expression-parent (expression d))) (expression d)))) (list (after (expression-parent (expression d)))) '()) ;; note: The following all assume a callee-first left-to-right argument ;; evaluation order. ;; From after callee to before first argument. (if (and (expression-parent (expression d)) (or (eq? (expression-kind (expression-parent (expression d))) 'call) (eq? (expression-kind (expression-parent (expression d))) 'converted-call)) (eq? (expression-callee (expression-parent (expression d))) (expression d)) (not (null? (expression-arguments (expression-parent (expression d)))))) (list (before (first (expression-arguments (expression-parent (expression d)))))) '()) ;; From after each argument to before next argument. (if (and (expression-parent (expression d)) (or (eq? (expression-kind (expression-parent (expression d))) 'call) (eq? (expression-kind (expression-parent (expression d))) 'converted-call)) (memq (expression d) (expression-arguments (expression-parent (expression d)))) (< (positionq (expression d) (expression-arguments (expression-parent (expression d)))) (- (length (expression-arguments (expression-parent (expression d)))) 1))) (list (before (list-ref (expression-arguments (expression-parent (expression d))) (+ (positionq (expression d) (expression-arguments (expression-parent (expression d)))) 1)))) '()) ;; From after callee or last argument to before target when target is a ;; non-noop native procedure. (if (and (expression-parent (expression d)) (or (eq? (expression-kind (expression-parent (expression d))) 'call) (eq? (expression-kind (expression-parent (expression d))) 'converted-call)) (or (and (eq? (expression-callee (expression-parent (expression d))) (expression d)) (null? (expression-arguments (expression-parent (expression d))))) (and (memq (expression d) (expression-arguments (expression-parent (expression d)))) (= (positionq (expression d) (expression-arguments (expression-parent (expression d)))) (- (length (expression-arguments (expression-parent (expression d)))) 1))))) (append (map (lambda (u) (before (expression-body (environment-expression (callee-environment u (create-call-site (expression-parent (expression d)))))))) (members-that (lambda (u) (and (native-procedure-type? u) (not (noop? u)) ((truly-compatible-call? (expression-parent (expression d))) u))) (expression-type-set (expression-callee (expression-parent (expression d)))))) (if (can-be? (lambda (u) (and ((primitive-procedure-type-named? 'apply) u) ((truly-compatible-call? (expression-parent (expression d))) u))) (expression-type-set (expression-callee (expression-parent (expression d))))) (map (lambda (u) (before (expression-body (environment-expression (callee-environment u (recreate-call-site (create-call-site (expression-parent (expression d))) 'first-argument)))))) (members-that (lambda (u) (and (native-procedure-type? u) (not (noop? u)) ((truly-compatible-call-via-apply? (expression-parent (expression d))) u))) (expression-type-set (first-argument (expression-parent (expression d)))))) '()) (if (can-be? (lambda (u) (and ((primitive-procedure-type-named? 'call-with-current-continuation) u) ((truly-compatible-call? (expression-parent (expression d))) u))) (expression-type-set (expression-callee (expression-parent (expression d))))) (map (lambda (u) (before (expression-body (environment-expression (callee-environment u (recreate-call-site (create-call-site (expression-parent (expression d))) 'first-argument)))))) (members-that (lambda (u) (and (native-procedure-type? u) (not (noop? u)) ((truly-compatible-call-via-call-with-current-continuation? (expression-parent (expression d))) u))) (expression-type-set (first-argument (expression-parent (expression d)))))) '()) (if (can-be? (lambda (u) (and ((primitive-procedure-type-named? 'fork) u) ((truly-compatible-call? (expression-parent (expression d))) u))) (expression-type-set (expression-callee (expression-parent (expression d))))) (append (map (lambda (u) (before (expression-body (environment-expression (callee-environment u (recreate-call-site (create-call-site (expression-parent (expression d))) 'first-argument)))))) (members-that (lambda (u) (and (native-procedure-type? u) (not (noop? u)) ((truly-compatible-call-via-fork1? (expression-parent (expression d))) u))) (expression-type-set (first-argument (expression-parent (expression d)))))) (map (lambda (u) (before (expression-body (environment-expression (callee-environment u (recreate-call-site (create-call-site (expression-parent (expression d))) 'second-argument)))))) (members-that (lambda (u) (and (native-procedure-type? u) (not (noop? u)) ((truly-compatible-call-via-fork2? (expression-parent (expression d))) u))) (expression-type-set (second-argument (expression-parent (expression d))))))) '()) (if (can-be? (lambda (u) (and ((primitive-procedure-type-named? 'mutex) u) ((truly-compatible-call? (expression-parent (expression d))) u))) (expression-type-set (expression-callee (expression-parent (expression d))))) (map (lambda (u) (before (expression-body (environment-expression (callee-environment u (recreate-call-site (create-call-site (expression-parent (expression d))) 'first-argument)))))) (members-that (lambda (u) (and (native-procedure-type? u) (not (noop? u)) ((truly-compatible-call-via-mutex? (expression-parent (expression d))) u))) (expression-type-set (first-argument (expression-parent (expression d)))))) '())) '()) ;; From after target to after call. (if (and (expression-parent (expression d)) ;; needs work: The following comment might not be accurate. ;; Calls to converted lambdas and continuations never return. (eq? (expression-kind (expression-parent (expression d))) 'lambda) (called? (expression-environment (expression d)))) (map after (remove-if-not (lambda (x) (can-be? (lambda (u) (and ((truly-compatible-call? x) u) (or (eq? u (environment-type (expression-environment (expression d)))) (and ((primitive-procedure-type-named? 'apply) u) (can-be? (lambda (u) (and ((truly-compatible-call-via-apply? x) u) (eq? u (environment-type (expression-environment (expression d)))))) (expression-type-set (first-argument x)))) (and ((primitive-procedure-type-named? 'call-with-current-continuation) u) (can-be? (lambda (u) (and ((truly-compatible-call-via-call-with-current-continuation? x) u) (eq? u (environment-type (expression-environment (expression d)))))) (expression-type-set (first-argument x)))) (and ((primitive-procedure-type-named? 'fork) u) (or (can-be? (lambda (u) (and ((truly-compatible-call-via-fork1? x) u) (eq? u (environment-type (expression-environment (expression d)))))) (expression-type-set (first-argument x))) (can-be? (lambda (u) (and ((truly-compatible-call-via-fork2? x) u) (eq? u (environment-type (expression-environment (expression d)))))) (expression-type-set (second-argument x))))) (and ((primitive-procedure-type-named? 'mutex) u) (can-be? (lambda (u) (and ((truly-compatible-call-via-mutex? x) u) (eq? u (environment-type (expression-environment (expression d)))))) (expression-type-set (first-argument x))))))) (expression-type-set (expression-callee x)))) *calls*)) '()) ;; From after callee or last argument to after call when target is a ;; noop, primitive procedure, or foreign procedure. (if (and (expression-parent (expression d)) ;; needs work: The following comment might not be accurate. ;; Converted calls never return. (eq? (expression-kind (expression-parent (expression d))) 'call) (or (and (eq? (expression-callee (expression-parent (expression d))) (expression d)) (null? (expression-arguments (expression-parent (expression d))))) (and (memq (expression d) (expression-arguments (expression-parent (expression d)))) (= (positionq (expression d) (expression-arguments (expression-parent (expression d)))) (- (length (expression-arguments (expression-parent (expression d)))) 1))) (can-be? (lambda (u) (and ((truly-compatible-call? (expression-parent (expression d))) u) (or (and (native-procedure-type? u) (noop? u)) (and (primitive-procedure-type? u) (not ((primitive-procedure-type-named? 'apply) u)) (not ((primitive-procedure-type-named? 'call-with-current-continuation) u)) (not ((primitive-procedure-type-named? 'fork) u)) (not ((primitive-procedure-type-named? 'mutex) u))) (foreign-procedure-type? u) (and ((primitive-procedure-type-named? 'apply) u) (can-be? (lambda (u) (and ((truly-compatible-call-via-apply? (expression-parent (expression d))) u) (or (and (native-procedure-type? u) (noop? u)) (foreign-procedure-type? u)))) (expression-type-set (first-argument (expression-parent (expression d)))))) (and ((primitive-procedure-type-named? 'call-with-current-continuation) u) (can-be? (lambda (u) (and ((truly-compatible-call-via-call-with-current-continuation? (expression-parent (expression d))) u) (or (and (native-procedure-type? u) (noop? u)) (foreign-procedure-type? u)))) (expression-type-set (first-argument (expression-parent (expression d)))))) (and ((primitive-procedure-type-named? 'fork) u) (or (can-be? (lambda (u) (and ((truly-compatible-call-via-fork1? (expression-parent (expression d))) u) (or (and (native-procedure-type? u) (noop? u)) (foreign-procedure-type? u)))) (expression-type-set (first-argument (expression-parent (expression d))))) (can-be? (lambda (u) (and ((truly-compatible-call-via-fork2? (expression-parent (expression d))) u) (or (and (native-procedure-type? u) (noop? u)) (foreign-procedure-type? u)))) (expression-type-set (second-argument (expression-parent (expression d))))))) (and ((primitive-procedure-type-named? 'mutex) u) (can-be? (lambda (u) (and ((truly-compatible-call-via-mutex? (expression-parent (expression d))) u) (or (and (native-procedure-type? u) (noop? u)) (foreign-procedure-type? u)))) (expression-type-set (first-argument (expression-parent (expression d))))))))) (expression-type-set (expression-callee (expression-parent (expression d))))))) (list (after (expression-parent (expression d)))) '()) ;; From after callee or last argument to after call to ;; CALL-WITH-CURRENT-CONTINUATION when target is a continuation. ;; needs work: Doesn't handle implicit continuations calls. (if (and (expression-parent (expression d)) (or (eq? (expression-kind (expression-parent (expression d))) 'call) (eq? (expression-kind (expression-parent (expression d))) 'converted-call)) (or (and (eq? (expression-callee (expression-parent (expression d))) (expression d)) (null? (expression-arguments (expression-parent (expression d))))) (and (memq (expression d) (expression-arguments (expression-parent (expression d)))) (= (positionq (expression d) (expression-arguments (expression-parent (expression d)))) (- (length (expression-arguments (expression-parent (expression d)))) 1))))) (map (lambda (u) (after (continuation-type-allocating-expression u))) (members-that (lambda (u) (and (continuation-type? u) ((truly-compatible-call? (expression-parent (expression d))) u))) (expression-type-set (expression-callee (expression-parent (expression d)))))) '())))) (define (program-points-that-properly-flow-from d) (let ((ds '())) (for-each (lambda (d) (let loop ((d d)) (unless (memp same-program-point? d ds) (set! ds (cons d ds)) (for-each loop (program-points-that-directly-flow-from d))))) (program-points-that-directly-flow-from d)) ds)) (define (program-points-that-flow-from d) (let ((ds (program-points-that-properly-flow-from d))) (if (memp same-program-point? d ds) ds (cons d ds)))) ;;; Error messages (define *october?* #f) (define (syntax-error s error) ;; conventions: ERROR (if (s-expression-pathname s) (notify "~a:~s:~s:~a" (s-expression-pathname s) (s-expression-line-position s) (s-expression-character-position s) error) (notify error)) (terminate)) (define (unimplemented x/y error) ;; conventions: ERROR ;; needs work: Should give an indication of the call-site offset. (cond ((expression? x/y) (if (expression-pathname x/y) (notify "~a:~s:~s:~a" (expression-pathname x/y) (expression-line-position x/y) (expression-character-position x/y)) (notify error))) ((call-site? x/y) (unimplemented (call-site-expression x/y) error)) (else (notify error))) (terminate)) ;;; Macro utilities (define (sx-datum s) ;; note: This can't be eta-converted because of bugs running under IRIX 5.3. (s-expression-datum s)) (define (macro? s) (assq (sx-datum s) *macros*)) (define (macro-expander s) (second (assq (sx-datum s) *macros*))) (define (expand-macro s) (unless (s-expression-expansion s) (set-s-expression-expansion! s (create-s-expression (s-expression-pathname s) (s-expression-line-position s) (s-expression-character-position s) (s-expression-character-position-within-line s) (s-expression-comments s) ;; needs work: This encapsulation loses the line and character positions of ;; the macro that is being expanded. (sx-datum (encapsulate ((macro-expander (sx-first s)) s)))))) (s-expression-expansion s)) (define (sx-car s) (car (sx-datum s))) (define (sx-cdr s) (cdr (sx-datum s))) (define (sx-first s) ;; note: This can't be eta-converted because of bugs running under IRIX 5.3. (sx-car s)) (define (sx-second s) (sx-car (sx-cdr s))) (define (sx-third s) (sx-car (sx-cdr (sx-cdr s)))) (define (sx-fourth s) (sx-car (sx-cdr (sx-cdr (sx-cdr s))))) (define (sx-fifth s) (sx-car (sx-cdr (sx-cdr (sx-cdr (sx-cdr s)))))) (define (sx-sixth s) (sx-car (sx-cdr (sx-cdr (sx-cdr (sx-cdr (sx-cdr s))))))) (define (sx-seventh s) (sx-car (sx-cdr (sx-cdr (sx-cdr (sx-cdr (sx-cdr (sx-cdr s)))))))) (define (sx-eighth s) (sx-car (sx-cdr (sx-cdr (sx-cdr (sx-cdr (sx-cdr (sx-cdr (sx-cdr s))))))))) (define (sx-ninth s) (sx-car (sx-cdr (sx-cdr (sx-cdr (sx-cdr (sx-cdr (sx-cdr (sx-cdr (sx-cdr s)))))))))) (define (sx-tenth s) (sx-car (sx-cdr (sx-cdr (sx-cdr (sx-cdr (sx-cdr (sx-cdr (sx-cdr (sx-cdr (sx-cdr s))))))))))) (define (sx-eleventh s) (sx-car (sx-cdr (sx-cdr (sx-cdr (sx-cdr (sx-cdr (sx-cdr (sx-cdr (sx-cdr (sx-cdr (sx-cdr s)))))))))))) (define (sx-twelfth s) (sx-car (sx-cdr (sx-cdr (sx-cdr (sx-cdr (sx-cdr (sx-cdr (sx-cdr (sx-cdr (sx-cdr (sx-cdr (sx-cdr s))))))))))))) (define (sx-rest s) ;; note: This can't be eta-converted because of bugs running under IRIX 5.3. (sx-cdr s)) (define (sx-length s) (let loop ((s s) (c 0)) ;; conventions: C (if (sx-null? s) c (loop (sx-rest s) (+ c 1))))) (define (sx-null? s) (null? (sx-datum s))) (define (sx-pair? s) (pair? (sx-datum s))) (define (sx-symbol? s) (symbol? (sx-datum s))) (define (sx-string? s) (string? (sx-datum s))) (define (sx-vector? s) (vector? (sx-datum s))) (define (sx-char? s) (char? (sx-datum s))) (define (sx-eq? s q) (eq? (sx-datum s) q)) (define (sx-integer? s) (integer? (sx-datum s))) (define (sx-rational? s) (rational? (sx-datum s))) (define (sx-real? s) (real? (sx-datum s))) (define (sx-complex? s) (complex? (sx-datum s))) (define (sx-exact? s) (exact? (sx-datum s))) (define (sx-negative? s) (negative? (sx-datum s))) (define (sx-map-vector p s) ;; note: Not a real analog. ;; conventions: P (map-vector p (sx-datum s))) (define (sx-map p s) ;; note: Not a real analog. ;; conventions: P (let loop ((s s) (c '())) ;; conventions: C (if (sx-null? s) (reverse c) (loop (sx-rest s) (cons (p (sx-first s)) c))))) (define (sx-every p s) ;; conventions: P (or (sx-null? s) (and (p (sx-first s)) (sx-every p (sx-rest s))))) (define (sx-some p s) ;; conventions: P (and (not (sx-null? s)) (or (p (sx-first s)) (sx-some p (sx-rest s))))) (define (sx-for-each p s) ;; conventions: P (unless (sx-null? s) (p (sx-first s)) (sx-for-each p (sx-rest s)))) (define (sx-list? s) (or (sx-null? s) (and (sx-pair? s) (sx-list? (sx-rest s))))) (define (sx-for-each-vector p s) ;; conventions: P (for-each-vector p (sx-datum s))) (define (sx-last s) (if (sx-null? (sx-rest s)) (sx-first s) (sx-last (sx-rest s)))) (define (sx-vector->list s) ;; note: Not a real analog. (vector->list (sx-datum s))) (define (sx-some-vector p s) ;; conventions: P (some-vector p (sx-datum s))) (define (sx-unlist s) (sx-map (lambda (s) s) s)) ;;; needs work: EVERY LIST? (define (encapsulate s/q) (cond ((s-expression? s/q) s/q) ((pair? s/q) (create-anonymous-s-expression (cons (encapsulate (car s/q)) (encapsulate (cdr s/q))))) ((vector? s/q) (create-anonymous-s-expression (map-vector encapsulate s/q))) (else (create-anonymous-s-expression s/q)))) (define (october-encapsulate version cursor s/q) (let loop ((s/q s/q)) (cond ((s-expression? s/q) s/q) ((pair? s/q) (create-october-s-expression version cursor (cons (loop (car s/q)) (loop (cdr s/q))))) ((vector? s/q) (create-october-s-expression version cursor (map-vector loop s/q))) (else (create-october-s-expression version cursor s/q))))) (define (unencapsulate s/q) (cond ((s-expression? s/q) (unencapsulate (s-expression-datum s/q))) ((vector? s/q) (map-vector unencapsulate s/q)) ((pair? s/q) (cons (unencapsulate (car s/q)) (unencapsulate (cdr s/q)))) (else s/q))) ;;; Foreign Procedures (define (valid-foreign-parameter-type? s) (or (sx-eq? s 'char) (sx-eq? s 'signed-char) (sx-eq? s 'unsigned-char) (sx-eq? s 'short) (sx-eq? s 'unsigned-short) (sx-eq? s 'int) (sx-eq? s 'unsigned) (sx-eq? s 'long) (sx-eq? s 'unsigned-long) (sx-eq? s 'float) (sx-eq? s 'double) (sx-eq? s 'long-double) (sx-eq? s 'char*) (sx-eq? s 'file*) (sx-eq? s 'void*))) (define (valid-foreign-return-type? s) (or (sx-eq? s 'char) (sx-eq? s 'signed-char) (sx-eq? s 'unsigned-char) (sx-eq? s 'short) (sx-eq? s 'unsigned-short) (sx-eq? s 'int) (sx-eq? s 'unsigned) (sx-eq? s 'long) (sx-eq? s 'unsigned-long) (sx-eq? s 'float) (sx-eq? s 'double) (sx-eq? s 'long-double) (sx-eq? s 'char*) (sx-eq? s 'input-port) (sx-eq? s 'output-port) (sx-eq? s 'void*) (sx-eq? s 'void) (sx-eq? s 'no-return))) (define (foreign-type? f) (case f ((char signed-char unsigned-char) char-type?) ((short unsigned-short int unsigned long unsigned-long) fixnum-type?) ((float double long-double) flonum-type?) ((char*) string-type?) ((file*) (lambda (u) (or (input-port-type? u) (output-port-type? u)))) ((input-port) input-port-type?) ((output-port) output-port-type?) ((void*) pointer-type?) (else (fuck-up)))) (define (foreign-return-type->type-set f) (case f ((char signed-char unsigned-char) *foreign-char-type-set*) ((short unsigned-short int unsigned long unsigned-long) *foreign-fixnum-type-set*) ((float double long-double) *foreign-flonum-type-set*) ((char*) *foreign-string-type-set*) ((input-port) *foreign-input-port-type-set*) ((output-port) *foreign-output-port-type-set*) ((void*) *foreign-pointer-type-set*) ((void no-return) *void*) (else (fuck-up)))) (define (foreign-procedure-return-type-set u) (foreign-return-type->type-set (foreign-procedure-type-result u))) (define (foreign-procedure-returns? u) (not (eq? (foreign-procedure-type-result u) 'no-return))) ;;; Enumerating symbol constants (define (valid-parameter? s) (and (sx-symbol? s) (not (sx-eq? s 'quote)) (not (sx-eq? s 'lambda)) (not (sx-eq? s 'set!)) (not (sx-eq? s 'if)) (not (sx-eq? s 'primitive-procedure)) (not (sx-eq? s 'foreign-procedure)) (not (sx-eq? s 'else)) (not (sx-eq? s '=>)) (not (sx-eq? s 'define)) (not (macro? s)))) (define (valid-parameters? s) (or (and (sx-pair? s) (valid-parameter? (sx-car s)) (valid-parameters? (sx-cdr s))) (sx-null? s) (valid-parameter? s))) (define (disjoint? qs) (or (null? qs) (and (let loop? ((qs1 (rest qs))) (or (null? qs1) (and (not (eq? (first qs) (first qs1))) (loop? (rest qs1))))) (disjoint? (rest qs))))) (define (parameters s) (cond ((sx-null? s) '()) ((sx-pair? s) (cons (sx-datum (sx-car s)) (parameters (sx-cdr s)))) ((sx-symbol? s) (list (sx-datum s))) (else (fuck-up)))) (define (parameters->variables s) (cond ((sx-null? s) '()) ((sx-pair? s) (cons (create-variable (sx-car s)) (parameters->variables (sx-cdr s)))) ((sx-symbol? s) (create-variable s)) (else (fuck-up)))) (define (symbols-in s) (let ((qs '())) (define (symbols-in-constant s) (cond ((sx-null? s) #f) ((sx-eq? s #t) #f) ((sx-eq? s #f) #f) ((sx-char? s) #f) ((and (sx-integer? s) (sx-exact? s)) #f) ((sx-rational? s) (when (sx-exact? s) (syntax-error s "Cannot (yet) compile exact rational noninteger constants"))) ((sx-real? s) (when (sx-exact? s) (syntax-error s "Cannot (yet) compile exact real nonrational constants"))) ((sx-complex? s) (when (sx-exact? s) (syntax-error s "Cannot (yet) compile exact complex nonreal constants"))) ((sx-string? s) #f) ((sx-symbol? s) (unless (memq (sx-datum s) qs) (set! qs (cons (sx-datum s) qs)))) ((sx-pair? s) (symbols-in-constant (sx-car s)) (symbols-in-constant (sx-cdr s))) ((sx-vector? s) (sx-for-each-vector symbols-in-constant s)) ;; procedures, input ports, output ports, eof objects, structures, and ;; pointers (else (syntax-error s "Unrecognized constant type")))) (define (symbols-in s) (cond ((sx-null? s) (syntax-error s "Improper expression")) ((sx-pair? s) (unless (sx-list? s) (syntax-error s "Improper expression")) (if (sx-symbol? (sx-first s)) (case (sx-datum (sx-first s)) ((quote) (unless (= (sx-length s) 2) (syntax-error s "Improper QUOTE")) (symbols-in-constant (sx-second s))) ((lambda) ;; Extension to R4RS: LAMBDA can have empty body. (unless (and (>= (sx-length s) 2) (valid-parameters? (sx-second s)) (disjoint? (parameters (sx-second s)))) (syntax-error s "Improper LAMBDA")) (let ((s (macroexpand-body s))) (unless (sx-null? (sx-rest (sx-rest s))) (symbols-in (sx-third s))))) ((set!) (unless (and (= (sx-length s) 3) (sx-symbol? (sx-second s))) (syntax-error s "Improper SET!")) (symbols-in (sx-third s))) ((if) (unless (or (= (sx-length s) 3) (= (sx-length s) 4)) (syntax-error s "Improper IF")) (symbols-in (sx-second s)) (symbols-in (sx-third s)) (when (= (sx-length s) 4) (symbols-in (sx-fourth s)))) ((primitive-procedure) ;; Extension to R4RS: Link to primitive procedures. (let ((s2 (sx-second s))) (unless (or (and (or (sx-eq? s2 'make-structure) (sx-eq? s2 'structure-ref) (sx-eq? s2 'structure-set!)) (= (sx-length s) 4) (sx-symbol? (sx-third s)) (sx-integer? (sx-fourth s)) (sx-exact? (sx-fourth s)) (not (sx-negative? (sx-fourth s)))) (and (sx-eq? s2 'structure?) (= (sx-length s) 3) (sx-symbol? (sx-third s))) (and (= (sx-length s) 2) (not (sx-eq? s2 'make-structure)) (not (sx-eq? s2 'structure-ref)) (not (sx-eq? s2 'structure-set!)) (not (sx-eq? s2 'structure?)) (assq (sx-datum s2) *primitive-procedure-handlers*))) (syntax-error s "Improper PRIMITIVE-PROCEDURE")))) ((foreign-procedure) (unless (or (and (= (sx-length s) 4) (sx-list? (sx-second s)) (sx-every valid-foreign-parameter-type? (sx-second s)) (valid-foreign-return-type? (sx-third s)) (sx-string? (sx-fourth s))) (and (= (sx-length s) 5) (sx-list? (sx-second s)) (sx-every valid-foreign-parameter-type? (sx-second s)) (valid-foreign-return-type? (sx-third s)) (sx-string? (sx-fourth s)) (sx-string? (sx-fifth s)))) (syntax-error s "Improper FOREIGN-PROCEDURE"))) (else (if (macro? (sx-first s)) (symbols-in (expand-macro s)) (sx-for-each symbols-in s)))) (sx-for-each symbols-in s))) ((sx-symbol? s) #f) (else (symbols-in-constant s)))) (symbols-in s) qs)) ;;; Macro expander (define (variable s gs) (when (null? gs) (syntax-error s "Unbound variable")) (if (sx-eq? s (variable-name (first gs))) (first gs) (variable s (rest gs)))) (define (dotted-append gs1 gs2) (cond ((null? gs1) gs2) ((variable? gs1) (cons gs1 gs2)) (else (cons (first gs1) (dotted-append (rest gs1) gs2))))) (define (macroexpand s) (define (macroexpand s gs v f) ;; conventions: V F (define (macroexpand-constant s1) (let ((q (sx-datum s1))) (cond ((sx-null? s1) (create-expression 'null-constant s #f)) ((sx-eq? s1 #t) (create-expression 'true-constant s #f)) ((sx-eq? s1 #f) (create-expression 'false-constant s #f)) ((sx-char? s1) (create-expression 'char-constant s q)) ((and (sx-integer? s1) (sx-exact? s1)) (create-expression 'fixnum-constant s q)) ((sx-rational? s1) (when (sx-exact? s1) (fuck-up)) (create-expression 'flonum-constant s q)) ((sx-real? s1) (when (sx-exact? s1) (fuck-up)) (create-expression 'flonum-constant s q)) ((sx-complex? s1) (when (sx-exact? s1) (fuck-up)) ;; needs work: 1.0+0.0i will create a FLONUM-CONSTANT so there is no way ;; to create a RECTANGULAR-CONSTANT with a 0.0 imaginary ;; component. (create-expression 'rectangular-constant s q)) ((sx-string? s1) (create-expression 'string-constant s q)) ((sx-symbol? s1) (create-expression 'symbol-constant s q)) ((sx-pair? s1) (create-expression 'pair-constant s (cons (macroexpand-constant (sx-car s1)) (macroexpand-constant (sx-cdr s1))))) ((sx-vector? s1) (create-expression 'vector-constant s (sx-map-vector macroexpand-constant s1))) ;; procedures, input ports, output ports, eof objects, structures, and ;; pointers (else (fuck-up))))) (cond ((sx-null? s) (fuck-up)) ((sx-pair? s) (unless (sx-list? s) (fuck-up)) (if (sx-symbol? (sx-first s)) (case (sx-datum (sx-first s)) ((quote) (unless (= (sx-length s) 2) (fuck-up)) (macroexpand-constant (sx-second s))) ((lambda) (unless (and (>= (sx-length s) 2) (valid-parameters? (sx-second s)) (disjoint? (parameters (sx-second s)))) (fuck-up)) (let ((s (macroexpand-body s))) (cond ((sx-null? (sx-rest (sx-rest s))) (create-lambda-expression s (create-environment v (if v (symbol->string v) f)) (parameters->variables (sx-second s)) #f)) ((sx-null? (sx-rest (sx-rest (sx-rest s)))) (let ((f (if v (symbol->string v) f)) (gs1 (parameters->variables (sx-second s)))) ;; conventions: F (create-lambda-expression s (create-environment v f) gs1 (macroexpand (sx-third s) (dotted-append gs1 gs) #f f)))) (else (fuck-up))))) ((set!) (unless (and (= (sx-length s) 3) (sx-symbol? (sx-second s))) (fuck-up)) (create-set!-expression s (variable (sx-second s) gs) (macroexpand (sx-third s) gs (sx-datum (sx-second s)) f))) ((if) (unless (or (= (sx-length s) 3) (= (sx-length s) 4)) (fuck-up)) (create-if-expression s (macroexpand (sx-second s) gs #f f) (macroexpand (sx-third s) gs #f f) (if (= (sx-length s) 3) (create-call-expression s (create-lambda-expression s (create-environment v (if v (symbol->string v) f)) '() #f) '()) (macroexpand (sx-fourth s) gs #f f)))) ((primitive-procedure) ;; Extension to R4RS: Link to primitive procedures. (let ((s2 (sx-second s))) (unless (or (and (or (sx-eq? s2 'make-structure) (sx-eq? s2 'structure-ref) (sx-eq? s2 'structure-set!)) (= (sx-length s) 4) (sx-symbol? (sx-third s)) (sx-integer? (sx-fourth s)) (sx-exact? (sx-fourth s)) (not (sx-negative? (sx-fourth s)))) (and (sx-eq? s2 'structure?) (= (sx-length s) 3) (sx-symbol? (sx-third s))) (and (= (sx-length s) 2) (not (sx-eq? s2 'make-structure)) (not (sx-eq? s2 'structure-ref)) (not (sx-eq? s2 'structure-set!)) (not (sx-eq? s2 'structure?)) (assq (sx-datum s2) *primitive-procedure-handlers*))) (fuck-up))) (create-expression 'primitive-procedure s (unencapsulate (sx-rest s)))) ((foreign-procedure) (unless (or (and (= (sx-length s) 4) (sx-list? (sx-second s)) (sx-every valid-foreign-parameter-type? (sx-second s)) (valid-foreign-return-type? (sx-third s)) (sx-string? (sx-fourth s))) (and (= (sx-length s) 5) (sx-list? (sx-second s)) (sx-every valid-foreign-parameter-type? (sx-second s)) (valid-foreign-return-type? (sx-third s)) (sx-string? (sx-fourth s)) (sx-string? (sx-fifth s)))) (fuck-up)) (create-expression 'foreign-procedure s (unencapsulate (sx-rest s)))) (else (if (macro? (sx-first s)) (macroexpand (expand-macro s) gs #f f) (create-call-expression s (macroexpand (sx-first s) gs #f f) (sx-map (lambda (s) (macroexpand s gs #f f)) (sx-rest s)))))) (create-call-expression s (macroexpand (sx-first s) gs #f f) (sx-map (lambda (s) (macroexpand s gs #f f)) (sx-rest s))))) ((sx-symbol? s) (create-access-expression s (variable s gs))) (else (macroexpand-constant s)))) (macroexpand s '() #f "top level")) ;;; Fast tree shake (define (fast-tree-shake!) (when (and (eq? (expression-kind *x*) 'lambda) (list? (expression-parameters *x*)) (= (length (expression-parameters *x*)) 1) (expression-body *x*) (eq? (expression-kind (expression-body *x*)) 'call) (eq? (expression-kind (expression-callee (expression-body *x*))) 'lambda) (eq? (expression-kind (expression-body (expression-callee (expression-body *x*)))) 'call) (eq? (expression-kind (expression-callee (expression-body (expression-callee (expression-body *x*))))) 'lambda) (list? (expression-parameters (expression-callee (expression-body (expression-callee (expression-body *x*)))))) (= (length (expression-parameters (expression-callee (expression-body (expression-callee (expression-body *x*)))))) 219) (every hunoz? (expression-parameters (expression-callee (expression-body (expression-callee (expression-body *x*)))))) (= (count-if-not (lambda (x) (eq? (expression-kind x) 'set!)) (expression-arguments (expression-body (expression-callee (expression-body *x*))))) 1) (eq? (expression-kind (expression-body (expression-callee (expression-body (expression-callee (expression-body *x*)))))) 'call) (= (length (expression-arguments (expression-body (expression-callee (expression-body (expression-callee (expression-body *x*))))))) 214) (every (lambda (x) (eq? (expression-kind x) 'access)) (expression-arguments (expression-body (expression-callee (expression-body (expression-callee (expression-body *x*))))))) (eq? (expression-kind (expression-callee (expression-body (expression-callee (expression-body (expression-callee (expression-body *x*))))))) 'lambda) (list? (expression-parameters (expression-callee (expression-body (expression-callee (expression-body (expression-callee (expression-body *x*)))))))) (= (length (expression-parameters (expression-callee (expression-body (expression-callee (expression-body (expression-callee (expression-body *x*)))))))) 214) (eq? (expression-kind (expression-body (expression-callee (expression-body (expression-callee (expression-body (expression-callee (expression-body *x*)))))))) 'call) (every (lambda (x) (and (eq? (expression-kind x) 'call) (null? (expression-arguments x)) (eq? (expression-kind (expression-callee x)) 'lambda) (not (expression-body (expression-callee x))) (null? (expression-parameters (expression-callee x))))) (expression-arguments (expression-body (expression-callee (expression-body (expression-callee (expression-body (expression-callee (expression-body *x*))))))))) (eq? (expression-kind (expression-callee (expression-body (expression-callee (expression-body (expression-callee (expression-body (expression-callee (expression-body *x*))))))))) 'lambda) (list? (expression-parameters (expression-callee (expression-body (expression-callee (expression-body (expression-callee (expression-body (expression-callee (expression-body *x*)))))))))) (eq? (expression-kind (expression-body (expression-callee (expression-body (expression-callee (expression-body (expression-callee (expression-body (expression-callee (expression-body *x*)))))))))) 'call) (eq? (expression-kind (expression-callee (expression-body (expression-callee (expression-body (expression-callee (expression-body (expression-callee (expression-body (expression-callee (expression-body *x*))))))))))) 'lambda) (list? (expression-parameters (expression-callee (expression-body (expression-callee (expression-body (expression-callee (expression-body (expression-callee (expression-body (expression-callee (expression-body *x*)))))))))))) (every hunoz? (expression-parameters (expression-callee (expression-body (expression-callee (expression-body (expression-callee (expression-body (expression-callee (expression-body (expression-callee (expression-body *x*))))))))))))) (let* ((gs (expression-parameters (expression-callee (expression-body (expression-callee (expression-body (expression-callee (expression-body (expression-callee (expression-body *x*)))))))))) (xs (cons (expression-body (expression-callee (expression-body (expression-callee (expression-body (expression-callee (expression-body (expression-callee (expression-body (expression-callee (expression-body *x*))))))))))) (expression-arguments (expression-body (expression-callee (expression-body (expression-callee (expression-body (expression-callee (expression-body (expression-callee (expression-body *x*)))))))))))) (xs1 (remove-if-not (lambda (x) (and (eq? (expression-kind x) 'set!) (eq? (expression-kind (expression-source x)) 'lambda) (memq (expression-variable x) gs) (one (lambda (x1) (and (eq? (expression-kind x1) 'set!) (eq? (expression-variable x) (expression-variable x1)))) *xs*))) xs)) (xs2 (set-differenceq xs xs1))) (for-each (lambda (x) (set-expression-accessed?! x #t)) *xs*) (for-each (lambda (g) (set-variable-accessed?! g #t)) *gs*) (for-each (lambda (x) (let loop ((x x)) (set-expression-accessed?! x #f) (case (expression-kind x) ((null-constant) #f) ((true-constant) #f) ((false-constant) #f) ((char-constant) #f) ((fixnum-constant) #f) ((flonum-constant) #f) ((rectangular-constant) #f) ((string-constant) #f) ((symbol-constant) #f) ((pair-constant) (loop (car (expression-constant x))) (loop (cdr (expression-constant x)))) ((vector-constant) (for-each-vector loop (expression-constant x))) ((lambda converted-lambda converted-continuation) (let loop ((gs (expression-parameters x))) (cond ((pair? gs) (set-variable-accessed?! (first gs) #f) (loop (rest gs))) ((variable? gs) (set-variable-accessed?! gs #f)))) (when (expression-body x) (loop (expression-body x)))) ((set!) (loop (expression-source x))) ((if) (loop (expression-antecedent x)) (loop (expression-consequent x)) (loop (expression-alternate x))) ((primitive-procedure) #f) ((foreign-procedure) #f) ((access) #f) ((call converted-call) (loop (expression-callee x)) (for-each loop (expression-arguments x))) (else (fuck-up))))) xs1) (for-each (lambda (g) (when (some (lambda (x) (eq? (expression-variable x) g)) xs1) (set-variable-accessed?! g #f))) gs) (for-each (lambda (x) (let loop ((x x)) (case (expression-kind x) ((null-constant) #f) ((true-constant) #f) ((false-constant) #f) ((char-constant) #f) ((fixnum-constant) #f) ((flonum-constant) #f) ((rectangular-constant) #f) ((string-constant) #f) ((symbol-constant) #f) ((pair-constant) #f) ((vector-constant) #f) ((lambda converted-lambda converted-continuation) (when (expression-body x) (loop (expression-body x)))) ((set!) (loop (expression-source x))) ((if) (loop (expression-antecedent x)) (loop (expression-consequent x)) (loop (expression-alternate x))) ((primitive-procedure) #f) ((foreign-procedure) #f) ((access) (when (memq (expression-variable x) gs) (set-variable-accessed?! (expression-variable x) #t))) ((call converted-call) (loop (expression-callee x)) (for-each loop (expression-arguments x))) (else (fuck-up))))) xs2) (let loop () (let ((again? #f)) (for-each (lambda (x) (when (variable-accessed? (expression-variable x)) (let loop ((x x)) (set-expression-accessed?! x #t) (case (expression-kind x) ((null-constant) #f) ((true-constant) #f) ((false-constant) #f) ((char-constant) #f) ((fixnum-constant) #f) ((flonum-constant) #f) ((rectangular-constant) #f) ((string-constant) #f) ((symbol-constant) #f) ((pair-constant) (loop (car (expression-constant x))) (loop (cdr (expression-constant x)))) ((vector-constant) (for-each-vector loop (expression-constant x))) ((lambda converted-lambda converted-continuation) (let loop ((gs (expression-parameters x))) (cond ((pair? gs) (set-variable-accessed?! (first gs) #t) (loop (rest gs))) ((variable? gs) (set-variable-accessed?! gs #t)))) (when (expression-body x) (loop (expression-body x)))) ((set!) (loop (expression-source x))) ((if) (loop (expression-antecedent x)) (loop (expression-consequent x)) (loop (expression-alternate x))) ((primitive-procedure) #f) ((foreign-procedure) #f) ((access) (when (and (memq (expression-variable x) gs) (not (variable-accessed? (expression-variable x)))) (set-variable-accessed?! (expression-variable x) #t) (set! again? #t))) ((call converted-call) (loop (expression-callee x)) (for-each loop (expression-arguments x))) (else (fuck-up)))))) xs1) (when again? (loop)))) ;; Remove the unused variables. (set-expression-parameters! (expression-callee (expression-body (expression-callee (expression-body (expression-callee (expression-body (expression-callee (expression-body *x*)))))))) (remove-if-not variable-accessed? (expression-parameters (expression-callee (expression-body (expression-callee (expression-body (expression-callee (expression-body (expression-callee (expression-body *x*))))))))))) ;; Remove the extra noops that initialize the unused variables to undefined. (for-each (lambda (x) (let loop ((x x)) (set-expression-accessed?! x #f) (case (expression-kind x) ((null-constant) #f) ((true-constant) #f) ((false-constant) #f) ((char-constant) #f) ((fixnum-constant) #f) ((flonum-constant) #f) ((rectangular-constant) #f) ((string-constant) #f) ((symbol-constant) #f) ((pair-constant) (loop (car (expression-constant x))) (loop (cdr (expression-constant x)))) ((vector-constant) (for-each-vector loop (expression-constant x))) ((lambda converted-lambda converted-continuation) (let loop ((gs (expression-parameters x))) (cond ((pair? gs) (set-variable-accessed?! (first gs) #f) (loop (rest gs))) ((variable? gs) (set-variable-accessed?! gs #f)))) (when (expression-body x) (loop (expression-body x)))) ((set!) (loop (expression-source x))) ((if) (loop (expression-antecedent x)) (loop (expression-consequent x)) (loop (expression-alternate x))) ((primitive-procedure) #f) ((foreign-procedure) #f) ((access) #f) ((call converted-call) (loop (expression-callee x)) (for-each loop (expression-arguments x))) (else (fuck-up))))) (sublist (expression-arguments (expression-body (expression-callee (expression-body (expression-callee (expression-body (expression-callee (expression-body *x*)))))))) (length (expression-parameters (expression-callee (expression-body (expression-callee (expression-body (expression-callee (expression-body (expression-callee (expression-body *x*)))))))))) (length (expression-arguments (expression-body (expression-callee (expression-body (expression-callee (expression-body (expression-callee (expression-body *x*))))))))))) (set-expression-arguments! (expression-body (expression-callee (expression-body (expression-callee (expression-body (expression-callee (expression-body *x*))))))) (sublist (expression-arguments (expression-body (expression-callee (expression-body (expression-callee (expression-body (expression-callee (expression-body *x*)))))))) 0 (length (expression-parameters (expression-callee (expression-body (expression-callee (expression-body (expression-callee (expression-body (expression-callee (expression-body *x*)))))))))))) ;; Remove the unused definitions. (set-expression-arguments! (expression-body (expression-callee (expression-body (expression-callee (expression-body (expression-callee (expression-body (expression-callee (expression-body *x*))))))))) (remove-if-not expression-accessed? (expression-arguments (expression-body (expression-callee (expression-body (expression-callee (expression-body (expression-callee (expression-body (expression-callee (expression-body *x*)))))))))))) (unless (expression-accessed? (expression-body (expression-callee (expression-body (expression-callee (expression-body (expression-callee (expression-body (expression-callee (expression-body (expression-callee (expression-body *x*)))))))))))) (set-expression-body! (expression-callee (expression-body (expression-callee (expression-body (expression-callee (expression-body (expression-callee (expression-body (expression-callee (expression-body *x*)))))))))) #f)) ;; Remove the hunoz variables for the unused definitions. (for-each (lambda (g) (set-variable-accessed?! g #f)) (sublist (expression-parameters (expression-callee (expression-body (expression-callee (expression-body (expression-callee (expression-body (expression-callee (expression-body (expression-callee (expression-body *x*))))))))))) (length (expression-arguments (expression-body (expression-callee (expression-body (expression-callee (expression-body (expression-callee (expression-body (expression-callee (expression-body *x*))))))))))) (length (expression-parameters (expression-callee (expression-body (expression-callee (expression-body (expression-callee (expression-body (expression-callee (expression-body (expression-callee (expression-body *x*)))))))))))))) (set-expression-parameters! (expression-callee (expression-body (expression-callee (expression-body (expression-callee (expression-body (expression-callee (expression-body (expression-callee (expression-body *x*)))))))))) (sublist (expression-parameters (expression-callee (expression-body (expression-callee (expression-body (expression-callee (expression-body (expression-callee (expression-body (expression-callee (expression-body *x*))))))))))) 0 (length (expression-arguments (expression-body (expression-callee (expression-body (expression-callee (expression-body (expression-callee (expression-body (expression-callee (expression-body *x*))))))))))))) (set! *gs* (remove-if-not variable-accessed? *gs*)) (set! *xs* (remove-if-not expression-accessed? *xs*)) (set! *calls* (remove-if-not expression-accessed? *calls*)) (set! *accesses* (remove-if-not expression-accessed? *accesses*)) (set! *assignments* (remove-if-not expression-accessed? *assignments*)) (set! *references* (remove-if-not expression-accessed? *references*)) (set! *es* (remove-if-not (lambda (e) (expression-accessed? (environment-expression e))) *es*)) ;; This is just for error checking. (for-each (lambda (g) (set-variable-accessed?! g #f)) *gs*) (for-each (lambda (x) (set-expression-accessed?! x #f)) *xs*) (let loop ((x *x*)) (unless (memq x *xs*) (fuck-up)) (set-expression-accessed?! x #t) (case (expression-kind x) ((null-constant) #f) ((true-constant) #f) ((false-constant) #f) ((char-constant) #f) ((fixnum-constant) #f) ((flonum-constant) #f) ((rectangular-constant) #f) ((string-constant) #f) ((symbol-constant) #f) ((pair-constant) (loop (car (expression-constant x))) (loop (cdr (expression-constant x)))) ((vector-constant) (for-each-vector loop (expression-constant x))) ((lambda converted-lambda converted-continuation) (let loop ((gs (expression-parameters x))) (cond ((pair? gs) (unless (memq (first gs) *gs*) (fuck-up)) (set-variable-accessed?! (first gs) #t) (loop (rest gs))) ((variable? gs) (unless (memq gs *gs*) (fuck-up)) (set-variable-accessed?! gs #t)))) (when (expression-body x) (loop (expression-body x)))) ((set!) (unless (memq (expression-variable x) *gs*) (fuck-up)) (loop (expression-source x))) ((if) (loop (expression-antecedent x)) (loop (expression-consequent x)) (loop (expression-alternate x))) ((primitive-procedure) #f) ((foreign-procedure) #f) ((access) (unless (memq (expression-variable x) *gs*) (fuck-up))) ((call converted-call) (loop (expression-callee x)) (for-each loop (expression-arguments x))) (else (fuck-up)))) (unless (and (every variable-accessed? *gs*) (every expression-accessed? *xs*)) (fuck-up))))) ;;; Annotate expressions with their parents (define (annotate-expressions-with-their-parents!) (for-each (lambda (x) (set-expression-parent! x (unspecified))) *xs*) (set-expression-parent! *x* #f) (let loop ((x *x*)) (case (expression-kind x) ((null-constant) #f) ((true-constant) #f) ((false-constant) #f) ((char-constant) #f) ((fixnum-constant) #f) ((flonum-constant) #f) ((rectangular-constant) #f) ((string-constant) #f) ((symbol-constant) #f) ((pair-constant) (unless (eq? (expression-parent (car (expression-constant x))) (unspecified)) (fuck-up)) (set-expression-parent! (car (expression-constant x)) x) (unless (eq? (expression-parent (cdr (expression-constant x))) (unspecified)) (fuck-up)) (set-expression-parent! (cdr (expression-constant x)) x) (loop (car (expression-constant x))) (loop (cdr (expression-constant x)))) ((vector-constant) (for-each-vector (lambda (x1) (unless (eq? (expression-parent x1) (unspecified)) (fuck-up)) (set-expression-parent! x1 x) (loop x1)) (expression-constant x))) ((lambda converted-lambda converted-continuation) (unless (noop? x) (unless (eq? (expression-parent (expression-body x)) (unspecified)) (fuck-up)) (set-expression-parent! (expression-body x) x) (loop (expression-body x)))) ((set!) (unless (eq? (expression-parent (expression-source x)) (unspecified)) (fuck-up)) (set-expression-parent! (expression-source x) x) (loop (expression-source x))) ((if) (unless (eq? (expression-parent (expression-antecedent x)) (unspecified)) (fuck-up)) (set-expression-parent! (expression-antecedent x) x) (unless (eq? (expression-parent (expression-consequent x)) (unspecified)) (fuck-up)) (set-expression-parent! (expression-consequent x) x) (unless (eq? (expression-parent (expression-alternate x)) (unspecified)) (fuck-up)) (set-expression-parent! (expression-alternate x) x) (loop (expression-antecedent x)) (loop (expression-consequent x)) (loop (expression-alternate x))) ((primitive-procedure) #f) ((foreign-procedure) #f) ((access) #f) ((call converted-call) (unless (eq? (expression-parent (expression-callee x)) (unspecified)) (fuck-up)) (set-expression-parent! (expression-callee x) x) (loop (expression-callee x)) (for-each (lambda (x1) (unless (eq? (expression-parent x1) (unspecified)) (fuck-up)) (set-expression-parent! x1 x) (loop x1)) (expression-arguments x))) (else (fuck-up)))) ;; This is needed because, after CPS conversion, there may be dangling ;; expressions, particularly clones. (set! *xs* (remove-if (lambda (x) (eq? (expression-parent x) (unspecified))) *xs*)) (set! *calls* (remove-if (lambda (x) (eq? (expression-parent x) (unspecified))) *calls*)) (set! *accesses* (remove-if (lambda (x) (eq? (expression-parent x) (unspecified))) *accesses*)) (set! *assignments* (remove-if (lambda (x) (eq? (expression-parent x) (unspecified))) *assignments*)) (set! *references* (remove-if (lambda (x) (eq? (expression-parent x) (unspecified))) *references*))) ;;; In-line first-order calls to primitive procedures (define (first-order-position? x) (or (not (expression-parent x)) (and (or (eq? (expression-kind (expression-parent x)) 'call) (eq? (expression-kind (expression-parent x)) 'converted-call)) (eq? x (expression-callee (expression-parent x)))) (and (eq? (expression-kind (expression-parent x)) 'if) (or (eq? x (expression-antecedent (expression-parent x))) (first-order-position? (expression-parent x)))))) (define *primitive-procedure-rewrites* ;; needs work: This doesn't in-line the procedures created by ;; DEFINE-STRUCTURE. '((not not) (boolean? boolean?) (eq? eq?) (pair? structure? pair) (cons make-structure pair 2) (car structure-ref pair 0) (cdr structure-ref pair 1) (set-car! structure-set! pair 0) (set-cdr! structure-set! pair 1) (null? null?) (symbol? symbol?) (symbol->string symbol->string) (string->uninterned-symbol string->uninterned-symbol) (number? number?) (real? real?) (integer? integer?) (exact? exact?) (inexact? inexact?) (= =) (< <) (> >) (<= <=) (>= >=) (zero? zero?) (positive? positive?) (negative? negative?) (max max) (min min) (+ +) (* *) (- -) (/ /) (quotient quotient) (remainder remainder) (<< <<) (>> >>) (bitwise-not bitwise-not) (bitwise-and bitwise-and) (bitwise-or bitwise-or) (bitwise-xor bitwise-xor) (floor floor) (ceiling ceiling) (truncate truncate) (round round) (exp exp) (log log) (sin sin) (cos cos) (tan tan) (asin asin) (acos acos) (atan atan) (sqrt sqrt) (expt expt) (exact->inexact exact->inexact) (inexact->exact inexact->exact) (char? char?) (char->integer char->integer) (integer->char integer->char) (string? string?) (make-string make-string) (string string) (string-length string-length) (string-ref string-ref) (string-set! string-set!) (vector? vector?) (make-vector make-vector) (make-displaced-vector make-displaced-vector) (vector vector) (vector-length vector-length) (vector-ref vector-ref) (vector-set! vector-set!) (procedure? procedure?) (apply apply) (call-with-current-continuation call-with-current-continuation) (input-port? input-port?) (output-port? output-port?) (open-input-file open-input-file) (open-output-file open-output-file) (close-input-port close-input-port) (close-output-port close-output-port) (eof-object? eof-object?) (panic panic) (pointer? pointer?) (integer->string integer->string) (integer->input-port integer->input-port) (integer->output-port integer->output-port) (integer->pointer integer->pointer))) (define (in-line-first-order-calls-to-primitive-procedures!) (let ((xs (remove-if-not (lambda (x) (and (first-order-position? x) (expression-parent x) (assq (variable-name (expression-variable x)) *primitive-procedure-rewrites*) (not (empty? (parent (variable-environment (expression-variable x))))) (or (empty? (parent (parent (variable-environment (expression-variable x))))) (and (not (empty? (parent (parent (parent (variable-environment (expression-variable x))))))) (empty? (parent (parent (parent (parent (variable-environment (expression-variable x))))))) (not (some (lambda (x1) (eq? (expression-variable x1) (expression-variable x))) *assignments*)))))) *accesses*))) (for-each (lambda (x) ((cond ((or (eq? (expression-kind (expression-parent x)) 'call) (eq? (expression-kind (expression-parent x)) 'converted-call)) set-expression-callee!) ((and (eq? (expression-kind (expression-parent x)) 'if) (eq? x (expression-antecedent (expression-parent x)))) set-expression-antecedent!) ((and (eq? (expression-kind (expression-parent x)) 'if) (eq? x (expression-consequent (expression-parent x)))) set-expression-consequent!) ((and (eq? (expression-kind (expression-parent x)) 'if) (eq? x (expression-alternate (expression-parent x)))) set-expression-alternate!) (else (fuck-up))) (expression-parent x) (create-expression 'primitive-procedure x (cdr (assq (variable-name (expression-variable x)) *primitive-procedure-rewrites*))))) xs) (set! *xs* (set-differenceq *xs* xs)) (set! *accesses* (set-differenceq *accesses* xs)) (set! *references* (set-differenceq *references* xs)))) ;;; Annotate variables with their environments (define (annotate-environment-variables-with-their-environment! e) (for-each (lambda (g) (unless (eq? (variable-environment g) (unspecified)) (fuck-up)) (set-variable-environment! g e)) (variables e))) (define (annotate-variables-with-their-environments!) (for-each (lambda (g) (set-variable-environment! g (unspecified))) *gs*) (for-each annotate-environment-variables-with-their-environment! *es*) (when (some (lambda (g) (eq? (variable-environment g) (unspecified))) *gs*) (fuck-up))) ;;; Annotate expressions with their environments (define (annotate-environment-expressions-with-their-environment! e) (unless (eq? e (narrow-prototype e)) (unless (eq? (expression-environment (environment-expression e)) (unspecified)) (fuck-up)) (set-expression-environment! (environment-expression e) (let loop ((x (expression-parent (environment-expression (narrow-prototype e))))) (if (or (eq? (expression-kind x) 'lambda) (eq? (expression-kind x) 'converted-lambda) (eq? (expression-kind x) 'converted-continuation)) (expression-lambda-environment x) (loop (expression-parent x)))))) (unless (noop? e) (let loop ((x (expression-body (environment-expression e)))) (unless (eq? (expression-environment x) (unspecified)) (fuck-up)) (set-expression-environment! x e) (case (expression-kind x) ((null-constant) #f) ((true-constant) #f) ((false-constant) #f) ((char-constant) #f) ((fixnum-constant) #f) ((flonum-constant) #f) ((rectangular-constant) #f) ((string-constant) #f) ((symbol-constant) #f) ((pair-constant) (loop (car (expression-constant x))) (loop (cdr (expression-constant x)))) ((vector-constant) (for-each-vector loop (expression-constant x))) ((lambda converted-lambda converted-continuation) #f) ((set!) (loop (expression-source x))) ((if) (loop (expression-antecedent x)) (loop (expression-consequent x)) (loop (expression-alternate x))) ((primitive-procedure) #f) ((foreign-procedure) #f) ((access) #f) ((call converted-call) (loop (expression-callee x)) (for-each loop (expression-arguments x))) (else (fuck-up)))))) (define (annotate-expressions-with-their-environments!) (for-each (lambda (x) (set-expression-environment! x (unspecified))) *xs*) (set-expression-environment! *x* #f) (for-each annotate-environment-expressions-with-their-environment! *es*) (when (some (lambda (x) (eq? (expression-environment x) (unspecified))) *xs*) (fuck-up))) ;;; Annotate variables with their references (define (annotate-variables-with-their-references!) (for-each (lambda (g) (set-variable-accesses! g '()) (set-variable-assignments! g '()) (set-variable-references! g '())) *gs*) (for-each (lambda (x) (case (expression-kind x) ((null-constant) #f) ((true-constant) #f) ((false-constant) #f) ((char-constant) #f) ((fixnum-constant) #f) ((flonum-constant) #f) ((rectangular-constant) #f) ((string-constant) #f) ((symbol-constant) #f) ((pair-constant) #f) ((vector-constant) #f) ((lambda converted-lambda converted-continuation) #f) ((set!) (set-variable-assignments! (expression-variable x) (cons x (variable-assignments (expression-variable x)))) (set-variable-references! (expression-variable x) (cons x (variable-references (expression-variable x))))) ((if) #f) ((primitive-procedure) #f) ((foreign-procedure) #f) ((access) (set-variable-accesses! (expression-variable x) (cons x (variable-accesses (expression-variable x)))) (set-variable-references! (expression-variable x) (cons x (variable-references (expression-variable x))))) ((call converted-call) #f) (else (fuck-up)))) *xs*)) ;;; Perform flow analysis ;;; Prior to conversion, `continues' and `returns' should be the same. Errors, ;;; infinite loops, and calls to PANIC, no-return foreign procedures, ;;; continuations don't return and don't continue. After conversion, `returns' ;;; implies `continues' but not vice versa. But even here, `continues' and ;;; `returns' should be the same for implicit continuation calls. Errors, ;;; infinite loops, and (both converted and nonconverted) calls to PANIC, ;;; no-return foreign procedures, and nonconverted continuations don't ;;; continue or return. (Both converted and nonconverted) calls to converted ;;; continuations and converted native procedures might return but don't ;;; continue. And converted calls whose implicit continuation call doesn't ;;; return might continue but don't return. (define (environment-continues? e) (when (or (converted? e) (converted-continuation? e)) (fuck-up)) (or (noop? e) (expression-continues? (expression-body (environment-expression e))))) (define (environment-returns? e) (or (noop? e) (expression-returns? (expression-body (environment-expression e))))) (define (continues? ws w y) (when (continuation-argument-call-site? y) (fuck-up)) (lambda (u) (and ((truly-compatible-procedure? ws w y) u) ;; Calls to nonconverted continuations never continue. (or (and (primitive-procedure-type? u) (cond (((primitive-procedure-type-named? 'apply) u) (and (if (converted? y) (cond ((null? ws) (can-be? (lambda (u) (and ((list-type-of-length-at-least? 2) u) (can-be? (continues? (list (pair-type-car u)) (pair-type-cdr (pair-type-cdr u)) (recreate-call-site y 'first-argument)) (pair-type-car (pair-type-cdr u))))) w)) ((null? (rest ws)) (can-be? (lambda (u) (and ((list-type-of-length-at-least? 1) u) (can-be? (continues? ws (pair-type-cdr u) (recreate-call-site y 'first-argument)) (pair-type-car u)))) w)) (else (or (and (can-be? null-type? w) (can-be? (continues? (cons (first ws) (but-last (rest (rest ws)))) (last ws) (recreate-call-site y 'first-argument)) (second ws))) (can-be? (continues? (cons (first ws) (rest (rest ws))) w (recreate-call-site y 'first-argument)) (second ws))))) (if (null? ws) (can-be? (lambda (u) (and ((list-type-of-length-at-least? 1) u) (can-be? (continues? '() (pair-type-cdr u) (recreate-call-site y 'first-argument)) (pair-type-car u)))) w) (or (and (can-be? null-type? w) (can-be? (continues? (but-last (rest ws)) (last ws) (recreate-call-site y 'first-argument)) (first ws))) (can-be? (continues? (rest ws) w (recreate-call-site y 'first-argument)) (first ws))))))) (((primitive-procedure-type-named? 'call-with-current-continuation) u) (and (or (if (converted? y) (cond ((null? ws) (can-be? (lambda (u) (and ((list-type-of-length? 2) u) (can-be? (continues? (list (pair-type-car u) (pair-type-car u)) (pair-type-cdr (pair-type-cdr u)) (recreate-call-site y 'first-argument)) (pair-type-car (pair-type-cdr u))))) w)) ((null? (rest ws)) (can-be? (lambda (u) (and ((list-type-of-length? 1) u) (can-be? (continues? (list (first ws) (first ws)) (pair-type-cdr u) (recreate-call-site y 'first-argument)) (pair-type-car u)))) w)) (else (can-be? (continues? (cons (first ws) (cons (first ws) (rest (rest ws)))) w (recreate-call-site y 'first-argument)) (second ws)))) (if (null? ws) (can-be? (lambda (u) (and ((list-type-of-length? 1) u) (can-be? (continues? (list (create-anonymous-type-set ( (call-site-expression y)))) (pair-type-cdr u) (recreate-call-site y 'first-argument)) (pair-type-car u)))) w) (can-be? (continues? (list (create-anonymous-type-set ( (call-site-expression y)))) w (recreate-call-site y 'first-argument)) (first ws)))) (some (lambda (u) (and ((continuation-type-to? (call-site-expression y)) u) (continuation-type-continuation-accessed? u))) *continuation-types*)))) (((primitive-procedure-type-named? 'panic) u) #f) (((primitive-procedure-type-named? 'fork) u) ;; needs work: To handle converted calls to FORK. (when (converted? y) (unimplemented y "unimplemented")) ;; For now, calls to FORK always continue. #t) (((primitive-procedure-type-named? 'mutex) u) ;; needs work: To handle converted calls to MUTEX. (when (converted? y) (unimplemented y "unimplemented")) ;; For now, calls to MUTEX always continue. #t) (else #t))) (and (native-procedure-type? u) (not (converted? (callee-environment u y))) (not (converted-continuation? (callee-environment u y))) (environment-continues? (callee-environment u y))) (and (foreign-procedure-type? u) (foreign-procedure-returns? u)))))) (define (returns? ws w y) (lambda (u) (and ((truly-compatible-procedure? ws w y) u) ;; Calls to nonconverted continuations never return. (or (and (primitive-procedure-type? u) (cond (((primitive-procedure-type-named? 'apply) u) (and (if (converted? y) (cond ((null? ws) (can-be? (lambda (u) (and ((list-type-of-length-at-least? 2) u) (can-be? (returns? (list (pair-type-car u)) (pair-type-cdr (pair-type-cdr u)) (recreate-call-site y 'first-argument)) (pair-type-car (pair-type-cdr u))))) w)) ((null? (rest ws)) (can-be? (lambda (u) (and ((list-type-of-length-at-least? 1) u) (can-be? (returns? ws (pair-type-cdr u) (recreate-call-site y 'first-argument)) (pair-type-car u)))) w)) (else (or (and (can-be? null-type? w) (can-be? (returns? (cons (first ws) (but-last (rest (rest ws)))) (last ws) (recreate-call-site y 'first-argument)) (second ws))) (can-be? (returns? (cons (first ws) (rest (rest ws))) w (recreate-call-site y 'first-argument)) (second ws))))) (if (null? ws) (can-be? (lambda (u) (and ((list-type-of-length-at-least? 1) u) (can-be? (returns? '() (pair-type-cdr u) (recreate-call-site y 'first-argument)) (pair-type-car u)))) w) (or (and (can-be? null-type? w) (can-be? (returns? (but-last (rest ws)) (last ws) (recreate-call-site y 'first-argument)) (first ws))) (can-be? (returns? (rest ws) w (recreate-call-site y 'first-argument)) (first ws))))))) (((primitive-procedure-type-named? 'call-with-current-continuation) u) (and (or (if (converted? y) (cond ((null? ws) (can-be? (lambda (u) (and ((list-type-of-length? 2) u) (can-be? (returns? (list (pair-type-car u) (pair-type-car u)) (pair-type-cdr (pair-type-cdr u)) (recreate-call-site y 'first-argument)) (pair-type-car (pair-type-cdr u))))) w)) ((null? (rest ws)) (can-be? (lambda (u) (and ((list-type-of-length? 1) u) (can-be? (returns? (list (first ws) (first ws)) (pair-type-cdr u) (recreate-call-site y 'first-argument)) (pair-type-car u)))) w)) (else (can-be? (returns? (cons (first ws) (cons (first ws) (rest (rest ws)))) w (recreate-call-site y 'first-argument)) (second ws)))) (if (null? ws) (can-be? (lambda (u) (and ((list-type-of-length? 1) u) (can-be? (returns? (list (create-anonymous-type-set ( (call-site-expression y)))) (pair-type-cdr u) (recreate-call-site y 'first-argument)) (pair-type-car u)))) w) (can-be? (returns? (list (create-anonymous-type-set ( (call-site-expression y)))) w (recreate-call-site y 'first-argument)) (first ws)))) (some (lambda (u) (and ((continuation-type-to? (call-site-expression y)) u) (continuation-type-continuation-accessed? u))) *continuation-types*)))) (((primitive-procedure-type-named? 'panic) u) #f) (((primitive-procedure-type-named? 'fork) u) ;; needs work: To handle converted calls to FORK. (when (converted? y) (unimplemented y "unimplemented")) ;; For now, calls to FORK always return. #t) (((primitive-procedure-type-named? 'mutex) u) ;; needs work: To handle converted calls to MUTEX. (when (converted? y) (unimplemented y "unimplemented")) ;; For now, calls to MUTEX always return. #t) (else (or (not (converted? y)) (can-be? (returns? (list *void*) *null* (recreate-call-site y 'continuation-argument)) (first ws)))))) (and (native-procedure-type? u) (environment-returns? (callee-environment u y)) (or (not (converted? y)) (converted? (callee-environment u y)) (converted-continuation? (callee-environment u y)) (not (environment-continues? (callee-environment u y))) (can-be? (returns? (list *void*) *null* (recreate-call-site y 'continuation-argument)) (first ws)))) (and (foreign-procedure-type? u) (foreign-procedure-returns? u) (or (not (converted? y)) (can-be? (returns? (list *void*) *null* (recreate-call-site y 'continuation-argument)) (first ws)))))))) (define (needs-implicit-continuation-call? ws w y) (unless (converted? y) (fuck-up)) (lambda (u) (and ((truly-compatible-procedure? ws w y) u) ;; Calls to nonconverted continuations never continue so you never need to ;; implicitly call the continuation after a call to a nonconverted ;; continuation. (or (and (primitive-procedure-type? u) (cond ;; The call to APPLY doesn't implicitly call the continuation. The ;; first-argument call does. (((primitive-procedure-type-named? 'apply) u) #f) ;; The call to CALL-WITH-CURRENT-CONTINUATION doesn't implicitly ;; call the continuation. The first-argument call does. (((primitive-procedure-type-named? 'call-with-current-continuation) u) #f) ;; PANIC doesn't continue so you never need to imlicitly call the ;; continuation after a call to PANIC. (((primitive-procedure-type-named? 'panic) u) #f) ;; needs work: To handle converted calls to FORK. (((primitive-procedure-type-named? 'fork) u) (unimplemented y "unimplemented")) ;; needs work: To handle converted calls to MUTEX. (((primitive-procedure-type-named? 'mutex) u) (unimplemented y "unimplemented")) ;; Assume all other primitive procedures continue. Since the primitive ;; procedures are not converted and don't implicitly call the ;; continuation it must be implicitly called after the call to the ;; primitive procedure continues. (else #t))) (and (native-procedure-type? u) ;; The call to a converted native procedure doesn't implicitly ;; call the continuation. The converted native procedure does. (not (converted? (callee-environment u y))) ;; Calls to converted continuations never continue so you never ;; need to implicitly call the continuation after a call to a ;; converted continuation. (not (converted-continuation? (callee-environment u y))) (environment-continues? (callee-environment u y))) (and (foreign-procedure-type? u) (foreign-procedure-returns? u)))))) (define (first-argument-needs-implicit-continuation-call? ws w y) (unless (converted? y) (fuck-up)) (lambda (u) (and ((truly-compatible-procedure? ws w y) u) (or (and ((primitive-procedure-type-named? 'apply) u) (cond ((null? ws) (can-be? (lambda (u) (and ((list-type-of-length-at-least? 2) u) (can-be? (needs-implicit-continuation-call? (list (pair-type-car u)) (pair-type-cdr (pair-type-cdr u)) (recreate-call-site y 'first-argument)) (pair-type-car (pair-type-cdr u))))) w)) ((null? (rest ws)) (can-be? (lambda (u) (and ((list-type-of-length-at-least? 1) u) (can-be? (needs-implicit-continuation-call? ws (pair-type-cdr u) (recreate-call-site y 'first-argument)) (pair-type-car u)))) w)) (else (or (and (can-be? null-type? w) (can-be? (needs-implicit-continuation-call? (cons (first ws) (but-last (rest (rest ws)))) (last ws) (recreate-call-site y 'first-argument)) (second ws))) (can-be? (needs-implicit-continuation-call? (cons (first ws) (rest (rest ws))) w (recreate-call-site y 'first-argument)) (second ws)))))) (and ((primitive-procedure-type-named? 'call-with-current-continuation) u) (or (cond ((null? ws) (can-be? (lambda (u) (and ((list-type-of-length? 2) u) (can-be? (needs-implicit-continuation-call? (list (pair-type-car u) (pair-type-car u)) (pair-type-cdr (pair-type-cdr u)) (recreate-call-site y 'first-argument)) (pair-type-car (pair-type-cdr u))))) w)) ((null? (rest ws)) (can-be? (lambda (u) (and ((list-type-of-length? 1) u) (can-be? (needs-implicit-continuation-call? (list (first ws) (first ws)) (pair-type-cdr u) (recreate-call-site y 'first-argument)) (pair-type-car u)))) w)) (else (can-be? (needs-implicit-continuation-call? (cons (first ws) (cons (first ws) (rest (rest ws)))) w (recreate-call-site y 'first-argument)) (second ws)))) (some (lambda (u) (and ((continuation-type-to? (call-site-expression y)) u) (continuation-type-continuation-accessed? u))) *continuation-types*))) (and ((primitive-procedure-type-named? 'fork) u) ;; needs work: To handle converted calls to FORK. (unimplemented y "unimplemented")) (and ((primitive-procedure-type-named? 'mutex) u) ;; needs work: To handle converted calls to MUTEX. (unimplemented y "unimplemented")))))) (define (assert-member! u w) (unless (member? u w) (insert-member! u w) (set! *again?* #t) ;; This is purely for efficiency. ;; It runs the inference rules for an expression when the type set of a ;; subexpression is widened. (when (and (type-set-location w) (expression? (type-set-location w)) (expression? (expression-parent (type-set-location w))) (not (eq? (expression-kind (expression-parent (type-set-location w))) 'lambda)) (not (eq? (expression-kind (expression-parent (type-set-location w))) 'converted-lambda)) (not (eq? (expression-kind (expression-parent (type-set-location w))) 'converted-continuation))) (push! (expression-parent (type-set-location w)))) ;; This is purely for efficiency. ;; It runs the inference rules for a call when the return type set of ;; the callee is widened. (when (and (type-set-location w) (expression? (type-set-location w)) (expression? (expression-parent (type-set-location w))) ;; The next expression is a kludge. (environment? (expression-lambda-environment (expression-parent (type-set-location w))))) (for-each (lambda (y) (unless (top-level-call-site? y) (push! (call-site-expression y)))) (call-sites (expression-lambda-environment (expression-parent (type-set-location w)))))) ;; This is purely for efficiency. ;; It runs the inference rules for an access when the type set of a ;; variable is widened. (when (and (type-set-location w) (variable? (type-set-location w))) (for-each push! (accesses (type-set-location w)))))) (define (assert-subset! w1 w2) (for-each-member (lambda (u1) (assert-member! u1 w2)) w1)) (define (assert-continues! x) (unless (expression-continues? x) (set-expression-continues?! x #t) (set! *again?* #t))) (define (assert-returns! x) (unless (expression-returns? x) (set-expression-returns?! x #t) (set! *again?* #t) ;; This is purely for efficiency. ;; It runs the inference rules for an expression when a subexpression ;; returns. (when (and (expression? (expression-parent x)) (not (eq? (expression-kind (expression-parent x)) 'lambda)) (not (eq? (expression-kind (expression-parent x)) 'converted-lambda)) (not (eq? (expression-kind (expression-parent x)) 'converted-continuation))) (push! (expression-parent x))) ;; This is purely for efficiency. ;; It runs the inference rules for a call when the callee returns. (when (and (expression? (expression-parent x)) ;; The next expression is a kludge. (environment? (expression-lambda-environment (expression-parent x)))) (for-each (lambda (y) (unless (top-level-call-site? y) (push! (call-site-expression y)))) (call-sites (expression-lambda-environment (expression-parent x))))))) (define (assert-expression-reached! x) (unless (expression-reached? x) (if (and (or (eq? (expression-kind x) 'lambda) (eq? (expression-kind x) 'converted-lambda) (eq? (expression-kind x) 'converted-continuation)) ;; The next expression is a kludge. (environment? (expression-lambda-environment x))) ;; note: This is because the EXPRESSION-REACHED? slot gets reset for ;; each round of flow analysis and clones are not anchored in ;; lambda expressions so their EXPRESSION-REACHED? slot never gets ;; set on subsequent passes. (for-each (lambda (e) (set-expression-reached?! (environment-expression e) #t)) (narrow-clones (expression-lambda-environment x))) (set-expression-reached?! x #t)) (set! *again?* #t) ;; This is purely for efficiency. ;; It runs the inference rule for an expression when it is used. (push! x))) (define (propagate-call! y w0 ws w) (for-each-member (lambda (u) (when ((truly-compatible-procedure? ws w y) u) (cond ((primitive-procedure-type? u) ;; Top-level calls should never be to a primitive procedure. ;; Implicit continuation calls should never be to a primitive procedure. (when (or (top-level-call-site? y) (continuation-argument-call-site? y)) (fuck-up)) (let ((w0 (if (converted? y) (first ws) #f)) (ws (if (converted? y) (rest ws) ws))) (let ((propagate-result! (if (converted? y) (lambda (u) (propagate-call! (recreate-call-site y 'continuation-argument) w0 (list (create-anonymous-type-set u)) *null*)) (lambda (u) ;; This works because APPLY and ;; CALL-WITH-CURRENT-CONTINUATION always return the result ;; returned by the call to their procedure argument. (assert-member! u (expression-type-set (call-site-expression y))))))) ;; conventions: PROPAGATE-RESULT! (((primitive-procedure-propagate-call! (cdr (assq (primitive-procedure-type-name u) *primitive-procedure-handlers*))) y u propagate-result! (lambda (m) (when (can-be? m (first ws)) (propagate-result! )) (when (can-be-non? m (first ws)) (propagate-result! ))) w0) ws w)) ;; For the life of me I can't remember what this does but if it is ;; removed then test21.sc and em-functional.sc break. ;; On R23May96 I partially rediscovered why this is needed. It is ;; because a converted call to a primitive procedure like SET-CAR! ;; might not ever call PROPAGATE-RESULT! in the propagator so the ;; continuation never gets asserted as called. (when (and (converted? y) ((needs-implicit-continuation-call? (cons w0 ws) w y) u)) (propagate-call! (recreate-call-site y 'continuation-argument) w0 (list *void*) *null*)))) ((native-procedure-type? u) (let ((e (callee-environment u y))) (when (and (not (converted? y)) (converted? e)) (fuck-up)) (unless (noop? e) (assert-expression-reached! (expression-body (environment-expression e)))) (unless (memp same-call-site? y (environment-call-sites e)) (set-environment-call-sites! e (cons y (environment-call-sites e)))) (let loop ((ws (if (and (converted? y) (not (converted? e))) (rest ws) ws)) (w w) (gs (variables e))) (unless (null? gs) (cond ((and (null? (rest gs)) (rest? e)) (set-type-set-used?! (variable-type-set (first gs)) #t) (if (null? ws) (assert-subset! w (variable-type-set (first gs))) ;; Since Y appears in the following and Y is #F at the top-level ;; call this assumes that the top level doesn't take a variable ;; number of arguments. ;; note: This is suboptimal since type propagation is not yet ;; complete and APPLY-CLOSED-WORLD-ASSUMPTION! has not ;; been done yet. (assert-member! ( (map members ws) (members w) (call-site-expression y)) (variable-type-set (first gs))))) ((null? ws) (for-each-member (lambda (u) (when ((if (rest? e) (list-type-of-length-at-least? (- (length gs) 1)) (list-type-of-length? (length gs))) u) (set-type-set-used?! (variable-type-set (first gs)) #t) (assert-subset! (pair-type-car u) (variable-type-set (first gs))) (loop ws (pair-type-cdr u) (rest gs)))) w)) (else (set-type-set-used?! (variable-type-set (first gs)) #t) (assert-subset! (first ws) (variable-type-set (first gs))) (loop (rest ws) w (rest gs)))))) ;; Top-level calls don't have an associated type set so there is no ;; need to propagate the return type. (unless (top-level-call-site? y) (when (and (converted? y) ((needs-implicit-continuation-call? ws w y) u)) (propagate-call! (recreate-call-site y 'continuation-argument) (first ws) (list (return-type-set e)) *null*)) ;; This works because APPLY and CALL-WITH-CURRENT-CONTINUATION always ;; return the result returned by the call to their procedure argument ;; and because implicit continuation calls should never be converted ;; and should never be through APPLY or CALL-WITH-CURRENT-CONTINUATION. (when ((returns? ws w y) u) (assert-subset! (return-type-set e) (expression-type-set (call-site-expression y))))))) ((foreign-procedure-type? u) ;; Top-level calls should never be to a foreign procedure. ;; Implicit continuation calls should never be to a foreign procedure. (when (or (top-level-call-site? y) (continuation-argument-call-site? y)) (fuck-up)) (set-foreign-procedure-type-called?! u #t) (when (and (converted? y) ((needs-implicit-continuation-call? ws w y) u)) (propagate-call! (recreate-call-site y 'continuation-argument) (first ws) (list (foreign-procedure-return-type-set u)) *null*)) ;; This works because APPLY and CALL-WITH-CURRENT-CONTINUATION always ;; return the result returned by the call to their procedure argument. (when ((returns? ws w y) u) (assert-subset! (foreign-procedure-return-type-set u) (expression-type-set (call-site-expression y))))) ((continuation-type? u) ;; Top-level calls should never be to a continuation. ;; Implicit continuation calls should never be to a continuation. (when (or (top-level-call-site? y) (continuation-argument-call-site? y)) (fuck-up)) ;; Calls to a nonconverted continuation should never be converted (even ;; if the argument to the call is converted) because they never return. ;; needs work: The above comment is not true because a call site might ;; call both a nonconverted continuation and somethings else ;; which does return and there might be a converted call to ;; a nonconverted continuation. (when (converted? y) (unimplemented y "unimplemented")) (set-continuation-type-continuation-accessed?! u #t) ;; Calls to nonconverted continuations never return. (let ((w1 (expression-type-set (continuation-type-allocating-expression u)))) (set-type-set-used?! w1 #t) (if (null? ws) (for-each-member (lambda (u) (when ((list-type-of-length? 1) u) (assert-subset! (pair-type-car u) w1))) w) (assert-subset! (first ws) w1)))) (else (fuck-up))))) w0)) (define (assert-types-in-if-context! us w x g p?) ;; conventions: P? (let ((x1 (expression-antecedent (expression-parent x)))) ;; note: Don't chain back through access, source of SET!, antecedent, ;; consequent, or alternate of IF, or callee or arguments of call. (cond ((eq? (expression-kind x1) 'call) (cond ((and (not (converted? x1)) (= (length (expression-arguments x1)) 1) (eq? (expression-kind (first (expression-arguments x1))) 'call)) (when (can-be? (primitive-procedure-type-named? 'not) (expression-type-set (expression-callee x1))) (let ((x2 (first (expression-arguments x1)))) (when (eq? (expression-kind x2) 'call) (for-each-member (lambda (u) (when ((truly-compatible-call? x2) u) ;; note: Don't chain back through calls to continuations or native ;; or foreign procedures. (if (primitive-procedure-type? u) (let loop ((us us) (xs (expression-arguments x2)) (ps (((if p? primitive-procedure-alternate-contexts primitive-procedure-consequent-contexts) (cdr (assq (primitive-procedure-type-name u) *primitive-procedure-handlers*))) (create-call-site x2) u (length (expression-arguments x2)) (if (converted? x2) (expression-type-set (first (expression-arguments x2))) #f)))) ;; conventions: PS (if (null? xs) (assert-types-in-context! us w (expression-parent x) g) (loop (if (and (eq? (expression-kind (first xs)) 'access) (eq? (expression-variable (first xs)) g)) (remove-if-not (first ps) us) us) (rest xs) (rest ps)))) (assert-types-in-context! us w (expression-parent x) g)))) (expression-type-set (expression-callee x2)))))) (when (can-be-non? (primitive-procedure-type-named? 'not) (expression-type-set (expression-callee x1))) (assert-types-in-context! us w (expression-parent x) g))) (else (for-each-member (lambda (u) (when ((truly-compatible-call? x1) u) ;; note: Don't chain back through calls to continuations or native or ;; foreign procedures. (if (primitive-procedure-type? u) (let loop ((us us) (xs (expression-arguments x1)) (ps (((if p? primitive-procedure-consequent-contexts primitive-procedure-alternate-contexts) (cdr (assq (primitive-procedure-type-name u) *primitive-procedure-handlers*))) (create-call-site x1) u (length (expression-arguments x1)) (if (converted? x1) (expression-type-set (first (expression-arguments x1))) #f)))) ;; conventions: PS (if (null? xs) (assert-types-in-context! us w (expression-parent x) g) (loop (if (and (eq? (expression-kind (first xs)) 'access) (eq? (expression-variable (first xs)) g)) (remove-if-not (first ps) us) us) (rest xs) (rest ps)))) (assert-types-in-context! us w (expression-parent x) g)))) (expression-type-set (expression-callee x1)))))) ((eq? (expression-kind x1) 'access) (assert-types-in-context! (if (eq? (expression-variable x1) g) (remove-if-not (if p? (lambda (u) (not (false-type? u))) false-type?) us) us) w (expression-parent x) g)) (else (assert-types-in-context! us w (expression-parent x) g))))) (define (assert-types-in-context! us w x g) (when (expression? (expression-parent x)) (case (expression-kind (expression-parent x)) ((lambda converted-lambda converted-continuation) ;; note: Don't chain back through callers except for LETs. Would have to ;; union across callers using demon. (if (let? (expression-lambda-environment (expression-parent x))) (assert-types-in-context! us w (expression-parent x) g) (for-each (lambda (u) (assert-member! u w)) us))) ((if) (cond ((eq? x (expression-consequent (expression-parent x))) (assert-types-in-if-context! us w x g #t)) ((eq? x (expression-alternate (expression-parent x))) (assert-types-in-if-context! us w x g #f)) (else (assert-types-in-context! us w (expression-parent x) g)))) (else (assert-types-in-context! us w (expression-parent x) g))))) (define (infer! x) (when (expression-reached? x) (let ((w (expression-type-set x))) (set-type-set-used?! w #t) (case (expression-kind x) ((null-constant) (unless (expression-inferred? x) (assert-member! w) (assert-continues! x) (assert-returns! x))) ((true-constant) (unless (expression-inferred? x) (assert-member! w) (assert-continues! x) (assert-returns! x))) ((false-constant) (unless (expression-inferred? x) (assert-member! w) (assert-continues! x) (assert-returns! x))) ((char-constant) (unless (expression-inferred? x) (assert-member! w) (assert-continues! x) (assert-returns! x))) ((fixnum-constant) (unless (expression-inferred? x) (assert-member! w) (assert-continues! x) (assert-returns! x))) ((flonum-constant) (unless (expression-inferred? x) (assert-member! w) (assert-continues! x) (assert-returns! x))) ((rectangular-constant) (unless (expression-inferred? x) (assert-member! w) (assert-continues! x) (assert-returns! x))) ((string-constant) (unless (expression-inferred? x) (assert-member! w) (assert-continues! x) (assert-returns! x))) ((symbol-constant) (unless (expression-inferred? x) (assert-member! (if *treat-all-symbols-as-external?* ( ) ( (expression-constant x))) w) (assert-continues! x) (assert-returns! x))) ((pair-constant) (unless (expression-inferred? x) (assert-expression-reached! (car (expression-constant x))) (assert-expression-reached! (cdr (expression-constant x)))) (assert-member! ( ;; note: This is suboptimal since type propagation is not yet complete ;; and APPLY-CLOSED-WORLD-ASSUMPTION! has not been done yet. (members (expression-type-set (car (expression-constant x)))) (members (expression-type-set (cdr (expression-constant x)))) x) w) (unless (expression-inferred? x) (assert-continues! x) (assert-returns! x))) ((vector-constant) (unless (expression-inferred? x) (for-each-vector assert-expression-reached! (expression-constant x))) (assert-member! ( ;; note: This is suboptimal since type propagation is not yet complete ;; and APPLY-CLOSED-WORLD-ASSUMPTION! has not been done yet. (reduce-vector unionq (map-vector (lambda (x1) (members (expression-type-set x1))) (expression-constant x)) '()) x) w) (unless (expression-inferred? x) (assert-continues! x) (assert-returns! x))) ((lambda converted-lambda converted-continuation) (unless (expression-inferred? x) (assert-member! ( (expression-lambda-environment x)) w) (assert-continues! x) (assert-returns! x))) ((set!) (assert-expression-reached! (expression-source x)) (set-type-set-used?! (variable-type-set (expression-variable x)) #t) (assert-subset! (expression-type-set (expression-source x)) (variable-type-set (expression-variable x))) (when (expression-continues? (expression-source x)) (assert-continues! x)) (when (expression-returns? (expression-source x)) (assert-returns! x))) ((if) (assert-expression-reached! (expression-antecedent x)) (when (can-be-non? false-type? (expression-type-set (expression-antecedent x))) (assert-expression-reached! (expression-consequent x)) (assert-subset! (expression-type-set (expression-consequent x)) w)) (when (can-be? false-type? (expression-type-set (expression-antecedent x))) (assert-expression-reached! (expression-alternate x)) (assert-subset! (expression-type-set (expression-alternate x)) w)) (when (and (expression-continues? (expression-antecedent x)) (or (expression-continues? (expression-consequent x)) (expression-continues? (expression-alternate x)))) (assert-continues! x)) (when (and (expression-returns? (expression-antecedent x)) (or (expression-returns? (expression-consequent x)) (expression-returns? (expression-alternate x)))) (assert-returns! x))) ((primitive-procedure) (unless (expression-inferred? x) (assert-member! ( (first (expression-constant x)) (rest (expression-constant x))) w) (assert-continues! x) (assert-returns! x))) ((foreign-procedure) (unless (expression-inferred? x) (assert-member! ( (third (expression-constant x)) (first (expression-constant x)) (second (expression-constant x)) (and (= (length (expression-constant x)) 4) (fourth (expression-constant x)))) w) (assert-continues! x) (assert-returns! x))) ((access) (set-type-set-used?! (variable-type-set (expression-variable x)) #t) ;; needs work: Should ignore assignments that aren't executed. ;; needs work: Should ignore void assignments. (if (null? (assignments (expression-variable x))) (assert-types-in-context! (members (variable-type-set (expression-variable x))) w x (expression-variable x)) (assert-subset! (variable-type-set (expression-variable x)) w)) (assert-continues! x) (assert-returns! x)) ((call) ;; needs work: Only assert a subexpression as used if the previous ;; subexpression returns. This assumes a left-to-right ;; evaluation order. As Olin Shivers pointed out, since ;; evaluation order is unspecified you can abort if any ;; subexpression doesn't return. But given the way the ;; propagator works, we can only determine whether an ;; expression returns by asserting it as used. So we have to ;; pick some order and it might as well be left to right. (assert-expression-reached! (expression-callee x)) (for-each assert-expression-reached! (expression-arguments x)) (when (executed? x) (propagate-call! (create-call-site x) (expression-type-set (expression-callee x)) (map expression-type-set (expression-arguments x)) *null*) (when (can-be? (continues? (map expression-type-set (expression-arguments x)) *null* (create-call-site x)) (expression-type-set (expression-callee x))) (assert-continues! x)) (when (can-be? (returns? (map expression-type-set (expression-arguments x)) *null* (create-call-site x)) (expression-type-set (expression-callee x))) (assert-returns! x)))) ((converted-call) ;; needs work: Only assert a subexpression as used if the previous ;; subexpression returns. This assumes a left-to-right ;; evaluation order. As Olin Shivers pointed out, since ;; evaluation order is unspecified you can abort if any ;; subexpression doesn't return. But given the way the ;; propagator works, we can only determine whether an ;; expression returns by asserting it as used. So we have to ;; pick some order and it might as well be left to right. (assert-expression-reached! (expression-callee x)) (for-each assert-expression-reached! (expression-arguments x)) (when (executed? x) (propagate-call! (create-call-site x) (expression-type-set (expression-callee x)) (map expression-type-set (expression-arguments x)) *null*) (when (can-be? (continues? (map expression-type-set (expression-arguments x)) *null* (create-call-site x)) (expression-type-set (expression-callee x))) (assert-continues! x)) (when (can-be? (returns? (map expression-type-set (expression-arguments x)) *null* (create-call-site x)) (expression-type-set (expression-callee x))) (assert-returns! x)))) (else (fuck-up)))) (set-expression-inferred?! x #t))) (define (push! x) (unless (expression-link x) (set-expression-link! x (if *x1* *x1* #t)) (set! *x1* x))) (define (run-stack!) (let loop () (when *x1* (let ((x *x1*)) (set! *x1* (if (eq? (expression-link x) #t) #f (expression-link x))) (set-expression-link! x #f) (infer! x) (loop))))) (define (perform-flow-analysis!) (set! *types-frozen?* #f) (reinitialize-types-and-type-sets!) (for-each (lambda (x) ;; Only narrow prototypes get a type set. (when (or (and (not (eq? (expression-kind x) 'lambda)) (not (eq? (expression-kind x) 'converted-lambda)) (not (eq? (expression-kind x) 'converted-continuation))) ;; The next expression is a kludge. (not (environment? (expression-lambda-environment x))) (eq? (narrow-prototype (expression-lambda-environment x)) (expression-lambda-environment x))) (set-expression-type-set! x (create-type-set x))) (set-expression-reached?! x #f) (set-expression-inferred?! x #f) (set-expression-returns?! x #f)) *xs*) (for-each (lambda (x) ;; Clones that are not narrow prototypes share their type set with their ;; narrow prototype. (when (and (or (eq? (expression-kind x) 'lambda) (eq? (expression-kind x) 'converted-lambda) (eq? (expression-kind x) 'converted-continuation)) ;; The next expression is a kludge. (environment? (expression-lambda-environment x)) (not (eq? (narrow-prototype (expression-lambda-environment x)) (expression-lambda-environment x)))) (set-expression-type-set! x (expression-type-set (environment-expression (narrow-prototype (expression-lambda-environment x))))))) *xs*) (for-each (lambda (e) (set-environment-call-sites! e '())) *es*) (for-each (lambda (g) (set-variable-type-set! g (create-type-set g))) *gs*) (assert-expression-reached! *x*) (let loop () (clock-sample) ;To prevent overflow. (set! *again?* #f) (propagate-call! *y* (expression-type-set *x*) (list *w1*) *null*) (run-stack!) (for-each push! *xs*) (run-stack!) (when *again?* (loop))) (set! *types-frozen?* #t)) ;;; Enumerate call sites (define (enumerate-call-sites!) (set! *ys* '()) (for-each (lambda (x) (when (and (executed? x) (not (empty? (expression-environment x))) (environment-used? (expression-environment x))) (set! *ys* (cons (create-call-site x) *ys*)) (when (can-be? (lambda (u) (and (or ((primitive-procedure-type-named? 'apply) u) ((primitive-procedure-type-named? 'call-with-current-continuation) u) ((primitive-procedure-type-named? 'fork) u) ((primitive-procedure-type-named? 'mutex) u)) ((truly-compatible-call? x) u))) (expression-type-set (expression-callee x))) (set! *ys* (cons (recreate-call-site (create-call-site x) 'first-argument) *ys*))) (when (can-be? (lambda (u) (and ((primitive-procedure-type-named? 'fork) u) ((truly-compatible-call? x) u))) (expression-type-set (expression-callee x))) (set! *ys* (cons (recreate-call-site (create-call-site x) 'second-argument) *ys*))))) *calls*)) ;;; Determine which types and type sets are used (define (determine-which-types-and-type-sets-are-used!) (let loop () (let ((again? #f)) (define (assert-used! u) (cond ((null-type? u) (set! *null-type-used?* #t)) ((true-type? u) (set! *true-type-used?* #t)) ((false-type? u) (set! *false-type-used?* #t)) ((char-type? u) (set! *char-type-used?* #t)) ((fixnum-type? u) (set! *fixnum-type-used?* #t)) ((flonum-type? u) (set! *flonum-type-used?* #t)) ((rectangular-type? u) (set! *rectangular-type-used?* #t)) ((input-port-type? u) (set! *input-port-type-used?* #t)) ((output-port-type? u) (set! *output-port-type-used?* #t)) ((eof-object-type? u) (set! *eof-object-type-used?* #t)) ((pointer-type? u) (set! *pointer-type-used?* #t)) ((internal-symbol-type? u) (set-internal-symbol-type-used?! u #t)) ((external-symbol-type? u) (unless (type-used? u) (set-external-symbol-type-used?! u #t) (set! again? #t))) ((primitive-procedure-type? u) (set-primitive-procedure-type-used?! u #t)) ((native-procedure-type? u) (set-native-procedure-type-used?! u #t)) ((foreign-procedure-type? u) (set-foreign-procedure-type-used?! u #t)) ((continuation-type? u) (unless (type-used? u) (set-continuation-type-used?! u #t))) ((string-type? u) (set-string-type-used?! u #t)) ((structure-type? u) (unless (type-used? u) (set-structure-type-used?! u #t) (set! again? #t))) ((headed-vector-type? u) (unless (type-used? u) (set-headed-vector-type-used?! u #t) (set! again? #t))) ((nonheaded-vector-type? u) (unless (type-used? u) (set-nonheaded-vector-type-used?! u #t) (set! again? #t))) ((displaced-vector-type? u) (unless (type-used? u) (set-displaced-vector-type-used?! u #t) (set! again? #t))) (else (fuck-up)))) (for-each (lambda (u) (when (type-used? u) (assert-used! (external-symbol-type-displaced-string-type u)))) *external-symbol-types*) (for-each (lambda (u) (when (type-used? u) (for-each (lambda (w) (unless (type-set-used? w) (set-type-set-used?! w #t) (set! again? #t))) (structure-type-slots u)))) *structure-types*) (for-each (lambda (u) (when (type-used? u) (unless (type-set-used? (headed-vector-type-element u)) (set-type-set-used?! (headed-vector-type-element u) #t) (set! again? #t)))) *headed-vector-types*) (for-each (lambda (u) (when (type-used? u) (unless (type-set-used? (nonheaded-vector-type-element u)) (set-type-set-used?! (nonheaded-vector-type-element u) #t) (set! again? #t)))) *nonheaded-vector-types*) (for-each (lambda (u) (when (type-used? u) (assert-used! (displaced-vector-type-displaced-vector-type u)))) *displaced-vector-types*) (for-each (lambda (w) (when (type-set-used? w) (for-each-member assert-used! w))) *ws*) (when again? (loop))))) (define (replace-expression! x1 x2) (case (expression-kind (expression-parent x1)) ((lambda converted-lambda converted-continuation) (unless (eq? (expression-body (expression-parent x1)) x1) (fuck-up)) (set-expression-body! (expression-parent x1) x2)) ((set!) (unless (eq? (expression-source (expression-parent x1)) x1) (fuck-up)) (set-expression-source! (expression-parent x1) x2)) ((if) (cond ((eq? (expression-antecedent (expression-parent x1)) x1) (set-expression-antecedent! (expression-parent x1) x2)) ((eq? (expression-consequent (expression-parent x1)) x1) (set-expression-consequent! (expression-parent x1) x2)) ((eq? (expression-alternate (expression-parent x1)) x1) (set-expression-alternate! (expression-parent x1) x2)) (else (fuck-up)))) ((call converted-call) (cond ((eq? (expression-callee (expression-parent x1)) x1) (set-expression-callee! (expression-parent x1) x2)) ((one (lambda (x3) (eq? x3 x1)) (expression-arguments (expression-parent x1))) (set-expression-arguments! (expression-parent x1) (map (lambda (x3) (if (eq? x3 x1) x2 x3)) (expression-arguments (expression-parent x1))))) (else (fuck-up)))) (else (fuck-up)))) (define (remove-unused-objects! p?) (when p? (set! *xs* (remove-if-not reached? *xs*)) (set! *calls* (remove-if-not reached? *calls*)) (set! *accesses* (remove-if-not reached? *accesses*)) (set! *assignments* (remove-if-not reached? *assignments*)) (set! *references* (remove-if-not reached? *references*)) (for-each (lambda (x) (when (and (or (eq? (expression-kind x) 'lambda) (eq? (expression-kind x) 'converted-lambda) (eq? (expression-kind x) 'converted-continuation)) (not (called? (expression-lambda-environment x)))) (set-expression-parameters! x (unspecified))) (when (and (or (eq? (expression-kind x) 'lambda) (eq? (expression-kind x) 'converted-lambda) (eq? (expression-kind x) 'converted-continuation)) (not (called? (expression-lambda-environment x)))) (set-expression-lambda-environment! x (unspecified)))) *xs*) (set! *internal-symbol-types* (remove-if-not type-used? *internal-symbol-types*)) (set! *external-symbol-types* (remove-if-not type-used? *external-symbol-types*)) (set! *primitive-procedure-types* (remove-if-not type-used? *primitive-procedure-types*)) (set! *native-procedure-types* (remove-if-not type-used? *native-procedure-types*)) (set! *foreign-procedure-types* (remove-if-not type-used? *foreign-procedure-types*)) (set! *continuation-types* (remove-if-not type-used? *continuation-types*)) (set! *string-types* (remove-if-not type-used? *string-types*)) (set! *structure-types* (remove-if-not type-used? *structure-types*)) (set! *headed-vector-types* (remove-if-not type-used? *headed-vector-types*)) (set! *nonheaded-vector-types* (remove-if-not type-used? *nonheaded-vector-types*)) (set! *displaced-vector-types* (remove-if-not type-used? *displaced-vector-types*))) (for-each (lambda (u) (set-native-procedure-type-call-site-environment-alist! u (remove-if-not (lambda (y-e) (and (or (top-level-call-site? (car y-e)) (reached? (call-site-expression (car y-e)))) (called? (cdr y-e)))) (native-procedure-type-call-site-environment-alist u))) (when p? (unless (called? (native-procedure-type-narrow-prototype u)) (set-native-procedure-type-narrow-prototype! u (find-if called? (narrow-clones u)))))) *native-procedure-types*) (when p? (set! *ws* (remove-if-not type-set-used? *ws*))) (for-each (lambda (w) (set-members! w (members-that type-used? w))) *ws*) (when p? (set! *gs* (remove-if-not variable-used? *gs*)) (for-each (lambda (g) (set-variable-accesses! g (remove-if-not reached? (variable-accesses g))) (set-variable-assignments! g (remove-if-not reached? (variable-assignments g))) (set-variable-references! g (remove-if-not reached? (variable-references g)))) *gs*) (for-each (lambda (e) (when (and (eq? (narrow-prototype e) e) (not (called? e)) (some (lambda (e1) (and (called? e1) (eq? (expression-accessed? (environment-expression e1)) (expression-accessed? (environment-expression e))))) (narrow-clones e))) (replace-expression! (environment-expression e) (environment-expression (find-if (lambda (e1) (and (called? e1) (eq? (expression-accessed? (environment-expression e1)) (expression-accessed? (environment-expression e))))) (narrow-clones e)))))) *es*) (for-each (lambda (e) (set-environment-narrow-clones! e (remove-if-not called? (narrow-clones (narrow-prototype e)))) (set-environment-parent-parameter! e (parent-parameter e))) *es*) (for-each (lambda (e) (when (and (not (called? (environment-narrow-prototype e))) ;; This is a kludge. (some called? (narrow-clones e))) (set-environment-narrow-prototype! e (find-if called? (narrow-clones e))))) *es*) (for-each (lambda (e) (unless (eq? e (environment-narrow-prototype e)) (set-environment-narrow-clones! e '()) (set-environment-parent-parameter! e (unspecified)))) *es*) (let ((es (remove-if-not called? *es*))) (for-each set-environment-wide-prototype! es (map (lambda (e) (find-if (lambda (e1) (and (eq? (environment-narrow-prototype e1) e1) (eq? (environment-wide-prototype e1) (environment-wide-prototype e)))) es)) es))) ;; This is just because of *CLOSURE-CONVERSION-METHOD*. (for-each (lambda (e) (when (environment-used? e) (set-environment-expressions! e (remove-if-not reached? (environment-expressions e))))) *es*) ;; This is just because of *CLOSURE-CONVERSION-METHOD*. (for-each (lambda (e) (when (environment-used? e) (set-environment-continuation-calls! e (remove-if-not reached? (environment-continuation-calls e))))) *es*) (set! *es0* (remove-if-not (lambda (e) (and (called? e) (noop? e))) *es*)) (set! *es* (remove-if-not environment-used? *es*)))) (define (check-for-corruption p?) (define (memq-*us* u) (cond ((internal-symbol-type? u) (memq u *internal-symbol-types*)) ((external-symbol-type? u) (memq u *external-symbol-types*)) ((primitive-procedure-type? u) (memq u *primitive-procedure-types*)) ((native-procedure-type? u) (memq u *native-procedure-types*)) ((foreign-procedure-type? u) (memq u *foreign-procedure-types*)) ((continuation-type? u) (memq u *continuation-types*)) ((string-type? u) (memq u *string-types*)) ((structure-type? u) (memq u *structure-types*)) ((headed-vector-type? u) (memq u *headed-vector-types*)) ((nonheaded-vector-type? u) (memq u *nonheaded-vector-types*)) ((displaced-vector-type? u) (memq u *displaced-vector-types*)) (else #t))) (let ((p0? #f) ;*XS* (p1? #f) ;*ES* (p2? #f) ;*WS* (p3? #f) ;*GS* (p4? #f)) ;*US* (unless (and (nonheaded-vector-type? (the-member *w1*)) (string-type? (the-member (nonheaded-vector-type-element (the-member *w1*))))) (fuck-up)) (unless (void? *void*) (fuck-up)) (unless (null-type? (the-member *null*)) (fuck-up)) (unless (input-port-type? (the-member *input-port*)) (fuck-up)) (unless (output-port-type? (the-member *output-port*)) (fuck-up)) (unless (char-type? (the-member *foreign-char-type-set*)) (fuck-up)) (unless (fixnum-type? (the-member *foreign-fixnum-type-set*)) (fuck-up)) (unless (flonum-type? (the-member *foreign-flonum-type-set*)) (fuck-up)) (unless (string-type? (the-member *foreign-string-type-set*)) (fuck-up)) (unless (input-port-type? (the-member *foreign-input-port-type-set*)) (fuck-up)) (unless (output-port-type? (the-member *foreign-output-port-type-set*)) (fuck-up)) (unless (pointer-type? (the-member *foreign-pointer-type-set*)) (fuck-up)) (when p0? (unless (subsetq? *calls* *xs*) (fuck-up)) (unless (subsetq? *accesses* *xs*) (fuck-up)) (unless (subsetq? *assignments* *xs*) (fuck-up)) (unless (subsetq? *references* *xs*) (fuck-up)) (let loop ((x *x*)) (when (reached? x) (unless (memq x *xs*) (fuck-up)) (case (expression-kind x) ((null-constant) #f) ((true-constant) #f) ((false-constant) #f) ((char-constant) #f) ((fixnum-constant) #f) ((flonum-constant) #f) ((rectangular-constant) #f) ((string-constant) #f) ((symbol-constant) #f) ((pair-constant) (loop (car (expression-constant x))) (loop (cdr (expression-constant x)))) ((vector-constant) (for-each-vector loop (expression-constant x))) ((lambda converted-lambda converted-continuation) (unless (noop? x) (loop (expression-body x)))) ((set!) (loop (expression-source x))) ((if) (loop (expression-antecedent x)) (loop (expression-consequent x)) (loop (expression-alternate x))) ((primitive-procedure) #f) ((foreign-procedure) #f) ((access) #f) ((call converted-call) (loop (expression-callee x)) (for-each loop (expression-arguments x))) (else (fuck-up)))))) (for-each (lambda (x) ;; EXPRESSION-LINK (when (and (reached? x) (environment? (expression-environment x)) (not (called? (expression-environment x)))) (fuck-up)) (when (and p1? (environment? (expression-environment x)) (not (memq (expression-environment x) *es*))) (fuck-up)) (when (and (reached? x) (not (type-set-used? (expression-type-set x)))) (fuck-up)) (when (and p2? (reached? x) (not (memq (expression-type-set x) *ws*))) (fuck-up)) (when (and (reached? x) (expression? (expression-parent x)) (not (reached? (expression-parent x)))) (fuck-up)) (when (and p0? (expression? (expression-parent x)) (not (memq (expression-parent x) *xs*))) (fuck-up)) ;; EXPRESSION-CONSTANT (when (and p? (environment? (expression-lambda-environment x)) (not (called? (expression-lambda-environment x)))) (fuck-up)) (when (and p1? (environment? (expression-lambda-environment x)) (not (noop? (expression-lambda-environment x))) (not (memq (expression-lambda-environment x) *es*))) (fuck-up)) (when (and p3? (or (variable? (expression-parameters x)) (pair? (expression-parameters x)))) (let loop ((gs (expression-parameters x))) (cond ((pair? gs) (unless (memq (first gs) *gs*) (fuck-up)) (loop (rest gs))) ((variable? gs) (unless (memq gs *gs*) (fuck-up))) ((null? gs) #f) (else (fuck-up))))) ;; EXPRESSION-BODY (when (and p3? (variable? (expression-variable x)) (not (memq (expression-variable x) *gs*))) (fuck-up)) (when (and (reached? x) (expression? (expression-source x)) (not (reached? (expression-source x)))) (fuck-up)) (when (and p0? (expression? (expression-source x)) (not (memq (expression-source x) *xs*))) (fuck-up)) (when (and (reached? x) (expression? (expression-antecedent x)) (not (reached? (expression-antecedent x)))) (fuck-up)) (when (and p0? (expression? (expression-antecedent x)) (not (memq (expression-antecedent x) *xs*))) (fuck-up)) ;; EXPRESSION-CONSEQUENT ;; EXPRESSION-ALTERNATE (when (and (reached? x) (expression? (expression-callee x)) (not (reached? (expression-callee x)))) (fuck-up)) (when (and p0? (expression? (expression-callee x)) (not (memq (expression-callee x) *xs*))) (fuck-up)) (when (list? (expression-arguments x)) (when (reached? x) (for-each (lambda (x) (unless (reached? x) (fuck-up))) (expression-arguments x))) (when p0? (for-each (lambda (x) (unless (memq x *xs*) (fuck-up))) (expression-arguments x)))) ;; EXPRESSION-ORIGINAL-EXPRESSION (when p1? (for-each (lambda (u-e) (when (or (not (type-used? (car u-e))) (not (memq-*us* (car u-e))) (and (region-allocation? (cdr u-e)) (or (not (called? (cdr u-e))) (not (memq (cdr u-e) *es*))))) (fuck-up))) (expression-type-allocation-alist x)))) *xs*) (for-each (lambda (u) ;; EXTERNAL-SYMBOL-TYPE-LINK (unless (type-used? (external-symbol-type-displaced-string-type u)) (fuck-up)) (when (and p4? (not (memq (external-symbol-type-displaced-string-type u) *string-types*))) (fuck-up))) *external-symbol-types*) (for-each (lambda (u) (when (and (native-procedure-type-narrow-prototype u) (not (eq? (environment-narrow-prototype (native-procedure-type-narrow-prototype u)) (native-procedure-type-narrow-prototype u)))) (fuck-up)) (when (and p? (native-procedure-type-narrow-prototype u) (not (called? (native-procedure-type-narrow-prototype u)))) (fuck-up)) (when (and p? p1? (native-procedure-type-narrow-prototype u) (not (noop? (native-procedure-type-narrow-prototype u))) (not (memq (native-procedure-type-narrow-prototype u) *es*))) (fuck-up)) (for-each (lambda (y-e) (when (and (call-site? (car y-e)) (not (reached? (call-site-expression (car y-e))))) (fuck-up)) (when (and p0? (call-site? (car y-e)) (not (memq (call-site-expression (car y-e)) *xs*))) (fuck-up)) (unless (called? (cdr y-e)) (fuck-up)) (when (and p1? (not (noop? (cdr y-e))) (not (memq (cdr y-e) *es*))) (fuck-up)) (unless (memq (cdr y-e) (narrow-clones (cdr y-e))) (fuck-up))) (native-procedure-type-call-site-environment-alist u))) *native-procedure-types*) (for-each (lambda (u) (when (and (expression? (continuation-type-allocating-expression u)) (not (reached? (continuation-type-allocating-expression u)))) (fuck-up)) (when (and p0? (expression? (continuation-type-allocating-expression u)) (not (memq (continuation-type-allocating-expression u) *xs*))) (fuck-up)) ;; This is a real kludge. (unless (eq? (continuation-type-call-sites u) (unspecified)) (for-each (lambda (y) (unless (reached? (call-site-expression y)) (fuck-up)) (when (and p0? (not (memq (call-site-expression y) *xs*))) (fuck-up))) (continuation-type-call-sites u)))) *continuation-types*) (for-each (lambda (u) ;; STRING-TYPE-LINK (for-each (lambda (x) (when (and (expression? x) (not (reached? x))) (fuck-up)) (when (and p0? (expression? x) (not (memq x *xs*))) (fuck-up))) (string-type-allocating-expressions u))) *string-types*) (for-each (lambda (u) (for-each (lambda (w) (unless (type-set-used? w) (fuck-up)) (when (and p2? (not (memq w *ws*))) (fuck-up))) (structure-type-slots u)) ;; STRUCTURE-TYPE-LINK (for-each (lambda (x) (when (and (expression? x) (not (reached? x))) (fuck-up)) (when (and p0? (expression? x) (not (memq x *xs*))) (fuck-up))) (structure-type-allocating-expressions u))) *structure-types*) (for-each (lambda (u) (unless (type-set-used? (headed-vector-type-element u)) (fuck-up)) (when (and p2? (not (memq (headed-vector-type-element u) *ws*))) (fuck-up)) ;; HEADED-VECTOR-TYPE-LINK (for-each (lambda (x) (when (and (expression? x) (not (reached? x))) (fuck-up)) (when (and p0? (expression? x) (not (memq x *xs*))) (fuck-up))) (headed-vector-type-allocating-expressions u))) *headed-vector-types*) (for-each (lambda (u) (unless (type-set-used? (nonheaded-vector-type-element u)) (fuck-up)) (when (and p2? (not (memq (nonheaded-vector-type-element u) *ws*))) (fuck-up)) ;; NONHEADED-VECTOR-TYPE-LINK (for-each (lambda (x) (when (and (expression? x) (not (reached? x))) (fuck-up)) (when (and p0? (expression? x) (not (memq x *xs*))) (fuck-up))) (nonheaded-vector-type-allocating-expressions u))) *nonheaded-vector-types*) (for-each (lambda (u) (unless (type-used? (displaced-vector-type-displaced-vector-type u)) (fuck-up)) ;; DISPLACED-VECTOR-TYPE-LINK (when (and p4? (not (memq-*us* (displaced-vector-type-displaced-vector-type u)))) (fuck-up))) *displaced-vector-types*) (for-each (lambda (w) (when (and (expression? (type-set-location w)) (not (reached? (type-set-location w)))) (fuck-up)) (when (and p0? (expression? (type-set-location w)) (not (memq (type-set-location w) *xs*))) (fuck-up)) (when (and p3? (variable? (type-set-location w)) (not (memq (type-set-location w) *gs*))) (fuck-up)) (when (and (structure-type? (type-set-location w)) (not (type-used? (type-set-location w)))) (fuck-up)) (when (and p4? (structure-type? (type-set-location w)) (not (memq (type-set-location w) *structure-types*))) (fuck-up)) (when (and (headed-vector-type? (type-set-location w)) (not (type-used? (type-set-location w)))) (fuck-up)) (when (and p4? (headed-vector-type? (type-set-location w)) (not (memq (type-set-location w) *headed-vector-types*))) (fuck-up)) (when (and (nonheaded-vector-type? (type-set-location w)) (not (type-used? (type-set-location w)))) (fuck-up)) (when (and p4? (nonheaded-vector-type? (type-set-location w)) (not (memq (type-set-location w) *nonheaded-vector-types*))) (fuck-up)) ;; TYPE-SET-LINK (for-each-member (lambda (u) (unless (type-used? u) (fuck-up)) (when (and p4? (not (memq-*us* u))) (fuck-up))) w)) *ws*) (for-each (lambda (g) (when (and p? (not (variable-used? g))) (fuck-up)) (when (and p1? (not (noop? (variable-environment g))) (not (memq (variable-environment g) *es*))) (fuck-up)) (when (and (variable-used? g) (not (type-set-used? (variable-type-set g)))) (fuck-up)) (when (and p2? (variable-used? g) (not (memq (variable-type-set g) *ws*))) (fuck-up)) (for-each (lambda (x) (unless (reached? x) (fuck-up)) (when (and p0? (not (memq x *xs*))) (fuck-up))) (accesses g)) (for-each (lambda (x) (unless (reached? x) (fuck-up)) (when (and p0? (not (memq x *xs*))) (fuck-up))) (assignments g)) (for-each (lambda (x) (unless (reached? x) (fuck-up)) (when (and p0? (not (memq x *xs*))) (fuck-up))) (references g))) *gs*) (for-each (lambda (e) (when (environment-used? e) (when (and (environment-expression e) (not (reached? (environment-expression e)))) (fuck-up)) (when (and p0? (environment-expression e) (not (memq (environment-expression e) *xs*))) (fuck-up)) (for-each (lambda (y) (unless (or (top-level-call-site? y) (reached? (call-site-expression y))) (fuck-up)) (when (and p0? (not (top-level-call-site? y)) (not (memq (call-site-expression y) *xs*))) (fuck-up))) (call-sites e)) (when (and (region-allocation? (allocation e)) (not (called? (allocation e)))) (fuck-up)) (when (and p1? (region-allocation? (allocation e)) (not (memq (allocation e) *es*))) (fuck-up)) ;; ENVIRONMENT-FREE-VARIABLES ;; ENVIRONMENT-QUICK-PARENT ;; ENVIRONMENT-PARENT-PARAMETER ;; ENVIRONMENT-PARENT-SLOT ;; ENVIRONMENT-ANCESTORS ;; ENVIRONMENT-CHILDREN ;; ENVIRONMENT-PROPERLY-IN-LINED-ENVIRONMENTS (unless (eq? (environment-narrow-prototype (environment-narrow-prototype e)) (environment-narrow-prototype e)) (fuck-up)) (unless (eq? (expression-type-set (environment-expression e)) (expression-type-set (environment-expression (environment-narrow-prototype e)))) (fuck-up)) (when (and (not (eq? e (environment-narrow-prototype e))) (not (null? (environment-narrow-clones e)))) (fuck-up)) (unless (memq e (environment-narrow-clones (environment-narrow-prototype e))) (fuck-up)) (when (and p? (not (called? (environment-narrow-prototype e)))) (fuck-up)) (when (and p? p1? (not (noop? (environment-narrow-prototype e))) (not (memq (environment-narrow-prototype e) *es*))) (fuck-up)) (when p? (for-each (lambda (e) (unless (called? (environment-narrow-prototype e)) (fuck-up)) (when (and p1? (not (noop? (environment-narrow-prototype e))) (not (memq (environment-narrow-prototype e) *es*))) (fuck-up))) (environment-narrow-clones e))) (unless (eq? (environment-narrow-prototype (environment-wide-prototype e)) (environment-wide-prototype e)) (fuck-up)) (when (and p? (not (called? (environment-wide-prototype e)))) (fuck-up)) (when (and p? p1? (not (noop? (environment-wide-prototype e))) (not (memq (environment-wide-prototype e) *es*))) (fuck-up)) ;; This is a real kludge. (unless (eq? (environment-direct-tail-callers e) (unspecified)) (for-each (lambda (e1) (unless (environment-used? e1) (fuck-up)) (when (and p1? (not (memq e1 *es*))) (fuck-up))) (environment-direct-tail-callers e))) ;; This is a real kludge. (unless (eq? (environment-direct-non-tail-callers e) (unspecified)) (for-each (lambda (e1) (unless (environment-used? e1) (fuck-up)) (when (and p1? (not (memq e1 *es*))) (fuck-up))) (environment-direct-non-tail-callers e))) ;; This is a real kludge. (unless (eq? (environment-direct-tail-callees e) (unspecified)) (for-each (lambda (e1) (unless (environment-used? e1) (fuck-up)) (when (and p1? (not (memq e1 *es*))) (fuck-up))) (environment-direct-tail-callees e))) ;; This is a real kludge. (unless (eq? (environment-direct-non-tail-callees e) (unspecified)) (for-each (lambda (e1) (unless (environment-used? e1) (fuck-up)) (when (and p1? (not (memq e1 *es*))) (fuck-up))) (environment-direct-non-tail-callees e))) ;; This is a real kludge. (unless (eq? (environment-expressions e) (unspecified)) (for-each (lambda (x) (unless (reached? x) (fuck-up)) (when (and p0? (not (memq x *xs*))) (fuck-up))) (environment-expressions e))) ;; This is a real kludge. (unless (eq? (environment-continuation-calls e) (unspecified)) (for-each (lambda (x) (unless (reached? x) (fuck-up)) (when (and p0? (not (memq x *xs*))) (fuck-up))) (environment-continuation-calls e))) ;; ENVIRONMENT-DIRECTLY-ESCAPING-TYPES ;; ENVIRONMENT-NON-SELF-TAIL-CALL-SITES (unless (eq? (parent e) (parent (narrow-prototype e))) (fuck-up)))) *es*))) ;;; Determine which call sites to split (define (splittable-call-site-count e) (count-if (lambda (y) (and ;; For now, only split explicit call sites. (explicit-call-site? y) ;; Don't split a call unless the call can actually happen. (executed? (call-site-expression y)) ((truly-compatible-call? (call-site-expression y)) (environment-type e)) ;; Don't split call sites to an environment that are nested in that ;; environment. (not (nested-in? (expression-environment (call-site-expression y)) e)))) (call-sites e))) (define (determine-which-call-sites-to-split!) ;; Reasons for splitting: ;; 1. to eliminate argument-parameter widening ;; 2. to allow in-lining ;; 3. to specialize the lifetime of a rest arg ;; 4. to specialize the lifetime of allocated data ;; 5. to make non-self tail calls self tail calls (let ((split? #f)) (let loop () (let ((again? #f)) (let* ((es1 (remove-if-not (lambda (e) (and ;; Don't split a procedure unless it can be called. (called? e) ;; Don't split noops. (not (noop? e)) ;; Don't split a procedure that has already been split. (eq? (environment-split e) #f) ;; Don't split a procedure when some call site that targets ;; that procedure is nested in some procedure that has ;; already been split. (not (some (lambda (y) (and (explicit-call-site? y) (let loop? ((e1 (expression-environment (call-site-expression y)))) (and (not (empty? e1)) (or (eq? (environment-split e1) #t) (eq? (environment-split e1) 'never) (loop? (parent e1))))))) (call-sites e))))) *es*)) ;; If both E1 and E2 are distinct candidates for splitting, don't ;; split E1 there is a call to E2 nested in E1. (es2 (remove-if (lambda (e1) (clock-sample) ;To prevent overflow. (some (lambda (e2) (and (not (eq? e1 e2)) (some (lambda (y) (and (explicit-call-site? y) (nested-in? (expression-environment (call-site-expression y)) e1))) (call-sites e2)))) es1)) es1))) (for-each (lambda (e) (let ((u (environment-type e))) (cond ((and (or (= *clone-size-limit* -1) (<= (clone-size e) *clone-size-limit*)) ;; Require some compelling reason for splitting. ;; needs work: This should also allow splitting in the following ;; cases: ;; 1. target is not reentrant; to allow in-lining ;; 2. target or some procedure in-lined in target ;; conses; to specialize the lifetime of allocated ;; data ;; 3. target is not in-lined and call site is not a self ;; tail call but there is a tail call path from the ;; target to the call site and the call site is a ;; tail call; to make non-self tail calls tail calls (or *split-even-if-no-widening?* ;; Split calls to varargs targets. To specialize the lifetime of ;; the rest arg. (rest? e) ;; Split calls to non-vararg targets that require widening some ;; argument. To eliminate argument-parameter widening. (some (lambda (y) (and (explicit-call-site? y) (some (lambda (x g) (not (set-equalp? ;; This is a form of uniqueness. ;; needs work: Doesn't handle displaced ;; vectors. (lambda (u1 u2) (or (eq? u1 u2) (and (string-type? u1) (string-type? u2)) (and (structure-type? u1) ((structure-type-named? (structure-type-name u1)) u2)) (and (headed-vector-type? u1) (headed-vector-type? u2)) (and (nonheaded-vector-type? u1) (nonheaded-vector-type? u2)))) (members (expression-type-set x)) (members (variable-type-set g))))) (expression-arguments (call-site-expression y)) (expression-parameters (environment-expression e))))) (call-sites e)))) (when #f ;debugging (notify "Clone size ~a is ~s" (environment-name e) (clone-size e))) (set-environment-split! e #t) (for-each (lambda (y) (when #f ;debugging (notify "Cloning x~s ~a->[clone ~a ~s]" (expression-index (call-site-expression y)) (environment-name e) (environment-name (wide-prototype e)) *ei*) (notify "~s" (undecorate (call-site-expression y)))) (set! *types-frozen?* #f) (set-cdr! (assp same-call-site? y (native-procedure-type-call-site-environment-alist u)) (clone e)) (set! *types-frozen?* #t)) (let ((ys (remove-if-not (lambda (y) (and ;; For now, only split explicit call sites. (explicit-call-site? y) ;; Don't split a call unless the call can actually happen. (executed? (call-site-expression y)) ((truly-compatible-call? (call-site-expression y)) u) ;; Don't split call sites to an environment that are ;; nested in that environment. (not (nested-in? (expression-environment (call-site-expression y)) e)))) (call-sites e)))) ;; The first call site remains assigned to the wide prototype. (if (null? ys) ys (rest ys)))) (set! split? #t)) (else (set-environment-split! e 'never))) (set! again? #t))) (if (null? es2) (if (null? es1) '() (list (minp (lambda (e1 e2) (> (splittable-call-site-count e1) (splittable-call-site-count e2))) es1))) es2))) (when again? (loop)))) split?)) ;;; Compute call graph (define (some-proper-callee p? marked? mark! e) ;; conventions: P? MARKED? MARK! ;; The PROPERLY-CALLS? relation is not necessarily reflexive. (define (loop? e) (and (not (marked? e)) (begin (mark! e #t) (or (p? e) (some loop? (environment-direct-tail-callees e)) (some loop? (environment-direct-non-tail-callees e)))))) (for-each (lambda (e) (mark! e #f)) *es*) (or (some loop? (environment-direct-tail-callees e)) (some loop? (environment-direct-non-tail-callees e)))) (define (some-callee p? marked? mark! e) ;; conventions: P? MARKED? MARK! (for-each (lambda (e) (mark! e #f)) *es*) (let loop? ((e e)) (and (not (marked? e)) (begin (mark! e #t) (or (p? e) (some loop? (environment-direct-tail-callees e)) (some loop? (environment-direct-non-tail-callees e))))))) (define (some-proper-caller p? marked? mark! e) ;; conventions: P? MARKED? MARK! ;; The PROPERLY-CALLS? relation is not necessarily reflexive. (define (loop? e) (and (not (marked? e)) (begin (mark! e #t) (or (p? e) (some loop? (environment-direct-tail-callers e)) (some loop? (environment-direct-non-tail-callers e)))))) (for-each (lambda (e) (mark! e #f)) *es*) (or (some loop? (environment-direct-tail-callers e)) (some loop? (environment-direct-non-tail-callers e)))) (define (some-caller p? marked? mark! e) ;; conventions: P? MARKED? MARK! (for-each (lambda (e) (mark! e #f)) *es*) (let loop? ((e e)) (and (not (marked? e)) (begin (mark! e #t) (or (p? e) (some loop? (environment-direct-tail-callers e)) (some loop? (environment-direct-non-tail-callers e))))))) (define (some-proper-tail-callee p? marked? mark! e) ;; conventions: P? MARKED? MARK! ;; The PROPERLY-TAIL-CALLS? relation is not necessarily reflexive. (define (loop? e) (and (not (marked? e)) (begin (mark! e #t) (or (p? e) (some loop? (environment-direct-tail-callees e)))))) (for-each (lambda (e) (mark! e #f)) *es*) (some loop? (environment-direct-tail-callees e))) (define (some-tail-callee p? marked? mark! e) ;; conventions: P? MARKED? MARK! (for-each (lambda (e) (mark! e #f)) *es*) (let loop? ((e e)) (and (not (marked? e)) (begin (mark! e #t) (or (p? e) (some loop? (environment-direct-tail-callees e))))))) (define (some-proper-tail-caller p? marked? mark! e) ;; conventions: P? MARKED? MARK! ;; The PROPERLY-TAIL-CALLS? relation is not necessarily reflexive. (define (loop? e) (and (not (marked? e)) (begin (mark! e #t) (or (p? e) (some loop? (environment-direct-tail-callers e)))))) (for-each (lambda (e) (mark! e #f)) *es*) (some loop? (environment-direct-tail-callers e))) (define (some-tail-caller p? marked? mark! e) ;; conventions: P? MARKED? MARK! (for-each (lambda (e) (mark! e #f)) *es*) (let loop? ((e e)) (and (not (marked? e)) (begin (mark! e #t) (or (p? e) (some loop? (environment-direct-tail-callers e))))))) (define (properly-calls? e1 e2) ;; The PROPERLY-CALLS? relation is not necessarily reflexive. (some-proper-caller (lambda (e) (eq? e e1)) environment-marked1? set-environment-marked1?! e2)) (define (calls? e1 e2) (or (eq? e1 e2) (properly-calls? e1 e2))) (define (properly-tail-calls? e1 e2) ;; The PROPERLY-TAIL-CALLS? relation is not necessarily reflexive. (some-proper-tail-caller (lambda (e) (eq? e e1)) environment-marked1? set-environment-marked1?! e2)) (define (tail-calls? e1 e2) (or (eq? e1 e2) (properly-tail-calls? e1 e2))) (define (properly-non-tail-calls? e1 e2) (unimplemented #f "unimplemented")) (define (directly-calls? e1 e2) (or (directly-tail-calls? e1 e2) (directly-non-tail-calls? e1 e2))) (define (directly-tail-calls? e1 e2) (memq e1 (environment-direct-tail-callers e2))) (define (directly-non-tail-calls? e1 e2) (memq e1 (environment-direct-non-tail-callers e2))) (define (proper-callees e) ;; The PROPERLY-CALLS? relation is not necessarily reflexive. ;; This is done just for side effect, to set the MARKED1? bits. (some-proper-callee (lambda (e) #f) environment-marked1? set-environment-marked1?! e) (remove-if-not environment-marked1? *es*)) (define (callees e) ;; This is done just for side effect, to set the MARKED1? bits. (some-callee (lambda (e) #f) environment-marked1? set-environment-marked1?! e) (remove-if-not environment-marked1? *es*)) (define (proper-callers e) ;; The PROPERLY-CALLS? relation is not necessarily reflexive. ;; This is done just for side effect, to set the MARKED1? bits. (some-proper-caller (lambda (e) #f) environment-marked1? set-environment-marked1?! e) (remove-if-not environment-marked1? *es*)) (define (callers e) ;; This is done just for side effect, to set the MARKED1? bits. (some-caller (lambda (e) #f) environment-marked1? set-environment-marked1?! e) (remove-if-not environment-marked1? *es*)) (define (proper-tail-callees e) ;; The PROPERLY-TAIL-CALLS? relation is not necessarily reflexive. ;; This is done just for side effect, to set the MARKED1? bits. (some-proper-tail-callee (lambda (e) #f) environment-marked1? set-environment-marked1?! e) (remove-if-not environment-marked1? *es*)) (define (tail-callees e) ;; This is done just for side effect, to set the MARKED1? bits. (some-tail-callee (lambda (e) #f) environment-marked1? set-environment-marked1?! e) (remove-if-not environment-marked1? *es*)) (define (proper-tail-callers e) ;; The PROPERLY-TAIL-CALLS? relation is not necessarily reflexive. ;; This is done just for side effect, to set the MARKED1? bits. (some-proper-tail-caller (lambda (e) #f) environment-marked1? set-environment-marked1?! e) (remove-if-not environment-marked1? *es*)) (define (tail-callers e) ;; This is done just for side effect, to set the MARKED1? bits. (some-tail-caller (lambda (e) #f) environment-marked1? set-environment-marked1?! e) (remove-if-not environment-marked1? *es*)) (define (proper-non-tail-callees e) (remove-if-not (lambda (e1) (and (environment-used? e1) (properly-non-tail-calls? e e1))) *es*)) (define (proper-non-tail-callers e) (remove-if-not (lambda (e1) (and (environment-used? e1) (properly-non-tail-calls? e1 e))) *es*)) (define (direct-callees e) (unionq (direct-tail-callees e) (direct-non-tail-callees e))) (define (direct-callers e) (unionq (direct-tail-callers e) (direct-non-tail-callers e))) (define (direct-tail-callees e) (environment-direct-tail-callees e)) (define (direct-tail-callers e) (environment-direct-tail-callers e)) (define (direct-non-tail-callees e) (environment-direct-non-tail-callees e)) (define (direct-non-tail-callers e) (environment-direct-non-tail-callers e)) (define (compute-call-graph! e) (define (assert-directly-tail-calls! e1 e2) (unless (directly-tail-calls? e1 e2) (set-environment-direct-tail-callers! e2 (cons e1 (environment-direct-tail-callers e2))) (set-environment-direct-tail-callees! e1 (cons e2 (environment-direct-tail-callees e1))))) (define (assert-directly-non-tail-calls! e1 e2) (unless (directly-non-tail-calls? e1 e2) (set-environment-direct-non-tail-callers! e2 (cons e1 (environment-direct-non-tail-callers e2))) (set-environment-direct-non-tail-callees! e1 (cons e2 (environment-direct-non-tail-callees e1))))) ;; Initialize. (for-each (lambda (e) (set-environment-direct-tail-callers! e (unspecified)) (set-environment-direct-non-tail-callers! e (unspecified)) (set-environment-direct-tail-callees! e (unspecified)) (set-environment-direct-non-tail-callees! e (unspecified))) *es*) (for-each (lambda (e) (when (environment-used? e) (set-environment-direct-tail-callers! e '()) (set-environment-direct-non-tail-callers! e '()) (set-environment-direct-tail-callees! e '()) (set-environment-direct-non-tail-callees! e '()))) *es*) ;; Compute direct callees/callers. (for-each (lambda (e1) ;; needs work: This notion of tail call, indicated by P?, doesn't take into ;; account in-lining and vacuous SET!s. (define (mark! x p?) ;; conventions: P? (case (expression-kind x) ((null-constant) #f) ((true-constant) #f) ((false-constant) #f) ((char-constant) #f) ((fixnum-constant) #f) ((flonum-constant) #f) ((rectangular-constant) #f) ((string-constant) #f) ((symbol-constant) #f) ((pair-constant) #f) ((vector-constant) #f) ((lambda converted-lambda converted-continuation) #f) ((set!) (mark! (expression-source x) #f)) ((if) (mark! (expression-antecedent x) #f) (when (can-be-non? false-type? (expression-type-set (expression-antecedent x))) (mark! (expression-consequent x) p?)) (when (can-be? false-type? (expression-type-set (expression-antecedent x))) (mark! (expression-alternate x) p?))) ((primitive-procedure) #f) ((foreign-procedure) #f) ((access) #f) ((call converted-call) (mark! (expression-callee x) #f) (for-each (lambda (x) (mark! x #f)) (expression-arguments x)) (when (executed? x) (when (converted? x) (when (can-be? (needs-implicit-continuation-call? (map expression-type-set (expression-arguments x)) *null* (create-call-site x)) (expression-type-set (expression-callee x))) (for-each-member (lambda (u) (unless (native-procedure-type? u) (fuck-up)) ;; Implicit continuation calls are always tail calls. (assert-directly-tail-calls! e1 (callee-environment u (recreate-call-site (create-call-site x) 'continuation-argument)))) (expression-type-set (continuation-argument x)))) ;; There currently is no need for an analogue of the following for ;; second-argument call sites because they currently cannot be ;; converted. (when (can-be? (first-argument-needs-implicit-continuation-call? (map expression-type-set (expression-arguments x)) *null* (create-call-site x)) (expression-type-set (expression-callee x))) (for-each-member (lambda (u) (unless (native-procedure-type? u) (fuck-up)) ;; Implicit continuation calls are always tail calls. (assert-directly-tail-calls! e1 (callee-environment u (recreate-call-site (recreate-call-site (create-call-site x) 'first-argument) 'continuation-argument)))) (expression-type-set (continuation-argument x))))) (for-each-member (lambda (u) (when ((truly-compatible-call? x) u) (cond (((primitive-procedure-type-named? 'apply) u) (for-each-member (lambda (u) (when (and (native-procedure-type? u) ((truly-compatible-call-via-apply? x) u)) (let ((e2 (callee-environment u (recreate-call-site (create-call-site x) 'first-argument)))) (if p? (assert-directly-tail-calls! e1 e2) (assert-directly-non-tail-calls! e1 e2))))) (expression-type-set (first-argument x)))) (((primitive-procedure-type-named? 'call-with-current-continuation) u) (for-each-member (lambda (u) (when (and (native-procedure-type? u) ((truly-compatible-call-via-call-with-current-continuation? x) u)) (let ((e2 (callee-environment u (recreate-call-site (create-call-site x) 'first-argument)))) (if p? (assert-directly-tail-calls! e1 e2) (assert-directly-non-tail-calls! e1 e2))))) (expression-type-set (first-argument x)))) (((primitive-procedure-type-named? 'fork) u) (for-each-member (lambda (u) (when (and (native-procedure-type? u) ((truly-compatible-call-via-fork1? x) u)) (assert-directly-non-tail-calls! e1 (callee-environment u (recreate-call-site (create-call-site x) 'first-argument))))) (expression-type-set (first-argument x))) (for-each-member (lambda (u) (when (and (native-procedure-type? u) ((truly-compatible-call-via-fork2? x) u)) (assert-directly-non-tail-calls! e1 (callee-environment u (recreate-call-site (create-call-site x) 'second-argument))))) (expression-type-set (second-argument x)))) (((primitive-procedure-type-named? 'mutex) u) (for-each-member (lambda (u) (when (and (native-procedure-type? u) ((truly-compatible-call-via-mutex? x) u)) (assert-directly-non-tail-calls! e1 (callee-environment u (recreate-call-site (create-call-site x) 'first-argument))))) (expression-type-set (first-argument x)))) ((native-procedure-type? u) (let ((e2 (callee-environment u (create-call-site x)))) (unless (noop? e2) (if p? (assert-directly-tail-calls! e1 e2) (assert-directly-non-tail-calls! e1 e2)))))))) (expression-type-set (expression-callee x))))) (else (fuck-up)))) (when (environment-used? e1) (mark! (expression-body (environment-expression e1)) #t))) *es*)) ;;; Determine which environments are called more than once (define (determine-which-environments-are-called-more-than-once!) (for-each (lambda (e) (when (environment-used? e) (clock-sample) ;To prevent overflow. (set-environment-called-more-than-once?! e (or (> (length (call-sites e)) 1) (some (lambda (e) (> (length (call-sites e)) 1)) (proper-callers e)))))) *es*)) ;;; Determine which variables are referenced (define (determine-which-variables-are-referenced!) (for-each (lambda (x) (set-expression-accessed?! x #f)) *xs*) (for-each (lambda (g) (set-variable-accessed?! g #f)) *gs*) (for-each (lambda (g) (set-variable-assigned?! g #f)) *gs*) (let loop () (let ((again? #f)) (define (assert-callee-accessed! w0 y ws w p?) (for-each-member (lambda (u) (when ((truly-compatible-procedure? ws w y) u) (cond ((primitive-procedure-type? u) (when (explicit-call-site? y) (when (can-be-non? null-type? w) (fuck-up)) ;; note: This assumes that all primitive procedures access all of ;; their arguments. This includes the continuation argument. ;; needs work: The continuation argument should not be accessed ;; by primitive procedures that don't return. (for-each (lambda (x) (assert-expression-accessed! x)) (expression-arguments (call-site-expression y))) ;; Calls to CALL-WITH-CURRENT-CONTINUATION access the results of ;; calling their procedure arguments only if they themselves are ;; accessed. (if (converted? y) (cond (((primitive-procedure-type-named? 'apply) u) (assert-callee-accessed! (second ws) (recreate-call-site y 'first-argument) (cons (first ws) (but-last (rest (rest ws)))) (last ws) p?)) (((primitive-procedure-type-named? 'call-with-current-continuation) u) (assert-callee-accessed! (second ws) (recreate-call-site y 'first-argument) (list (first ws) (first ws)) *null* p?)) (((primitive-procedure-type-named? 'fork) u) (assert-callee-accessed! (second ws) (recreate-call-site y 'first-argument) (list (first ws)) *null* p?) (assert-callee-accessed! (third ws) (recreate-call-site y 'second-argument) (list (first ws)) *null* p?)) (((primitive-procedure-type-named? 'mutex) u) (assert-callee-accessed! (second ws) (recreate-call-site y 'first-argument) (list (first ws)) *null* p?))) (cond (((primitive-procedure-type-named? 'apply) u) (assert-callee-accessed! (first ws) (recreate-call-site y 'first-argument) (but-last (rest ws)) (last ws) p?)) (((primitive-procedure-type-named? 'call-with-current-continuation) u) (assert-callee-accessed! (first ws) (recreate-call-site y 'first-argument) (list (create-anonymous-type-set ( (call-site-expression y)))) *null* p?)) (((primitive-procedure-type-named? 'fork) u) (assert-callee-accessed! (first ws) (recreate-call-site y 'first-argument) '() *null* p?) (assert-callee-accessed! (second ws) (recreate-call-site y 'second-argument) '() *null* p?)) (((primitive-procedure-type-named? 'mutex) u) (assert-callee-accessed! (first ws) (recreate-call-site y 'first-argument) '() *null* p?)))) (when (converted? y) ;; The result of calling the continuation argument is accessed is ;; the call site is accessed. (assert-callee-accessed! (first ws) (recreate-call-site y 'continuation-argument) (list (expression-type-set (call-site-expression y))) *null* p?)))) ((native-procedure-type? u) (let ((e (callee-environment u y))) (when (and (not (noop? e)) (or p? (and (converted? y) (not (converted? e)) (can-be? (lambda (u) (and ((truly-compatible-procedure? (list (return-type-set e)) *null* (recreate-call-site y 'continuation-argument)) u) (or ;; note: This assumes that all primitive procedures ;; access all of their arguments. (primitive-procedure-type? u) (and (native-procedure-type? u) (variable-accessed? (first (variables (callee-environment u (recreate-call-site y 'continuation-argument)))))) ;; note: This assumes that all foreign procedures ;; access all of their arguments. (foreign-procedure-type? u) (and (continuation-type? u) ;; Continuations access their arguments only if their ;; allocation expression is accessed. (expression-accessed? (continuation-type-allocating-expression u)))))) (expression-type-set (continuation-argument (call-site-expression y))))))) (assert-expression-accessed! (expression-body (environment-expression e)))) (when (explicit-call-site? y) (let loop ((gs (variables e)) (xs (if (and (converted? y) (not (converted? e))) (rest (expression-arguments (call-site-expression y))) (expression-arguments (call-site-expression y))))) (unless (null? gs) (cond ((and (rest? e) (null? (rest gs))) (when (variable-accessed? (first gs)) (for-each assert-expression-accessed! xs))) (else (when (variable-accessed? (first gs)) (assert-expression-accessed! (first xs))) (loop (rest gs) (rest xs)))))) (when (and (converted? y) (not (converted? e))) ;; The continuation argument is itself accessed. (assert-expression-accessed! (continuation-argument (call-site-expression y))) ;; The result of calling the continuation argument is accessed if ;; the call site is accessed. (assert-callee-accessed! (first ws) (recreate-call-site y 'continuation-argument) (list (expression-type-set (call-site-expression y))) *null* p?))))) ((foreign-procedure-type? u) (when (explicit-call-site? y) ;; note: This assumes that all foreign procedures access all of their ;; arguments. This includes the continuation argument. ;; needs work: The continuation argument should not be accessed ;; by foreign procedures that don't return. (for-each assert-expression-accessed! (expression-arguments (call-site-expression y))) (when (converted? y) ;; The result of calling the continuation argument is accessed if ;; the call site is accessed. (assert-callee-accessed! (first ws) (recreate-call-site y 'continuation-argument) (list (expression-type-set (call-site-expression y))) *null* p?)))) ((continuation-type? u) (when (and (explicit-call-site? y) ;; Continuations access their arguments only if their ;; allocation expression is accessed. (expression-accessed? (continuation-type-allocating-expression u))) ;; Since nonconverted continuations never return they don't access ;; their continuation argument. And since the continuation argument ;; is never called there is no call to ASSERT-CALLEE-ACCESSED!. (assert-expression-accessed! (first-argument (call-site-expression y))))) (else (fuck-up))))) w0)) (define (assert-expression-accessed! x) (unless (expression-accessed? x) (set-expression-accessed?! x #t) (set! again? #t))) ;; The top-level lambda expression itself is accessed. (assert-expression-accessed! *x*) ;; The result of calling the top-level lambda expression is accessed only ;; if the result can be a fixnum. (assert-callee-accessed! (expression-type-set *x*) *y* (list *w1*) *null* (can-be? fixnum-type? (expression-type-set (expression-body *x*)))) (for-each (lambda (x) (when (reached? x) (let ((w (expression-type-set x))) (case (expression-kind x) ((null-constant) #f) ((true-constant) #f) ((false-constant) #f) ((char-constant) #f) ((fixnum-constant) #f) ((flonum-constant) #f) ((rectangular-constant) #f) ((string-constant) #f) ((symbol-constant) #f) ((pair-constant) #f) ((vector-constant) #f) ((lambda converted-lambda converted-continuation) #f) ((set!) ;; The source of an assignment is accessed only if the destination ;; variable is accessed. (when (variable-accessed? (expression-variable x)) (assert-expression-accessed! (expression-source x)))) ((if) ;; The antecedent is always accessed. (assert-expression-accessed! (expression-antecedent x)) ;; The consequent and alternate are accessed only if the expression ;; itself is accessed. (when (expression-accessed? x) (when (can-be-non? false-type? (expression-type-set (expression-antecedent x))) (assert-expression-accessed! (expression-consequent x))) (when (can-be? false-type? (expression-type-set (expression-antecedent x))) (assert-expression-accessed! (expression-alternate x))))) ((primitive-procedure) #f) ((foreign-procedure) #f) ((access) (when (and (expression-accessed? x) (not (variable-accessed? (expression-variable x)))) (set-variable-accessed?! (expression-variable x) #t) (set! again? #t))) ((call converted-call) ;; The callee itself is accessed. (assert-expression-accessed! (expression-callee x)) ;; But the result of calling the callee is accessed only if the ;; call site is accessed. (when (executed? x) (assert-callee-accessed! (expression-type-set (expression-callee x)) (create-call-site x) (map expression-type-set (expression-arguments x)) *null* (expression-accessed? x)))) (else (fuck-up)))))) *xs*) (when again? (loop)))) (for-each (lambda (x) (when (executed? x) (set-variable-assigned?! (expression-variable x) #t))) *assignments*)) ;;; Determine free variables (define (determine-free-variables!) (for-each (lambda (e) (set-environment-free-variables! e (unspecified))) *es*) (for-each (lambda (e) (when (environment-used? e) (set-environment-free-variables! e '()))) *es*) (for-each (lambda (x) (when (case (expression-kind x) ((access) (reached? x)) ((set!) (executed? x)) (else (fuck-up))) (let* ((g (expression-variable x)) (e1 (variable-environment g))) (when (accessed? g) (let loop ((e (expression-environment x))) (unless (eq? e e1) ;; This is just because of *CLOSURE-CONVERSION-METHOD*. (when (environment-used? e) (unless (memq g (environment-free-variables e)) (set-environment-free-variables! e (cons g (environment-free-variables e))))) (loop (parent e)))))))) *references*)) ;;; Annotate environments and continuation types (define (annotate-environments-and-continuation-types!) (for-each (lambda (e) (set-environment-expressions! e (unspecified)) (set-environment-continuation-calls! e (unspecified))) *es*) (for-each (lambda (e) (when (environment-used? e) (set-environment-expressions! e '()) (set-environment-continuation-calls! e '()))) *es*) (for-each (lambda (u) (set-continuation-type-call-sites! u (unspecified))) *continuation-types*) (for-each (lambda (u) (when (type-used? u) (set-continuation-type-call-sites! u '()))) *continuation-types*) (for-each (lambda (x) (when (and (reached? x) (not (empty? (expression-environment x))) (environment-used? (expression-environment x))) (set-environment-expressions! (expression-environment x) (cons x (environment-expressions (expression-environment x)))))) *xs*) (for-each (lambda (x) (when (and (reached? x) (not (empty? (expression-environment x))) (environment-used? (expression-environment x))) (when (can-be? (lambda (u) (and (continuation-type? u) ((truly-compatible-call? x) u))) (expression-type-set (expression-callee x))) (set-environment-continuation-calls! (expression-environment x) (cons x (environment-continuation-calls (expression-environment x)))) (for-each-member (lambda (u) (when (and (continuation-type? u) ((truly-compatible-call? x) u)) (set-continuation-type-call-sites! u (cons (create-call-site x) (continuation-type-call-sites u))))) (expression-type-set (expression-callee x)))) (when (can-be? (lambda (u) (and ((primitive-procedure-type-named? 'apply) u) ((truly-compatible-call? x) u) (can-be? (lambda (u) (and (continuation-type? u) ((truly-compatible-call-via-apply? x) u))) (expression-type-set (first-argument x))))) (expression-type-set (expression-callee x))) (for-each-member (lambda (u) (when (and ((primitive-procedure-type-named? 'apply) u) ((truly-compatible-call? x) u)) (for-each-member (lambda (u) (when (and (continuation-type? u) ((truly-compatible-call-via-apply? x) u)) (set-continuation-type-call-sites! u (cons (recreate-call-site (create-call-site x) 'first-argument) (continuation-type-call-sites u))))) (expression-type-set (first-argument x))))) (expression-type-set (expression-callee x)))) (when (can-be? (lambda (u) (and ((primitive-procedure-type-named? 'call-with-current-continuation) u) ((truly-compatible-call? x) u) (can-be? (lambda (u) (and (continuation-type? u) ((truly-compatible-call-via-call-with-current-continuation? x) u))) (expression-type-set (first-argument x))))) (expression-type-set (expression-callee x))) (for-each-member (lambda (u) (when (and ((primitive-procedure-type-named? 'call-with-current-continuation) u) ((truly-compatible-call? x) u)) (for-each-member (lambda (u) (when (and (continuation-type? u) ((truly-compatible-call-via-call-with-current-continuation? x) u)) (set-continuation-type-call-sites! u (cons (recreate-call-site (create-call-site x) 'first-argument) (continuation-type-call-sites u))))) (expression-type-set (first-argument x))))) (expression-type-set (expression-callee x)))) (when (can-be? (lambda (u) (and ((primitive-procedure-type-named? 'fork) u) ((truly-compatible-call? x) u) (can-be? (lambda (u) (and (continuation-type? u) ((truly-compatible-call-via-fork1? x) u))) (expression-type-set (first-argument x))))) (expression-type-set (expression-callee x))) (for-each-member (lambda (u) (when (and ((primitive-procedure-type-named? 'fork) u) ((truly-compatible-call? x) u)) (for-each-member (lambda (u) (when (and (continuation-type? u) ((truly-compatible-call-via-fork1? x) u)) (set-continuation-type-call-sites! u (cons (recreate-call-site (create-call-site x) 'first-argument) (continuation-type-call-sites u))))) (expression-type-set (first-argument x))))) (expression-type-set (expression-callee x)))) (when (can-be? (lambda (u) (and ((primitive-procedure-type-named? 'fork) u) ((truly-compatible-call? x) u) (can-be? (lambda (u) (and (continuation-type? u) ((truly-compatible-call-via-fork2? x) u))) (expression-type-set (second-argument x))))) (expression-type-set (expression-callee x))) (for-each-member (lambda (u) (when (and ((primitive-procedure-type-named? 'fork) u) ((truly-compatible-call? x) u)) (for-each-member (lambda (u) (when (and (continuation-type? u) ((truly-compatible-call-via-fork2? x) u)) (set-continuation-type-call-sites! u (cons (recreate-call-site (create-call-site x) 'second-argument) (continuation-type-call-sites u))))) (expression-type-set (second-argument x))))) (expression-type-set (expression-callee x)))) (when (can-be? (lambda (u) (and ((primitive-procedure-type-named? 'mutex) u) ((truly-compatible-call? x) u) (can-be? (lambda (u) (and (continuation-type? u) ((truly-compatible-call-via-mutex? x) u))) (expression-type-set (first-argument x))))) (expression-type-set (expression-callee x))) (for-each-member (lambda (u) (when (and ((primitive-procedure-type-named? 'mutex) u) ((truly-compatible-call? x) u)) (for-each-member (lambda (u) (when (and (continuation-type? u) ((truly-compatible-call-via-mutex? x) u)) (set-continuation-type-call-sites! u (cons (recreate-call-site (create-call-site x) 'first-argument) (continuation-type-call-sites u))))) (expression-type-set (first-argument x))))) (expression-type-set (expression-callee x)))))) *calls*)) ;;; Invert points-to relation (define (invert-points-to-relation!) (for-each (lambda (u) (set-types-and-type-sets-that-directly-point-to! u '())) *internal-symbol-types*) (for-each (lambda (u) (set-types-and-type-sets-that-directly-point-to! u '())) *external-symbol-types*) (for-each (lambda (u) (set-types-and-type-sets-that-directly-point-to! u '())) *primitive-procedure-types*) (for-each (lambda (u) (set-types-and-type-sets-that-directly-point-to! u '())) *native-procedure-types*) (for-each (lambda (u) (set-types-and-type-sets-that-directly-point-to! u '())) *foreign-procedure-types*) (for-each (lambda (u) (set-types-and-type-sets-that-directly-point-to! u '())) *continuation-types*) (for-each (lambda (u) (set-types-and-type-sets-that-directly-point-to! u '())) *string-types*) (for-each (lambda (u) (set-types-and-type-sets-that-directly-point-to! u '())) *structure-types*) (for-each (lambda (u) (set-types-and-type-sets-that-directly-point-to! u '())) *headed-vector-types*) (for-each (lambda (u) (set-types-and-type-sets-that-directly-point-to! u '())) *nonheaded-vector-types*) (for-each (lambda (u) (set-types-and-type-sets-that-directly-point-to! u '())) *displaced-vector-types*) (for-each (lambda (w) (for-each-member (lambda (u) (when (or (internal-symbol-type? u) (external-symbol-type? u) (primitive-procedure-type? u) (native-procedure-type? u) (foreign-procedure-type? u) (continuation-type? u) (string-type? u) (structure-type? u) (headed-vector-type? u) (nonheaded-vector-type? u) (displaced-vector-type? u)) (set-types-and-type-sets-that-directly-point-to! u (cons w (types-and-type-sets-that-directly-point-to u))))) w)) *ws*) (for-each (lambda (u) (set-types-and-type-sets-that-directly-point-to! (external-symbol-type-displaced-string-type u) (cons u (types-and-type-sets-that-directly-point-to (external-symbol-type-displaced-string-type u))))) *external-symbol-types*) (for-each (lambda (u) (set-types-and-type-sets-that-directly-point-to! (displaced-vector-type-displaced-vector-type u) (cons u (types-and-type-sets-that-directly-point-to (displaced-vector-type-displaced-vector-type u))))) *displaced-vector-types*)) ;;; Determine directly escaping types (define (mark-referencing-environments-proper-callees! u) (define (mark-proper-callees! e) ;; The PROPERLY-CALLS? relation is not necessarily reflexive. (define (loop e) (unless (environment-marked1? e) (set-environment-marked1?! e #t) (for-each loop (environment-direct-tail-callees e)) (for-each loop (environment-direct-non-tail-callees e)))) (for-each loop (environment-direct-tail-callees e)) (for-each loop (environment-direct-non-tail-callees e))) (when (or (internal-symbol-type? u) (external-symbol-type? u) (primitive-procedure-type? u) (native-procedure-type? u) (foreign-procedure-type? u) (continuation-type? u) (string-type? u) (structure-type? u) (headed-vector-type? u) (nonheaded-vector-type? u) (displaced-vector-type? u)) (let outer ((u/w u)) (cond ((type? u/w) (unless (type-marked? u/w) (set-type-marked?! u/w #t) (for-each outer (types-and-type-sets-that-directly-point-to u/w)))) ((type-set? u/w) (unless (type-set-marked? u/w) (set-type-set-marked?! u/w #t) (cond ((expression? (type-set-location u/w)) (when (reached? (type-set-location u/w)) (mark-proper-callees! (expression-environment (type-set-location u/w))))) ((variable? (type-set-location u/w)) (when (and (accessed? (type-set-location u/w)) (not (necessarily-fictitious? u/w))) (let inner ((e (variable-environment (type-set-location u/w)))) (when (memq (type-set-location u/w) (free-variables e)) (outer (environment-type e))) (for-each (lambda (x) (case (expression-kind x) ((lambda converted-lambda converted-continuation) (when (environment-used? (expression-lambda-environment x)) (inner (expression-lambda-environment x)))))) (environment-expressions e))))) ((type? (type-set-location u/w)) (outer (type-set-location u/w))) ((eq? (type-set-location u/w) #f) #f) (else (fuck-up))))) (else (fuck-up)))))) (define (for-each-marked-caller p e) (let loop ((e e)) (when (environment-marked1? e) (set-environment-marked1?! e #f) (p e) (for-each loop (environment-direct-tail-callers e)) (for-each loop (environment-direct-non-tail-callers e))))) (define (important? u) (and (or (native-procedure-type? u) (continuation-type? u) (string-type? u) (structure-type? u) (headed-vector-type? u) (nonheaded-vector-type? u)) (not (necessarily-fictitious? u)))) (define (important-marked-types) (remove-if necessarily-fictitious? (append (remove-if-not native-procedure-type-marked? *native-procedure-types*) (remove-if-not continuation-type-marked? *continuation-types*) (remove-if-not string-type-marked? *string-types*) (remove-if-not structure-type-marked? *structure-types*) (remove-if-not headed-vector-type-marked? *headed-vector-types*) (remove-if-not nonheaded-vector-type-marked? *nonheaded-vector-types*)))) (define (determine-escaping-types!) (for-each (lambda (e) (set-environment-escaping-types! e (unspecified))) *es*) (for-each (lambda (e) (when (environment-used? e) (set-environment-escaping-types! e '()) ;; Nothing escapes the top-level environment. (unless (empty? (parent e)) (clock-sample) ;To prevent overflow. (unmark-types!) ;; This is done just for side effect, to set the MARKED? bits. (for-each-pointed-to-type (lambda (u) #f) (return-type-set e)) (set-environment-escaping-types! e (important-marked-types))))) *es*) (for-each (lambda (g) (when (and (accessed? g) (assigned? g) ;; This tries to state that G must be hidden thus the assignment ;; X is trivial and should be ignored. ;; needs work: But G will not be hidden if it is global, its ;; hidden native-procedure type is fictitious, or ;; some access causes its environment to be ;; nonfictitious. (not (and (monomorphic? (variable-type-set g)) (native-procedure-type? (the-member (variable-type-set g))) (called? (the-member (variable-type-set g))) (not (noop? (the-member (variable-type-set g)))) (every (lambda (e) ;; This is a weaker condition than used by ;; DETERMINE-WHETHER-HIDDEN? so G might actually ;; turn out to be hidden. (let loop ((e1 (variable-environment g))) (and (not (empty? e1)) (or (eq? e1 (parent e)) (loop (parent e1)))))) (narrow-clones (the-member (variable-type-set g)))))) (begin (unmark-types!) (some (lambda (x) (some-pointed-to-type important? (expression-type-set (expression-source x)))) (assignments g)))) (clock-sample) ;To prevent overflow. (unmark-types-and-type-sets!) (for-each (lambda (e) (set-environment-marked1?! e #f)) *es*) (for-each (lambda (x1) (let loop ((e (expression-environment x1))) (unless (eq? e (variable-environment g)) (mark-referencing-environments-proper-callees! (environment-type e)) (loop (parent e))))) (accesses g)) (for-each (lambda (x) (when (executed? x) (clock-sample) ;To prevent overflow. ;; If E points to U1 then it points to U since U1 points to U. But not ;; vice versa. It could be that a caller of E points to U but not U1 ;; because that caller is also a callee that is passed U as an argument ;; but not passed U1. Such cases do not count as escaping. Even so, this ;; is still suboptimal because a caller of E could point to U1 only by ;; virtue of that caller also being a callee that is called with U1 as ;; an argument. (unmark-types!) ;; This is done just for side effect, to set the MARKED? bits. (for-each-pointed-to-type (lambda (u) #f) (expression-type-set (expression-source x))) (let ((us (important-marked-types))) (unless (null? us) (for-each-marked-caller (lambda (e) (set-environment-escaping-types! e (unionq (environment-escaping-types e) us))) (expression-environment x)))))) (assignments g)))) *gs*) (for-each (lambda (x) (when (and (executed? x) (can-be? (lambda (u1) (and (continuation-type? u1) ((truly-compatible-call? x) u1))) (expression-type-set (expression-callee x)))) (clock-sample) ;To prevent overflow. (unmark-types!) ;; This is done just for side effect, to set the MARKED? bits. (for-each-pointed-to-type (lambda (u) #f) (expression-type-set (first-argument x))) (let ((us (important-marked-types))) (unless (null? us) (for-each (lambda (e) (when (can-be? (lambda (u1) (and (continuation-type? u1) ((truly-compatible-call? x) u1) ;; This checks that the call to the continuation can ;; actually escape E by checking that the creator of the ;; continuation can be a caller of E. This is suboptimal ;; because the creator of the continuation could also be a ;; callee of E. If the creator is not a callee then ;; calling the continuation must escape E. But if the ;; creator is also a callee then calling the continuation ;; might or might not escape E. (can-be? (lambda (u2) (and (native-procedure-type? u2) (some (lambda (e1) (properly-calls? e1 e)) (narrow-clones u2)))) (expression-type-set (first-argument (continuation-type-allocating-expression u1)))))) (expression-type-set (expression-callee x))) (set-environment-escaping-types! e (unionq (environment-escaping-types e) us)))) (callers (expression-environment x))))))) ;; needs work: Doesn't handle implicit continuation calls. *calls*) (for-each (lambda (u2) (unmark-types!) (when (some (lambda (x) (and (executed? x) (can-be? (lambda (u1) (and ((primitive-procedure-type-named? 'structure-set!) u1) ((structure-type-named? (first (primitive-procedure-type-arguments u1))) u2) ((truly-compatible-call? x) u1))) (expression-type-set (expression-callee x))) (member? u2 (expression-type-set (first-argument x))) (some-pointed-to-type important? (expression-type-set (second-argument x))))) ;; note: Because of eta expansion there can be no implicit calls to ;; STRUCTURE-SET!. *calls*) (clock-sample) ;To prevent overflow. (unmark-types-and-type-sets!) (for-each (lambda (e) (set-environment-marked1?! e #f)) *es*) (mark-referencing-environments-proper-callees! u2) (for-each (lambda (x) (when (and (executed? x) (can-be? (lambda (u1) (and ((primitive-procedure-type-named? 'structure-set!) u1) ((structure-type-named? (first (primitive-procedure-type-arguments u1))) u2) ((truly-compatible-call? x) u1))) (expression-type-set (expression-callee x))) (member? u2 (expression-type-set (first-argument x)))) (clock-sample) ;To prevent overflow. ;; If E points to U2 then it points to U since U2 points to U. But not ;; vice versa. It could be that a caller of E points to U but not U2 ;; because that caller is also a callee that is passed U as an argument ;; but not passed U2. Such cases do not count as escaping. Even so, this ;; is still suboptimal because a caller of E could point to U2 only by ;; virtue of that caller also being a callee that is called with U2 as ;; an argument. (unmark-types!) ;; This is done just for side effect, to set the MARKED? bits. (for-each-pointed-to-type (lambda (u) #f) (expression-type-set (second-argument x))) (let ((us (important-marked-types))) (unless (null? us) (for-each-marked-caller (lambda (e) (set-environment-escaping-types! e (unionq (environment-escaping-types e) us))) (expression-environment x)))))) ;; note: Because of eta expansion there can be no implicit calls to ;; STRUCTURE-SET!. *calls*))) *structure-types*) (for-each (lambda (u2) (unmark-types!) (when (some (lambda (x) (and (executed? x) (can-be? (lambda (u1) (and ((primitive-procedure-type-named? 'vector-set!) u1) ((truly-compatible-call? x) u1))) (expression-type-set (expression-callee x))) (member? u2 (expression-type-set (first-argument x))) (some-pointed-to-type important? (expression-type-set (third-argument x))))) ;; note: Because of eta expansion there can be no implicit calls to ;; VECTOR-SET!. *calls*) (clock-sample) ;To prevent overflow. (unmark-types-and-type-sets!) (for-each (lambda (e) (set-environment-marked1?! e #f)) *es*) (mark-referencing-environments-proper-callees! u2) (for-each (lambda (x) (when (and (executed? x) (can-be? (lambda (u1) (and ((primitive-procedure-type-named? 'vector-set!) u1) ((truly-compatible-call? x) u1))) (expression-type-set (expression-callee x))) (member? u2 (expression-type-set (first-argument x)))) (clock-sample) ;To prevent overflow. ;; If E points to U2 then it points to U since U2 points to U. But not ;; vice versa. It could be that a caller of E points to U but not U2 ;; because that caller is also a callee that is passed U as an argument ;; but not passed U2. Such cases do not count as escaping. Even so, this ;; is still suboptimal because a caller of E could point to U2 only by ;; virtue of that caller also being a callee that is called with U2 as ;; an argument. (unmark-types!) ;; This is done just for side effect, to set the MARKED? bits. (for-each-pointed-to-type (lambda (u) #f) (expression-type-set (third-argument x))) (let ((us (important-marked-types))) (unless (null? us) (for-each-marked-caller (lambda (e) (set-environment-escaping-types! e (unionq (environment-escaping-types e) us))) (expression-environment x)))))) ;; note: Because of eta expansion there can be no implicit calls to ;; VECTOR-SET!. *calls*))) (append *headed-vector-types* *nonheaded-vector-types* *displaced-vector-types*))) ;;; Determine which environments have unique call sites (define (determine-which-environments-have-unique-call-sites!) (for-each (lambda (e) (when (environment-used? e) (set-environment-non-self-tail-call-sites! e (call-sites e)))) *es*) (let loop () (set! *again?* #f) (infer-all-unique-call-site!) (when *again?* (loop)))) ;;; Determine which environments are recursive (define (determine-which-environments-are-recursive!) (for-each (lambda (e) (when (environment-used? e) (set-environment-recursive?! e (properly-calls? e e)))) *es*)) ;;; Determine which environments are reentrant (define (determine-which-environments-are-reentrant!) ;; note: In principle, this can be (NON-TAIL-CALLS? E E) but in practise it ;; can't because tail merging is done only on self tail calls. (for-each (lambda (e) (when (environment-used? e) (clock-sample) ;To prevent overflow. ;; This is done just for side effect, to set the MARKED2? bits. (some-proper-callee (lambda (e) #f) environment-marked2? set-environment-marked2?! e) (set-environment-reentrant?! e (some (lambda (e1) (and (environment-used? e1) (not (unique-call-site? e1)) (some (lambda (y) (and (not (top-level-call-site? y)) (environment-marked2? (expression-environment (call-site-expression y))) (not (can-be-self-tail-call-to? y e1)))) (call-sites e1)))) (proper-callers e))))) *es*)) ;;; Assert uniqueness (define (assert-uniqueness!) ;; This is a special case for when the type set members are sorted. (define (set-equalq? us1 us2) (or (and (null? us1) (null? us2)) (and (not (null? us1)) (not (null? us2)) (eq? (first us1) (first us2)) (set-equalq? (rest us1) (rest us2))))) ;; This is a special case for when the type set members are sorted. (define (unionq us1 us2) (cond ((null? us1) us2) ((null? us2) us1) ((eq? (first us1) (first us2)) (cons (first us1) (unionq (rest us1) (rest us2)))) ((< (type-index (first us1)) (type-index (first us2))) (cons (first us1) (unionq (rest us1) us2))) (else (cons (first us2) (unionq us1 (rest us2)))))) ;; We no longer need to sort the members of W because this is done by the ;; red-black trees. (let loop () (let ((again? #f)) (for-each (lambda (v) ;; conventions: V (let ((uss (map list (remove-if-not (structure-type-named? v) *structure-types*)))) (for-each (lambda (w) (let ((us (members-that (structure-type-named? v) w))) (unless (or (null? us) (null? (rest us))) (do ((us us (rest us))) ((null? (rest us))) (let ((us1 (find-if (lambda (us0) (memq (first us) us0)) uss)) (us2 (find-if (lambda (us0) (memq (second us) us0)) uss))) (unless (eq? us1 us2) (set! uss (cons (append us1 us2) (removeq us1 (removeq us2 uss)))))))))) *ws*) (for-each (lambda (us) (let ((uss (map-n (lambda (i) (reduce unionq (map (lambda (u) (members (list-ref (structure-type-slots u) i))) us) '())) (length (structure-type-slots (first us)))))) (for-each (lambda (u) (for-each (lambda (w us) (unless (set-equalq? (members w) us) (set-members! w us) (set! again? #t))) (structure-type-slots u) uss)) us))) uss))) (remove-duplicates (map structure-type-name *structure-types*))) (let ((uss (map list *headed-vector-types*))) (for-each (lambda (w) (let ((us (members-that headed-vector-type? w))) (unless (or (null? us) (null? (rest us))) (do ((us us (rest us))) ((null? (rest us))) (let ((us1 (find-if (lambda (us0) (memq (first us) us0)) uss)) (us2 (find-if (lambda (us0) (memq (second us) us0)) uss))) (unless (eq? us1 us2) (set! uss (cons (append us1 us2) (removeq us1 (removeq us2 uss)))))))))) *ws*) (for-each (lambda (us) (let ((us1 (reduce unionq (map (lambda (u) (members (headed-vector-type-element u))) us) '()))) (for-each (lambda (u) (unless (set-equalq? (members (headed-vector-type-element u)) us1) (set-members! (headed-vector-type-element u) us1) (set! again? #t))) us))) uss)) (let ((uss (map list *nonheaded-vector-types*))) (for-each (lambda (w) (let ((us (members-that nonheaded-vector-type? w))) (unless (or (null? us) (null? (rest us))) (do ((us us (rest us))) ((null? (rest us))) (let ((us1 (find-if (lambda (us0) (memq (first us) us0)) uss)) (us2 (find-if (lambda (us0) (memq (second us) us0)) uss))) (unless (eq? us1 us2) (set! uss (cons (append us1 us2) (removeq us1 (removeq us2 uss)))))))))) *ws*) (for-each (lambda (us) (let ((us1 (reduce unionq (map (lambda (u) (members (nonheaded-vector-type-element u))) us) '()))) (for-each (lambda (u) (unless (set-equalq? (members (nonheaded-vector-type-element u)) us1) (set-members! (nonheaded-vector-type-element u) us1) (set! again? #t))) us))) uss)) (when again? (loop))))) ;;; Perform lightweight closure conversion (define (perform-lightweight-closure-conversion!) (for-each (lambda (u) (set-native-procedure-type-fictitious?! u #t)) *native-procedure-types*) (for-each (lambda (u) (set-continuation-type-fictitious?! u #t)) *continuation-types*) (for-each (lambda (u) (set-structure-type-fictitious?! u #t)) *structure-types*) (for-each (lambda (w) (set-type-set-fictitious?! w #t)) *ws*) (for-each (lambda (g) (set-variable-local?! g #f) (set-variable-global?! g #f) (set-variable-hidden?! g #f) (set-variable-slotted?! g #f)) *gs*) (for-each (lambda (e) (set-environment-ancestors! e (unspecified)) (set-environment-has-closure?! e #f)) *es*) (for-each (lambda (e) (when (environment-used? e) (set-environment-ancestors! e '()))) *es*) (for-each (lambda (e2) (when (environment-used? e2) (let loop ((e1 (parent e2))) (if (or (empty? e1) (some accessed? (variables e1))) (set-environment-quick-parent! e2 e1) (loop (parent e1)))))) *es*) (let loop () (clock-sample) ;To prevent overflow. (set! *again?* #f) ;; The order in which the following inferences are made should only ;; affect compilation time and not soundness or the code produced. (infer-all-whether-type-fictitious?! #f) (infer-all-whether-type-set-fictitious?! #f) (infer-all-whether-local?! #f) (infer-all-whether-global?! #f) (infer-all-whether-hidden?! #f) (infer-all-whether-slotted?! #f) (infer-all-whether-ancestor?! #f) (infer-all-whether-has-closure?! #f) (when *again?* (loop))) (clock-sample) ;To prevent overflow. (set! *again?* #f) ;; The order in which the following inferences are made should only ;; affect compilation time and not soundness or the code produced. (infer-all-whether-type-fictitious?! #t) (infer-all-whether-type-set-fictitious?! #t) (infer-all-whether-local?! #t) (infer-all-whether-global?! #t) (infer-all-whether-hidden?! #t) (infer-all-whether-slotted?! #t) (infer-all-whether-ancestor?! #t) (infer-all-whether-has-closure?! #t) (when *again?* (fuck-up))) ;;; Determine parents (define (determine-parents!) (for-each (lambda (e) (set-environment-parent-parameter! e (unspecified)) (set-environment-parent-slot! e (unspecified)) (set-environment-descendents! e '()) (set-environment-properly-in-lined-environments! e '())) *es*) ;; needs work: This can be made faster. (for-each (lambda (e1) (when (environment-used? e1) (clock-sample) ;To prevent overflow. (for-each (lambda (e2) (when (environment-used? e2) (set-environment-descendents! e2 (cons e1 (descendents e2))))) (ancestors e1)))) *es*) (when (eq? *closure-representation* 'linked) ;; It used to be possible for two different narrow clones to have different ;; parent parameters. This was discovered with the matrix.sc example of ;; jbs@quiotix.com. This created problems when applying PARENT-PARAMETER to ;; a type instead of an environment and also caused generation of incorrect ;; code where one backchain was accessed as the backchain of a narrow clone. ;; Now we take the most-nested parent parameter of all the narrow clones. ;; This might cause some procedures to have a parent parameter that is used ;; only to indirect through a parent slot and not to access other slots (i.e. ;; reducing the amount of parent-parameter compression). So it goes. (for-each (lambda (e) (when (environment-used? e) (clock-sample) ;To prevent overflow. (set-environment-parent-parameter! (narrow-prototype e) (let ((es (reduce unionq (map ancestors (remove-if-not environment-used? (narrow-clones e))) '()))) (if (null? es) #f (minp nested-in? es)))))) *es*) (let loop ((x *x*)) (define (update x) (reduce unionq (map (lambda (e) (cond ((or (noop? e) (not (environment-used? e))) (set-environment-parent-slot! e #f) '()) (else (let ((es (removeq e (loop (expression-body (environment-expression e)))))) (set-environment-parent-slot! e (if (and (has-closure? e) (not (null? es))) (minp nested-in? es) #f)) (unionq es (if (has-parent-parameter? e) (removeq (parent-parameter e) (ancestors e)) '())))))) (narrow-clones (expression-lambda-environment x))) '())) (case (expression-kind x) ((null-constant) '()) ((true-constant) '()) ((false-constant) '()) ((char-constant) '()) ((fixnum-constant) '()) ((flonum-constant) '()) ((rectangular-constant) '()) ((string-constant) '()) ((symbol-constant) '()) ((pair-constant) '()) ((vector-constant) '()) ((lambda) (update x)) ((converted-lambda) (update x)) ((converted-continuation) (update x)) ((set!) (loop (expression-source x))) ((if) (unionq (loop (expression-antecedent x)) (unionq (loop (expression-consequent x)) (loop (expression-alternate x))))) ((primitive-procedure) '()) ((foreign-procedure) '()) ((access) '()) ((call) (unionq (loop (expression-callee x)) (reduce unionq (map loop (expression-arguments x)) '()))) ((converted-call) (unionq (loop (expression-callee x)) (reduce unionq (map loop (expression-arguments x)) '()))) (else (fuck-up)))) (for-each (lambda (e) (when (environment-used? e) (clock-sample) ;To prevent overflow. (unless (and (pairwise? (lambda (e1 e2) (or (not (environment-used? e1)) (not (environment-used? e2)) (and (eq? (has-parent-parameter? e1) (has-parent-parameter? e2)) (eq? (parent-parameter e1) (parent-parameter e2))))) (narrow-clones e)) (eq? (has-parent-parameter? e) (environment? (parent-parameter e))) (or (not (has-parent-slot? e)) (and (has-parent-parameter? e) (has-closure? e)))) (fuck-up)))) *es*)) (for-each (lambda (e) (when (environment-used? e) (clock-sample) ;To prevent overflow. (let loop ((e1 e)) (unless (eq? e e1) (set-environment-properly-in-lined-environments! e1 (cons e (environment-properly-in-lined-environments e1)))) (when (unique-call-site? e1) (loop (expression-environment (call-site-expression (unique-call-site e1)))))))) *es*)) ;;; Determine which expressions need conversion to CPS (define (escapes-expression? u x) ;; debugging: This is a temporary kludge to handle the NEPLS pyth benchmark. ;; It is unsound because it doesn't check for escapes by way of ;; continuation calls, STRUCTURE-SET!, and VECTOR-SET!. And you ;; really want to check that the continuation is allocated by some ;; expression called by X. This is only a kludge to make the NEPLS ;; pyth benchmark work. (or #t ;; This handles escaping by returning. (points-to? (expression-type-set x) u) ;; This handles escaping by SET!. (some (lambda (g) (and (nested-in? (expression-environment x) (variable-environment g)) (points-to? (variable-type-set g) u))) *gs*))) (define (determine-which-expressions-need-conversion-to-CPS!) (define (some-subexpression-calls? x x1) (let loop ((x x)) (and (reached? x) (case (expression-kind x) ((set!) (loop (expression-source x))) ((if) (or (loop (expression-antecedent x)) (loop (expression-consequent x)) (loop (expression-alternate x)))) ;; needs work: Doesn't handle implicit call sites. ((call converted-call) (or (eq? x x1) (can-be? (lambda (u) (and ((truly-compatible-call? x) u) (or (and (native-procedure-type? u) (calls? (callee-environment u (create-call-site x)) (expression-environment x1))) (and ((primitive-procedure-type-named? 'apply) u) (can-be? (lambda (u) (and (native-procedure-type? u) ((truly-compatible-call-via-apply? x) u) (calls? (callee-environment u (recreate-call-site (create-call-site x) 'first-argument)) (expression-environment x1)))) (expression-type-set (first-argument x)))) (and ((primitive-procedure-type-named? 'call-with-current-continuation) u) (can-be? (lambda (u) (and (native-procedure-type? u) ((truly-compatible-call-via-call-with-current-continuation? x) u) (calls? (callee-environment u (recreate-call-site (create-call-site x) 'first-argument)) (expression-environment x1)))) (expression-type-set (first-argument x)))) (and ((primitive-procedure-type-named? 'fork) u) (or (can-be? (lambda (u) (and (native-procedure-type? u) ((truly-compatible-call-via-fork1? x) u) (calls? (callee-environment u (recreate-call-site (create-call-site x) 'first-argument)) (expression-environment x1)))) (expression-type-set (first-argument x))) (can-be? (lambda (u) (and (native-procedure-type? u) ((truly-compatible-call-via-fork2? x) u) (calls? (callee-environment u (recreate-call-site (create-call-site x) 'second-argument)) (expression-environment x1)))) (expression-type-set (second-argument x))))) (and ((primitive-procedure-type-named? 'mutex) u) (can-be? (lambda (u) (and (native-procedure-type? u) ((truly-compatible-call-via-mutex? x) u) (calls? (callee-environment u (recreate-call-site (create-call-site x) 'first-argument)) (expression-environment x1)))) (expression-type-set (first-argument x))))))) (expression-type-set (expression-callee x))) (loop (expression-callee x)) (some loop (expression-arguments x)))) (else #f))))) ;; XS are all the nonconverted calls to CALL-WITH-CURRENT-CONTINUATION where ;; the continuation created escapes the call site. For each X in XS, the ;; corresponding entry in XSS is the set of all calls to the continuation ;; created by X. (let* ((xs (remove-if-not (lambda (x) (and (executed? x) (not (converted? x)) (can-be? (lambda (u) (and ((primitive-procedure-type-named? 'call-with-current-continuation) u) ((truly-compatible-call? x) u) (can-be? (lambda (u) (and (native-procedure-type? u) ((truly-compatible-procedure? (list (create-anonymous-type-set ( x))) *null* (recreate-call-site (create-call-site x) 'first-argument)) u) (escapes? ( x) (callee-environment u (recreate-call-site (create-call-site x) 'first-argument))))) (expression-type-set (first-argument x))))) (expression-type-set (expression-callee x))))) ;; note: Because of eta expansion there can be no implicit calls ;; to CALL-WITH-CURRENT-CONTINUATION. *calls*)) (xss (map (lambda (x) (remove-if-not (lambda (x1) (and (executed? x1) (can-be? (lambda (u) (and (continuation-type? u) ((truly-compatible-call? x1) u) (eq? (continuation-type-allocating-expression u) x))) (expression-type-set (expression-callee x1))))) ;; needs work: Doesn't handle implicit continuation calls. *calls*)) xs))) (define (needs-conversion-to-CPS? x) (and (some (lambda (x1 xs) (and (some-subexpression-calls? x x1) (some (lambda (x2) (control-flows? (after x) (before x2))) xs))) xs xss) (some (lambda (u) (escapes-expression? u x)) *continuation-types*))) (for-each (lambda (x) (set-expression-needs-conversion-to-CPS?! x (needs-conversion-to-CPS? x)) (set-expression-needs-stop-conversion-to-CPS?! x (and (not (needs-conversion-to-CPS? x)) (case (expression-kind x) ((set!) (needs-conversion-to-CPS? (expression-source x))) ((if) (or (needs-conversion-to-CPS? (expression-antecedent x)) (needs-conversion-to-CPS? (expression-consequent x)) (needs-conversion-to-CPS? (expression-alternate x)))) ((call converted-call) (or (needs-conversion-to-CPS? (expression-callee x)) (some needs-conversion-to-CPS? (expression-arguments x)) (can-be? (lambda (u) (and (native-procedure-type? u) ((truly-compatible-call? x) u) (not (noop? (callee-environment u (create-call-site x)))) (needs-conversion-to-CPS? (expression-body (environment-expression (callee-environment u (create-call-site x))))))) (expression-type-set (expression-callee x))))) (else #f))))) *xs*))) ;;; Convert to CPS ;;; Needs work: To convert a call to APPLY or CALL-WITH-CURRENT-CONTINUATION ;;; to CPS when its procedure argument is a converted native ;;; procedure. (define (maybe-create-access-expression g/x) ;; needs work: Should give S/X argument so that it has a file position. (if (variable? g/x) (create-access-expression #f g/x) g/x)) (define (call-continuation g/x x) ;; needs work: Should give S/X argument so that it has a file position. (create-call-expression #f (maybe-create-access-expression g/x) (list x))) (define (string->variable string) (create-variable (create-anonymous-s-expression (gensym string)))) (define (convert-to-CPS g/x x) (cond ((or (expression-needs-conversion-to-CPS? x) (expression-needs-stop-conversion-to-CPS? x)) (case (expression-kind x) ((null-constant) (fuck-up)) ((true-constant) (fuck-up)) ((false-constant) (fuck-up)) ((char-constant) (fuck-up)) ((fixnum-constant) (fuck-up)) ((flonum-constant) (fuck-up)) ((rectangular-constant) (fuck-up)) ((string-constant) (fuck-up)) ((symbol-constant) (fuck-up)) ((pair-constant) (fuck-up)) ((vector-constant) (fuck-up)) ((lambda) (fuck-up)) ((converted-lambda converted-continuation) (fuck-up)) ((set!) ;; [(SET! g x)]_g/x --> [x]_(LAMBDA (g1) (g/x (SET! g g1))) (unless (or (expression-needs-conversion-to-CPS? (expression-source x)) (expression-needs-stop-conversion-to-CPS? (expression-source x))) (fuck-up)) (let ((g1 (string->variable "x"))) (convert-to-CPS (create-converted-continuation-expression x ;; needs work: To give the environment a name. (create-environment #f "continuation") (list g1) (call-continuation g/x (create-set!-expression x (expression-variable x) (create-access-expression x g1)))) (expression-source x)))) ((if) (cond ((or (expression-needs-conversion-to-CPS? (expression-antecedent x)) (expression-needs-stop-conversion-to-CPS? (expression-antecedent x))) ;; [(IF x2 x3 x4)]_c --> [x2]_(LAMBDA (g1) (IF g1 [x3]_c [x4]_c)) ;; [(IF x2 x3 x4)]_c --> ;; ((LAMBDA (g2) [x2]_(LAMBDA (g1) (IF g1 [x3]_g2 [x4]_g2))) c) (let ((g1 (string->variable "x"))) (if (expression? g/x) (let ((g2 (string->variable "x"))) (create-call-expression x (create-converted-continuation-expression x ;; needs work: To give the environment a name. (create-environment #f "continuation") (list g2) (convert-to-CPS (create-converted-continuation-expression x ;; needs work: To give the environment a name. (create-environment #f "continuation") (list g1) (create-if-expression x (create-access-expression x g1) (convert-to-CPS g2 (expression-consequent x)) (convert-to-CPS g2 (expression-alternate x)))) (expression-antecedent x))) (list g/x))) (convert-to-CPS (create-converted-continuation-expression x ;; needs work: To give the environment a name. (create-environment #f "continuation") (list g1) (create-if-expression x (create-access-expression x g1) (convert-to-CPS g/x (expression-consequent x)) (convert-to-CPS g/x (expression-alternate x)))) (expression-antecedent x))))) (else ;; [(IF x1 x2 x3)]_c --> (IF x1 [x2]_c [x3]_c) ;; [(IF x1 x2 x3)]_c --> ((LAMBDA (g2) (IF x1 [x2]_g2 [x3]_g2)) c) (unless (or (expression-needs-conversion-to-CPS? (expression-consequent x)) (expression-needs-stop-conversion-to-CPS? (expression-consequent x)) (expression-needs-conversion-to-CPS? (expression-alternate x)) (expression-needs-stop-conversion-to-CPS? (expression-alternate x))) (fuck-up)) (if (expression? g/x) (let ((g2 (string->variable "x"))) (create-call-expression x (create-converted-continuation-expression x ;; needs work: To give the environment a name. (create-environment #f "continuation") (list g2) (create-if-expression x (nonconvert-to-CPS (expression-antecedent x)) (convert-to-CPS g2 (expression-consequent x)) (convert-to-CPS g2 (expression-alternate x)))) (list g/x))) (create-if-expression x (nonconvert-to-CPS (expression-antecedent x)) (convert-to-CPS g/x (expression-consequent x)) (convert-to-CPS g/x (expression-alternate x))))))) ((primitive-procedure) (fuck-up)) ((foreign-procedure) (fuck-up)) ((access) (fuck-up)) ((call) ;; [(x3 ...)]_g/x --> [x3]_(LAMBDA (g1) ... (g1 g/x ...) ...) (let loop ((xs1 (cons (expression-callee x) (expression-arguments x))) (gs '())) (if (null? xs1) (create-converted-call-expression x (create-access-expression x (last gs)) (cons (maybe-create-access-expression g/x) (map (lambda (g) (create-access-expression x g)) (rest (reverse gs))))) (let* ((g1 (string->variable "x")) (x1 (create-converted-continuation-expression x ;; needs work: To give the environment a name. (create-environment #f "continuation") (list g1) (loop (rest xs1) (cons g1 gs))))) (if (or (expression-needs-conversion-to-CPS? (first xs1)) (expression-needs-stop-conversion-to-CPS? (first xs1))) (convert-to-CPS x1 (first xs1)) (create-call-expression x x1 (list (nonconvert-to-CPS (first xs1))))))))) ((converted-call) (fuck-up)) (else (fuck-up)))) (else (call-continuation g/x (nonconvert-to-CPS x))))) (define (nonconvert-to-CPS x) (when (expression-needs-conversion-to-CPS? x) (fuck-up)) (if (expression-needs-stop-conversion-to-CPS? x) ;; x --> [x]_(LAMBDA (g) g) (convert-to-CPS (let ((g (string->variable "x"))) (create-converted-continuation-expression x ;; needs work: To give the environment a name. (create-environment #f "continuation") (list g) (create-access-expression x g))) x) (case (expression-kind x) ((null-constant) x) ((true-constant) x) ((false-constant) x) ((char-constant) x) ((fixnum-constant) x) ((flonum-constant) x) ((rectangular-constant) x) ((string-constant) x) ((symbol-constant) x) ((pair-constant) x) ((vector-constant) x) ((lambda) ;; (LAMBDA (g ...) x) --> (LAMBDA (c g ...) [x]_c) (cond ((noop? x) x) ((expression-needs-conversion-to-CPS? (expression-body x)) (let ((g (string->variable "c"))) (create-converted-lambda-expression x (expression-lambda-environment x) (cons g (expression-parameters x)) (convert-to-CPS g (expression-body x))))) (else (create-lambda-expression x (expression-lambda-environment x) (expression-parameters x) (nonconvert-to-CPS (expression-body x)))))) ((converted-lambda converted-continuation) (fuck-up)) ((set!) (create-set!-expression x (expression-variable x) (nonconvert-to-CPS (expression-source x)))) ((if) (create-if-expression x (nonconvert-to-CPS (expression-antecedent x)) (nonconvert-to-CPS (expression-consequent x)) (nonconvert-to-CPS (expression-alternate x)))) ((primitive-procedure) x) ((foreign-procedure) x) ((access) x) ((call) (create-call-expression x (nonconvert-to-CPS (expression-callee x)) (map nonconvert-to-CPS (expression-arguments x)))) ((converted-call) (fuck-up)) (else (fuck-up))))) (define (fully-convert-to-CPS x) (define (fully-convert-to-CPS g/x x) (case (expression-kind x) ((null-constant) (call-continuation g/x x)) ((true-constant) (call-continuation g/x x)) ((false-constant) (call-continuation g/x x)) ((char-constant) (call-continuation g/x x)) ((fixnum-constant) (call-continuation g/x x)) ((flonum-constant) (call-continuation g/x x)) ((rectangular-constant) (call-continuation g/x x)) ((string-constant) (call-continuation g/x x)) ((symbol-constant) (call-continuation g/x x)) ((pair-constant) (call-continuation g/x x)) ((vector-constant) (call-continuation g/x x)) ((lambda) (call-continuation g/x (if (noop? x) x (let ((g (string->variable "c"))) (create-converted-lambda-expression x (expression-lambda-environment x) (cons g (expression-parameters x)) (fully-convert-to-CPS g (expression-body x))))))) ((converted-lambda converted-continuation) (fuck-up)) ((set!) ;; [(SET! g x)]_g/x --> [x]_(LAMBDA (g1) (g/x (SET! g g1))) (let ((g1 (string->variable "x"))) (fully-convert-to-CPS (create-converted-continuation-expression x ;; needs work: To give the environment a name. (create-environment #f "continuation") (list g1) (call-continuation g/x (create-set!-expression x (expression-variable x) (create-access-expression x g1)))) (expression-source x)))) ((if) ;; [(IF x2 x3 x4)]_c --> [x2]_(LAMBDA (g1) (IF g1 [x3]_c [x4]_c)) ;; [(IF x2 x3 x4)]_c --> ;; ((LAMBDA (g2) [x2]_(LAMBDA (g1) (IF g1 [x3]_g2 [x4]_g2))) c) (let ((g1 (string->variable "x"))) (if (expression? g/x) (let ((g2 (string->variable "x"))) (create-call-expression x (create-converted-continuation-expression x ;; needs work: To give the environment a name. (create-environment #f "continuation") (list g2) (fully-convert-to-CPS (create-converted-continuation-expression x ;; needs work: To give the environment a name. (create-environment #f "continuation") (list g1) (create-if-expression x (create-access-expression x g1) (fully-convert-to-CPS g2 (expression-consequent x)) (fully-convert-to-CPS g2 (expression-alternate x)))) (expression-antecedent x))) (list g/x))) (fully-convert-to-CPS (create-converted-continuation-expression x ;; needs work: To give the environment a name. (create-environment #f "continuation") (list g1) (create-if-expression x (create-access-expression x g1) (fully-convert-to-CPS g/x (expression-consequent x)) (fully-convert-to-CPS g/x (expression-alternate x)))) (expression-antecedent x))))) ((primitive-procedure) (call-continuation g/x x)) ((foreign-procedure) (call-continuation g/x x)) ((access) (call-continuation g/x x)) ((call) ;; [(x3 ...)]_g/x --> [x3]_(LAMBDA (g1) ... (g1 g/x ...) ...) (let loop ((xs1 (cons (expression-callee x) (expression-arguments x))) (gs '())) (if (null? xs1) (create-converted-call-expression x (create-access-expression x (last gs)) (cons (maybe-create-access-expression g/x) (map (lambda (g) (create-access-expression x g)) (rest (reverse gs))))) (let* ((g1 (string->variable "x")) (x1 (create-converted-continuation-expression x ;; needs work: To give the environment a name. (create-environment #f "continuation") (list g1) (loop (rest xs1) (cons g1 gs))))) (fully-convert-to-CPS x1 (first xs1)))))) ((converted-call) (fuck-up)) (else (fuck-up)))) (create-lambda-expression x (expression-lambda-environment x) (expression-parameters x) ;; x --> [x]_(LAMBDA (g) g) (fully-convert-to-CPS (let ((g (string->variable "x"))) (create-converted-continuation-expression (expression-body x) ;; needs work: To give the environment a name. (create-environment #f "continuation") (list g) (create-access-expression (expression-body x) g))) (expression-body x)))) ;;; Determine environment distances from root (define (determine-environment-distances-from-root!) ;; We used to be anal here and find the root by two means. One was the ;; procedure that called every procedure. The other was the procedure that ;; wasn't properly called by any other procedure. And we even checked that ;; these two means produced the same singleton result. But now that computing ;; the CALLS? and PROPERLY-CALLS? relations are expensive we punt and make ;; use of the hardwired assumption that the root is the procedure with no ;; parent. Life is short. (let ((root (find-if (lambda (e) (empty? (parent e))) *es*))) ;; conventions: ROOT (let loop ((es (list root)) (i 0)) ;; conventions: I (unless (null? es) (for-each (lambda (e) (set-environment-distance-from-root! e i)) es) (loop (remove-if-not (lambda (e1) (and (not (number? (distance-from-root e1))) (some (lambda (e2) (directly-calls? e2 e1)) es))) *es*) (+ i 1)))) (unless (every (lambda (e) (number? (distance-from-root e))) *es*) (fuck-up)))) ;;; Determine which environments have external self tail calls (define (determine-which-environments-have-external-self-tail-calls!) ;; An external self tail call is a self tail call that is in-lined in E to a ;; procedure that E is properly in-lined in. This situation can cause a ;; memory leak if E has a reentrant region because E will not be returned from ;; and its region will not be restored. Also, E can't have a non-reentrant ;; region because the external self tail call will cause the region to be ;; clobbered the next time E is entered. It is OK to for there to be a self ;; tail call to E (but not to a procedure that E is properly in-lined in) ;; because the self-tail-call entry point comes after the region ;; initialization code. ;; note: The following is an efficiency hack. (for-each (lambda (e) (set-environment-marked1?! e (some (lambda (y) (and (not (top-level-call-site? y)) (can-be-self-tail-call-to? y e))) (call-sites e)))) *es*) (for-each (lambda (e) (set-environment-has-external-self-tail-call?! e (and (unique-call-site? e) (let loop? ((e1 (expression-environment (call-site-expression (unique-call-site e))))) (or (and (environment-marked1? e1) (some (lambda (y) (and (not (top-level-call-site? y)) (can-be-self-tail-call-to? y e1) (in-lined-in? (call-site-expression y) e))) (call-sites e1))) (and (unique-call-site? e1) (loop? (expression-environment (call-site-expression (unique-call-site e1)))))))))) *es*)) ;;; Determine which environments have external continuation calls (define (determine-which-environments-have-external-continuation-calls!) ;; An external continuation call is a call that is in a procedure that can be ;; called by E to a continuation created not by E but by a procedure that ;; calls E. This situation can cause a memory leak if E has a reentrant region ;; because E will not be returned from and its region will not be restored. ;; note: This is really misnamed. It is not an external continuation call but ;; rather an external call to a continuation. But then then the name ;; becomes too long. (for-each (lambda (e) (clock-sample) ;To prevent overflow. ;; This is done just for side effect, to set the MARKED2? bits. (some-proper-caller (lambda (e) #f) environment-marked2? set-environment-marked2?! e) (set-environment-has-external-continuation-call?! e (some (lambda (e1) (some (lambda (x) (can-be? (lambda (u) (and (continuation-type? u) ((truly-compatible-call? x) u) (can-be? (lambda (u1) (and (native-procedure-type? u1) ((truly-compatible-procedure? (list (create-anonymous-type-set u)) *null* (recreate-call-site (create-call-site (continuation-type-allocating-expression u)) 'first-argument)) u1) (some (lambda (e1) (and (not (eq? e1 e)) (environment-marked2? e1))) (narrow-clones u1)))) (expression-type-set (first-argument (continuation-type-allocating-expression u)))))) (expression-type-set (expression-callee x)))) ;; needs work: What about implicit call sites? (environment-continuation-calls e1))) (proper-callees e)))) *es*)) ;;; Determine blocked environments (define (determine-blocked-environments!) (for-each (lambda (e) (clock-sample) ;To prevent overflow. (when (and (environment-used? e) (not (has-external-self-tail-call? e)) (not (and (reentrant? e) (has-external-continuation-call? e)))) (for-each (lambda (e) (set-environment-marked1?! e #f)) *es*) (set-environment-marked1?! e #t) (let loop ((e1 (find-if (lambda (e) (empty? (parent e))) *es*))) (unless (environment-marked1? e1) (set-environment-marked1?! e1 #t) (for-each loop (environment-direct-tail-callees e1)) (for-each loop (environment-direct-non-tail-callees e1)))) (set-environment-blocked-environments! e (cons e (remove-if environment-marked1? *es*))))) *es*)) ;;; Determine which environments need to pass parameters globally (define (determine-which-environments-need-to-pass-parameters-globally!) (for-each (lambda (e) (set-environment-passes-parameters-globally?! e #f)) *es*) (when *tail-call-optimization?* (for-each (lambda (y) (for-each (lambda (e) (set-environment-passes-parameters-globally?! e #t)) (nonmerged-tail-recursive-purely-tail-call-site-callees y))) (remove-if-not nonmerged-tail-recursive-purely-tail-call-site? *ys*)))) ;;; Determine allocations (define (environment-necessarily-on-path-from-root-to-expression? e x) (when (or (empty? e) (not (environment-used? e)) (has-external-self-tail-call? e) (and (reentrant? e) (has-external-continuation-call? e))) (fuck-up)) (memq (expression-environment x) (environment-blocked-environments e))) (define (safe-type-allocation-environment? e u x) (and (environment-marked2? e) ;This is just an efficiency hack. (not (has-external-self-tail-call? e)) (not (and (reentrant? e) (has-external-continuation-call? e))) (environment-necessarily-on-path-from-root-to-expression? e x) (not (escapes? u e)))) (define (safe-environment-allocation-environment? e1 e2) (and (environment-marked2? e1) ;This is just an efficiency hack. (not (has-external-self-tail-call? e1)) (not (and (reentrant? e1) (has-external-continuation-call? e1))) (environment-necessarily-on-path-from-root-to-expression? e1 (expression-body (environment-expression e2))) ;; It is safe to allocate E2 on E1 if no native procedure that has E2 as ;; an ancestor escapes E1. (not (some (lambda (e3) (escapes? (environment-type e3) e1)) (descendents e2))))) (define (minimal f distance-from-root-to-environments-map) ;; conventions: F DISTANCE-FROM-ROOT-TO-ENVIRONMENTS-MAP (let loop ((i (- (vector-length distance-from-root-to-environments-map) 1))) ;; conventions: I (let ((e (find-if f (vector-ref distance-from-root-to-environments-map i)))) (cond (e (unless (one f (vector-ref distance-from-root-to-environments-map i)) (fuck-up)) e) (else (loop (- i 1))))))) (define (choose-allocation e p?) (cond ((and *stack-allocation?* p? ;; alloca foils tail-call optimization. (not (environment-passes-parameters-globally? (home e))) ;; If E is in-lined then stack allocating on E allocates on the home ;; of E. Don't stack allocate on an environment that is not called ;; more than once because then reclaimation never occurs. This is a ;; heuristic because it actually might be a good policy to allocate in ;; such a way because the program might consist of a sequence of major ;; subcomponents and transition between subcomponents might be the ;; appropriate reclaimation time. (called-more-than-once? (home e)) ;; If E is in-lined then stack allocating on E allocates on the home ;; of E. If E is in-lined in a recursive procedure but E itself is ;; is not recursive then you don't want to stack allocate on the home ;; of E because then you don't reclaim on exit from E. It is likely ;; that the home of E repeatedly calls E so it is better to be able ;; to reclaim on each call. (not (and (unique-call-site? e) (in-lined-in-recursive? e) (not (recursive? e))))) 'stack) ((and *region-allocation?* ;; Reentrant regions foil tail-call optimization. (not (and (reentrant? e) (let loop ((e e)) (if (unique-call-site? e) (and (directly-tail-calls? (expression-environment (call-site-expression (unique-call-site e))) e) (loop (expression-environment (call-site-expression (unique-call-site e))))) (environment-passes-parameters-globally? e))))) ;; Don't allocate on the region of an environment that is not called ;; more than once because then reclaimation never occurs. This is a ;; heuristic because it actually might be a good policy to allocate in ;; such a way because the program might consist of a sequence of major ;; subcomponents and transition between subcomponents might be the ;; appropriate reclaimation time. (called-more-than-once? e)) e) (*heap-allocation?* 'heap) ((and *stack-allocation?* p?) 'stack) (else e))) (define (determine-allocations!) (let ((distance-from-root-to-environments-map (make-vector (+ (reduce max (map distance-from-root *es*) 0) 1) '()))) (for-each (lambda (e) (vector-set! distance-from-root-to-environments-map (distance-from-root e) (cons e (vector-ref distance-from-root-to-environments-map (distance-from-root e))))) *es*) (for-each (lambda (u) (clock-sample) ;To prevent overflow. (for-each (lambda (x) (when (expression? x) (unless (eq? (expression-kind x) 'string-constant) ;; This is done just for side effect, to set the MARKED2? bits. (some-caller (lambda (e) #f) environment-marked2? set-environment-marked2?! (expression-environment x)) (let ((e (minimal (lambda (e) (safe-type-allocation-environment? e u x)) distance-from-root-to-environments-map))) (set-expression-type-allocation-alist! x (cons (cons u (choose-allocation e (eq? e (expression-environment x)))) (expression-type-allocation-alist x))))))) (string-type-allocating-expressions u))) *string-types*) (for-each (lambda (u) ;; Note: Need to determine an allocation even for immediate structures ;; because they may become indirect. (unless (fictitious? u) (clock-sample) ;To prevent overflow. (for-each (lambda (x) (unless (eq? (expression-kind x) 'pair-constant) ;; This is done just for side effect, to set the MARKED2? bits. (some-caller (lambda (e) #f) environment-marked2? set-environment-marked2?! (expression-environment x)) (let ((e (minimal (lambda (e) (safe-type-allocation-environment? e u x)) distance-from-root-to-environments-map))) (set-expression-type-allocation-alist! x (cons (cons u (choose-allocation e (eq? e (expression-environment x)))) (expression-type-allocation-alist x)))))) (structure-type-allocating-expressions u)))) *structure-types*) (for-each (lambda (u) (unless (degenerate-vector-type? u) (clock-sample) ;To prevent overflow. (for-each (lambda (x) (unless (eq? (expression-kind x) 'vector-constant) ;; This is done just for side effect, to set the MARKED2? bits. (some-caller (lambda (e) #f) environment-marked2? set-environment-marked2?! (expression-environment x)) (let ((e (minimal (lambda (e) (safe-type-allocation-environment? e u x)) distance-from-root-to-environments-map))) (set-expression-type-allocation-alist! x (cons (cons u (choose-allocation e (eq? e (expression-environment x)))) (expression-type-allocation-alist x)))))) (headed-vector-type-allocating-expressions u)))) *headed-vector-types*) (for-each (lambda (u) (unless (degenerate-vector-type? u) (clock-sample) ;To prevent overflow. (for-each (lambda (x) (when (expression? x) ;; This is done just for side effect, to set the MARKED2? bits. (some-caller (lambda (e) #f) environment-marked2? set-environment-marked2?! (expression-environment x)) (let ((e (minimal (lambda (e) (safe-type-allocation-environment? e u x)) distance-from-root-to-environments-map))) (set-expression-type-allocation-alist! x (cons (cons u (choose-allocation e (eq? e (expression-environment x)))) (expression-type-allocation-alist x)))))) (nonheaded-vector-type-allocating-expressions u)))) *nonheaded-vector-types*) (for-each (lambda (e) (when (and (not (noop? e)) (has-closure? e)) (clock-sample) ;To prevent overflow. ;; This is done just for side effect, to set the MARKED2? bits. (some-caller (lambda (e) #f) environment-marked2? set-environment-marked2?! e) (let ((e1 (minimal (lambda (e1) (safe-environment-allocation-environment? e1 e)) distance-from-root-to-environments-map))) (set-environment-allocation! e (choose-allocation e1 (eq? e1 e)))))) *es*))) ;;; Apply closed-world assumption (define (dereference-type u) (cond ((null-type? u) u) ((true-type? u) u) ((false-type? u) u) ((char-type? u) u) ((fixnum-type? u) u) ((flonum-type? u) u) ((rectangular-type? u) u) ((input-port-type? u) u) ((output-port-type? u) u) ((eof-object-type? u) u) ((pointer-type? u) u) ((internal-symbol-type? u) u) ((external-symbol-type? u) (if (eq? (external-symbol-type-link u) u) u (let ((u1 (dereference-type (external-symbol-type-link u)))) (set-external-symbol-type-link! u u1) u1))) ((primitive-procedure-type? u) u) ((native-procedure-type? u) u) ((foreign-procedure-type? u) u) ((continuation-type? u) u) ((string-type? u) (if (eq? (string-type-link u) u) u (let ((u1 (dereference-type (string-type-link u)))) (set-string-type-link! u u1) u1))) ((structure-type? u) (if (eq? (structure-type-link u) u) u (let ((u1 (dereference-type (structure-type-link u)))) (set-structure-type-link! u u1) u1))) ((headed-vector-type? u) (if (eq? (headed-vector-type-link u) u) u (let ((u1 (dereference-type (headed-vector-type-link u)))) (set-headed-vector-type-link! u u1) u1))) ((nonheaded-vector-type? u) (if (eq? (nonheaded-vector-type-link u) u) u (let ((u1 (dereference-type (nonheaded-vector-type-link u)))) (set-nonheaded-vector-type-link! u u1) u1))) ((displaced-vector-type? u) (if (eq? (displaced-vector-type-link u) u) u (let ((u1 (dereference-type (displaced-vector-type-link u)))) (set-displaced-vector-type-link! u u1) u1))) (else (fuck-up)))) (define (dereference-type-set w) (if (eq? (type-set-link w) w) w (let ((w1 (dereference-type-set (type-set-link w)))) (set-type-set-link! w w1) w1))) ;;; Note that one can't filter out subtypes from a type set, i.e. replace ;;; union(u1,u2,u3) with union(u1,u3) if subtype(u2,u1). This won't work ;;; because types denote representations, not sets of values. Even though ;;; subtype(fixnum,union(fixnum,flonum)) and even though ;;; subset(headed-vector(fixnum),headed-vector(union(fixnum,flonum))) it is not ;;; the case that ;;; subtype(headed-vector(fixnum),headed-vector(union(fixnum,flonum))) since ;;; headed-vector(fixnum) has a different representation from ;;; headed-vector(union(fixnum,flonum)) and you can't widen the former into the ;;; later without deep widening. (define (apply-closed-world-assumption!) (define (sorting-remove-duplicatesq us) (let loop ((us (sort us > type-index)) (us1 '())) (if (null? us) us1 (loop (rest us) (if (and (not (null? us1)) (eq? (first us) (first us1))) us1 (cons (first us) us1)))))) (define (create-trie . initial-value) (if (null? initial-value) (set! initial-value #f) (set! initial-value (first initial-value))) (make-trie #f #f #f initial-value (make-trie-node '() initial-value))) (define (trie-ref trie list) (let loop ((trie-node (trie-trie-node trie)) (list list)) (if trie-node (if (null? list) (trie-node-value trie-node) (loop (and (assq (first list) (trie-node-table trie-node)) (cdr (assq (first list) (trie-node-table trie-node)))) (rest list))) (trie-initial-value trie)))) (define (trie-set! trie list value) (let loop ((trie-node (trie-trie-node trie)) (list list)) (if (null? list) (set-trie-node-value! trie-node value) (let ((entry (assq (first list) (trie-node-table trie-node)))) ;; conventions: ENTRY (unless entry (set! entry (cons (first list) (make-trie-node '() (trie-initial-value trie)))) (set-trie-node-table! trie-node (cons entry (trie-node-table trie-node)))) (loop (cdr entry) (rest list)))))) (let loop () (let ((again? #f)) ;; Congruence Closure (do ((us *external-symbol-types* (rest us))) ((null? us)) (let ((u1 (first us))) (when (eq? (external-symbol-type-link u1) u1) (clock-sample) ;To prevent overflow. (for-each (lambda (u2) (when (and (eq? (external-symbol-type-link u1) u1) (eq? (external-symbol-type-link u2) u2) (not (eq? u1 u2)) (eq? (dereference-type (external-symbol-type-displaced-string-type u1)) (dereference-type (external-symbol-type-displaced-string-type u2)))) (set-external-symbol-type-link! u2 u1) (set! again? #t))) (rest us))))) (do ((us *string-types* (rest us))) ((null? us)) (let ((u1 (first us))) (when (eq? (string-type-link u1) u1) (clock-sample) ;To prevent overflow. (for-each (lambda (u2) (when (and (eq? (string-type-link u1) u1) (eq? (string-type-link u2) u2) (not (eq? u1 u2))) (set-string-type-allocating-expressions! u1 (unionq (string-type-allocating-expressions u1) (string-type-allocating-expressions u2))) (set-string-type-link! u2 u1) (set! again? #t))) (rest us))))) (do ((us *structure-types* (rest us))) ((null? us)) (let ((u1 (first us))) (when (eq? (structure-type-link u1) u1) (clock-sample) ;To prevent overflow. (for-each (lambda (u2) (when (and (eq? (structure-type-link u1) u1) (eq? (structure-type-link u2) u2) (not (eq? u1 u2)) (eq? (structure-type-name u1) (structure-type-name u2)) (= (length (structure-type-slots u1)) (length (structure-type-slots u2))) (every (lambda (w1 w2) (eq? (dereference-type-set w1) (dereference-type-set w2))) (structure-type-slots u1) (structure-type-slots u2))) (unless (structure-type-immediate? u2) (set-structure-type-immediate?! u1 #f)) (set-structure-type-allocating-expressions! u1 (unionq (structure-type-allocating-expressions u1) (structure-type-allocating-expressions u2))) (when (structure-type-alignment? u2) (set-structure-type-alignment?! u1 #t)) (when (structure-type-alignment&? u2) (set-structure-type-alignment&?! u1 #t)) (when (structure-type-size? u2) (set-structure-type-size?! u1 #t)) (set-structure-type-link! u2 u1) (set! again? #t))) (rest us))))) (do ((us *headed-vector-types* (rest us))) ((null? us)) (let ((u1 (first us))) (when (eq? (headed-vector-type-link u1) u1) (clock-sample) ;To prevent overflow. (for-each (lambda (u2) (when (and (eq? (headed-vector-type-link u1) u1) (eq? (headed-vector-type-link u2) u2) (not (eq? u1 u2)) (eq? (dereference-type-set (headed-vector-type-element u1)) (dereference-type-set (headed-vector-type-element u2)))) (set-headed-vector-type-allocating-expressions! u1 (unionq (headed-vector-type-allocating-expressions u1) (headed-vector-type-allocating-expressions u2))) (when (headed-vector-type-alignment? u2) (set-headed-vector-type-alignment?! u1 #t)) (when (headed-vector-type-alignment&? u2) (set-headed-vector-type-alignment&?! u1 #t)) (when (headed-vector-type-size? u2) (set-headed-vector-type-size?! u1 #t)) (set-headed-vector-type-link! u2 u1) (set! again? #t))) (rest us))))) (do ((us *nonheaded-vector-types* (rest us))) ((null? us)) (let ((u1 (first us))) (when (eq? (nonheaded-vector-type-link u1) u1) (clock-sample) ;To prevent overflow. (for-each (lambda (u2) (when (and (eq? (nonheaded-vector-type-link u1) u1) (eq? (nonheaded-vector-type-link u2) u2) (not (eq? u1 u2)) (eq? (dereference-type-set (nonheaded-vector-type-element u1)) (dereference-type-set (nonheaded-vector-type-element u2)))) (set-nonheaded-vector-type-allocating-expressions! u1 (unionq (nonheaded-vector-type-allocating-expressions u1) (nonheaded-vector-type-allocating-expressions u2))) (when (nonheaded-vector-type-alignment? u2) (set-nonheaded-vector-type-alignment?! u1 #t)) (when (nonheaded-vector-type-size? u2) (set-nonheaded-vector-type-size?! u1 #t)) (set-nonheaded-vector-type-link! u2 u1) (set! again? #t))) (rest us))))) (do ((us *displaced-vector-types* (rest us))) ((null? us)) (let ((u1 (first us))) (when (eq? (displaced-vector-type-link u1) u1) (clock-sample) ;To prevent overflow. (for-each (lambda (u2) (when (and (eq? (displaced-vector-type-link u1) u1) (eq? (displaced-vector-type-link u2) u2) (eq? (dereference-type (displaced-vector-type-displaced-vector-type u1)) (dereference-type (displaced-vector-type-displaced-vector-type u2)))) (when (displaced-vector-type-alignment? u2) (set-displaced-vector-type-alignment?! u1 #t)) (when (displaced-vector-type-size? u2) (set-displaced-vector-type-size?! u1 #t)) (set-displaced-vector-type-link! u2 u1) (set! again? #t))) (rest us))))) ;; Closed World Assumption (let ((trie (create-trie '()))) ;; conventions: TRIE (for-each (lambda (w) (when (eq? (type-set-link w) w) (clock-sample) ;To prevent overflow. (let ((us (sorting-remove-duplicatesq (map dereference-type (members w))))) ;; This is the case where we previously determined that a type set was ;; not fictitious because it was not monomorphic but we now discover ;; that all of its members are equivalent (and fictitious). Thus ;; the type set is really ficitious. But all havoc will break loose if ;; we have a monomorphic nonfictitious type set whose member is ;; fictitious. And it is way too late to propagate ficition. So we ;; force the typeset to be tag-only even though it will always have a ;; known tag. So it goes. (when (and (multimorphic? w) (= (length us) 1) (fictitious? (dereference-type (first (members w))))) (notify "Warning! W~a should be fictitious but isn't" (type-set-index w))) (set-members! w us) (trie-set! trie us (cons w (trie-ref trie us)))))) *ws*) (for-each (lambda (w) (when (eq? (type-set-link w) w) (clock-sample) ;To prevent overflow. (let* ((ws (trie-ref trie (members w))) (w1 (first ws))) (when (eq? w1 w) (for-each (lambda (w2) (cond ((eq? (fictitious? w1) (fictitious? w2)) (set-type-set-link! w2 w1) (set! again? #t)) (else (notify "Warning! Not merging W~s and W~s because the former is ~a and the latter is ~a" (type-set-index w1) (type-set-index w2) (if (fictitious? w1) "fictitious" "not fictitious") (if (fictitious? w2) "fictitious" "not fictitious"))))) (rest ws)))))) *ws*)) (when again? (loop)))) (set! *external-symbol-types* (remove-if-not (lambda (u) (eq? (external-symbol-type-link u) u)) *external-symbol-types*)) (set-members! *foreign-string-type-set* (map dereference-type (members *foreign-string-type-set*))) (set! *string-types* (remove-if-not (lambda (u) (eq? (string-type-link u) u)) *string-types*)) (set! *structure-types* (remove-if-not (lambda (u) (eq? (structure-type-link u) u)) *structure-types*)) (set! *headed-vector-types* (remove-if-not (lambda (u) (eq? (headed-vector-type-link u) u)) *headed-vector-types*)) (set! *nonheaded-vector-types* (remove-if-not (lambda (u) (eq? (nonheaded-vector-type-link u) u)) *nonheaded-vector-types*)) (set! *displaced-vector-types* (remove-if-not (lambda (u) (eq? (displaced-vector-type-link u) u)) *displaced-vector-types*)) (set! *ws* (remove-if-not (lambda (w) (eq? (type-set-link w) w)) *ws*)) (for-each (lambda (x) (set-expression-type-set! x (dereference-type-set (expression-type-set x))) (for-each (lambda (u-e) (set-car! u-e (dereference-type (car u-e)))) (expression-type-allocation-alist x)) (set-expression-type-allocation-alist! x (remove-duplicatesp (lambda (u-e1 u-e2) (and (eq? (car u-e1) (car u-e2)) (eq? (cdr u-e1) (cdr u-e2)))) (expression-type-allocation-alist x))) (unless (= (length (expression-type-allocation-alist x)) (length (remove-duplicatesq (map car (expression-type-allocation-alist x))))) (fuck-up))) *xs*) (for-each (lambda (u) (set-external-symbol-type-displaced-string-type! u (dereference-type (external-symbol-type-displaced-string-type u)))) *external-symbol-types*) (for-each (lambda (u) (set-structure-type-slots! u (map dereference-type-set (structure-type-slots u)))) *structure-types*) (for-each (lambda (u) (set-headed-vector-type-element! u (dereference-type-set (headed-vector-type-element u)))) *headed-vector-types*) (for-each (lambda (u) (set-nonheaded-vector-type-element! u (dereference-type-set (nonheaded-vector-type-element u)))) *nonheaded-vector-types*) (for-each (lambda (u) (set-displaced-vector-type-displaced-vector-type! u (dereference-type (displaced-vector-type-displaced-vector-type u)))) *displaced-vector-types*) (for-each (lambda (g) (set-variable-type-set! g (dereference-type-set (variable-type-set g)))) *gs*) (for-each (lambda (e) (set-environment-escaping-types! e (sorting-remove-duplicatesq (map dereference-type (environment-escaping-types e))))) *es*) (set! (dereference-type )) (set! (dereference-type )) (for-each (lambda (w) (set-type-set-location! w #f)) *ws*)) ;;; Determine indirect structure types (define (determine-indirect-structure-types!) ;; needs work: This is conservative. It makes all structures that are part of ;; a points-to cycle indirect. It is sufficient to make only one ;; edge in the cycle indirect. Also, this doesn't take into ;; account that native procedures and vectors are always indirect. (for-each (lambda (u) (when (some (lambda (w) (points-to? w u)) (structure-type-slots u)) (set-structure-type-immediate?! u #f))) *structure-types*)) ;;; Determine which types are never allocated on the heap (define (determine-which-types-are-never-allocated-on-the-heap!) (define (never-allocated-on-the-heap? u) (not (some (lambda (x) (let ((u-e (assq u (expression-type-allocation-alist x)))) (and u-e (heap-allocation? (cdr u-e))))) *calls*))) (for-each (lambda (u) (set-string-type-never-allocated-on-the-heap?! u (never-allocated-on-the-heap? u))) *string-types*) (for-each (lambda (u) (set-structure-type-never-allocated-on-the-heap?! u (never-allocated-on-the-heap? u))) *structure-types*) (for-each (lambda (u) (set-headed-vector-type-never-allocated-on-the-heap?! u (never-allocated-on-the-heap? u))) *headed-vector-types*) (for-each (lambda (u) (set-nonheaded-vector-type-never-allocated-on-the-heap?! u (never-allocated-on-the-heap? u))) *nonheaded-vector-types*)) ;;; Determine which environments have regions (define (region-allocation? e) (environment? e)) (define (stack-allocation? e) (eq? e 'stack)) (define (heap-allocation? e) (eq? e 'heap)) (define *program-has-heap?* #f) (define (determine-which-environments-have-regions!) (for-each (lambda (e) (set-environment-has-region?! e #f) (set-environment-has-nonatomic-region?! e #f)) *es*) (set! *program-has-heap?* #f) (for-each (lambda (x) (for-each (lambda (u-e) (cond ((region-allocation? (cdr u-e)) (set-environment-has-region?! (cdr u-e) #t) (unless (type-atomic? (car u-e)) (set-environment-has-nonatomic-region?! (cdr u-e) #t))) ((heap-allocation? (cdr u-e)) (set! *program-has-heap?* #t)))) (expression-type-allocation-alist x))) *calls*) (for-each (lambda (e) (cond ((region-allocation? (allocation e)) (set-environment-has-region?! (allocation e) #t) (unless (environment-atomic? e) (set-environment-has-nonatomic-region?! (allocation e) #t))) ((heap-allocation? (allocation e)) (set! *program-has-heap?* #t)))) *es*)) ;;; The remaining procedures are used just for debugging. (define (hunoz? g) (string=? (symbol->string (variable-name g)) "hunoz")) (define *abbreviate?* #f) (define (list+-type? u) (and (pair-type? u) (= (length (members (pair-type-cdr u))) 2) (or (and (null-type? (first (members (pair-type-cdr u)))) (eq? (second (members (pair-type-cdr u))) u)) (and (null-type? (second (members (pair-type-cdr u)))) (eq? (first (members (pair-type-cdr u))) u))))) (define (list-slots u) (if (null-type? u) '() (cons (pair-type-car u) (list-slots (the-member (pair-type-cdr u)))))) (define (list*-type? w) (and (= (length (members w)) 2) (or (and (null-type? (first (members w))) (pair-type? (second (members w))) (eq? (pair-type-cdr (second (members w))) w)) (and (null-type? (second (members w))) (pair-type? (first (members w))) (eq? (pair-type-cdr (first (members w))) w))))) (define (up u/w u/ws) (if (or (eq? u/w (first u/ws)) (and (type-set? u/w) (monomorphic? u/w) (eq? (the-member u/w) (first u/ws)))) 0 (+ (up u/w (rest u/ws)) 1))) (define (externalize-type-internal u u/ws) (define (list-type? u) (or (null-type? u) (and (pair-type? u) (monomorphic? (pair-type-cdr u)) (list-type? (the-member (pair-type-cdr u)))))) (cond ((memq u u/ws) `(up ,(up u u/ws))) ((null-type? u) 'null) ((true-type? u) 'true) ((false-type? u) 'false) ((char-type? u) 'char) ((fixnum-type? u) 'fixnum) ((flonum-type? u) 'flonum) ((rectangular-type? u) 'rectangular) ((input-port-type? u) 'input-port) ((output-port-type? u) 'output-port) ((eof-object-type? u) 'eof-object) ((pointer-type? u) 'pointer) ((internal-symbol-type? u) `',(internal-symbol-type-name u)) ((external-symbol-type? u) ;; note: Ambiguous between external symbol type and structure type. `(external-symbol ,(externalize-type-internal (external-symbol-type-displaced-string-type u) (cons u u/ws)))) ((primitive-procedure-type? u) (if (null? (primitive-procedure-type-arguments u)) (primitive-procedure-type-name u) (cons (primitive-procedure-type-name u) (primitive-procedure-type-arguments u)))) ((native-procedure-type? u) `(native-procedure ,@(map environment-name (narrow-clones u)))) ((foreign-procedure-type? u) (foreign-procedure-type-name u)) ((continuation-type? u) `(continuation ,(expression-index (continuation-type-allocating-expression u)))) ;; note: Ambiguous between string type and primitive-procedure type. ((string-type? u) 'string) ((structure-type? u) (cond ((list+-type? u) ;; note: Ambiguous between list+ type and structure type. `(list+ ,(if *abbreviate?* (type-set-index (pair-type-car u)) (externalize-type-set-internal (pair-type-car u) (cons u u/ws))))) ((list-type? u) ;; note: Ambiguous between list type and structure type. `(list ,@(map (lambda (w) (externalize-type-set-internal w (cons u u/ws))) (list-slots u)))) (else `(,(structure-type-name u) ,@(map (lambda (w) (if *abbreviate?* (type-set-index w) (externalize-type-set-internal w (cons u u/ws)))) (structure-type-slots u)))))) ((headed-vector-type? u) ;; note: Ambiguous between headed-vector type and structure type. `(headed-vector ,(if *abbreviate?* (type-set-index (headed-vector-type-element u)) (externalize-type-set-internal (headed-vector-type-element u) (cons u u/ws))))) ((nonheaded-vector-type? u) ;; note: Ambiguous between nonheaded-vector type and structure type. `(nonheaded-vector ,(if *abbreviate?* (type-set-index (nonheaded-vector-type-element u)) (externalize-type-set-internal (nonheaded-vector-type-element u) (cons u u/ws))))) ((displaced-vector-type? u) ;; note: Ambiguous between displaced-vector type and structure type. `(displaced-vector ,(externalize-type-internal (displaced-vector-type-displaced-vector-type u) (cons u u/ws)))) (else (fuck-up)))) (define (externalize-type-set-internal w u/ws) (cond ((or (memq w u/ws) (and (monomorphic? w) (memq (the-member w) u/ws))) `(up ,(up w u/ws))) ((void? w) 'void) ((monomorphic? w) (externalize-type-internal (the-member w) u/ws)) ((list*-type? w) ;; note: Ambiguous between list* type and structure type. `(list* ,(externalize-type-set-internal (pair-type-car (the-member-that structure-type? w)) (cons w u/ws)))) (else `(union ,@(map (lambda (u) (externalize-type-internal u (cons w u/ws))) (members w)))))) (define (externalize-type u) (externalize-type-internal u '())) (define (externalize-type-set w) (externalize-type-set-internal w '())) (define (variable-names x) ;; This is a real kludge. (if (eq? (expression-parameters x) (unspecified)) 'unspecified (let loop ((gs (variables x))) (cond ((null? gs) '()) ((and (null? (rest gs)) (rest? x)) (variable-name (first gs))) (else (cons (variable-name (first gs)) (loop (rest gs)))))))) (define (externalize-expression x) (define (undecorate-constant x) (case (expression-kind x) ((null-constant) '()) ((true-constant) #t) ((false-constant) #f) ((char-constant) (expression-constant x)) ((fixnum-constant) (expression-constant x)) ((flonum-constant) (expression-constant x)) ((rectangular-constant) (expression-constant x)) ((string-constant) (expression-constant x)) ((symbol-constant) (expression-constant x)) ((pair-constant) (cons (undecorate-constant (car (expression-constant x))) (undecorate-constant (cdr (expression-constant x))))) ((vector-constant) (map-vector undecorate-constant (expression-constant x))) (else (fuck-up)))) (define (externalize-expressions x) (if (and (eq? (expression-kind x) 'call) (= (length (expression-arguments x)) 1) (eq? (expression-kind (expression-callee x)) 'lambda) ;; This is a real kludge. (not (eq? (expression-parameters (expression-callee x)) (unspecified))) (= (length (variables (expression-callee x))) 1) (not (rest? (expression-callee x))) (hunoz? (first (variables (expression-callee x))))) (cons (externalize-expression (first (expression-arguments x))) (externalize-expressions (expression-body (expression-callee x)))) (list (externalize-expression x)))) ;; conventions: X1 (let ((x1 (case (expression-kind x) ((null-constant) ''()) ((true-constant) #t) ((false-constant) #f) ((char-constant) (expression-constant x)) ((fixnum-constant) (expression-constant x)) ((flonum-constant) (expression-constant x)) ((rectangular-constant) (expression-constant x)) ((string-constant) (expression-constant x)) ((symbol-constant) `',(expression-constant x)) ((pair-constant) `',(undecorate-constant x)) ((vector-constant) (undecorate-constant x)) ((lambda converted-lambda converted-continuation) (if (noop? x) `(lambda ,(variable-names x)) `(lambda ,(variable-names x) ,@(externalize-expressions (expression-body x))))) ((set!) `(set! ,(variable-name (expression-variable x)) ,(externalize-expression (expression-source x)))) ((if) `(if ,(externalize-expression (expression-antecedent x)) ,(externalize-expression (expression-consequent x)) ,(externalize-expression (expression-alternate x)))) ((primitive-procedure) `(primitive-procedure ,@(expression-constant x))) ((foreign-procedure) `(foreign-procedure ,@(expression-constant x))) ((access) (variable-name (expression-variable x))) ((call converted-call) (cons (externalize-expression (expression-callee x)) (map externalize-expression (expression-arguments x)))) (else (fuck-up))))) `(the ,(if *abbreviate?* (type-set-index (expression-type-set x)) (externalize-type-set (expression-type-set x))) ,x1))) (define (undecorate x) (define (undecorate-constant x) (case (expression-kind x) ((null-constant) '()) ((true-constant) #t) ((false-constant) #f) ((char-constant) (expression-constant x)) ((fixnum-constant) (expression-constant x)) ((flonum-constant) (expression-constant x)) ((rectangular-constant) (expression-constant x)) ((string-constant) (expression-constant x)) ((symbol-constant) (expression-constant x)) ((pair-constant) (cons (undecorate-constant (car (expression-constant x))) (undecorate-constant (cdr (expression-constant x))))) ((vector-constant) (map-vector undecorate-constant (expression-constant x))) (else (fuck-up)))) (define (undecorate-expressions x) (if (and (eq? (expression-kind x) 'call) (= (length (expression-arguments x)) 1) (eq? (expression-kind (expression-callee x)) 'lambda) ;; This is a real kludge. (not (eq? (expression-parameters (expression-callee x)) (unspecified))) (= (length (variables (expression-callee x))) 1) (not (rest? (expression-callee x))) (hunoz? (first (variables (expression-callee x))))) (cons (undecorate (first (expression-arguments x))) (undecorate-expressions (expression-body (expression-callee x)))) (list (undecorate x)))) (case (expression-kind x) ((null-constant) ''()) ((true-constant) #t) ((false-constant) #f) ((char-constant) (expression-constant x)) ((fixnum-constant) (expression-constant x)) ((flonum-constant) (expression-constant x)) ((rectangular-constant) (expression-constant x)) ((string-constant) (expression-constant x)) ((symbol-constant) `',(expression-constant x)) ((pair-constant) `',(undecorate-constant x)) ((vector-constant) (undecorate-constant x)) ((lambda converted-lambda converted-continuation) (if (noop? x) `(lambda ,(variable-names x)) `(lambda ,(variable-names x) ,@(undecorate-expressions (expression-body x))))) ((set!) `(set! ,(variable-name (expression-variable x)) ,(undecorate (expression-source x)))) ((if) `(if ,(undecorate (expression-antecedent x)) ,(undecorate (expression-consequent x)) ,(undecorate (expression-alternate x)))) ((primitive-procedure) `(primitive-procedure ,@(expression-constant x))) ((foreign-procedure) `(foreign-procedure ,@(expression-constant x))) ((access) (variable-name (expression-variable x))) ((call converted-call) (cons (undecorate (expression-callee x)) (map undecorate (expression-arguments x)))) (else (fuck-up)))) (define (small? x) (define (atoms-in list) (if (pair? list) (+ (atoms-in (car list)) (atoms-in (cdr list))) 1)) (< (atoms-in (undecorate x)) 50)) (define *accounts* '#()) (define (create-accounts! n) (set! *accounts* (make-vector n 0))) (define (account index thunk) (let* ((start (clock-sample)) (result (thunk)) (end (clock-sample))) (vector-set! *accounts* index (+ (vector-ref *accounts* index) (- end start))) result)) (define (print-accounts) (pp (let ((sum (reduce-vector + *accounts* 0.0))) (map-vector (lambda (account) (inexact->exact (floor (/ (* 100.0 account) sum)))) *accounts*)))) (define (debug-generate c) ;; note: This will not handle braces inside comments. (let ((backslash? #f) (newline? #f) (open? #f) (state 'code) (indent 0)) ;; conventions: BACKSLASH? STATE INDENT (define (generate-char c) (case state ((code) (cond ((char=? c #\") (set! state 'string)) ((char=? c #\') (set! state 'char)) ((char=? c #\{) (set! indent (+ indent 1))) ((char=? c #\}) (set! indent (- indent 1))))) ((string) (cond (backslash? (set! backslash? #f)) ((char=? c #\\) (set! backslash? #t)) ((char=? c #\") (set! state 'code)))) ((char) (cond (backslash? (set! backslash? #f)) ((char=? c #\\) (set! backslash? #t)) ((char=? c #\') (set! state 'code))))) (set! newline? #f) (set! open? (char=? c #\{)) (write-char c)) (let loop ((c c)) (cond ((char? c) (unless (char=? c #\newline) (fuck-up)) (unless (or newline? open?) (newline) (for-each-n (lambda (i) ;; conventions: I (write-char #\space)) indent) (set! newline? #t))) ((string? c) (for-each-n (lambda (i) ;; conventions: I (generate-char (string-ref c i))) (string-length c))) ((c:declaration? c) (loop (third c))) ((c:protect? c) (loop (second c))) ((c:no-return? c) (loop (second c))) ((pair? c) (loop (car c)) (loop (cdr c))) ((null? c) #f) (else (fuck-up)))))) (define (print-counts) (notify "~a expression~a" (number->string-of-length (length *xs*) 6) (if (= (length *xs*) 1) "" "s")) (notify "~a internal symbol type~a" (number->string-of-length (length *internal-symbol-types*) 6) (if (= (length *internal-symbol-types*) 1) "" "s")) (notify "~a external symbol type~a" (number->string-of-length (length *external-symbol-types*) 6) (if (= (length *external-symbol-types*) 1) "" "s")) (notify "~a primitive procedure type~a" (number->string-of-length (length *primitive-procedure-types*) 6) (if (= (length *primitive-procedure-types*) 1) "" "s")) (notify "~a non-called native procedure type~a" (number->string-of-length (count-if-not called? *native-procedure-types*) 6) (if (one (lambda (u) (not (called? u))) *native-procedure-types*) "" "s")) (notify "~a called noop native procedure type~a" (number->string-of-length (count-if (lambda (u) (and (called? u) (noop? u))) *native-procedure-types*) 6) (if (one (lambda (u) (and (called? u) (noop? u))) *native-procedure-types*) "" "s")) (notify "~a called non-noop native procedure type~a" (number->string-of-length (count-if (lambda (u) (and (called? u) (not (noop? u)))) *native-procedure-types*) 6) (if (one (lambda (u) (and (called? u) (not (noop? u)))) *native-procedure-types*) "" "s")) (notify "~a foreign procedure type~a" (number->string-of-length (length *foreign-procedure-types*) 6) (if (= (length *foreign-procedure-types*) 1) "" "s")) (notify "~a continuation type~a" (number->string-of-length (length *continuation-types*) 6) (if (= (length *continuation-types*) 1) "" "s")) (notify "~a string type~a" (number->string-of-length (length *string-types*) 6) (if (= (length *string-types*) 1) "" "s")) (notify "~a structure type~a" (number->string-of-length (length *structure-types*) 6) (if (= (length *structure-types*) 1) "" "s")) (notify "~a headed vector type~a" (number->string-of-length (length *headed-vector-types*) 6) (if (= (length *headed-vector-types*) 1) "" "s")) (notify "~a nonheaded vector type~a" (number->string-of-length (length *nonheaded-vector-types*) 6) (if (= (length *nonheaded-vector-types*) 1) "" "s")) (notify "~a displaced vector type~a" (number->string-of-length (length *displaced-vector-types*) 6) (if (= (length *displaced-vector-types*) 1) "" "s")) (notify "~a type set~a" (number->string-of-length (length *ws*) 6) (if (= (length *ws*) 1) "" "s")) (notify "~a hunoz variable~a" (number->string-of-length (count-if hunoz? *gs*) 6) (if (one hunoz? *gs*) "" "s")) (notify "~a non-hunoz variable~a" (number->string-of-length (count-if-not hunoz? *gs*) 6) (if (one (lambda (g) (not (hunoz? g))) *gs*) "" "s")) (notify "~a noop environment~a" (number->string-of-length (count-if noop? *es*) 6) (if (one noop? *es*) "" "s")) (notify "~a non-noop environment~a" (number->string-of-length (count-if-not noop? *es*) 6) (if (one (lambda (e) (not (noop? e))) *es*) "" "s"))) (define (global-memory-usage) ;; needs work: This is out of date now that we merged Stalin with October. ;; This is all very specific to Scheme->C. ;; This will overflow without warning at 512M on Linux. (define (object-memory-usage object) ;; conventions: OBJECT ;; Doesn't handle continuations, records, forwarding pointers, and undefined ;; objects. (cond ((and (number? object) (exact? object)) 0) ;; Doesn't trace name, value, or property list. ((symbol? object) (* c-sizeof-s2cuint 5)) ((string? object) (let ((l (+ (string-length object) 1))) (+ c-sizeof-s2cuint l (if (zero? (remainder l c-sizeof-s2cuint)) 0 (- c-sizeof-s2cuint (remainder l c-sizeof-s2cuint)))))) ;; Doesn't trace elements. ((vector? object) (+ c-sizeof-s2cuint (* c-sizeof-s2cuint (vector-length object)))) ;; Doesn't trace closure. ((procedure? object) (* c-sizeof-s2cuint 3)) ;; Can be 4 words if doubles must be aligned. ((and (number? object) (inexact? object)) (* c-sizeof-s2cuint 3)) ((null? object) 0) ((not object) 0) ((eq? object #t) 0) ((char? object) 0) ((eof-object? object) 0) ((pair? object) (* c-sizeof-s2cuint 2)) (else (fuck-up)))) (define (recursive-object-memory-usage object) ;; conventions: OBJECT ;; Doesn't handle continuations, records, forwarding pointers, and undefined ;; objects. (cond ((and (number? object) (exact? object)) 0) ;; Assume all symbols are interned. Don't count the size of interned ;; symbols. Assume that symbols don't have values or property lists. ((symbol? object) 0) ;; Assume that strings aren't shared. ((string? object) (let ((l (+ (string-length object) 1))) (+ c-sizeof-s2cuint l (if (zero? (remainder l c-sizeof-s2cuint)) 0 (- c-sizeof-s2cuint (remainder l c-sizeof-s2cuint)))))) ;; Assume that vectors aren't shared. ((vector? object) (+ c-sizeof-s2cuint (* c-sizeof-s2cuint (vector-length object)) (reduce-vector + (map-vector recursive-object-memory-usage object) 0))) ;; Assume that procedures aren't shared. ;; Doesn't trace closure. ((procedure? object) (* c-sizeof-s2cuint 3)) ;; Can be 4 words if doubles must be aligned. ((and (number? object) (inexact? object)) (* c-sizeof-s2cuint 3)) ((null? object) 0) ((not object) 0) ((eq? object #t) 0) ((char? object) 0) ((eof-object? object) 0) ;; Assume that pairs aren't shared. ((pair? object) (+ (* c-sizeof-s2cuint 2) (recursive-object-memory-usage (car object)) (recursive-object-memory-usage (cdr object)))) (else (fuck-up)))) (define (flat-memory-usage object) ;; conventions: OBJECT (cond ((and (number? object) (exact? object)) 0) ;; Assume all symbols are interned. Don't count the size of interned ;; symbols. Assume that symbols don't have values or property lists. ((symbol? object) 0) ;; Assume that strings aren't shared. ((string? object) (let ((l (+ (string-length object) 1))) (+ c-sizeof-s2cuint l (if (zero? (remainder l c-sizeof-s2cuint)) 0 (- c-sizeof-s2cuint (remainder l c-sizeof-s2cuint)))))) ;; Assume that vectors aren't shared. Count the size of elements ;; elsewhere. ((vector? object) (+ c-sizeof-s2cuint (* c-sizeof-s2cuint (vector-length object)))) ;; Assume that no top-level variable has a procedure as its value. ((procedure? object) (fuck-up)) ;; Can be 4 words if doubles must be aligned. ((and (number? object) (inexact? object)) (* c-sizeof-s2cuint 3)) ((null? object) 0) ((not object) 0) ((eq? object #t) 0) ((char? object) 0) ((eof-object? object) 0) ((pair? object) ;; Assume that pairs aren't shared. Count the size of the car slots ;; elsewhere. (+ (* c-sizeof-s2cuint 2) (flat-memory-usage (cdr object)))) (else (fuck-up)))) (define (scalar-one-level-memory-usage object) ;; conventions: OBJECT ;; Assume all top-level scalar variables hold vectors, symbols, or #F. ;; Assume all symbols are interned. Don't count the size of interned ;; symbols. Assume that symbols don't have values or property lists. (unless (or (not object) (symbol? object) (vector? object)) (fuck-up)) ;; Assume that vectors aren't shared. (if (vector? object) (+ c-sizeof-s2cuint (* c-sizeof-s2cuint (vector-length object)) (reduce-vector + (map-vector flat-memory-usage object) 0)) 0)) (define (list-one-level-memory-usage object) ;; conventions: OBJECT ;; Assume all top-level list variables hold lists or #F. (unless (or (not object) (list? object)) (fuck-up)) ;; Assume that pairs aren't shared. (if object (+ (* c-sizeof-s2cuint 2 (length object)) (reduce + (map scalar-one-level-memory-usage object) 0)) 0)) ;; The following aren't counted: ;; *PRIMITIVE-PROCEDURE-REWRITES* quote ;; *ERRORS* quote ;; *MACROS* computed at startup ;; *READ* backquote ;; *I/O* backquote ;; *Scheme->C-compatibility-macros* computed at startup ;; *QobiScheme-macros* computed at startup ;; *Trotsky-macros* computed at startup (+ (flat-memory-usage *types-frozen?*) (flat-memory-usage *again?*) (flat-memory-usage *xi*) (list-one-level-memory-usage *xs*) (flat-memory-usage *calls*) ;subsumed by *XS* (flat-memory-usage *accesses*) ;subsumed by *XS* (flat-memory-usage *assignments*) ;subsumed by *XS* (flat-memory-usage *references*) ;subsumed by *XS* ;; *X* is contained in *XS* ;; *X1* is contained in *XS* (flat-memory-usage *ui*) (scalar-one-level-memory-usage ) (flat-memory-usage *null-type-used?*) (flat-memory-usage *null-type-use-count*) (scalar-one-level-memory-usage ) (flat-memory-usage *true-type-used?*) (flat-memory-usage *true-type-use-count*) (scalar-one-level-memory-usage ) (flat-memory-usage *false-type-used?*) (flat-memory-usage *false-type-use-count*) (scalar-one-level-memory-usage ) (flat-memory-usage *char-type-used?*) (flat-memory-usage *char-type-use-count*) (scalar-one-level-memory-usage ) (flat-memory-usage *fixnum-type-used?*) (flat-memory-usage *fixnum-type-use-count*) (scalar-one-level-memory-usage ) (flat-memory-usage *flonum-type-used?*) (flat-memory-usage *flonum-type-use-count*) (scalar-one-level-memory-usage ) (flat-memory-usage *rectangular-type-used?*) (flat-memory-usage *rectangular-type-use-count*) (scalar-one-level-memory-usage ) (flat-memory-usage *input-port-type-used?*) (flat-memory-usage *input-port-type-use-count*) (scalar-one-level-memory-usage ) (flat-memory-usage *output-port-type-used?*) (flat-memory-usage *output-port-type-use-count*) (scalar-one-level-memory-usage ) (flat-memory-usage *eof-object-type-used?*) (flat-memory-usage *eof-object-type-use-count*) (scalar-one-level-memory-usage ) (flat-memory-usage *pointer-type-used?*) (flat-memory-usage *pointer-type-use-count*) (list-one-level-memory-usage *internal-symbol-types*) (list-one-level-memory-usage *external-symbol-types*) (list-one-level-memory-usage *primitive-procedure-types*) (list-one-level-memory-usage *native-procedure-types*) (list-one-level-memory-usage *foreign-procedure-types*) (list-one-level-memory-usage *continuation-types*) (list-one-level-memory-usage *string-types*) ;; is contained in *STRING-TYPES* (list-one-level-memory-usage *structure-types*) (list-one-level-memory-usage *headed-vector-types*) (list-one-level-memory-usage *nonheaded-vector-types*) ;; is contained in *NONHEADED-VECTOR-TYPES* (list-one-level-memory-usage *displaced-vector-types*) (flat-memory-usage *wi*) (list-one-level-memory-usage *ws*) ;; *W0* is contained in *WS* ;; *W1* is contained in *WS* ;; *W* is contained in *WS* ;; *VOID* is contained in *WS* ;; *NULL* is contained in *WS* ;; *INPUT-PORT* is contained in *WS* ;; *OUTPUT-PORT* is contained in *WS* ;; *FOREIGN-CHAR-TYPE-SET* is contained in *WS* ;; *FOREIGN-FIXNUM-TYPE-SET* is contained in *WS* ;; *FOREIGN-FLONUM-TYPE-SET* is contained in *WS* ;; *FOREIGN-STRING-TYPE-SET* is contained in *WS* ;; *FOREIGN-INPUT-PORT-TYPE-SET* is contained in *WS* ;; *FOREIGN-OUTPUT-PORT-TYPE-SET* is contained in *WS* ;; *FOREIGN-POINTER-TYPE-SET* is contained in *WS* (flat-memory-usage *gi*) (list-one-level-memory-usage *gs*) (flat-memory-usage *ei*) (list-one-level-memory-usage *es*) (list-one-level-memory-usage *es0*) (flat-memory-usage *y*) ;not counted (list-one-level-memory-usage *ys*) ;not fully counted (flat-memory-usage *program-has-heap?*) (flat-memory-usage *abbreviate?*) (recursive-object-memory-usage *accounts*) (flat-memory-usage *char*) (flat-memory-usage *fixnum*) (flat-memory-usage *flonum*) (flat-memory-usage *length*) (flat-memory-usage *tag*) (flat-memory-usage *squished*) (flat-memory-usage *signed-squished*) (flat-memory-usage *file*) (flat-memory-usage *jmpbuf*) (flat-memory-usage *char-alignment*) (flat-memory-usage *fixnum-alignment*) (flat-memory-usage *flonum-alignment*) (flat-memory-usage *pointer-alignment*) (flat-memory-usage *length-alignment*) (flat-memory-usage *tag-alignment*) (flat-memory-usage *squished-alignment*) (flat-memory-usage *file-alignment*) (flat-memory-usage *jmpbuf-alignment*) (flat-memory-usage *char-size*) (flat-memory-usage *fixnum-size*) (flat-memory-usage *flonum-size*) (flat-memory-usage *pointer-size*) (flat-memory-usage *length-size*) (flat-memory-usage *tag-size*) (flat-memory-usage *squished-size*) (flat-memory-usage *worst-alignment*) (flat-memory-usage *allocation-alignment*) (flat-memory-usage *char-alignment?*) (flat-memory-usage *fixnum-alignment?*) (flat-memory-usage *flonum-alignment?*) (flat-memory-usage *rectangular-alignment?*) (flat-memory-usage *void*-alignment?*) (flat-memory-usage *char*-alignment?*) (flat-memory-usage *file*-alignment?*) (flat-memory-usage *jmpbuf*-alignment?*) (flat-memory-usage *length-alignment?*) (flat-memory-usage *tag-alignment?*) (flat-memory-usage *squished-alignment?*) (flat-memory-usage *file-alignment?*) (flat-memory-usage *jmpbuf-alignment?*) (flat-memory-usage *char-size?*) (flat-memory-usage *fixnum-size?*) (flat-memory-usage *flonum-size?*) (flat-memory-usage *rectangular-size?*) (flat-memory-usage *void*-size?*) (flat-memory-usage *char*-size?*) (flat-memory-usage *file*-size?*) (flat-memory-usage *jmpbuf*-size?*) (flat-memory-usage *length-size?*) (flat-memory-usage *tag-size?*) (flat-memory-usage *squished-size?*) (flat-memory-usage *uss*) ;subsumed elsewhere (flat-memory-usage *strings*) ;not counted (flat-memory-usage *symbols*) ;not counted (flat-memory-usage *outside-main*) ;not counted (flat-memory-usage *inside-main*) ;not counted (flat-memory-usage *outside-body*) ;not counted (flat-memory-usage *discard*) (flat-memory-usage *errors-used*) ;not counted (flat-memory-usage *warnings*) ;not counted (flat-memory-usage *ti*) (flat-memory-usage *statements-per-constant-initialization-procedure*) (flat-memory-usage *li*) (flat-memory-usage *primitive-procedure-handlers*) ;not counted (recursive-object-memory-usage *list->vector*) (recursive-object-memory-usage *append*) (recursive-object-memory-usage *cons*) (recursive-object-memory-usage *eqv?*) (flat-memory-usage *c:noreturn?*) (flat-memory-usage *c:c?*) (flat-memory-usage *c:panic?*) (flat-memory-usage *c:backtrace?*) (flat-memory-usage *c:backtrace-internal?*) (flat-memory-usage *c:ipow?*) (flat-memory-usage *c:input-waiting?*) (flat-memory-usage *p7?*) (flat-memory-usage *closure-representation*) (flat-memory-usage *type-if?*) (flat-memory-usage *immediate-structures?*) (flat-memory-usage *bounds-checks?*) (flat-memory-usage *memory-checks?*) (flat-memory-usage *overflow-checks?*) (flat-memory-usage *type-checks?*) (flat-memory-usage *runtime-checks?*) (flat-memory-usage *heap-allocation?*) (flat-memory-usage *stack-allocation?*) (flat-memory-usage *region-allocation?*) (flat-memory-usage *memory-messages?*) (flat-memory-usage *globals?*) (flat-memory-usage *expandable-regions?*) (flat-memory-usage *forgery?*) (flat-memory-usage *eq?-forgery?*) (flat-memory-usage *uniqueness?*) (flat-memory-usage *align-strings?*) (flat-memory-usage *treat-all-symbols-as-external?*) (flat-memory-usage *index-allocated-string-types-by-expression?*) (flat-memory-usage *index-constant-structure-types-by-slot-types?*) (flat-memory-usage *index-constant-structure-types-by-expression?*) (flat-memory-usage *index-allocated-structure-types-by-slot-types?*) (flat-memory-usage *index-allocated-structure-types-by-expression?*) (flat-memory-usage *index-constant-headed-vector-types-by-element-type?*) (flat-memory-usage *index-constant-headed-vector-types-by-expression?*) (flat-memory-usage *index-allocated-headed-vector-types-by-element-type?*) (flat-memory-usage *index-allocated-headed-vector-types-by-expression?*) (flat-memory-usage *index-constant-nonheaded-vector-types-by-element-type?*) (flat-memory-usage *index-constant-nonheaded-vector-types-by-expression?*) (flat-memory-usage *index-allocated-nonheaded-vector-types-by-element-type?*) (flat-memory-usage *index-allocated-nonheaded-vector-types-by-expression?*) (recursive-object-memory-usage *include-path*) (recursive-object-memory-usage *includes*) (recursive-object-memory-usage *herald*) (recursive-object-memory-usage *heralds*) (recursive-object-memory-usage *program-has-pthreads?*))) (define (print-global-memory-usage) (let* ((c1 (global-memory-usage)) (c4 (cond ((>= c1 1048576) (inexact->exact (ceiling (/ c1 1048576)))) ((>= c1 1024) (inexact->exact (ceiling (/ c1 1024)))) (else c1))) (c5 (cond ((>= c1 1048576) "M") ((>= c1 1024) "K") (else "")))) ;; conventions: C1 C4 C5 (notify "Stalin thinks ~s~a byte~a in use" c4 c5 (if (= c1 1) " is" "s are")) (collect-all) (let* ((c2 (first (collect-info))) (c4 (cond ((>= c2 1048576) (inexact->exact (ceiling (/ c2 1048576)))) ((>= c2 1024) (inexact->exact (ceiling (/ c2 1024)))) (else c2))) (c5 (cond ((>= c2 1048576) "M") ((>= c2 1024) "K") (else "")))) ;; conventions: C2 C4 C5 (notify "Scheme->C thinks ~s~a byte~a in use" c4 c5 (if (= c2 1) " is" "s are")) (let* ((c3 (- c1 c2)) (c4 (cond ((>= (abs c3) 1048576) (inexact->exact (ceiling (/ (abs c3) 1048576)))) ((>= (abs c3) 1024) (inexact->exact (ceiling (/ (abs c3) 1024)))) (else (abs c3)))) (c5 (cond ((>= (abs c3) 1048576) "M") ((>= (abs c3) 1024) "K") (else "")))) (unless (zero? c3) (notify "~s~a byte~a too ~a" c4 c5 (if (= (abs c3) 1) "" "s") (if (negative? c3) "few" "many"))))))) (define (print-number-of-call-sites-that-dispatch-on-clones) (let ((n (count-if (lambda (x) (and (executed? x) (let ((us (members (expression-type-set (expression-callee x))))) (some (lambda (u1) (some (lambda (u2) (and (not (eq? u1 u2)) (native-procedure-type? u1) (called? u1) (native-procedure-type? u2) (called? u2) (wide-clones? u1 u2))) us)) us)))) ;; needs work: Doesn't handle implicit call sites. *calls*))) (notify "~s call site~a on clones" n (if (= n 1) " dispatches" "s dispatch")))) (define (print-maximal-non-let-lexical-nesting-depth) (notify "Maximal non-LET lexical nesting depth is ~s" (reduce max (map non-let-lexical-nesting-depth (remove-if-not environment-used? *es*)) 0))) (define (print-maximal-clone-rate) (notify "Maximal clone rate is ~s" (reduce max (map length (equivalence-classesq (map wide-prototype (remove-if-not environment-used? *es*)))) 0))) (define (print-clone-rates) (for-each (lambda (e) (notify "~a ~a ~a ~a" (number->string-of-length (lexical-nesting-depth e) 5) (number->string-of-length (non-let-lexical-nesting-depth e) 5) (number->string-of-length (count-if called? (wide-clones e)) 5) (environment-name e))) (remove-if-not environment-used? *es*))) (define (print-escaping-type-counts) (let ((n (reduce + (map (lambda (e) (if (eq? (environment-escaping-types e) (unspecified)) 0 (count-if native-procedure-type? (environment-escaping-types e)))) *es*) 0))) (notify "~s escaping native procedure type~a" n (if (= n 1) "" "s"))) (let ((n (reduce + (map (lambda (e) (if (eq? (environment-escaping-types e) (unspecified)) 0 (count-if continuation-type? (environment-escaping-types e)))) *es*) 0))) (notify "~s escaping continuation type~a" n (if (= n 1) "" "s"))) (let ((n (reduce + (map (lambda (e) (if (eq? (environment-escaping-types e) (unspecified)) 0 (count-if string-type? (environment-escaping-types e)))) *es*) 0))) (notify "~s escaping string type~a" n (if (= n 1) "" "s"))) (let ((n (reduce + (map (lambda (e) (if (eq? (environment-escaping-types e) (unspecified)) 0 (count-if structure-type? (environment-escaping-types e)))) *es*) 0))) (notify "~s escaping structure type~a" n (if (= n 1) "" "s"))) (let ((n (reduce + (map (lambda (e) (if (eq? (environment-escaping-types e) (unspecified)) 0 (count-if headed-vector-type? (environment-escaping-types e)))) *es*) 0))) (notify "~s escaping headed vector type~a" n (if (= n 1) "" "s"))) (let ((n (reduce + (map (lambda (e) (if (eq? (environment-escaping-types e) (unspecified)) 0 (count-if nonheaded-vector-type? (environment-escaping-types e)))) *es*) 0))) (notify "~s escaping nonheaded vector type~a" n (if (= n 1) "" "s"))) (let ((n (reduce + (map (lambda (e) (if (eq? (environment-escaping-types e) (unspecified)) 0 (length (environment-escaping-types e)))) *es*) 0))) (notify "~s total escaping type~a" n (if (= n 1) "" "s")))) ;;; Architecture parameters ;;; needs work: Character constants, string constants, and ARGV will screw up ;;; if *CHAR* is not "char". Exact integer constants will screw up ;;; if *FIXNUM* is not "int". Inexact constants will screw up if ;;; *FLONUM* is not "double". Subscript constants will screw up if ;;; *LENGTH* is not "int". Type constants will screw up if *TAG* is ;;; not "int". (define *char* #f) (define *fixnum* #f) (define *flonum* #f) (define *length* #f) (define *tag* #f) (define *squished* #f) (define *signed-squished* #f) (define *file* #f) (define *jmpbuf* #f) (define *char-alignment* #f) (define *fixnum-alignment* #f) (define *flonum-alignment* #f) ;;; This is a limitation. We can only generate code on architectures where ;;; all pointers have the same alignment. (define *pointer-alignment* #f) (define *length-alignment* #f) (define *tag-alignment* #f) (define *squished-alignment* #f) (define *file-alignment* #f) (define *jmpbuf-alignment* #f) (define *char-size* #f) (define *fixnum-size* #f) (define *flonum-size* #f) ;;; This is a limitation. We can only generate code on architectures where ;;; all pointers have the same size. (define *pointer-size* #f) (define *length-size* #f) (define *tag-size* #f) (define *squished-size* #f) ;;; For AIX (define *include-malloc-for-alloca?* #f) ;;; Derived alignments (define *worst-alignment* #f) (define *allocation-alignment* #f) ;;; Alignment check flags (define *char-alignment?* #f) (define *fixnum-alignment?* #f) (define *flonum-alignment?* #f) (define *rectangular-alignment?* #f) (define *void*-alignment?* #f) (define *char*-alignment?* #f) (define *file*-alignment?* #f) (define *jmpbuf*-alignment?* #f) (define *length-alignment?* #f) (define *tag-alignment?* #f) (define *squished-alignment?* #f) (define *file-alignment?* #f) (define *jmpbuf-alignment?* #f) ;;; Size check flags (define *char-size?* #f) (define *fixnum-size?* #f) (define *flonum-size?* #f) (define *rectangular-size?* #f) (define *void*-size?* #f) (define *char*-size?* #f) (define *file*-size?* #f) (define *jmpbuf*-size?* #f) (define *length-size?* #f) (define *tag-size?* #f) (define *squished-size?* #f) (define *uss* #f) (define *strings* #f) (define *symbols* #f) (define *outside-main* #f) (define *inside-main* #f) (define *outside-body* #f) (define *discard* #f) ;;; C surface-syntax predicates and accessors ;;; needs work: To replace the calls to LIST? and LENGTH in the following with ;;; more efficient code: (define (c:noop? c) (or (and (pair? c) (c:noop? (car c)) (c:noop? (cdr c))) (null? c) (and (string? c) (zero? (string-length c))))) (define (c:whitespace? c) (or (and (pair? c) (c:whitespace? (car c)) (c:whitespace? (cdr c))) (null? c) (and (char? c) (char=? c #\newline)) (and (string? c) (or (string=? c "") (string=? c " "))))) (define (c:/**/? c) (or (c:whitespace? c) (and (pair? c) (c:/**/? (car c)) (c:/**/? (cdr c))) (and (list? c) (= (length c) 3) (string? (first c)) (string=? (first c) "/*") (string? (second c)) (string=? (second c) " ") (list? (third c)) (= (length (third c)) 3) (string? (first (third c))) (string? (second (third c))) (string=? (second (third c)) " ") (string? (third (third c))) (string=? (third (third c)) "*/")))) (define (c:declaration? c) (and (list? c) (= (length c) 4) (eq? (first c) 'c:declaration))) (define (c:protect? c) (and (list? c) (= (length c) 2) (eq? (first c) 'c:protect))) (define (c:protected? c) (or (eq? c 'c:protect) (and (pair? c) (or (c:protected? (car c)) (c:protected? (cdr c)))))) (define (c:no-return? c) (and (list? c) (= (length c) 2) (eq? (first c) 'c:no-return))) (define (c:parentheses? c) (or (and (c:no-return? c) (c:parentheses? (second c))) (and (c:protect? c) (c:parentheses? (second c))) (and (list? c) (= (length c) 3) (string? (first c)) (string=? (first c) "(") (string? (third c)) (string=? (third c) ")")))) (define (c:strip c) (cond ((c:no-return? c) (c:strip (second c))) ((c:protect? c) (c:strip (second c))) ((c:parentheses? c) (c:strip (second c))) (else c))) (define (c:match? c1 c2) (define (c:match c1 c2) (define (augment variable variables) ;; conventions: VARIABLE VARIABLES (cond ((eq? variables #f) #f) ((member variable variables) variables) ((some (lambda (other-variable) ;; conventions: OTHER-VARIABLE (equal? (car variable) (car other-variable))) variables) #f) (else (cons variable variables)))) (define (merge variables1 variables2) ;; conventions: VARIABLE1 VARIABLE2 (cond ((eq? variables1 #f) #f) ((null? variables1) variables2) (else (merge (rest variables1) (augment (first variables1) variables2))))) (cond ((or (and (char? c1) (char? c2) (char=? c1 c2)) (and (string? c1) (string? c2) (string=? c1 c2)) (and (number? c1) (number? c2) (= c1 c2)) (and (null? c1) (null? c2)) (and (symbol? c1) (symbol? c2) (eq? c1 c2))) '()) ((and (pair? c1) (pair? c2)) (if (and (string? (car c1)) (string? (car c2)) (string=? (car c1) "t") (string=? (car c2) "t") (pair? (cdr c1)) (pair? (cdr c2)) (integer? (cadr c1)) (integer? (cadr c2)) (null? (cddr c1)) (null? (cddr c2))) (list (cons c1 c2)) (merge (c:match (car c1) (car c2)) (c:match (cdr c1) (cdr c2))))) (else #f))) (not (eq? (c:match c1 c2) #f))) (define (c:assignment? c) (and (list? c) (= (length c) 2) (list? (first c)) (= (length (first c)) 2) (eq? (first (first c)) 'c:protect) (list? (second (first c))) (= (length (second (first c))) 3) (string? (second (second (first c)))) (string=? (second (second (first c))) " ") (list? (third (second (first c)))) (= (length (third (second (first c)))) 3) (string? (first (third (second (first c))))) (string=? (first (third (second (first c)))) "=") (string? (second (third (second (first c))))) (string=? (second (third (second (first c)))) " ") (string? (second c)) (string=? (second c) ";"))) (define (c:atomic-t? c) (and (list? c) (= (length c) 2) (string? (first c)) (string=? (first c) "t") (string? (second c)))) (define (c:t? c) (or (and (list? c) (= (length c) 2) (string? (first c)) (string=? (first c) "t") (string? (second c))) (and (list? c) (= (length c) 3) (c:t? (first c)) (string? (second c)) (string=? (second c) ".")))) (define (c:atomic-t c) (if (and (list? c) (= (length c) 3) (c:t? (first c)) (string? (second c)) (string=? (second c) ".")) (c:atomic-t (first c)) c)) (define (c:assignment-to-temporary? c) (and (c:assignment? c) (c:t? (first (second (first c)))))) (define (c:unprotected-assignment-to-atomic-temporary? c) (and (c:assignment? c) (c:atomic-t? (first (second (first c)))) (not (c:protected? (third (third (second (first c)))))))) (define (c:label? c) (and (list? c) (= (length c) 2) (list? (first c)) (= (length (first c)) 2) (string? (first (first c))) (or (string=? (first (first c)) "h") (string=? (first (first c)) "l") (string=? (first (first c)) "x")) (string? (second (first c))) (string? (second c)) (string=? (second c) ":"))) ;;; C surface-syntax constructors (define (outside-main c) (unless (c:noop? c) (set! *outside-main* (cons c *outside-main*)))) (define (inside-main c) (unless (c:noop? c) ;; needs work: To replace the call to LIST? and LENGTH in the following with ;; more efficient code: (cond ((and (list? c) (= (length c) 3) (char? (second c)) (char=? (second c) #\newline)) (inside-main (first c)) (inside-main (third c))) (else (set! *inside-main* (cons c *inside-main*)))))) (define (outside-body c) (unless (c:noop? c) (set! *outside-body* (cons c *outside-body*)))) (define (c:protect c) (list 'c:protect c)) (define (c:no-return c) (list 'c:no-return c)) (define (spaces-between cs) (define (space-between c1 c2) (cond ((c:noop? c1) c2) ((c:noop? c2) c1) (else (list c1 " " c2)))) (if (null? cs) "" (space-between (first cs) (spaces-between (rest cs))))) (define (space-between . cs) (spaces-between cs)) (define (commas-between cs) (define (comma-between c1 c2) (cond ((c:noop? c1) c2) ((c:noop? c2) c1) (else (list c1 ", " c2)))) (if (null? cs) "" (comma-between (first cs) (commas-between (rest cs))))) (define (comma-between . cs) (commas-between cs)) (define (newlines-between cs) (define (newline-between c1 c2) (cond ((c:noop? c1) c2) ((c:noop? c2) c1) (else (list c1 #\newline c2)))) (if (null? cs) "" (newline-between (first cs) (newlines-between (rest cs))))) (define (newline-between . cs) (newlines-between cs)) (define (braces-around c) (define (c:ends-in-colon? c) (or (and (pair? c) (or (c:ends-in-colon? (cdr c)) (and (c:ends-in-colon? (car c)) (c:/**/? (cdr c))))) (and (string? c) (string=? c ":")))) ;; ANSI C doesn't allow "label:}" (list "{" (if (c:ends-in-colon? c) (semicolon-after c) c) "}")) (define (unparenthesize c) (cond ((c:no-return? c) (c:no-return (unparenthesize (second c)))) ((c:protect? c) (c:protect (unparenthesize (second c)))) ((c:parentheses? c) (unparenthesize (second c))) (else c))) (define (parentheses-around c) (list "(" (unparenthesize c) ")")) (define (semicolon-after c) (list (unparenthesize c) ";")) (define (colon-after c) (list c ":")) (define (star-before c) (list "*" c)) ;;; C declaration constructors (define (c:declaration w c c1) (let ((c (if (c:protect? c) (second c) c))) (list 'c:declaration c (if (c:noop? c1) (semicolon-after (c:type-set w c)) (space-between (semicolon-after (c:type-set w c)) (c:/**/ c1))) #f))) ;;; C expression constructors (define (c:initialize-constants i) (list "initialize_constants" (number->string i))) (define (c:main) "main") (define (c:argc) "argc") (define (c:argv) "argv") (define (c:escape c) (cond ((char=? c #\newline) "\\n") ((char=? c #\') "\\'") ((char=? c #\") "\\\"") ((char=? c #\\) "\\\\") (else (string c)))) (define (c:character c) (list "'" (c:escape c) "'")) (define (c:fixnum c) (number->string c)) (define (c:flonum c) (number->string c)) (define (c:string c) (cond (*align-strings?* (unless (memp string=? c *strings*) (set! *strings* (append *strings* (list c))) (outside-main ;; needs work: needs abstraction for initialized declaration (semicolon-after (space-between "union" (braces-around (space-between (semicolon-after (space-between *char* (c:raw-subscript "string" (number->string (+ (string-length c) 1))))) (semicolon-after (space-between *fixnum* "align")))) (unparenthesize (c:= (list "string" (number->string (positionp string=? c *strings*))) (braces-around (braces-around (commas-between (append (map (lambda (c) (number->string (char->integer c))) (string->list c)) (list (c:0)))))))))))) (c:& (c:. (list "string" (number->string (positionp string=? c *strings*))) (c:raw-subscript "string" (c:0))))) (else (list "\"" (map c:escape (string->list c)) "\"")))) (define (c:subscript c1 c2) (parentheses-around (c:protect (list c1 "[" (unparenthesize c2) "]")))) (define (c:raw-subscript c1 c2) (list c1 "[" (unparenthesize c2) "]")) (define (c:= c1 c2) (parentheses-around (c:protect (space-between (unparenthesize c1) "=" (unparenthesize c2))))) (define (c:call c . cs) (list c (parentheses-around (commas-between cs)))) (define (c:sizeof c) (c:call "sizeof" c)) (define (c:alignof c) (include! "stddef") ;offsetof (c:call "offsetof" (list "struct" (braces-around (space-between (semicolon-after (space-between "char" "dummy")) (semicolon-after (c "probe"))))) "probe")) (define (c:cast c1 c2) (parentheses-around (list (parentheses-around c1) c2))) (define (c:unsigned-char-cast c) (c:cast (space-between "unsigned" "char") c)) ;;; needs work: Calls to this might need checks for -On. (define (c:fixnum-cast c) (c:cast *fixnum* c)) (define (c:flonum-cast c) (c:cast *flonum* c)) (define (c:void*-cast c) (c:cast (space-between "void" "*") c)) (define (c:fixnum*-cast c) (c:cast (space-between *fixnum* "*") c)) (define (c:char*-cast c) (c:cast (space-between *char* "*") c)) (define (c:file*-cast c) (include! "stdio") ;FILE (c:cast (space-between *file* "*") c)) (define (c:boolean-or . cs) ;; note: This can't be c:|| becaust this is not allowed by the Scheme reader. (parentheses-around (let loop ((cs cs)) (cond ((null? cs) (fuck-up)) ((null? (rest cs)) (first cs)) (else (list (first cs) "||" (loop (rest cs)))))))) (define (c:&& . cs) (parentheses-around (let loop ((cs cs)) (cond ((null? cs) (fuck-up)) ((null? (rest cs)) (first cs)) (else (list (first cs) "&&" (loop (rest cs)))))))) (define (unary c1 c2) (parentheses-around (list c1 c2))) (define (binary c1 c2 c3) (parentheses-around (list c1 c2 c3))) (define (c:?: c1 c2 c3) (parentheses-around (list c1 "?" c2 ":" c3))) ;; needs work: To distinguish between signed and unsigned and int and long int. (define (c:0) "0") ;; needs work: To distinguish between float, double, and long double. (define (c:0.0) "0.0") ;; needs work: To distinguish between signed and unsigned and int and long int. (define (c:1) "1") ;; needs work: To distinguish between float, double, and long double. (define (c:1.0) "1.0") ;; needs work: To distinguish between signed and unsigned and int and long int. (define (c:256) "256") ;; needs work: To distinguish between char and wchar_t. (define (c:nul) "'\\0'") (define (c:null) (include! "stdlib") ;NULL "NULL") (define (c:eof) (include! "stdio") ;EOF "EOF") (define (c:. c1 c2) (if (let ((c1 (c:strip c1))) ;; needs work: To replace the calls to LIST? and LENGTH in the ;; following with more efficient code: (and (list? c1) (= (length c1) 3) (string? (second c1)) (or (string=? (second c1) ".") (string=? (second c1) "->")))) (binary (unparenthesize c1) "." c2) (binary c1 "." c2))) (define (c:-> c1 c2) (c:protect (if (let ((c1 (c:strip c1))) ;; needs work: To replace the calls to LIST? and LENGTH in the ;; following with more efficient code: (and (list? c1) (= (length c1) 3) (string? (second c1)) (or (string=? (second c1) ".") (string=? (second c1) "->")))) (binary (unparenthesize c1) "->" c2) (binary c1 "->" c2)))) (define (c:== c1 c2) (binary c1 "==" c2)) (define (c:==0 c) (c:== c (c:0))) (define (c:==0.0 c) (c:== c (c:0.0))) (define (c:==infinity c) (include! "math") ;HUGE_VAL (c:== c "HUGE_VAL")) (define (c:==null c) (c:== c (c:null))) (define (c:==eof c) (c:== c (c:eof))) (define (c:!= c1 c2) (binary c1 "!=" c2)) (define (c:!=0 c) (c:!= c (c:0))) (define (c:!=0.0 c) (c:!= c (c:0.0))) (define (c:< c1 c2) (binary c1 "<" c2)) (define (c:<0 c) (c:< c (c:0))) (define (c:<0.0 c) (c:< c (c:0.0))) (define (c:> c1 c2) (binary c1 ">" c2)) (define (c:>0 c) (c:> c (c:0))) (define (c:>0.0 c) (c:> c (c:0.0))) (define (c:<= c1 c2) (binary c1 "<=" c2)) (define (c:>= c1 c2) (binary c1 ">=" c2)) ;;; needs work: Calls to this might need checks for -On. (define (c:+ c1 c2) (if (equal? c2 "0") c1 (binary c1 "+" c2))) ;;; needs work: Calls to this might need checks for -On. (define (c:- c . cs) (when (> (length cs) 1) (fuck-up)) (cond ((null? cs) (unary "-" c)) ((equal? (first cs) "0") c) (else (binary c "-" (first cs))))) ;;; needs work: Calls to this might need checks for -On. (define (c:* c . cs) (when (> (length cs) 1) (fuck-up)) (if (null? cs) (unary "*" c) (binary c "*" (first cs)))) (define (c:/ c1 c2) (binary c1 "/" c2)) (define (c:% c1 c2) ;; needs work: The % operator in C is implementation dependent for negative ;; arguments. (binary c1 "%" c2)) ;;; needs work: Calls to this might need checks for -On. (define (c:<< c1 c2) (if (equal? c2 "0") c1 (binary c1 "<<" c2))) ;;; needs work: Calls to this might need checks for -On. (define (c:>> c1 c2) ;; needs work: The >> operator in C is implementation dependent for negative ;; arguments. (if (equal? c2 "0") c1 (binary c1 ">>" c2))) (define (c:& c . cs) (when (> (length cs) 1) (fuck-up)) (if (null? cs) (unary "&" c) (binary c "&" (first cs)))) (define (c:bitwise-or c1 c2) ;; note: This can't be c:| because this is not allowed by the Scheme reader. (if (equal? c2 "0") c1 (binary c1 "|" c2))) (define (c:^ c1 c2) (binary c1 "^" c2)) (define (c:~ c) (unary "~" c)) (define (c:! c) (unary "!" c)) ;;; needs work: Calls to this might need checks for -On. (define (c:++ c) (parentheses-around (c:protect (list c "++")))) ;;; C statement constructors (define (c:/**/ c) (space-between "/*" c "*/")) (define (c:define c1 c2) (space-between "#define" c1 c2)) (define (c:noop) "") (define (c::= c1 c2) (semicolon-after (c:= c1 c2))) ;;; needs work: Calls to this might need checks for -On. (define (c:+= c1 c2) (semicolon-after (c:protect (space-between (unparenthesize c1) "+=" (unparenthesize c2))))) (define (c:: c) (colon-after c)) (define (c:goto c) (c:no-return (semicolon-after (space-between "goto" c)))) (define (c:header c . cs) (if (null? cs) (list c (parentheses-around "void")) (list c (parentheses-around (commas-between cs))))) (define (c:prototype c . cs) (semicolon-after (apply c:header c cs))) (define (c:noreturn-prototype c . cs) (set! *c:noreturn?* #t) (semicolon-after (space-between (apply c:header c cs) "NORETURN"))) (define (c:gosub c . cs) (semicolon-after (c:protect (apply c:call c cs)))) (define (c:return . cs) (when (> (length cs) 1) (fuck-up)) (c:no-return (semicolon-after (if (null? cs) "return" (space-between "return" (unparenthesize (first cs))))))) (define (strict-operator c1 c2) (if (let loop ((c2 c2)) (cond ((c:no-return? c2) (loop (second c2))) ((c:protect? c2) (loop (second c2))) ;; needs work: To replace the calls to LIST? and LENGTH in the ;; following with more efficient code: (else (or (and (list? c2) (= (length c2) 3) (char? (second c2)) (char=? (second c2) #\newline)) (and (list? c2) (list? (first c2)) (string? (first (first c2))) (or (string=? (first (first c2)) "if") (string=? (first (first c2)) "switch"))))))) (newline-between c1 (braces-around c2)) (space-between c1 c2))) (define (operator c1 c2) (if (let loop ((c2 c2)) (cond ((c:no-return? c2) (loop (second c2))) ((c:protect? c2) (loop (second c2))) ;; needs work: To replace the calls to LIST? and LENGTH in the ;; following with more efficient code: (else (and (list? c2) (= (length c2) 3) (char? (second c2)) (char=? (second c2) #\newline) (or (not (list? (first c2))) (not (string? (first (first c2)))) (and (not (string=? (first (first c2)) "if")) (not (string=? (first (first c2)) "switch")))))))) (newline-between c1 (braces-around c2)) (space-between c1 c2))) (define (c:while c1 c2) (operator (space-between "while" (parentheses-around c1)) c2)) (define (c:for c1 c2 c3 c4) (operator (space-between "for" (parentheses-around (space-between (semicolon-after (unparenthesize c1)) (semicolon-after (unparenthesize c2)) (unparenthesize c3)))) c4)) (define (c:if c1 c2 c3 p?) (if (c:match? c2 c3) (if p? (newline-between (semicolon-after c1) c2) c2) (if (c:/**/? c2) (if (c:/**/? c3) (if p? (semicolon-after c1) (c:noop)) ;; note: This assumes that C:! wraps in parentheses. (operator (space-between "if" (c:! (parentheses-around c1))) c3)) (if (c:/**/? c3) (operator (space-between "if" (parentheses-around c1)) c2) (if (c:no-return? c2) (if (c:no-return? c3) (c:no-return (newline-between (strict-operator (space-between "if" (parentheses-around c1)) c2) (operator "else" c3))) (newline-between (strict-operator (space-between "if" (parentheses-around c1)) c2) c3)) (if (c:no-return? c3) (newline-between (strict-operator ;; note: This assumes that C:! wraps in parentheses. (space-between "if" (c:! (parentheses-around c1))) c3) c2) (if (and (c:assignment? c2) (c:assignment? c3) (equal? (first (second (first c2))) (first (second (first c3))))) (c::= (first (second (first c2))) (c:?: c1 (third (third (second (first c2)))) (third (third (second (first c3)))))) (newline-between (strict-operator (space-between "if" (parentheses-around c1)) c2) (operator "else" c3))))))))) (define (equate-cases cs1 cs2) (transitive-equivalence-classesp (lambda (pair1 pair2) ;; conventions: PAIR1 PAIR2 (c:match? (second pair1) (second pair2))) (map list cs1 cs2))) (define (c:default c) (newline-between (colon-after "default") c)) (define (c:switch c1 cs2 cs3 c4 p?) (let ((cases (transitive-equivalence-classesp (lambda (pair1 pair2) ;; conventions: PAIR1 PAIR2 (c:match? (second pair1) (second pair2))) (cons (list (colon-after "default") c4) (map (lambda (c2 c3) (list (colon-after (space-between "case" c2)) c3)) cs2 cs3))))) ;; conventions: CASES (when (null? cases) (fuck-up)) (if (null? (rest cases)) ;; note: Technically we would need to prepend an evaluation of C1 but ;; we don't since SWITCH is always called as a type switch and the ;; antecedent can't do any side effects, diverge, or cause an ;; error. (second (first (first cases))) (let ((the-case (find-if (lambda (pairs) ;; conventions: PAIRS (some (lambda (pair) ;; conventions: PAIR (equal? (first pair) (colon-after "default"))) pairs)) cases))) ;; conventions: THE-CASE (if (and (null? (rest (removeq the-case cases))) (null? (rest (first (removeq the-case cases))))) (if p? (c:if (c:== c1 (third (first (first (first (first (removeq the-case cases))))))) (second (first (first (removeq the-case cases)))) (second (first the-case)) #f) (newline-between (c:if (c:== c1 (third (first (first (first (first (removeq the-case cases))))))) (second (first (first (removeq the-case cases)))) (c:noop) #f) (second (first the-case)))) (newline-between (space-between "switch" (parentheses-around c1)) (braces-around (newline-between (newlines-between (map (lambda (pairs) ;; conventions: PAIRS (newline-between (newlines-between (map first pairs)) (second (first pairs)) (if p? (semicolon-after "break") (c:noop)))) (removeq the-case cases))) (c:default (second (first the-case))))))))))) (define (c:defaultless-switch c1 cs2 cs3 p?) ;; Defaultless here means not that the default is a noop but rather that the ;; compiler guarantees that the default will never be taken so that the ;; default can be reallocated to one of the cases. (let ((cases (transitive-equivalence-classesp (lambda (pair1 pair2) ;; conventions: PAIR1 PAIR2 (c:match? (second pair1) (second pair2))) (map (lambda (c2 c3) (list (colon-after (space-between "case" c2)) c3)) cs2 cs3)))) ;; conventions: CASES (when (null? cases) (fuck-up)) (if (null? (rest cases)) ;; note: Technically we would need to prepend an evaluation of C1 but ;; we don't since SWITCH is always called as a type switch and the ;; antecedent can't do any side effects, diverge, or cause an ;; error. (second (first (first cases))) ;; Choose the case with the greatest number of pairs to be the default. ;; Note that MINP is being used to compute the maximal member here. (let ((the-case (minp (lambda (case1 case2) ;; conventions: CASE1 CASE2 (> (length case1) (length case2))) cases))) ;; conventions: THE-CASE (if (and (null? (rest (removeq the-case cases))) (null? (rest (first (removeq the-case cases))))) (if p? (c:if (c:== c1 (third (first (first (first (first (removeq the-case cases))))))) (second (first (first (removeq the-case cases)))) (second (first the-case)) #f) (newline-between (c:if (c:== c1 (third (first (first (first (first (removeq the-case cases))))))) (second (first (first (removeq the-case cases)))) (c:noop) #f) (second (first the-case)))) (newline-between (space-between "switch" (parentheses-around c1)) (braces-around (newline-between (newlines-between (map (lambda (pairs) ;; conventions: PAIRS (newline-between (newlines-between (map first pairs)) (second (first pairs)) (if p? (semicolon-after "break") (c:noop)))) (removeq the-case cases))) (c:default (second (first the-case))))))))))) ;;; C type constructors (define (c:byte) "char") ;;; C function call constructors (define (c:rint c) (include! "math") ;rint (c:call "rint" c)) (define (c:floor c) (include! "math") ;floor (c:call "floor" c)) (define (c:ceil c) (include! "math") ;ceil (c:call "ceil" c)) (define (c:exp c) (include! "math") ;exp (c:call "exp" c)) (define (c:log c) (include! "math") ;log (c:call "log" c)) (define (c:sin c) (include! "math") ;sin (c:call "sin" c)) (define (c:cos c) (include! "math") ;cos (c:call "cos" c)) (define (c:tan c) (include! "math") ;tan (c:call "tan" c)) (define (c:asin c) (include! "math") ;asin (c:call "asin" c)) (define (c:acos c) (include! "math") ;acos (c:call "acos" c)) (define (c:atan c) (include! "math") ;atan (c:call "atan" c)) (define (c:atan2 c1 c2) (include! "math") ;atan2 (c:call "atan2" c1 c2)) (define (c:sqrt c) (include! "math") ;sqrt (c:call "sqrt" c)) (define (c:pow c1 c2) (include! "math") ;pow (c:call "pow" c1 c2)) (define (c:setjmp c) (include! "setjmp") ;setjmp (c:protect (c:call "setjmp" c))) (define (c:longjmp c1 c2) (include! "setjmp") ;longjmp (c:gosub "longjmp" c1 c2)) (define (c:fopen c1 c2) (include! "stdio") ;fopen (c:protect (c:call "fopen" c1 c2))) (define (c:fclose c) (include! "stdio") ;fclose (c:protect (c:call "fclose" c))) (define (c:getc c) (include! "stdio") ;getc (c:protect (c:call "getc" c))) (define (c:ungetc c1 c2) (include! "stdio") ;ungetc (c:protect (c:call "ungetc" c1 c2))) (define (c:putc c1 c2) (include! "stdio") ;putc (c:gosub "putc" c1 c2)) (define (c:printf . cs) (include! "stdio") ;printf (apply c:gosub "printf" cs)) (define (c:malloc c p?) (cond (*treadmarks?* (include! "Tmk") ;Tmk_malloc (c:protect (c:call "Tmk_malloc" c))) (*program-has-heap?* (cond (p? (include! "gc/gc") ;GC_malloc_uncollectable (c:protect (c:call "GC_malloc_uncollectable" c))) (else (include! "gc/gc") ;GC_malloc_atomic_uncollectable (c:protect (c:call "GC_malloc_atomic_uncollectable" c))))) (else (include! "malloc") ;malloc (c:protect (c:call "malloc" c))))) (define (c:gc-malloc c) (when *treadmarks?* (fuck-up)) (include! "gc/gc") ;GC_malloc (c:protect (c:call "GC_malloc" c))) (define (c:gc-malloc-atomic c) (when *treadmarks?* (fuck-up)) (include! "gc/gc") ;GC_malloc_atomic (c:protect (c:call "GC_malloc_atomic" c))) (define (c:free c p?) (cond (*treadmarks?* (include! "Tmk") ;Tmk_free (c:gosub "Tmk_free" c)) (*program-has-heap?* (cond (p? (include! "gc/gc") ;GC_free (c:gosub "GC_free" c)) (else (include! "gc/gc") ;GC_free (c:gosub "GC_free" c)))) (else (include! "malloc") ;free (c:gosub "free" c)))) (define (c:alloca c) (when *treadmarks?* (fuck-up)) (include! (if *include-malloc-for-alloca?* "malloc" "alloca")) ;alloca (c:protect (c:call "alloca" c))) (define (c:gc-enable-incremental) (when *treadmarks?* (fuck-up)) (include! "gc/gc") ;GC_enable_incremental (c:gosub "GC_enable_incremental")) (define (c:strlen c) (include! "string") ;strlen (c:call "strlen" c)) (define (c:exit c) (include! "stdlib") ;exit (c:gosub "exit" c)) (define (c:assert c) (include! "assert") ;assert (c:gosub "assert" c)) ;;; Stalin-specific code generation utilities (define (c:==struct c1 c2 u) (cond ((rectangular-type? u) (c:&& (c:== (c:r c1) (c:r c2)) (c:== (c:i c1) (c:i c2)))) ((native-procedure-type? u) (case *closure-representation* ((immediate-flat immediate-display) (apply c:&& (map (lambda (e) (c:== (c:. c1 (c:e e)) (c:. c2 (c:e e)))) (ancestors u)))) ((indirect-flat indirect-display linked) (c:== c1 c2)) (else (fuck-up)))) ;; Immediate structures should never be compared for EQ?-ness. ((and (or (nonheaded-vector-type? u) (displaced-vector-type? u)) (not (degenerate-vector-type? u))) (c:&& (c:== (c:. c1 "length") (c:. c2 "length")) (c:== (c:. c1 "elements") (c:. c2 "elements")))) (else (c:== c1 c2)))) (define (tag-only? w) (must-be? (lambda (u) (or (char-type? u) (fictitious? u))) w)) (define (has-union? w) (> (count-if-not (lambda (u) (or (char-type? u) (fictitious? u))) (members w)) 1)) (define (determine-which-type-sets-are-squeezable!) ;; needs work: This really depends on the architecture parameters. (for-each (lambda (w) (set-type-set-squeezable?! w (and (not (can-be? fixnum-type? w)) (not (can-be? flonum-type? w)) (not (can-be? rectangular-type? w)) (not (can-be? pointer-type? w)) (case *closure-representation* ((immediate-flat immediate-display) ;; needs work: Can be extended to allow squeezing a native procedure ;; with a closure that has a single slot or environment. (not (can-be? (lambda (u) (and (native-procedure-type? u) (not (fictitious? u)))) w))) ((indirect-flat indirect-display linked) #t) (else (fuck-up))) ;; needs work: Can be extended to allow squeezing a singleton ;; immediate structure if its slot is squeezed. (not (can-be? (lambda (u) (and (structure-type? u) (structure-type-immediate? u))) w)) (not (can-be? (lambda (u) (and (headed-vector-type? u) (degenerate-vector-type? u))) w)) (not (can-be? nonheaded-vector-type? w)) (not (can-be? displaced-vector-type? w)) (one (lambda (u) (and (not (char-type? u)) (not (fictitious? u)))) (members w))))) *ws*)) (define (squeezable? w) ;; needs work: This really depends on the architecture parameters. (for-each-member (lambda (u) (cond ((null-type? u) (set! *tag-size?* #t)) ((true-type? u) (set! *tag-size?* #t)) ((false-type? u) (set! *tag-size?* #t)) ((char-type? u) (set! *char-size?* #t)) ((fixnum-type? u) #f) ((flonum-type? u) #f) ((rectangular-type? u) #f) ((input-port-type? u) (include! "stdio") ;FILE (set! *file*-size?* #t)) ((output-port-type? u) (include! "stdio") ;FILE (set! *file*-size?* #t)) ((eof-object-type? u) (set! *tag-size?* #t)) ((pointer-type? u) (set! *void*-size?* #t)) ((internal-symbol-type? u) (set! *tag-size?* #t)) ((external-symbol-type? u) (set! *char*-size?* #t)) ((primitive-procedure-type? u) (set! *tag-size?* #t)) ((native-procedure-type? u) (if (fictitious? u) (set! *tag-size?* #t) (set-native-procedure-type-size?! u #t))) ((foreign-procedure-type? u) (set! *tag-size?* #t)) ((continuation-type? u) (cond ((fictitious? u) (set! *tag-size?* #t)) (else (include! "setjmp") ;jmp_buf (set! *jmpbuf*-size?* #t)))) ((string-type? u) (set! *char*-size?* #t)) ((structure-type? u) (cond ((fictitious? u) (set! *tag-size?* #t)) (else (unless (structure-type-immediate? u) (set-structure-type-size?! u #t))))) ((headed-vector-type? u) (unless (degenerate-vector-type? u) (set-headed-vector-type-size?! u #t))) ((nonheaded-vector-type? u) #f) ((displaced-vector-type? u) #f) (else (fuck-up)))) w) (type-set-squeezable? w)) (define (squeezed-member w) (unless (squeezed? w) (fuck-up)) (the-member-that (lambda (u) (and (not (char-type? u)) (not (fictitious? u)))) w)) (define (squeezed? w) (and *squeeze?* (not (fictitious? w)) (not (monomorphic? w)) (not (tag-only? w)) (squeezable? w))) (define (type-alignment& u) ;; This is only defined where U is a pointer type. This gives the alignment ;; of the object pointed to by U. In other words, this number is the minimum ;; number of low-order zeros bits in pointers of type U. (cond ((input-port-type? u) (set! *file-alignment?* #t) *file-alignment*) ((output-port-type? u) (set! *file-alignment?* #t) *file-alignment*) ((pointer-type? u) ;; This is worst case because you don't know what the pointer is pointing ;; to. (set! *char-alignment?* #t) *char-alignment*) ((external-symbol-type? u) (cond (*align-strings?* (set! *fixnum-alignment?* #t) *fixnum-alignment*) (else (set! *char-alignment?* #t) *char-alignment*))) ((native-procedure-type? u) (when (fictitious? u) (fuck-up)) (case *closure-representation* ((immediate-flat immediate-display) (fuck-up)) ((indirect-flat indirect-display linked) (set-native-procedure-type-alignment&?! u #t) (cond ((and (or (eq? *closure-conversion-method* 'baseline) (eq? *closure-conversion-method* 'conventional)) (or (not (environment? (native-procedure-type-narrow-prototype u))) (not (environment-used? (narrow-prototype u))) (not (environment? (parent-parameter u))) (not (environment-used? (parent-parameter u))))) (set! *fixnum-alignment?* #t) *fixnum-alignment*) (else (let ((e (parent-parameter u))) (if (has-parent-slot? e) ;; note: See the note in TYPE-ALIGNMENT. (max *pointer-alignment* (reduce ;; note: See the note in TYPE-ALIGNMENT. max (map (lambda (g) (type-set-alignment (variable-type-set g))) (remove-if-not slotted? (variables e))) ;; This should never happen. #f)) (reduce ;; note: See the note in TYPE-ALIGNMENT. max (map (lambda (g) (type-set-alignment (variable-type-set g))) (remove-if-not slotted? (variables e))) ;; This should never happen. #f)))))) (else (fuck-up)))) ((continuation-type? u) (when (fictitious? u) (fuck-up)) (set! *jmpbuf-alignment?* #t) *jmpbuf-alignment*) ((string-type? u) (cond (*align-strings?* (set! *fixnum-alignment?* #t) *fixnum-alignment*) (else (set! *char-alignment?* #t) *char-alignment*))) ((structure-type? u) (when (fictitious? u) (fuck-up)) ;; needs work: Can be extended to allow squishing a singleton immediate ;; structure if its slot is squished. (when (structure-type-immediate? u) (fuck-up)) (set-structure-type-alignment&?! u #t) (reduce ;; note: See the note in TYPE-ALIGNMENT. max (map type-set-alignment (remove-if fictitious? (structure-type-slots u))) ;; This should never happen. #f)) ((headed-vector-type? u) (when (degenerate-vector-type? u) (fuck-up)) (set-headed-vector-type-alignment&?! u #t) ;; note: See the note in TYPE-ALIGNMENT. (max *length-alignment* (type-set-alignment (headed-vector-type-element u)))) (else (fuck-up)))) (define (pointer-member? u) (and (not (char-type? u)) (not (fictitious? u)) (not (fixnum-type? u)) ;; needs work: Can be extended to allow squishing a singleton ;; immediate structure if its slot is squished. (not (degenerate-vector-type? u)))) (define (non-pointer-member? u) (not (pointer-member? u))) (define (no-pointer-members? w) (must-be? non-pointer-member? w)) (define (squish-alignment w) (if (no-pointer-members? w) ;; Type sets that do not have pointer members have no limit on the number ;; of members that are not fictitious because we tolerate an arbitrary ;; loss in range for non-pointer values. Remember that CHAR is fictitious. ;; In this case, allocate just enough squish tag bits to encode all of ;; the members that are not fictitious. But if there are a power-of-two ;; such members, allocate an extra squish tag bit because we can't assign ;; squish tag zero to a fixnum or a degenerate vector. (max (if (can-be-non? (lambda (u) (or (char-type? u) (fictitious? u))) w) (inexact->exact (ceiling (+ (/ (log (count-if (lambda (u) (or (fixnum-type? u) ;; needs work: Can be extended to allow ;; squishing a singleton ;; immediate structure if its ;; slot is squished. (degenerate-vector-type? u))) (members w))) (log 2.0)) 0.1))) 0) (type-set-minimal-alignment w)) ;; Type sets that do have pointer members have a limit on the number of ;; squish tag bits because pointers aren't shifted. The number of squish ;; tag bits is limited to the smallest number over all of the pointer ;; members. The reason is that there are ways that pointers can be ;; created where we have no control over the alignment. For example, ;; string, pair, and vector constants, alloca, malloc, GC_malloc, fopen, ;; stdin, and stdout. In fact, the only place where we do have control ;; over alignment is in the region allocator. (reduce min (map type-alignment& (members-that pointer-member? w)) ;; This can't happen if the type set is squished. #f))) (define (determine-which-type-sets-are-squishable!) ;; needs work: This really depends on the architecture parameters. ;; note: Squishing reduces the maximum magnitude of fixnums and the maximum ;; length of degenerate vectors. (for-each (lambda (w) (set-type-set-squishable?! w #t)) *ws*) (let loop () (let ((again? #f)) (for-each (lambda (w) (unless (and ;; A flonum can't be squished because it would result in a loss ;; of precision and a double might not fit in a pointer. ;; needs work: Floats can be squished on 64-bit architectures. (not (can-be? flonum-type? w)) ;; A rectangular can't be squished because it won't fit in a ;; pointer. (not (can-be? rectangular-type? w)) (case *closure-representation* ((immediate-flat immediate-display) ;; A native procedure with a closure can't be squished because ;; it might not fit in a pointer. ;; needs work: Can be extended to allow squishing a native ;; procedure with a closure that has a single ;; slot or environment. (not (can-be? (lambda (u) (and (native-procedure-type? u) (not (fictitious? u)))) w))) ((indirect-flat indirect-display linked) #t) (else (fuck-up))) ;; An immediate structure can't be squished because it might not ;; fit in a pointer and because some of its components might not ;; be squished. ;; needs work: Can be extended to allow squishing a singleton ;; immediate structure if its slot is squished. (not (can-be? (lambda (u) (and (structure-type? u) (structure-type-immediate? u))) w)) ;; A nondegenerate nonheaded vector can't be squished because it ;; might not fit in a pointer. (not (can-be? (lambda (u) (and (nonheaded-vector-type? u) (not (degenerate-vector-type? u)))) w)) ;; A nondegenerate displaced vector can't be squished because it ;; might not fit in a pointer. (not (can-be? (lambda (u) (and (displaced-vector-type? u) (not (degenerate-vector-type? u)))) w)) ;; There must be enough squish tag bits. (<= (count-if-not (lambda (u) (or (char-type? u) (fictitious? u))) (members w)) (expt 2 (squish-alignment w)))) (when (type-set-squishable? w) (set-type-set-squishable?! w #f) (set! again? #t)))) *ws*) (when again? (loop))))) (define (print-reasons-why-type-sets-are-not-squishable!) ;; needs work: This really depends on the architecture parameters. (for-each (lambda (w) (unless (squishable? w) (notify "W~a is general case for the following reasons:" (type-set-index w)) (when (can-be? flonum-type? w) (notify " flonum")) (when (can-be? rectangular-type? w) (notify " rectangular")) (when (and (or (eq? *closure-representation* 'immediate-flat) (eq? *closure-representation* 'immediate-display)) (can-be? (lambda (u) (and (native-procedure-type? u) (not (fictitious? u)))) w)) (notify " immediate native procedure")) (when (can-be? (lambda (u) (and (structure-type? u) (structure-type-immediate? u))) w) (notify " immediate structure")) (when (can-be? (lambda (u) (and (nonheaded-vector-type? u) (not (degenerate-vector-type? u)))) w) (notify " nondegenerate nonheaded vector")) (when (can-be? (lambda (u) (and (displaced-vector-type? u) (not (degenerate-vector-type? u)))) w) (notify " nondegenerate displaced vector")) (when (and (not (can-be? flonum-type? w)) (not (can-be? rectangular-type? w)) (not (and (or (eq? *closure-representation* 'immediate-flat) (eq? *closure-representation* 'immediate-display)) (can-be? (lambda (u) (and (native-procedure-type? u) (not (fictitious? u)))) w))) (not (can-be? (lambda (u) (and (structure-type? u) (structure-type-immediate? u))) w)) (not (can-be? (lambda (u) (and (nonheaded-vector-type? u) (not (degenerate-vector-type? u)))) w)) (not (can-be? (lambda (u) (and (displaced-vector-type? u) (not (degenerate-vector-type? u)))) w)) (> (count-if-not (lambda (u) (or (char-type? u) (fictitious? u))) (members w)) (expt 2 (squish-alignment w)))) (notify " insufficient squish tag bits (~s needed ~s available)" (inexact->exact (ceiling (/ (log (count-if-not (lambda (u) (or (char-type? u) (fictitious? u))) (members w))) (log 2)))) (squish-alignment w))))) *ws*)) (define (squishable? w) (for-each-member (lambda (u) (cond ((null-type? u) (set! *tag-size?* #t)) ((true-type? u) (set! *tag-size?* #t)) ((false-type? u) (set! *tag-size?* #t)) ((char-type? u) (set! *char-size?* #t)) ((fixnum-type? u) (set! *fixnum-size?* #t)) ((flonum-type? u) #f) ((rectangular-type? u) #f) ((input-port-type? u) (include! "stdio") ;FILE (set! *file*-size?* #t)) ((output-port-type? u) (include! "stdio") ;FILE (set! *file*-size?* #t)) ((eof-object-type? u) (set! *tag-size?* #t)) ((pointer-type? u) (set! *void*-size?* #t)) ((internal-symbol-type? u) (set! *tag-size?* #t)) ((external-symbol-type? u) (set! *char*-size?* #t)) ((primitive-procedure-type? u) (set! *tag-size?* #t)) ((native-procedure-type? u) (if (fictitious? u) (set! *tag-size?* #t) (set-native-procedure-type-size?! u #t))) ((foreign-procedure-type? u) (set! *tag-size?* #t)) ((continuation-type? u) (cond ((fictitious? u) (set! *tag-size?* #t)) (else (include! "setjmp") ;jmp_buf (set! *jmpbuf*-size?* #t)))) ((string-type? u) (set! *char*-size?* #t)) ((structure-type? u) (cond ((fictitious? u) (set! *tag-size?* #t)) (else (unless (structure-type-immediate? u) (set-structure-type-size?! u #t))))) ((headed-vector-type? u) (if (degenerate-vector-type? u) (set! *length-size?* #t) (set-headed-vector-type-size?! u #t))) ((nonheaded-vector-type? u) (when (degenerate-vector-type? u) (set! *length-size?* #t))) ((displaced-vector-type? u) (when (degenerate-vector-type? u) (set! *length-size?* #t))) (else (fuck-up)))) w) (set! *squished-size?* #t) (type-set-squishable? w)) (define (squished? w) (and (not (zero? *squished-size*)) (not (fictitious? w)) (not (monomorphic? w)) (not (tag-only? w)) (not (squeezed? w)) (squishable? w))) (define (general? w) (and (not (fictitious? w)) (not (monomorphic? w)) (not (tag-only? w)) (not (squeezed? w)) (not (squished? w)))) (define (determine-alignments!) (set! *worst-alignment* ;; note: See the note in TYPE-ALIGNMENT. (reduce max (map squish-alignment (remove-if-not squished? *ws*)) 0)) (set! *allocation-alignment* ;; note: See the note in TYPE-ALIGNMENT. (max ;; note: See the note in TYPE-ALIGNMENT. ;; At this point we no longer know which strings are non-reclaimable. (reduce max (map type-alignment& *string-types*) 0) (reduce ;; note: See the note in TYPE-ALIGNMENT. max (map type-alignment& (remove-if fictitious? (remove-if structure-type-immediate? *structure-types*))) 0) (reduce ;; note: See the note in TYPE-ALIGNMENT. max (map type-alignment& (remove-if degenerate-vector-type? *headed-vector-types*)) 0)))) (define (type-alignment u) (cond ((fixnum-type? u) (set! *fixnum-alignment?* #t) *fixnum-alignment*) ((flonum-type? u) (set! *flonum-alignment?* #t) *flonum-alignment*) ((rectangular-type? u) (set! *rectangular-alignment?* #t) ;; needs work: See the needs work below. ;; note: See the note below. *flonum-alignment*) ((input-port-type? u) (set! *file*-alignment?* #t) *pointer-alignment*) ((output-port-type? u) (set! *file*-alignment?* #t) *pointer-alignment*) ((pointer-type? u) (set! *void*-alignment?* #t) *pointer-alignment*) ((external-symbol-type? u) (set! *char*-alignment?* #t) *pointer-alignment*) ((native-procedure-type? u) (when (fictitious? u) (fuck-up)) (set-native-procedure-type-alignment?! u #t) ;; needs work: See the needs work below. ;; note: See the note below. *pointer-alignment*) ((continuation-type? u) (when (fictitious? u) (fuck-up)) (set! *jmpbuf*-alignment?* #t) *pointer-alignment*) ((string-type? u) (set! *char*-alignment?* #t) *pointer-alignment*) ((structure-type? u) (when (fictitious? u) (fuck-up)) (set-structure-type-alignment?! u #t) (if (structure-type-immediate? u) ;; needs work: I'm not sure but it may be the case that ;; struct {tau s0;} has different alignment and size ;; than tau. It also may be the case that something like ;; struct {char s0; char s1;} has different alignment ;; than char and different size than twice char. ;; note: (= (LG (LCM (EXPT 2 X) (EXPT 2 Y))) (MAX X Y)) (reduce max (map type-set-alignment (remove-if fictitious? (structure-type-slots u))) ;; This can't happen if the structure type is not fictitious. #f) *pointer-alignment*)) ((headed-vector-type? u) (cond ((degenerate-vector-type? u) (set! *length-alignment?* #t) *length-alignment*) (else (set-headed-vector-type-alignment?! u #t) *pointer-alignment*))) ((nonheaded-vector-type? u) (cond ((degenerate-vector-type? u) (set! *length-alignment?* #t) *length-alignment*) (else (set-nonheaded-vector-type-alignment?! u #t) ;; note: See the note above. (max *length-alignment* *pointer-alignment*)))) ((displaced-vector-type? u) (cond ((degenerate-vector-type? u) (set! *length-alignment?* #t) *length-alignment*) (else (set-displaced-vector-type-alignment?! u #t) ;; note: See the note above. (max *length-alignment* *pointer-alignment*)))) (else (case *closure-conversion-method* ((baseline conventional) (set! *fixnum-alignment?* #t) *fixnum-alignment*) ((lightweight) (fuck-up)) (else (fuck-up)))))) (define (type-set-alignment w) (cond ((fictitious? w) (fuck-up)) ((monomorphic? w) (cond ((char-type? (the-member w)) (set! *char-alignment?* #t) *char-alignment*) (else (type-alignment (the-member w))))) ((tag-only? w) (set! *tag-alignment?* #t) *tag-alignment*) ((squeezed? w) (type-alignment (squeezed-member w))) ((squished? w) (set! *squished-alignment?* #t) *squished-alignment*) (else (set-type-set-alignment?! w #t) (set! *tag-alignment?* #t) ;; needs work: See the needs work in TYPE-ALIGNMENT. ;; note: See the note in TYPE-ALIGNMENT. (max *tag-alignment* (reduce max (map type-alignment (members-that (lambda (u) (and (not (char-type? u)) (not (fictitious? u)))) w)) ;; This can't happen if the type set isn't fictitious, ;; monomorphic, or tag only. #f))))) (define (align s a) ;; conventions: S A ;; This adds the appropriate padding to S so that it can be followed by an ;; object with alignment A. (* (+ (quotient s (expt 2 a)) (if (zero? (remainder s (expt 2 a))) 0 1)) (expt 2 a))) (define (type-size u) (cond ((fixnum-type? u) (set! *fixnum-size?* #t) *fixnum-size*) ((flonum-type? u) (set! *flonum-size?* #t) *flonum-size*) ((rectangular-type? u) (set! *rectangular-size?* #t) ;; needs work: See the needs work in TYPE-ALIGNMENT. (align (+ (align *flonum-size* *flonum-alignment*) *flonum-size*) (type-alignment u))) ((input-port-type? u) (set! *file*-size?* #t) *pointer-size*) ((output-port-type? u) (set! *file*-size?* #t) *pointer-size*) ((pointer-type? u) (set! *void*-size?* #t) *pointer-size*) ((external-symbol-type? u) (set! *char*-size?* #t) *pointer-size*) ((native-procedure-type? u) (when (fictitious? u) (fuck-up)) (case *closure-representation* ((immediate-flat) (unimplemented #f "Immediate flat closures are not (yet) implemented")) ((immediate-display) (set-native-procedure-type-size?! u #t) (let loop ((s 0) (n (length (ancestors u)))) ;; conventions: S N (if (zero? n) (align s (type-alignment u)) (loop (+ (align s *pointer-alignment*) *pointer-size*) (- n 1))))) ((indirect-flat indirect-display linked) (set-native-procedure-type-size?! u #t) *pointer-size*) (else (fuck-up)))) ((continuation-type? u) (when (fictitious? u) (fuck-up)) (set! *jmpbuf*-size?* #t) *pointer-size*) ((string-type? u) (set! *char*-size?* #t) *pointer-size*) ((structure-type? u) (set-structure-type-size?! u #t) (if (structure-type-immediate? u) (let loop ((s 0) (ws (structure-type-slots u))) ;; conventions: S (if (null? ws) (align s (type-alignment u)) (loop (if (fictitious? (first ws)) s (+ (align s (type-set-alignment (first ws))) (type-set-size (first ws)))) (rest ws)))) *pointer-size*)) ((headed-vector-type? u) (cond ((degenerate-vector-type? u) (set! *length-size?* #t) *length-size*) (else (set-headed-vector-type-size?! u #t) *pointer-size*))) ((nonheaded-vector-type? u) (cond ((degenerate-vector-type? u) (set! *length-size?* #t) *length-size*) (else (set-nonheaded-vector-type-size?! u #t) (align (+ (align *length-size* *pointer-alignment*) *pointer-size*) (type-alignment u))))) ((displaced-vector-type? u) (cond ((degenerate-vector-type? u) (set! *length-size?* #t) *length-size*) (else (set-displaced-vector-type-size?! u #t) (align (+ (align *length-size* *pointer-alignment*) *pointer-size*) (type-alignment u))))) (else (fuck-up)))) (define (type-set-size w) (cond ((fictitious? w) (fuck-up)) ((monomorphic? w) (cond ((char-type? (the-member w)) (set! *char-size?* #t) *char-size*) (else (type-size (the-member w))))) ((tag-only? w) (set! *tag-size?* #t) *tag-size*) ((squeezed? w) (type-size (squeezed-member w))) ((squished? w) (set! *squished-size?* #t) *squished-size*) (else (set! *tag-size?* #t) (set-type-set-size?! w #t) (align (+ (align *tag-size* ;; needs work: I'm not sure but it may be the case that ;; union {tau s0;} has different alignment and size ;; than tau. It also may be the case that something ;; like union {char s0; short s1;} has different ;; alignment than char or short and different size ;; than char max short. ;; note: See the note in TYPE-ALIGNMENT. (reduce max (map type-alignment (members-that (lambda (u) (and (not (char-type? u)) (not (fictitious? u)))) w)) ;; This can't happen if the type set isn't fictitious, ;; monomorphic, or tag only. #f)) (reduce max (map type-size (members-that (lambda (u) (and (not (char-type? u)) (not (fictitious? u)))) w)) ;; This can't happen if the type set isn't fictitious, ;; monomorphic, or tag only. #f)) (type-set-alignment w))))) (define (determine-which-types-are-atomic!) ;; A type is atomic if it cannot contain pointers that point directly or ;; indirectly to heap-allocated data. A heap-allocated type can be atomic. ;; needs work: There is a potential optimization here. One can treat pointers ;; to stack-allocated objects as atomic because the stack is scavanged. And ;; one can treat pointers to objects allocated on nonatomic regions as atomic ;; because regions allocated with GC_malloc_uncollectable are also scavanged. (for-each (lambda (u) (set-native-procedure-type-atomic?! u #t)) *native-procedure-types*) (for-each (lambda (u) (set-structure-type-atomic?! u #t)) *structure-types*) (for-each (lambda (u) (set-headed-vector-type-atomic?! u #t)) *headed-vector-types*) (for-each (lambda (u) (set-nonheaded-vector-type-atomic?! u #t)) *nonheaded-vector-types*) (let loop () (let ((again? #f)) (for-each (lambda (u) (when (type-atomic? u) (unless (or (fictitious? u) (every (lambda (y-e) (let ((e (cdr y-e))) (case *closure-representation* ((immediate-flat) (unimplemented #f "Immediate flat closures are not (yet) implemented")) ((indirect-flat) (unimplemented #f "Indirect flat closures are not (yet) implemented")) ((immediate-display) (every (lambda (e) (and (not (heap-allocation? (allocation e))) (environment-atomic? e))) (ancestors e))) ((indirect-display) (unimplemented #f "Indirect display closures are not (yet) implemented")) ((linked) (or (not (has-parent-parameter? e)) (and (not (heap-allocation? (allocation (parent-parameter e)))) (environment-atomic? (parent-parameter e))))) (else (fuck-up))))) (native-procedure-type-call-site-environment-alist u))) (set-native-procedure-type-atomic?! u #f) (set! again? #t)))) *native-procedure-types*) (for-each (lambda (u) (when (type-atomic? u) (unless (if (structure-type-immediate? u) (every (lambda (w) (must-be? type-atomic? w)) (structure-type-slots u)) (every (lambda (w) (must-be? (lambda (u) (and (never-allocated-on-the-heap? u) (type-atomic? u))) w)) (structure-type-slots u))) (set-structure-type-atomic?! u #f) (set! again? #t)))) *structure-types*) (for-each (lambda (u) (when (type-atomic? u) (unless (or (degenerate-vector-type? u) (must-be? (lambda (u) (and (never-allocated-on-the-heap? u) (type-atomic? u))) (headed-vector-type-element u))) (set-headed-vector-type-atomic?! u #f) (set! again? #t)))) *headed-vector-types*) (for-each (lambda (u) (when (type-atomic? u) (unless (or (degenerate-vector-type? u) (must-be? (lambda (u) (and (never-allocated-on-the-heap? u) (type-atomic? u))) (nonheaded-vector-type-element u))) (set-nonheaded-vector-type-atomic?! u #f) (set! again? #t)))) *nonheaded-vector-types*) (when again? (loop))))) (define (environment-atomic? e) (case *closure-representation* ((immediate-flat) (unimplemented #f "Immediate flat closures are not (yet) implemented")) ((indirect-flat) (unimplemented #f "Indirect flat closures are not (yet) implemented")) ((immediate-display indirect-display) ;; With display closures, closures don't have parent slots. The closure is ;; atomic if none of its slots point to heap-allocated data. (every (lambda (g) (or (not (slotted? g)) (must-be? (lambda (u) (and (never-allocated-on-the-heap? u) (type-atomic? u))) (variable-type-set g)))) (variables e))) ((linked) ;; With linked closures, closures do have parent slots. The closure is ;; atomic if none of its slots, including its parent slot, if it has one, ;; point to heap-allocated data. (let loop ((e e)) (and (every (lambda (g) (or (not (slotted? g)) (must-be? (lambda (u) (and (never-allocated-on-the-heap? u) (type-atomic? u))) (variable-type-set g)))) (variables e)) (or (not (has-parent-slot? e)) (and (not (heap-allocation? (allocation (parent-slot e)))) (loop (parent-slot e))))))) (else (fuck-up)))) (define (type-atomic? u) (cond ((null-type? u) #t) ((true-type? u) #t) ((false-type? u) #t) ((char-type? u) #t) ((fixnum-type? u) #t) ((flonum-type? u) #t) ((rectangular-type? u) #t) ((input-port-type? u) #t) ((output-port-type? u) #t) ((eof-object-type? u) #t) ((pointer-type? u) #t) ((internal-symbol-type? u) #t) ((external-symbol-type? u) (type-atomic? (external-symbol-type-displaced-string-type u))) ((primitive-procedure-type? u) #t) ((native-procedure-type? u) (native-procedure-type-atomic? u)) ((foreign-procedure-type? u) #t) ((continuation-type? u) #t) ((string-type? u) #t) ((structure-type? u) (structure-type-atomic? u)) ((headed-vector-type? u) (headed-vector-type-atomic? u)) ((nonheaded-vector-type? u) (nonheaded-vector-type-atomic? u)) ((displaced-vector-type? u) (type-atomic? (displaced-vector-type-displaced-vector-type u))) (else (fuck-up)))) ;;; Stalin-specific C constructors (define (c:a g) (if (or (assigned? g) (has-self-tail-call? (variable-environment g))) (c:protect (list "a" (number->string (variable-index g)))) (list "a" (number->string (variable-index g))))) (define (c:b g) (list "b" (number->string (variable-index g)))) (define (c:c) (set! *c:c?* #t) "c") (define (c:d e) (list "d" (number->string (environment-index e)))) (define (c:e e) (list "e" (number->string (environment-index e)))) (define (c:f e) (list "f" (number->string (environment-index e)))) (define (c:h e) (list "h" (number->string (environment-index e)))) (define (c:i c) (c:. c "i")) (define (c:j x) (list "j" (number->string (expression-index x)))) (define (c:l i) (list "l" (number->string i))) (define (c:p u/e) ;; note: This must use the narrow notion of clone because different wide ;; clones can have different parent parameters. (cond ((native-procedure-type? u/e) (c:p (narrow-prototype u/e))) ((environment? u/e) (list "p" (number->string (environment-index u/e)))) (else (fuck-up)))) (define (c:q i) (list "q" (number->string i))) (define (c:r c/e) (if (environment? c/e) (list "r" (number->string (environment-index c/e))) (c:. c/e "r"))) (define (c:s i) (list "s" (number->string i))) (define (c:t i) (list "t" (number->string i))) (define (c:u u) (cond ((null-type? u) (fuck-up)) ((true-type? u) (fuck-up)) ((false-type? u) (fuck-up)) ((char-type? u) (fuck-up)) ((fixnum-type? u) "fixnum_type") ((flonum-type? u) "flonum_type") ((rectangular-type? u) "rectangular_type") ((input-port-type? u) "input_port_type") ((output-port-type? u) "output_port_type") ((eof-object-type? u) (fuck-up)) ((pointer-type? u) "pointer_type") ((internal-symbol-type? u) (fuck-up)) ;; note: There should be only one external symbol type since there ;; should be only one string type after ;; APPLY-CLOSED-WORLD-ASSUMPTION!. ((external-symbol-type? u) "external_symbol_type") ((primitive-procedure-type? u) (fuck-up)) ((native-procedure-type? u) (list "native_procedure_type" (number->string (type-index u)))) ((foreign-procedure-type? u) (fuck-up)) ((continuation-type? u) (unless (continuation-type-allocating-expression u) (fuck-up)) (list "continuation_type" (number->string (expression-index (continuation-type-allocating-expression u))))) ;; note: There should be only one string type after ;; APPLY-CLOSED-WORLD-ASSUMPTION!. ((string-type? u) "string_type") ((structure-type? u) (list "structure_type" (number->string (structure-type-index u)))) ((headed-vector-type? u) (list "headed_vector_type" (number->string (headed-vector-type-index u)))) ((nonheaded-vector-type? u) (list "nonheaded_vector_type" (number->string (nonheaded-vector-type-index u)))) ((displaced-vector-type? u) (list "displaced_vector_type" (number->string (displaced-vector-type-index u)))) (else (fuck-up)))) (define (c:v x) (c:protect (list "v" (number->string (expression-index x))))) (define (c:w w) (list "w" (number->string (type-set-index w)))) (define (c:x x) (list "x" (number->string (expression-index x)))) (define (c:mutex x) (list "mutex" (number->string (expression-index x)))) (define (c:error c) (list c "_error")) (define (c:fp e) (c:protect (list "fp" (number->string (environment-index e))))) (define (c:sfp e) (list "sfp" (number->string (environment-index e)))) (define (c:data) "data") (define (c:region . es) (when (> (length es) 1) (fuck-up)) (if (null? es) "region" (list "region" (number->string (environment-index (first es)))))) (define (c:region-size . es) (when (> (length es) 1) (fuck-up)) (if (null? es) "region_size" (list "region_size" (number->string (environment-index (first es)))))) (define (c:initial-region e) (list "initial_region" (number->string (environment-index e)))) (define (c:big-region-size e) (list "REGION_SIZE" (number->string (environment-index e)))) (define (c:stdin) (include! "stdio") ;stdin "stdin") (define (c:stdout) (include! "stdio") ;stdout "stdout") (define (c:clocks-per-second) (include! "time") ;CLOCKS_PER_SEC "CLOCKS_PER_SEC") (define (c:rand-max) (include! "stdlib") ;RAND_MAX "RAND_MAX") (define (c:pointer-size) (c:sizeof (space-between "void" "*"))) (define (c:imax c1 c2) (c:call "IMAX" c1 c2)) (define (c:rmax c1 c2) (c:call "RMAX" c1 c2)) (define (c:imin c1 c2) (c:call "IMIN" c1 c2)) (define (c:rmin c1 c2) (c:call "RMIN" c1 c2)) (define (c:pluscc c1 c2) (c:call "PLUSCC" c1 c2)) (define (c:pluscr c1 c2) (c:call "PLUSCR" c1 c2)) (define (c:plusrc c1 c2) (c:call "PLUSRC" c1 c2)) (define (c:negc c) (c:call "NEGC" c)) (define (c:minuscc c1 c2) (c:call "MINUSCC" c1 c2)) (define (c:minuscr c1 c2) (c:call "MINUSCR" c1 c2)) (define (c:minusrc c1 c2) (c:call "MINUSRC" c1 c2)) (define (c:timescc c1 c2) (c:call "TIMESCC" c1 c2)) (define (c:timescr c1 c2) (c:call "TIMESCR" c1 c2)) (define (c:timesrc c1 c2) (c:call "TIMESRC" c1 c2)) (define (c:recipc c) (c:call "RECIPC" c)) (define (c:dividecc c1 c2) (c:call "DIVIDECC" c1 c2)) (define (c:dividecr c1 c2) (c:call "DIVIDECR" c1 c2)) (define (c:dividerc c1 c2) (c:call "DIVIDERC" c1 c2)) (define (c:ipow c1 c2) (set! *c:ipow?* #t) (c:call "ipow" c1 c2)) (define (c:input-waiting c) (set! *c:input-waiting?* #t) (c:protect (c:call "input_waiting" c))) (define (c:panic c) (set! *c:panic?* #t) (c:gosub "stalin_panic" c)) (define (c:backtrace c1 c2 c3) (set! *c:backtrace?* #t) (c:gosub "backtrace" c1 c2 c3)) (define (c:backtrace-internal c) (set! *c:backtrace-internal?* #t) (c:gosub "backtrace_internal" c)) (define (c:align c) (if (positive? *allocation-alignment*) (c:gosub "ALIGN" c) (c:noop))) (define (c:value-offset) "VALUE_OFFSET") (define (c:char-offset) "CHAR_OFFSET") (define (c:type u c) (cond ((char-type? u) (space-between *char* c)) ((fixnum-type? u) (space-between *fixnum* c)) ((flonum-type? u) (space-between *flonum* c)) ((rectangular-type? u) (space-between "struct" "rectangular" c)) ((input-port-type? u) (include! "stdio") ;FILE (space-between *file* (star-before c))) ((output-port-type? u) (include! "stdio") ;FILE (space-between *file* (star-before c))) ((pointer-type? u) (space-between "void" (star-before c))) ((external-symbol-type? u) (space-between *char* (star-before c))) ((native-procedure-type? u) (case *closure-representation* ((immediate-flat immediate-display) (space-between "struct" (c:p u) c)) ((indirect-flat indirect-display) (space-between "struct" (c:p u) (star-before c))) ((linked) (if (and (or (eq? *closure-conversion-method* 'baseline) (eq? *closure-conversion-method* 'conventional)) (or (not (environment? (native-procedure-type-narrow-prototype u))) (not (environment-used? (narrow-prototype u))) (not (environment? (parent-parameter u))) (not (environment-used? (parent-parameter u))))) (space-between (c:/**/ "fake") *fixnum* c) (space-between "struct" (c:p (parent-parameter u)) (star-before c)))) (else (fuck-up)))) ((continuation-type? u) (include! "setjmp") ;jmp_buf (space-between *jmpbuf* (star-before c))) ((string-type? u) (space-between *char* (star-before c))) ((structure-type? u) (if (structure-type-immediate? u) (space-between "struct" (c:u u) c) (space-between "struct" (c:u u) (star-before c)))) ((headed-vector-type? u) (if (degenerate-vector-type? u) (space-between *length* c) (space-between "struct" (c:u u) (star-before c)))) ((nonheaded-vector-type? u) (if (degenerate-vector-type? u) (space-between *length* c) (space-between "struct" (c:u u) c))) ((displaced-vector-type? u) (if (degenerate-vector-type? u) (space-between *length* c) (space-between "struct" (c:u u) c))) (else (case *closure-conversion-method* ((baseline conventional) (space-between (c:/**/ "fake") *fixnum* c)) ((lightweight) (fuck-up)) (else (fuck-up)))))) (define (c:type& u c) (unless (and (structure-type? u) (not (structure-type-immediate? u)) (not (every fictitious? (structure-type-slots u)))) (fuck-up)) (space-between "struct" (c:u u) c)) (define (c:type-set w c) (cond ((fictitious? w) (fuck-up)) ((monomorphic? w) (c:type (the-member w) c)) ((tag-only? w) (space-between *tag* c)) ((squeezed? w) (c:type (squeezed-member w) c)) ((squished? w) (space-between *squished* c)) (else (space-between "struct" (c:w w) c)))) (define (c:type-cast c u) (c:cast (c:type u "") c)) (define (c:type-set-cast c w) (c:cast (c:type-set w "") c)) (define (c:squished-cast c) (set! *squished-size?* #t) (c:cast *squished* c)) (define (c:signed-squished-cast c) (set! *squished-size?* #t) (c:cast *signed-squished* c)) (define (c:tag-cast c) (c:cast *tag* c)) (define (c:tag->squeezed-cast c w1 w2) (set! *tag-size?* #t) (if (= (type-set-size w2) *tag-size*) (c:type-set-cast (c:tag c w1) w2) ;; The squished cast is needed because *POINTER-SIZE* is not the same as ;; *TAG-SIZE*. (c:type-set-cast (c:squished-cast (c:tag c w1)) w2))) (define (c:squeezed->tag-cast c w) (set! *tag-size?* #t) (if (= (type-set-size w) *tag-size*) (c:tag-cast c) ;; The squished cast is needed because *POINTER-SIZE* is not the same as ;; *TAG-SIZE*. (c:tag-cast (c:squished-cast c)))) (define (c:forgery-cast c w) (c:* (c:cast (c:type-set w "*") (c:& c)))) (define (c:type-tag u) (cond ((null-type? u) (set! *null-type-use-count* (+ *null-type-use-count* 1)) "NULL_TYPE") ((true-type? u) (set! *true-type-use-count* (+ *true-type-use-count* 1)) "TRUE_TYPE") ((false-type? u) (set! *false-type-use-count* (+ *false-type-use-count* 1)) "FALSE_TYPE") ((char-type? u) (fuck-up)) ((fixnum-type? u) (set! *fixnum-type-use-count* (+ *fixnum-type-use-count* 1)) "FIXNUM_TYPE") ((flonum-type? u) (set! *flonum-type-use-count* (+ *flonum-type-use-count* 1)) "FLONUM_TYPE") ((rectangular-type? u) (set! *rectangular-type-use-count* (+ *rectangular-type-use-count* 1)) "RECTANGULAR_TYPE") ((input-port-type? u) (set! *input-port-type-use-count* (+ *input-port-type-use-count* 1)) "INPUT_PORT_TYPE") ((output-port-type? u) (set! *output-port-type-use-count* (+ *output-port-type-use-count* 1)) "OUTPUT_PORT_TYPE") ((eof-object-type? u) (set! *eof-object-type-use-count* (+ *eof-object-type-use-count* 1)) "EOF_OBJECT_TYPE") ((pointer-type? u) (set! *pointer-type-use-count* (+ *pointer-type-use-count* 1)) "POINTER_TYPE") ((internal-symbol-type? u) (set-internal-symbol-type-use-count! u (+ (internal-symbol-type-use-count u) 1)) ;; note: We can't use the symbol name without mangling it. (list "INTERNAL_SYMBOL_TYPE" (number->string (internal-symbol-type-index u)))) ((external-symbol-type? u) (set-external-symbol-type-use-count! u (+ (external-symbol-type-use-count u) 1)) ;; note: There should be only one external symbol type since there ;; should be only one string type after ;; APPLY-CLOSED-WORLD-ASSUMPTION!. "EXTERNAL_SYMBOL_TYPE") ((primitive-procedure-type? u) (set-primitive-procedure-type-use-count! u (+ (primitive-procedure-type-use-count u) 1)) ;; note: We can't use the primitive procedure name (and arguments) ;; without mangling it. (list "PRIMITIVE_PROCEDURE_TYPE" (number->string (primitive-procedure-type-index u)))) ((native-procedure-type? u) (set-native-procedure-type-use-count! u (+ (native-procedure-type-use-count u) 1)) (list "NATIVE_PROCEDURE_TYPE" (number->string (type-index u)))) ((foreign-procedure-type? u) (set-foreign-procedure-type-use-count! u (+ (foreign-procedure-type-use-count u) 1)) (list "FOREIGN_PROCEDURE_" (foreign-procedure-type-name u) "_TYPE")) ((continuation-type? u) (set-continuation-type-use-count! u (+ (continuation-type-use-count u) 1)) (if (continuation-type-allocating-expression u) (list "CONTINUATION_TYPE" (number->string (expression-index (continuation-type-allocating-expression u)))) "TOP_LEVEL_CONTINUATION_TYPE")) ((string-type? u) (set-string-type-use-count! u (+ (string-type-use-count u) 1)) ;; note: There should be only one string type after ;; APPLY-CLOSED-WORLD-ASSUMPTION!. "STRING_TYPE") ((structure-type? u) (set-structure-type-use-count! u (+ (structure-type-use-count u) 1)) (list "STRUCTURE_TYPE" (number->string (structure-type-index u)))) ((headed-vector-type? u) (set-headed-vector-type-use-count! u (+ (headed-vector-type-use-count u) 1)) (list "HEADED_VECTOR_TYPE" (number->string (headed-vector-type-index u)))) ((nonheaded-vector-type? u) (set-nonheaded-vector-type-use-count! u (+ (nonheaded-vector-type-use-count u) 1)) (list "NONHEADED_VECTOR_TYPE" (number->string (nonheaded-vector-type-index u)))) ((displaced-vector-type? u) (set-displaced-vector-type-use-count! u (+ (displaced-vector-type-use-count u) 1)) (list "DISPLACED_VECTOR_TYPE" (number->string (displaced-vector-type-index u)))) (else (fuck-up)))) (define (c:tag c w) (cond ((fictitious? w) (fuck-up)) ((monomorphic? w) (fuck-up)) ((tag-only? w) c) ((squeezed? w) (fuck-up)) ((squished? w) (fuck-up)) (else (c:. c "tag")))) (define (c:value c u w) (unless (and (member? u w) (or (eq? *closure-conversion-method* 'baseline) (eq? *closure-conversion-method* 'conventional) (not (fictitious? u)))) (fuck-up)) (cond ((and (or (eq? *closure-conversion-method* 'baseline) (eq? *closure-conversion-method* 'conventional)) (fictitious? u)) "fake") ((fictitious? w) (fuck-up)) ((monomorphic? w) c) ((tag-only? w) ;; note: Converting from tag-only to character used to be free but now ;; requires a right shift when there is some squishing. This is the ;; price to pay for universal type tags. (unless (char-type? u) (fuck-up)) ;; This assumes that *TAG* is unsigned so that >> does a logical shift. ;; This also assumes that casting a *TAG* to a *CHAR* does not modify the ;; bit pattern except for truncation. (c:type-cast (c:>> (c:tag c w) (c:fixnum *worst-alignment*)) u)) ((squeezed? w) ;; note: Unsqueezing characters used to be free but now requires a right ;; shift when there is some squishing. This is the price to pay for ;; universal type tags. (if (char-type? u) ;; The C:SQUISHED-CAST is needed to convert the pointer to an integer. ;; This assumes that *SQUISHED* is unsigned so that >> does a logical ;; shift. This also assumes that casting a *SQUISHED* to a *CHAR* does ;; not modify the bit pattern except for truncation. (c:type-cast (c:>> (c:squished-cast c) (c:fixnum *worst-alignment*)) u) c)) ((squished? w) (cond ;; This assumes that *SQUISHED* is unsigned so that >> does a logical ;; shift. This also assumes that casting a *SQUISHED* to a *CHAR* does ;; not modify the bit pattern except for truncation. ((char-type? u) (c:type-cast (c:>> c (c:fixnum *worst-alignment*)) u)) ((fixnum-type? u) ;; This assumes that *SQUISHED* is unsigned and *FIXNUM* is signed so ;; that C:SIGNED-SQUISHED-CAST is needed to cause >> to do an arithmetic ;; shift to preserve the sign bit. This assumes that *SIGNED-SQUISHED* is ;; signed. This also assumes that casting a *SQUISHED* to a ;; *SIGNED-SQUISHED* does not modify the bit pattern. The final cast from ;; *SIGNED-SQUISHED* to *FIXNUM* may change the size and thus may require ;; sign extension. (c:type-cast (c:>> (c:signed-squished-cast c) (c:fixnum (squish-alignment w))) u)) ((degenerate-vector-type? u) ;; This assumes that both *SQUISHED* and *LENGTH* are unsigned so that >> ;; does a logical shift. The final cast from *SQUISHED* to *LENGTH* may ;; change the size but should not modify the bit pattern. (c:type-cast (c:>> c (c:fixnum (squish-alignment w))) u)) (else (c:type-cast (strip-known-squish-tag c u w) u)))) (else ;; note: Converting from general to character used to be free but now ;; requires a right shift when there is some squishing. This is the ;; price to pay for universal type tags. (if (char-type? u) ;; This assumes that *TAG* is unsigned so that >> does a logical shift. ;; If *CHAR* is signed then this also assumes that casting an unsigned ;; expression to a signed char does not modify the bit pattern except ;; for truncation. (c:type-cast (c:>> (c:tag c w) (c:fixnum *worst-alignment*)) u) (if (has-union? w) (c:. (c:. c "value") (c:u u)) (c:. c "value")))))) (define (c:foreign-type f c) (case f ((char) (space-between "char" c)) ((signed-char) (space-between "signed" "char" c)) ((unsigned-char) (space-between "unsigned" "char" c)) ((short) (space-between "short" c)) ((unsigned-short) (space-between "unsigned" "short" c)) ((int) (space-between "int" c)) ((unsigned) (space-between "unsigned" c)) ((long) (space-between "long" c)) ((unsigned-long) (space-between "unsigned" "long" c)) ((float) (space-between "float" c)) ((double) (space-between "double" c)) ((long-double) (space-between "long" "double" c)) ((char*) (space-between "char" (star-before c))) ((file* input-port output-port) (include! "stdio") ;FILE (space-between *file* (star-before c))) ((void*) (space-between "void" (star-before c))) ((void) (space-between "void" c)) ((no-return) (space-between "void" c)) (else (fuck-up)))) ;;; End of C constructors (define (squeeze c u w) (unless (and (member? u w) (squeezed? w)) (fuck-up)) (cond ((char-type? u) ;; note: Squeezing characters used to be free but now requires a left shift ;; when there is some squishing. This is the price to pay for ;; universal type tags. ;; This assumes that *SQUISHED* is unsigned so that << does a logical ;; shift. The call to C:UNSIGNED-CHAR-CAST is in case *CHAR* is signed to ;; force << to be a logical shift without a prior sign extend. The call to ;; C:SQUISHED-CAST is to prevent any overflow in the logical shift. (c:type-set-cast (c:<< (c:squished-cast (c:unsigned-char-cast c)) (c:fixnum *worst-alignment*)) w)) ((fictitious? u) (c:type-set-cast (c:type-tag u) w)) (else c))) (define (squeeze-tag-test c u w) (unless (and (member? u w) (squeezed? w)) (fuck-up)) (cond ((char-type? u) (c:< c (c:type-set-cast (c:char-offset) w))) ((fictitious? u) (c:== c (c:type-set-cast (c:type-tag u) w))) (else (c:>= c (c:type-set-cast (c:value-offset) w))))) (define (assign-global-squish-tags!) ;; This is a special case for when the type set members are sorted. (define (unionq us1 us2) (cond ((null? us1) us2) ((null? us2) us1) ((eq? (first us1) (first us2)) (cons (first us1) (unionq (rest us1) (rest us2)))) ((< (type-index (first us1)) (type-index (first us2))) (cons (first us1) (unionq (rest us1) us2))) (else (cons (first us2) (unionq us1 (rest us2)))))) (set! *uss* (let ((uss (let ((ws (remove-if-not squished? *ws*))) (equivalence-classesp (lambda (u1 u2) (some (lambda (w) (and (member? u1 w) (member? u2 w))) ws)) (remove-if (lambda (u) (or (char-type? u) (fictitious? u))) (reduce unionq (map members ws) '())))))) (map (lambda (us) (if (every (lambda (u) (or (fixnum-type? u) ;; needs work: Can be extended to allow squishing a ;; singleton immediate structure if its ;; slot is squished. (degenerate-vector-type? u))) us) ;; In this case, there are no pointer members to get squish tag ;; zero. (cons 'foo us) ;; This guarantees that a pointer member is assigned squish tag ;; zero. (sort us (lambda (u1 u2) ;; needs work: Can be extended to allow squishing a ;; singleton immediate structure if its slot ;; is squished. (or (fixnum-type? u2) (degenerate-vector-type? u2))) identity))) uss)))) (define (squish-tag u w) (unless (and (member? u w) (squished? w)) (fuck-up)) ;; note: This is complicated by the need to guarantee that fixnums and ;; degenerate vectors aren't assigned squish tag zero since they ;; aren't sparse. ;; needs work: Actually, can assign squish tag zero to a fixnum or degenerate ;; vector when the type set has no members that are fictitious. ;; Would also need to modify SQUISH-ALIGNMENT and ;; ASSIGN-GLOBAL-SQUISH-TAGS! as well. ;; note: Since squish tag zero is more costly to test than other squish ;; tags one might try to assign it only when necessary. But on the ;; other hand squish tag zero is less costly to squish so it is not ;; clear whether this would be a useful optimization. (let ((us (find-if (lambda (us) (memq u us)) *uss*))) (cond ((char-type? u) 0) ((fictitious? u) 0) ((<= (length us) (expt 2 (squish-alignment w))) (positionq u us)) ((can-be? pointer-member? w) ;; This guarantees that a pointer member is assigned squish tag zero. (positionq u (sort (members-that (lambda (u) (and (not (char-type? u)) (not (fictitious? u)))) w) (lambda (u1 u2) ;; needs work: Can be extended to allow squishing a singleton ;; immediate structure if its slot is squished. (or (fixnum-type? u2) (degenerate-vector-type? u2))) identity))) (else ;; In this case, there are no pointer members to get squish tag zero. (+ (positionq u (members-that (lambda (u) (and (not (char-type? u)) (not (fictitious? u)))) w)) 1))))) (define (squish c u w) (unless (and (member? u w) (squished? w)) (fuck-up)) (cond ;; This assumes that *SQUISHED* is unsigned so that << does a logical shift. ;; The call to C:UNSIGNED-CHAR-CAST is in case *CHAR* is signed to force << ;; to be a logical shift without a prior sign extend. The call to ;; C:TYPE-SET-CAST is to prevent any overflow in the logical shift. ((char-type? u) (c:<< (c:type-set-cast (c:unsigned-char-cast c) w) (c:fixnum *worst-alignment*))) ((fictitious? u) (c:type-tag u)) (else (c:+ (cond ((or (fixnum-type? u) (degenerate-vector-type? u)) (when *overflow-checks?* (unimplemented #f "Safe exact arithmetic is not (yet) implemented")) (c:<< (c:type-set-cast c w) (c:fixnum (squish-alignment w)))) (else (c:type-set-cast c w))) (c:fixnum (squish-tag u w)))))) (define (strip-squish-tag c w) (c:& c (c:~ (c:fixnum (- (expt 2 (squish-alignment w)) 1))))) (define (strip-known-squish-tag c u w) (c:- c (c:fixnum (squish-tag u w)))) (define (extract-squish-tag c w) (c:& c (c:fixnum (- (expt 2 (squish-alignment w)) 1)))) (define (squish-tag-test c u w) (unless (and (member? u w) (squished? w)) (fuck-up)) (cond ((char-type? u) (c:< c (c:char-offset))) ((fictitious? u) (c:== c (c:type-tag u))) ((and (zero? (squish-tag u w)) (can-be? (lambda (u) (or (char-type? u) (fictitious? u))) w)) ;; note: Squish tag zero is more costly to test than other squish tags ;; because of squeezing. (c:&& (c:>= c (c:value-offset)) (c:==0 (extract-squish-tag c w)))) (else (c:== (extract-squish-tag c w) (c:fixnum (squish-tag u w)))))) (define (compile-squeezed-type-if us w c1 c2 c3) (let ((cs2 (map c2 us))) (let loop ((cases (equate-cases (map (lambda (u) (squeeze-tag-test c1 u w)) us) cs2))) ;; conventions: CASES (if (null? cases) (c3 #f) (c:if (apply c:boolean-or (map first (first cases))) (second (first (first cases))) (loop (rest cases)) #f))))) (define (compile-squeezed-defaultless-type-if us w c1 c2) ;; This has the semantics that the behaviour is undefined when C1 takes on ;; a type that is not in US. (let loop ((cases (equate-cases (map (lambda (u) (squeeze-tag-test c1 u w)) us) (map c2 us)))) ;; conventions: CASES (cond ((null? cases) (c:noop)) ((null? (rest cases)) (second (first (first cases)))) (else (c:if (apply c:boolean-or (map first (first cases))) (second (first (first cases))) (loop (rest cases)) #f))))) (define (compile-squeezed-type-switch us w c1 c2 c3 p?) (define (c u) (if (memq u us) (c2 u) (c3 #f))) (if (and (not (some fictitious? us)) (can-be? fictitious? w)) (if (some char-type? us) (if (memq (squeezed-member w) us) (c:if (c:< c1 (c:type-set-cast (c:char-offset) w)) (c2 (the-member-that char-type? w)) (c:if (c:>= c1 (c:type-set-cast (c:value-offset) w)) (c2 (squeezed-member w)) (c3 #f) #f) #f) (c:if (c:< c1 (c:type-set-cast (c:char-offset) w)) (c2 (the-member-that char-type? w)) (c3 #f) #f)) (if (memq (squeezed-member w) us) (c:if (c:>= c1 (c:type-set-cast (c:value-offset) w)) (c2 (squeezed-member w)) (c3 #f) #f) (c3 #f))) (let ((us (members-that fictitious? w))) (c:switch (c:squeezed->tag-cast c1 w) (map c:type-tag us) (map c us) (if (can-be? char-type? w) (c:if (c:< c1 (c:type-set-cast (c:char-offset) w)) (c (the-member-that char-type? w)) (c (squeezed-member w)) #f) (c (squeezed-member w))) p?)))) (define (compile-squeezed-defaultless-type-switch us w c1 c2 p?) ;; This has the semantics that the behaviour is undefined when C1 takes on ;; a type that is not in US. (let ((us1 (remove-if-not fictitious? us))) (if (or (some char-type? us) (memq (squeezed-member w) us)) (c:switch (c:squeezed->tag-cast c1 w) (map c:type-tag us1) (map c2 us1) (if (some char-type? us) (if (memq (squeezed-member w) us) (c:if (c:< c1 (c:type-set-cast (c:char-offset) w)) (c2 (the-member-that char-type? w)) (c2 (squeezed-member w)) #f) (c2 (the-member-that char-type? w))) (c2 (squeezed-member w))) p?) (c:defaultless-switch (c:squeezed->tag-cast c1 w) (map c:type-tag us1) (map c2 us1) p?)))) (define (compile-squished-type-if us w c1 c2 c3) (let ((cs2 (map c2 us))) (let loop ((cases (equate-cases (map (lambda (u) (squish-tag-test c1 u w)) us) cs2))) ;; conventions: CASES (if (null? cases) (c3 #f) (c:if (apply c:boolean-or (map first (first cases))) (second (first (first cases))) (loop (rest cases)) #f))))) (define (compile-squished-defaultless-type-if us w c1 c2) ;; This has the semantics that the behaviour is undefined when C1 takes on ;; a type that is not in US. (let loop ((cases (equate-cases (map (lambda (u) (squish-tag-test c1 u w)) us) (map c2 us)))) ;; conventions: CASES (cond ((null? cases) (c:noop)) ((null? (rest cases)) (second (first (first cases)))) (else (c:if (apply c:boolean-or (map first (first cases))) (second (first (first cases))) (loop (rest cases)) #f))))) (define (compile-squished-type-switch us w c1 c2 c3 p?) ;; We dispatch on C1 of type W. If the type U of C1 is in US we generate ;; code by calling (C2 U). Otherwise we generate it with (C3 #f) because the ;; error might occur. ;; In our case W should be (union fixnum char) and US should be {char}. ;; Neither fixnum nor char are fictitious. ;; If W can be both a character and a nonfictitous noncharacter, then US2 is ;; is the set of all nonfictitous noncharacter types in W. Otherwise US2 is ;; the set of all nonfictitious types in W. I think that this means that US2 ;; is the set of all nonfictitous noncharacter types in W except when W has ;; char but no other nonfictitious types in which case it is just char. ;; In our case US2 should be {FIXNUM} and US1 should be empty. (define (c u) (if (memq u us) (c2 u) (c3 #f))) (if (and (not (some fictitious? us)) (can-be? fictitious? w)) ;; This case is taken when some fictitious types take the C3 branch. (let ((us2 (if (can-be? (lambda (u) (and (pointer-member? u) (zero? (squish-tag u w)))) w) (members-that (lambda (u) (and (not (char-type? u)) (not (fictitious? u)))) w) (members-that (lambda (u) (not (fictitious? u))) w)))) ;; This holds when W contains a fictitious type or a nonfictitious type ;; with the same squish tag. (if (can-be? (lambda (u) (or (fictitious? u) (some (lambda (u1) (and (not (fictitious? u1)) (= (squish-tag u w) (squish-tag u1 w)))) us))) w) (c:switch (extract-squish-tag c1 w) (map (lambda (u) (c:fixnum (squish-tag u w))) us2) (map (lambda (u) (if (zero? (squish-tag u w)) (if (and (can-be? char-type? w) (not (char-type? u))) (c:if (c:< c1 (c:type-set-cast (c:char-offset) w)) (c (the-member-that char-type? w)) (c:if (c:>= c1 (c:type-set-cast (c:value-offset) w)) (c u) (c3 #f) #f) #f) (c:if (c:>= c1 (c:type-set-cast (c:value-offset) w)) (c u) (c3 #f) #f)) (c u))) us2) (c3 #f) p?) (c:defaultless-switch (extract-squish-tag c1 w) (map (lambda (u) (c:fixnum (squish-tag u w))) us2) (map (lambda (u) (if (zero? (squish-tag u w)) (if (and (can-be? char-type? w) (not (char-type? u))) (c:if (c:< c1 (c:type-set-cast (c:char-offset) w)) (c (the-member-that char-type? w)) (c:if (c:>= c1 (c:type-set-cast (c:value-offset) w)) (c u) (c3 #f) #f) #f) (c:if (c:>= c1 (c:type-set-cast (c:value-offset) w)) (c u) (c3 #f) #f)) (c u))) us2) p?))) (let ((us1 (members-that fictitious? w)) ;; Exclude char if it can have a pointer member. (us2 (if (can-be? (lambda (u) (and (pointer-member? u) (zero? (squish-tag u w)))) w) (members-that (lambda (u) (and (not (char-type? u)) (not (fictitious? u)))) w) (members-that (lambda (u) (not (fictitious? u))) w)))) (c:switch c1 (map c:type-tag us1) (map c us1) ;; This test is used only to decide if there needs to be a default in ;; the switch for C3. It appears to be bogus. (if (can-be? (lambda (u) (or (fictitious? u) (some (lambda (u1) (and (not (fictitious? u1)) (= (squish-tag u w) (squish-tag u1 w)))) us))) w) (c:switch (extract-squish-tag c1 w) (map (lambda (u) (c:fixnum (squish-tag u w))) us2) (map (lambda (u) (if (and (zero? (squish-tag u w)) (can-be? char-type? w) (not (char-type? u))) (c:if (c:< c1 (c:type-set-cast (c:char-offset) w)) (c (the-member-that char-type? w)) (c u) #f) (c u))) us2) (c3 #f) p?) (c:defaultless-switch (extract-squish-tag c1 w) (map (lambda (u) (c:fixnum (squish-tag u w))) us2) (map (lambda (u) (if (and (zero? (squish-tag u w)) (can-be? char-type? w) (not (char-type? u))) (c:if (c:< c1 (c:type-set-cast (c:char-offset) w)) (c (the-member-that char-type? w)) (c u) #f) (c u))) us2) p?)) p?)))) (define (compile-squished-defaultless-type-switch us w c1 c2 p?) ;; This has the semantics that the behaviour is undefined when C1 takes on ;; a type that is not in US. (if (every fictitious? us) (c:defaultless-switch c1 (map c:type-tag us) (map c2 us) p?) (let ((us1 (remove-if-not fictitious? us)) ;; US1 are all of the fictitious members. US2 are all of the ;; nonfictitious members. US2 only contains char is US contains ;; char and does not contain some other nonfictitous nonchar. (us2 (if (some (lambda (u) (and (pointer-member? u) (zero? (squish-tag u w)))) us) (remove-if (lambda (u) (or (char-type? u) (fictitious? u))) us) (remove-if fictitious? us)))) (c:switch c1 (map c:type-tag us1) (map c2 us1) (c:defaultless-switch (extract-squish-tag c1 w) (map (lambda (u) (c:fixnum (squish-tag u w))) us2) (map (lambda (u) (if (and (zero? (squish-tag u w)) (some char-type? us) (not (char-type? u))) (c:if (c:< c1 (c:type-set-cast (c:char-offset) w)) (c2 (the-member-that char-type? w)) (c2 u) #f) (c2 u))) us2) p?) p?)))) (define (compile-type-switch us w c1 c2 c3 p?) (define (c u) (if (memq u us) (c2 u) (c3 #f))) (if (and (every char-type? us) (can-be-non? char-type? w)) (if (some char-type? us) (c:if (c:< (c:tag c1 w) (c:char-offset)) (c2 (the-member-that char-type? w)) (c3 #f) #f) (c3 #f)) (let ((us (members-that (lambda (u) (not (char-type? u))) w))) (if (can-be? char-type? w) (c:switch (c:tag c1 w) (map c:type-tag us) (map c us) (c (the-member-that char-type? w)) p?) (c:defaultless-switch (c:tag c1 w) (map c:type-tag us) (map c us) p?))))) (define (compile-defaultless-type-switch us w c1 c2 p?) ;; This has the semantics that the behaviour is undefined when C1 takes on ;; a type that is not in US. (if (some char-type? us) (let ((us (remove-if char-type? us))) (c:switch (c:tag c1 w) (map c:type-tag us) (map c2 us) (c2 (the-member-that char-type? w)) p?)) (c:defaultless-switch (c:tag c1 w) (map c:type-tag us) (map c2 us) p?))) (define (break? r) ;; needs work: Should also eliminate the break when the code generated by a ;; particular C2 doesn't return as would be the case if it were a ;; call to a nonconverted continuation. (or (accessor? r) (discard? r) (antecedent? r))) (define (type-switch m w r c1 c2 c3) ;; This dispatches on the type W of C1. All members U of W that satisfy M ;; have code generated by C2 applied to U. Members that don't have code ;; generated by C3. If *TYPE-CHECKS?* is false then code is not generated for ;; members that don't satisfy M. Thus C3 should only generate error code. ;; C3 is called with #T if the error must occur and #F if the error might ;; occur. (cond ((squeezed? w) (if (can-be? m w) (if (and *type-checks?* (can-be-non? m w)) (if *type-if?* (compile-squeezed-type-if (members-that m w) w c1 c2 c3) (compile-squeezed-type-switch (members-that m w) w c1 c2 c3 (break? r))) ;; note: -Ot will also eliminate warnings. (if *type-if?* (compile-squeezed-defaultless-type-if (members-that m w) w c1 c2) (compile-squeezed-defaultless-type-switch (members-that m w) w c1 c2 (break? r)))) (if (can-be-non? m w) (c3 #t) (fuck-up)))) ((squished? w) (if (can-be? m w) (if (and *type-checks?* (can-be-non? m w)) (if *type-if?* (compile-squished-type-if (members-that m w) w c1 c2 c3) (compile-squished-type-switch (members-that m w) w c1 c2 c3 (break? r))) ;; note: -Ot will also eliminate warnings. (if *type-if?* (compile-squished-defaultless-type-if (members-that m w) w c1 c2) (compile-squished-defaultless-type-switch (members-that m w) w c1 c2 (break? r)))) (if (can-be-non? m w) (c3 #t) (fuck-up)))) ;; needs work: There is no COMPILE-TYPE-IF and ;; COMPILE-DEFAULTLESS-TYPE-IF. (else (if (can-be? m w) (if (and *type-checks?* (can-be-non? m w)) (compile-type-switch (members-that m w) w c1 c2 c3 (break? r)) ;; note: -Ot will also eliminate warnings. (if (null? (rest (members-that m w))) (c2 (first (members-that m w))) (compile-defaultless-type-switch (members-that m w) w c1 c2 (break? r)))) (if (can-be-non? m w) (c3 #t) (fuck-up)))))) (define (nonchecking-type-switch m w r c1 c2) ;; This dispatches on the type W of C1. Some member U of W must satisfy M. ;; All members U of W that satisfy M have code generated by C2 applied to U. ;; Code is not generated for members that don't satisfy W. (unless (can-be? m w) (fuck-up)) (cond ((squeezed? w) (if *type-if?* (compile-squeezed-defaultless-type-if (members-that m w) w c1 c2) (compile-squeezed-defaultless-type-switch (members-that m w) w c1 c2 (break? r)))) ((squished? w) (if *type-if?* (compile-squished-defaultless-type-if (members-that m w) w c1 c2) (compile-squished-defaultless-type-switch (members-that m w) w c1 c2 (break? r)))) ;; needs work: There is no COMPILE-DEFAULTLESS-TYPE-IF. (else (compile-defaultless-type-switch (members-that m w) w c1 c2 (break? r))))) (define (nonerror-type-switch m w r c1 c2 c3) ;; This dispatches on the type W of C1. All members U of W that satisfy M ;; have code generated by C2 applied to U. Members that don't have code ;; generated by C3. Code is generated for the members that don't satisfy W ;; irrespective of the setting of *TYPE-CHECKS?*. C3 is called with #T if ;; no member of W satisfies M and #F otherwise. (cond ((squeezed? w) (if (can-be? m w) (if (can-be-non? m w) (if *type-if?* (compile-squeezed-type-if (members-that m w) w c1 c2 c3) (compile-squeezed-type-switch (members-that m w) w c1 c2 c3 (break? r))) (if *type-if?* (compile-squeezed-defaultless-type-if (members-that m w) w c1 c2) (compile-squeezed-defaultless-type-switch (members-that m w) w c1 c2 (break? r)))) (if (can-be-non? m w) (c3 #t) (fuck-up)))) ((squished? w) (if (can-be? m w) (if (can-be-non? m w) (if *type-if?* (compile-squished-type-if (members-that m w) w c1 c2 c3) (compile-squished-type-switch (members-that m w) w c1 c2 c3 (break? r))) (if *type-if?* (compile-squished-defaultless-type-if (members-that m w) w c1 c2) (compile-squished-defaultless-type-switch (members-that m w) w c1 c2 (break? r)))) (if (can-be-non? m w) (c3 #t) (fuck-up)))) ;; needs work: There is no COMPILE-TYPE-IF and ;; COMPILE-DEFAULTLESS-TYPE-IF. (else (if (can-be? m w) (if (can-be-non? m w) (compile-type-switch (members-that m w) w c1 c2 c3 (break? r)) (if (null? (rest (members-that m w))) (c2 (first (members-that m w))) (compile-defaultless-type-switch (members-that m w) w c1 c2 (break? r)))) (if (can-be-non? m w) (c3 #t) (fuck-up)))))) (define (return-true r) (widen r 'void1 true-type?)) (define (return-false r) (widen r 'void2 false-type?)) (define (compile-test r c) (c:if c (return-true r) (return-false r) #t)) (define (compile-time-test r p?) (if p? (return-true r) (return-false r))) (define (compile-predicate m r w c) (nonerror-type-switch m w r c (lambda (u) (return-true r)) (lambda (p?) (return-false r)))) (define (structure-ref-accessor c u i) (unless (and (integer? i) (exact? i) (>= i 0) (< i (length (structure-type-slots u)))) (fuck-up)) (cond ((fictitious? (list-ref (structure-type-slots u) i)) 'void3) ((structure-type-immediate? u) (c:. c (c:s i))) (else (c:-> c (c:s i))))) (define (car-accessor c u) (unless (pair-type? u) (fuck-up)) (structure-ref-accessor c u 0)) (define (cdr-accessor c u) (unless (pair-type? u) (fuck-up)) (structure-ref-accessor c u 1)) (define (string-length-accessor c) (c:strlen c)) (define (string-ref-accessor c1 c2) (c:subscript c1 c2)) (define (vector-length-accessor c u) ;; needs work: To use code-generation abstractions. (if (degenerate-vector-type? u) c (cond ((headed-vector-type? u) (c:-> c "length")) ((nonheaded-vector-type? u) (c:. c "length")) ((displaced-vector-type? u) (c:. c "length")) (else (fuck-up))))) (define (vector-elements-accessor c u) ;; needs work: To use code-generation abstractions. (if (degenerate-vector-type? u) 'void4 (cond ((headed-vector-type? u) (c:-> c "element")) ((nonheaded-vector-type? u) (c:. c "element")) ((displaced-vector-type? u) (c:. c "element")) (else (fuck-up))))) (define (vector-ref-accessor c1 u1 c2) ;; needs work: To use code-generation abstractions. (if (degenerate-vector-type? u1) 'void5 (cond ((headed-vector-type? u1) (c:subscript (c:-> c1 "element") c2)) ((nonheaded-vector-type? u1) (c:subscript (c:. c1 "element") c2)) ((displaced-vector-type? u1) (c:subscript (c:. c1 "element") c2)) (else (fuck-up))))) (define (value-structure-ref c u w i) (if (fictitious? u) 'void6 (structure-ref-accessor (c:value c u w) u i))) (define (value-car c u w) (if (fictitious? u) 'void7 (car-accessor (c:value c u w) u))) (define (value-cdr c u w) (if (fictitious? u) 'void8 (cdr-accessor (c:value c u w) u))) (define (value-string-length c u w) (string-length-accessor (c:value c u w))) (define (value-string-ref c1 u1 w1 c2) (string-ref-accessor (c:value c1 u1 w1) c2)) (define (value-vector-length c u w) (vector-length-accessor (c:value c u w) u)) (define (value-vector-elements c u w) (vector-elements-accessor (c:value c u w) u)) (define (value-vector-ref c1 u1 w1 c2) (vector-ref-accessor (c:value c1 u1 w1) u1 c2)) (define (accessor g e) (cond ((local? g) (c:a g)) ((global? g) (c:a g)) ((hidden? g) (case *closure-representation* ((immediate-flat indirect-flat immediate-display indirect-display) (fuck-up)) ((linked) (let ((e1 (parent-parameter (the-member (variable-type-set g))))) (if (eq? e e1) (c:e e) (let loop ((e (parent-parameter e)) (c (c:p e))) (if (eq? e e1) c (loop (parent-slot e) (c:-> c (c:p (parent-slot e))))))))) (else (fuck-up)))) ((slotted? g) (case *closure-representation* ((immediate-flat) (star-before (if (eq? (variable-environment g) e) (c:. (c:e e) (c:a g)) (c:. (c:p e) (c:a g))))) ((indirect-flat) (star-before (if (eq? (variable-environment g) e) (c:-> (c:e e) (c:a g)) (c:-> (c:p e) (c:a g))))) ((immediate-display) (if (eq? (variable-environment g) e) (c:-> (c:e e) (c:a g)) (c:-> (c:. (c:p e) (c:e (variable-environment g))) (c:a g)))) ((indirect-display) (if (eq? (variable-environment g) e) (c:-> (c:e e) (c:a g)) (c:-> (c:-> (c:p e) (c:e (variable-environment g))) (c:a g)))) ((linked) (let ((e1 (variable-environment g))) (if (eq? e e1) (c:-> (c:e e) (c:a g)) (let loop ((e (parent-parameter e)) (c (c:p e))) (if (eq? e e1) (c:-> c (c:a g)) (loop (parent-slot e) (c:-> c (c:p (parent-slot e))))))))) (else (fuck-up)))) (else (format #t "Warning! Variable ~a{~a}:W~s is fake~%" (variable-name g) (variable-index g) (type-set-index (variable-type-set g))) "fake"))) (define (number-of-accessor-indirections x) (let ((g (expression-variable x)) (e (expression-environment x))) (cond ((not (accessed? g)) 0) ((fictitious? (variable-type-set g)) 0) ((local? g) 0) ((global? g) 0) ((hidden? g) (case *closure-representation* ((immediate-flat indirect-flat immediate-display indirect-display) (fuck-up)) ((linked) (let ((e1 (parent-parameter (the-member (variable-type-set g))))) (if (eq? e e1) 0 (let loop ((e (parent-parameter e)) (c 0)) (if (eq? e e1) c (loop (parent-slot e) (+ c 1))))))) (else (fuck-up)))) ((slotted? g) (case *closure-representation* ((immediate-flat) 0) ((indirect-flat) 1) ((immediate-display) 1) ((indirect-display) 1) ((linked) (let ((e1 (variable-environment g))) (if (eq? e e1) 1 (let loop ((e (parent-parameter e)) (c 0)) (if (eq? e e1) (+ c 1) (loop (parent-slot e) (+ c 1))))))) (else (fuck-up)))) (else (fuck-up))))) (define (lambda-accessor u e) (case *closure-representation* ((immediate-flat indirect-flat immediate-display indirect-display) (fuck-up)) ((linked) (if (and (or (eq? *closure-conversion-method* 'baseline) (eq? *closure-conversion-method* 'conventional)) (or (not (environment? (native-procedure-type-narrow-prototype u))) (not (environment-used? (narrow-prototype u))) (not (environment? (parent-parameter u))) (not (environment-used? (parent-parameter u))))) "fake" (let ((e1 (parent-parameter u))) (if (eq? e e1) (c:e e) (let loop ((e (parent-parameter e)) (c (c:p e))) (if (eq? e e1) c (loop (parent-slot e) (c:-> c (c:p (parent-slot e)))))))))) (else (fuck-up)))) (define (parent-accessor e) (case *closure-representation* ((immediate-flat indirect-flat immediate-display indirect-display) (fuck-up)) ((linked) (let ((e1 (parent-slot e))) (let loop ((e (parent-parameter e)) (c (c:p e))) (if (eq? e e1) c (loop (parent-slot e) (c:-> c (c:p (parent-slot e)))))))) (else (fuck-up)))) ;;; Representation Promotion (define (promote! r w w2) (unless (or (discard? r) (antecedent? r)) (let* ((w1 (result-type-set r)) (us (intersectionq (members w) (members w2))) ;; note: This was added because of uniqueness. With uniqueness, it is ;; possible for the source to be widened and contain members ;; that the more precise analysis determines can't really occur ;; so that they may be absent from the destination. (us (if *uniqueness?* (intersectionq (members w1) us) us))) (unless (null? us) (cond ((and (general? w) (squeezed? w1)) (let ((u1 (squeezed-member w1))) (when (and (some (lambda (u) (eq? u u1)) us) (not (every (lambda (u) (eq? u u1)) us))) (when #t ;debugging (notify "Promoting W~s from squeezed to avoid" (type-set-index w1)) (notify " MOVE: branching general (W~s) to squeezed (W~s)" (type-set-index w) (type-set-index w1))) (set-type-set-squeezable?! w1 #f) (determine-alignments!) (assign-global-squish-tags!) (set! *again?* #t)))) ((and (squeezed? w) (squished? w1)) (when (and (not (every (lambda (u) (or (char-type? u) (fictitious? u))) us)) (not (zero? (squish-tag (squeezed-member w) w1))) (some (lambda (u) (or (char-type? u) (fictitious? u))) us)) (when #t ;debugging (notify "Promoting W~s from squeezed to avoid" (type-set-index w)) (notify " MOVE: branching squeezed (W~s) to squished (W~s)" (type-set-index w) (type-set-index w1))) ;; needs work: Could try to promote W1 to general. Could also try to ;; reassign squish tags of W1 so that the squeezed member of ;; W has squish tag zero. (set-type-set-squeezable?! w #f) (determine-alignments!) (assign-global-squish-tags!) (set! *again?* #t))) ((and (squished? w) (squished? w1)) (when (and (or (some (lambda (u) (and (not (char-type? u)) (not (fictitious? u)) (not (= (squish-tag u w) (squish-tag u w1))))) us) (not (= (squish-alignment w) (squish-alignment w1)))) (some (lambda (u) (or (char-type? u) (fictitious? u))) us) (or (not (= (squish-alignment w) (squish-alignment w1))) (not (every (lambda (u) (or (not (zero? (squish-tag u w))) (zero? (squish-tag u w1)))) us)))) (cond ((and (every (lambda (u) (or (char-type? u) (fictitious? u) (= (squish-tag u w) (squish-tag u w1)))) us) (every (lambda (u) (or (not (zero? (squish-tag u w))) (zero? (squish-tag u w1)))) us) (if (> (squish-alignment w) (squish-alignment w1)) (no-pointer-members? w1) (no-pointer-members? w))) (cond ((> (squish-alignment w) (squish-alignment w1)) (when #t ;debugging (notify "Increasing alignment of W~s from ~a to ~a to avoid" (type-set-index w1) (squish-alignment w1) (squish-alignment w)) (notify " MOVE: branching squished (W~s) to squished (W~s)" (type-set-index w) (type-set-index w1))) (set-type-set-minimal-alignment! w1 (squish-alignment w)) (determine-alignments!) (assign-global-squish-tags!) (set! *again?* #t)) (else (when #t ;debugging (notify "Increasing alignment of W~s from ~a to ~a to avoid" (type-set-index w) (squish-alignment w) (squish-alignment w1)) (notify " MOVE: branching squished (W~s) to squished (W~s)" (type-set-index w) (type-set-index w1))) (set-type-set-minimal-alignment! w (squish-alignment w1)) (determine-alignments!) (assign-global-squish-tags!) (set! *again?* #t)))) (else (when #t ;debugging (notify "Promoting W~s from squished to avoid" (type-set-index w1)) (notify " MOVE: branching squished (W~s) to squished (W~s)" (type-set-index w) (type-set-index w1))) ;; needs work: Could try to promote W to general. (set-type-set-squishable?! w1 #f) (determine-alignments!) (assign-global-squish-tags!) (set! *again?* #t))))) ((and (general? w) (squished? w1)) (unless (or (every (lambda (u) (or (char-type? u) (fictitious? u))) us) (null? (rest us))) (when #t ;debugging (notify "Promoting W~s from squished to avoid" (type-set-index w1)) (notify " MOVE: dispatching general (W~s) to squished (W~s)" (type-set-index w) (type-set-index w1))) (set-type-set-squishable?! w1 #f) (determine-alignments!) (assign-global-squish-tags!) (set! *again?* #t))) ((and (squeezed? w) (general? w1)) (when (and (not (every (lambda (u) (or (char-type? u) (fictitious? u))) us)) (some (lambda (u) (or (char-type? u) (fictitious? u))) us)) (when #t ;debugging (notify "Promoting W~s from squeezed to avoid" (type-set-index w)) (notify " MOVE: branching squeezed (W~s) to general (W~s)" (type-set-index w) (type-set-index w1))) (set-type-set-squeezable?! w #f) (determine-alignments!) (assign-global-squish-tags!) (set! *again?* #t))) ((and (squished? w) (general? w1)) (unless (or (every (lambda (u) (or (char-type? u) (fictitious? u))) us) (null? (rest us))) (when #t ;debugging (notify "Promoting W~s from squished to avoid" (type-set-index w)) (notify " MOVE: dispatching squished (W~s) to general (W~s)" (type-set-index w) (type-set-index w1))) (set-type-set-squishable?! w #f) (determine-alignments!) (assign-global-squish-tags!) (set! *again?* #t))) ((and (general? w) (general? w1)) (unless (or (eq? w w1) (and *forgery?* (= (type-set-size w) (type-set-size w1))) (every (lambda (u) (or (char-type? u) (fictitious? u))) us) (null? (rest us))) (when #t ;debugging (notify "MOVE: dispatching general to general") (notify " because of mismatched type set sizes ~a vs. ~a" (type-set-size w) (type-set-size w1)))))))))) (define (promote-pair+! r y ws w) (cond ((discard? r) #f) ((antecedent? r) #f) ((null? ws) (promote! r w w)) (else (let loop ((uss (map members ws)) (w1 (result-type-set r)) (us1 '()) (ws1 '())) (if (null? uss) (let loop ((ws (reverse ws)) (us1 us1) (ws1 ws1) (w w)) (unless (null? ws) (let ((w2 (first ws)) (u1 (first us1)) (w1 (first ws1))) (unless (or (fictitious? w1) (and (return? r) (not (result-accessed? r)))) (cond ((fictitious? u1) (let ((w (create-anonymous-type-set u1))) (set-type-set-fictitious?! w (case *closure-conversion-method* ((baseline conventional) #f) ((lightweight) (or (void? w) (and (not (multimorphic? w)) (must-be? fictitious? w)))) (else (fuck-up)))) (promote! (create-accessor-result w1 #f) w w))) (else (promote! (create-accessor-result (pair-type-car u1) #f) w2 w2) (promote! (create-accessor-result (pair-type-cdr u1) #f) w w)))) (loop (rest ws) (rest us1) (rest ws1) w1)))) (let ((u1 (the-member-that (pair+-type? uss (members w) (call-site-expression y)) w1))) (loop (rest uss) (pair-type-cdr u1) (cons u1 us1) (cons w1 ws1)))))))) (define (promote-gather! e0 y ws w gs) (let loop ((ws ws) (w w) (gs gs)) (unless (null? gs) (let* ((g (first gs))) (if (null? ws) (if (and (rest? e0) (null? (rest gs))) (when (or (local? g) (global? g) (slotted? g)) (promote! (create-accessor-result (variable-type-set g) #f) w w)) (for-each (lambda (u) (when (or (local? g) (global? g) (slotted? g)) (promote! (create-accessor-result (variable-type-set g) #f) (pair-type-car u) (pair-type-car u))) (loop ws (pair-type-cdr u) (rest gs))) (members-that pair-type? w))) (cond ((and (rest? e0) (null? (rest gs))) (when (or (local? g) (global? g) (slotted? g)) (promote-pair+! (create-accessor-result (variable-type-set g) #f) y ws w))) (else (when (or (local? g) (global? g) (slotted? g)) (promote! (create-accessor-result (variable-type-set g) #f) (first ws) (first ws))) (loop (rest ws) w (rest gs))))))))) (define (promote-converted-call! r y u0 ws w) (unless (procedure-type? u0) (fuck-up)) (when (continuation-type? u0) (fuck-up)) (cond ;; CALL/CC==(LAMBDA (C X) (C (X C))) (((primitive-procedure-type-named? 'call-with-current-continuation) u0) (when (can-be-non? null-type? w) (fuck-up)) (for-each (lambda (u2) (promote-converted-call! r (recreate-call-site y 'first-argument) u2 (list (first ws) (first ws)) *null*)) (members-that (compatible-procedure? (list (first ws) (first ws)) *null* (recreate-call-site y 'first-argument)) (second ws)))) ((and (native-procedure-type? u0) (converted? (callee-environment u0 y))) (promote-call! r y u0 ws w)) (((needs-implicit-continuation-call? ws w y) u0) (let ((w1 (minp subtype-set? (map (lambda (u) (continuation-argument-type-set u y)) (members (first ws)))))) (when (can-be-non? (lambda (u) (subtype-set? w1 (continuation-argument-type-set u y))) (first ws)) (fuck-up)) (promote-call! (if (fictitious? w1) *discard* (create-accessor-result w1 #f)) y u0 (rest ws) w) ;; This relies on the fact that the implicit continuation call is never ;; done through APPLY. (for-each (lambda (u1) (promote-call! r (recreate-call-site y 'continuation-argument) u1 (list w1) *null*)) (members-that (compatible-procedure? (list w1) *null* (recreate-call-site y 'continuation-argument)) (first ws))))) (else (promote-call! r y u0 (rest ws) w)))) (define (promote-call! r y u0 ws w) (cond ((primitive-procedure-type? u0) (when (can-be-non? null-type? w) (fuck-up)) (unless (some void? ws) ((primitive-procedure-promote! (cdr (assq (primitive-procedure-type-name u0) *primitive-procedure-handlers*))) r y u0 ws w (if (converted? y) (expression-type-set (continuation-argument (call-site-expression y))) #f) (if (>= (length ws) 1) (first ws) #f) (if (>= (length ws) 2) (second ws) #f) (if (>= (length ws) 3) (third ws) #f)))) ((native-procedure-type? u0) (let* ((e (expression-environment (call-site-expression y))) (e0 (callee-environment u0 y)) (x0 (environment-expression e0)) (gs (variables e0))) (unless (called? e0) (fuck-up)) (cond ((noop? e0) #f) ((can-be-self-tail-call-to? y e0) (promote-gather! e0 y ws w gs)) ((unique-call-site? e0) (promote-gather! e0 y ws w gs) (promote-expression! r (expression-body x0))) (else (promote-gather! e0 y ws w gs) (promote! r (return-type-set e0) (return-type-set e0)))))) ((foreign-procedure-type? u0) #f) ((continuation-type? u0) (when (can-be-non? null-type? w) (unimplemented y "APPLY of a continuation is not (yet) implemented")) (unless (continuation-type-continuation-accessed? u0) (fuck-up)) (if (goto? y u0) (promote! (expression-result (continuation-type-allocating-expression u0)) (first ws) (first ws)) (promote! (if (fictitious? (expression-type-set (continuation-type-allocating-expression u0))) *discard* (create-accessor-result (expression-type-set (continuation-type-allocating-expression u0)) #f)) (first ws) (first ws)))) (else (fuck-up)))) (define (promote-antecedent! x) (promote-expression! (create-antecedent-result (expression-type-set x) #f #f #f) x)) (define (promote-expression! r x) (set-expression-result! x r) (if (and (not (antecedent? r)) (must-be? boolean-type? (expression-type-set x)) (can-be-non? true-type? (expression-type-set x)) (can-be-non? false-type? (expression-type-set x)) (or (and-expression? x) (or-expression? x) (not-expression? x))) (promote-antecedent! x) (case (expression-kind x) ((null-constant) #f) ((true-constant) #f) ((false-constant) #f) ((char-constant) #f) ((fixnum-constant) #f) ((flonum-constant) #f) ((rectangular-constant) #f) ((string-constant) #f) ((symbol-constant) #f) ((pair-constant) #f) ((vector-constant) #f) ((lambda converted-lambda converted-continuation) #f) ((set!) (promote-expression! (if (and (or (local? (expression-variable x)) (global? (expression-variable x)) (slotted? (expression-variable x))) (nontrivial-reference? x) (executed? x)) (create-accessor-result (variable-type-set (expression-variable x)) #f) *discard*) (expression-source x))) ((if) (promote-antecedent! (expression-antecedent x)) (cond ((and (antecedent? r) (and-expression? x)) (when (reached? (expression-consequent x)) (promote-antecedent! (expression-consequent x)))) (else (when (reached? (expression-consequent x)) (promote-expression! r (expression-consequent x))) (when (reached? (expression-alternate x)) (promote-expression! r (expression-alternate x)))))) ((primitive-procedure) #f) ((foreign-procedure) #f) ((access) (when (and (accessed? (expression-variable x)) (or (not (hidden? (expression-variable x))) (discard? r) (antecedent? r))) (promote! r (variable-type-set (expression-variable x)) (expression-type-set x)))) ((call converted-call) (cond ((and (antecedent? r) (or-expression? x)) (let* ((u (the-member (expression-type-set (expression-callee x)))) (e0 (callee-environment u (create-call-site x))) (x0 (environment-expression e0)) (x1 (expression-body x0)) (x2 (first (expression-arguments x)))) (promote-antecedent! x2) (when (reached? (expression-alternate x1)) (promote-antecedent! (expression-alternate x1))))) ((and (antecedent? r) (not-expression? x)) (promote-antecedent! (first (expression-arguments x)))) (else (let* ((w0 (expression-type-set (expression-callee x))) (ws (map expression-type-set (expression-arguments x)))) (promote-expression! (create-accessor-result w0 #f) (expression-callee x)) (for-each (lambda (w x) (promote-expression! (create-accessor-result w #f) x)) ws (expression-arguments x)) (when (and (executed? x) (not (void? w0))) (for-each (lambda (u0) (if (converted? x) (promote-converted-call! r (create-call-site x) u0 ws *null*) (promote-call! r (create-call-site x) u0 ws *null*))) (members-that (compatible-call? x) w0))))))) (else (fuck-up))))) (define (promote-representations!) (let loop () (set! *again?* #f) (for-each (lambda (e) (unless (unique-call-site? e) (promote-expression! (create-return-result e (expression-type-set (expression-body (environment-expression e)))) (expression-body (environment-expression e))))) *es*) (when *again?* (loop)))) ;;; Copy Propagation (define (maybe-parentheses-around c) ;; needs work: To replace the calls to LIST? and LENGTH in the following with ;; more efficient code: (if (or (and (string? c) (or (string=? c "argc") (string=? c "argv") (string=? c "'\\0'") (string=? c "NULL") (string=? c "EOF") (string=? c "data") (string=? c "region") (string=? c "region_size") (string=? c "stdin") (string=? c "stdout") (string=? c "CLOCKS_PER_SEC") (string=? c "RAND_MAX") (string=? c "VALUE_OFFSET") (string=? c "CHAR_OFFSET") (string->number c))) (and (list? c) (= (length c) 3) (string? (first c)) (string=? (first c) "'") (string? (second c)) (string? (third c)) (string=? (third c) "'")) (and (list? c) (= (length c) 3) (string? (first c)) (string=? (first c) "\"") (string? (third c)) (string=? (third c) "\"")) (and (list? c) (= (length c) 2) (string? (first c)) (or (string=? (first c) "a") (string=? (first c) "e") (string=? (first c) "j") (string=? (first c) "p") (string=? (first c) "q") (string=? (first c) "r") (string=? (first c) "t") (string=? (first c) "v") (string=? (first c) "fp") (string=? (first c) "sfp") (string=? (first c) "region") (string=? (first c) "region_size") (string=? (first c) "initial_region") (string=? (first c) "REGION_SIZE")) (string? (second c)))) c (parentheses-around c))) (define (c:copy-propagate! c) (let ((cs1 '()) (cs2 '())) (let loop ((c c)) (when (c:assignment-to-temporary? c) (set! cs1 (cons c cs1))) (when (and (pair? c) (not (c:declaration? c))) (loop (car c)) (loop (cdr c)))) (let loop ((c c)) (when (c:unprotected-assignment-to-atomic-temporary? c) (set! cs2 (cons c cs2))) (when (and (pair? c) (not (c:declaration? c))) (loop (car c)) (loop (cdr c)))) (let ((cs2 (remove-if-not (lambda (c2) (one (lambda (c1) (equal? (c:atomic-t (first (second (first c1)))) (first (second (first c2))))) cs1)) cs2))) (let loop ((c c)) (when (and (pair? c) (not (c:declaration? c))) (cond ((and (c:assignment-to-temporary? (car c)) (memq (car c) cs2)) (set-car! c '())) ((c:atomic-t? (car c)) (let ((c2 (find-if (lambda (c2) (equal? (first (second (first c2))) (car c))) cs2))) (when c2 (set-car! c (maybe-parentheses-around (third (third (second (first c2)))))))))) (cond ((and (c:assignment-to-temporary? (cdr c)) (memq (cdr c) cs2)) (set-cdr! c '())) ((c:atomic-t? (cdr c)) (let ((c2 (find-if (lambda (c2) (equal? (first (second (first c2))) (cdr c))) cs2))) (when c2 (set-cdr! c (maybe-parentheses-around (third (third (second (first c2)))))))))) (loop (car c)) (loop (cdr c))))))) ;;; Removing Unused Declarations (define (c:remove-unused-declarations! c) (let ((a-trie (create-trie 10 ;; conventions: CHAR (lambda (char) (- (char->integer char) (char->integer #\0))) ;; conventions: K (lambda (k) (integer->char (+ k (char->integer #\0)))) #f)) (r-trie (create-trie 10 ;; conventions: CHAR (lambda (char) (- (char->integer char) (char->integer #\0))) ;; conventions: K (lambda (k) (integer->char (+ k (char->integer #\0)))) #f)) (t-trie (create-trie 10 ;; conventions: CHAR (lambda (char) (- (char->integer char) (char->integer #\0))) ;; conventions: K (lambda (k) (integer->char (+ k (char->integer #\0)))) #f)) (v-trie (create-trie 10 ;; conventions: CHAR (lambda (char) (- (char->integer char) (char->integer #\0))) ;; conventions: K (lambda (k) (integer->char (+ k (char->integer #\0)))) #f))) ;; conventions: A-TRIE, R-TRIE, T-TRIE, V-TRIE (let loop ((c c)) (when (c:declaration? c) (when (and (list? (second c)) (= (length (second c)) 2) (string? (first (second c))) (string? (second (second c)))) (cond ((string=? (first (second c)) "a") (when (trie-ref a-trie (second (second c))) (fuck-up)) (trie-set! a-trie (second (second c)) c)) ((string=? (first (second c)) "r") (when (trie-ref r-trie (second (second c))) (fuck-up)) (trie-set! r-trie (second (second c)) c)) ((string=? (first (second c)) "t") (when (trie-ref t-trie (second (second c))) (fuck-up)) (trie-set! t-trie (second (second c)) c)) ((string=? (first (second c)) "v") (when (trie-ref v-trie (second (second c))) (fuck-up)) (trie-set! v-trie (second (second c)) c))))) (when (and (pair? c) (not (c:declaration? c))) (loop (car c)) (loop (cdr c)))) (let loop ((c c)) ;; needs work: To replace the calls to LIST? and LENGTH in the following ;; with more efficient code: (when (and (list? c) (= (length c) 2) (string? (first c)) (or (string=? (first c) "a") (string=? (first c) "r") (string=? (first c) "t") (string=? (first c) "v")) (string? (second c)) (every char-numeric? (string->list (second c)))) (let ((c (cond ((string=? (first c) "a") (trie-ref a-trie (second c))) ((string=? (first c) "r") (trie-ref r-trie (second c))) ((string=? (first c) "t") (trie-ref t-trie (second c))) ((string=? (first c) "v") (trie-ref v-trie (second c))) (else (fuck-up))))) (when c (set-car! (cdddr c) #t)))) (when (and (pair? c) (not (c:declaration? c))) (loop (car c)) (loop (cdr c))))) (let loop ((c c)) (when (and (pair? c) (not (c:declaration? c))) (when (and (c:declaration? (car c)) (not (fourth (car c)))) (set-car! c '())) (when (and (c:declaration? (cdr c)) (not (fourth (cdr c)))) (set-cdr! c '())) (loop (car c)) (loop (cdr c))))) ;;; Removing Unused Labels (define (c:remove-unused-labels! c) (let ((cs '())) (let loop ((c c)) ;; needs work: To replace the calls to LIST? and LENGTH in the following ;; with more efficient code: (when (and (list? c) (= (length c) 2) (list? (first c)) (= (length (first c)) 3) (string? (first (first c))) (string=? (first (first c)) "goto") (string? (second (first c))) (string=? (second (first c)) " ") (list? (third (first c))) (= (length (third (first c))) 2) (string? (first (third (first c)))) (or (string=? (first (third (first c))) "h") (string=? (first (third (first c))) "l") (string=? (first (third (first c))) "x")) (string? (second (third (first c)))) (not (member (third (first c)) cs))) (set! cs (cons (third (first c)) cs))) (when (and (pair? c) (not (c:declaration? c))) (loop (car c)) (loop (cdr c)))) (let loop ((c c)) (when (and (pair? c) (not (c:declaration? c))) (when (and (c:label? (car c)) (not (member (first (car c)) cs))) (set-car! c '())) (when (and (c:label? (cdr c)) (not (member (first (cdr c)) cs))) (set-cdr! c '())) (loop (car c)) (loop (cdr c)))))) (define *errors* '(("out_of_memory" "Out of memory" #f) ("call" "Attempt to call a non-procedure or call a procedure with the wrong number of arguments" "Might call a non-procedure or call a procedure with the wrong number of arguments" "Will call a non-procedure or call a procedure with the wrong number of arguments") ("foreign_call" "Attempt to call a foreign procedure with arguments of the wrong type" "Might call a foreign procedure with arguments of the wrong type" "Will call a foreign procedure with arguments of the wrong type") ("void_if" "The antecedent to an IF has an unspecified value" "The antecedent to an IF might have an unspecified value" "The antecedent to an IF will have an unspecified value") ("void_call" "Attempt to call an unspecified value" "Might call an unspecified value" "Will call an unspecified value") ("void_primitive_procedure_call" "Attempt to call a primitive procedure with an unspecified value" "Might call a primitive procedure with an unspecified value" "Will call a primitive procedure with an unspecified value") ("void_foreign_procedure_call" "Attempt to call a foreign procedure with an unspecified value" "Might call a foreign procedure with an unspecified value" "Will call a foreign procedure with an unspecified value") ("structure_ref" "Argument to STRUCTURE-REF ~a a structure of the correct type" #t) ("structure_set" "First argument to STRUCTURE-SET! ~a a structure of the correct type" #t) ("string_to_uninterned_symbol" "Argument to STRING->UNINTERNED-SYMBOL ~a a string" #t) ("exact" "Argument to EXACT? ~a a number" #t) ("inexact" "Argument to INEXACT? ~a a number" #t) ("symbol_string" "Argument to SYMBOL->STRING ~a a symbol" #t) ("eql" "Argument to = ~a a number" #t) ("lt" "Argument to < ~a a real number" #t) ("gt" "Argument to > ~a a real number" #t) ("le" "Argument to <= ~a a real number" #t) ("ge" "Argument to >= ~a a real number" #t) ("zero" "Argument to ZERO? ~a a number or a pointer" #t) ("positive" "Argument to POSITIVE? ~a a real number" #t) ("negative" "Argument to NEGATIVE? ~a a real number" #t) ("max" "Argument to MAX ~a a real number" #t) ("min" "Argument to MIN ~a a real number" #t) ("plus" "Argument to + ~a a number" #t) ("minus" "Argument to - ~a a number" #t) ("times" "Argument to * ~a a number" #t) ("divide" "Argument to / ~a a number" #t) ("quotient1" "First argument to QUOTIENT ~a an integer" #t) ("quotient2" "Second argument to QUOTIENT ~a an integer" #t) ("remainder1" "First argument to REMAINDER ~a an integer" #t) ("remainder2" "Second argument to REMAINDER ~a an integer" #t) ("lsh1" "First argument to << ~a an integer" #t) ("lsh2" "Second argument to >> ~a an integer" #t) ("rsh1" "First argument to << ~a an integer" #t) ("rsh2" "Second argument to >> ~a an integer" #t) ("bitwise_not" "Argument to BITWISE-NOT ~a an exact integer" #t) ("bitwise_and" "Argument to BITWISE-AND ~a an exact integer" #t) ("bitwise_or" "Argument to BITWISE-OR ~a an exact integer" #t) ("floor" "Argument to FLOOR ~a a real number" #t) ("ceiling" "Argument to CEILING ~a a real number" #t) ("truncate" "Argument to TRUNCATE ~a a real number" #t) ("round" "Argument to ROUND ~a a real number" #t) ("exp" "Argument to EXP ~a a number" #t) ("log" "Argument to LOG ~a a number" #t) ("sin" "Argument to SIN ~a a number" #t) ("cos" "Argument to COS ~a a number" #t) ("tan" "Argument to TAN ~a a number" #t) ("asin" "Argument to ASIN ~a a number" #t) ("acos" "Argument to ACOS ~a a number" #t) ("atan1" "Argument to ATAN ~a a number" #t) ("atan2" "First argument to ATAN ~a a number" #t) ("atan3" "Second argument to ATAN ~a a number" #t) ("sqrt" "Argument to SQRT ~a a number" #t) ("expt1" "First argument to EXPT ~a a number" #t) ("expt2" "Second argument to EXPT ~a a number" #t) ("exact_to_inexact" "Argument to EXACT->INEXACT ~a a number" #t) ("inexact_to_exact1" "Argument to INEXACT->EXACT ~a a number" #t) ("inexact_to_exact2" "Implementation restriction: Argument to INEXACT->EXACT ~a a real number" #t) ("char_to_integer" "Argument to CHAR->INTEGER ~a a character" #t) ("integer_to_char1" "Argument to INTEGER->CHAR ~a an exact integer" #t) ("integer_to_char2" "Argument to INTEGER->CHAR is out of bounds" #f) ("make_string1" "First argument to MAKE-STRING ~a an exact integer" #t) ("make_string2" "Second argument to MAKE-STRING ~a a character" #t) ("string" "Argument to STRING ~a a character" #t) ("string_length" "Argument to STRING-LENGTH ~a a string" #t) ("string_ref1" "First argument to STRING-REF ~a a string" #t) ("string_ref2" "Second argument to STRING-REF ~a an exact integer" #t) ("string_ref3" "Second argument to STRING-REF is out of bounds" #f) ("string_set1" "First argument to STRING-SET! ~a a string" #t) ("string_set2" "Second argument to STRING-SET! ~a an exact integer" #t) ("string_set3" "Third argument to STRING-SET! ~a a character" #t) ("string_set4" "Second argument to STRING-SET! is out of bounds" #f) ("make_vector" "First argument to MAKE-VECTOR ~a an exact integer" #t) ("make_displaced_vector1" "First argument to MAKE-DISPLACED-VECTOR ~a a vector" #t) ("make_displaced_vector2" "Second argument to MAKE-DISPLACED-VECTOR ~a an exact integer" #t) ("make_displaced_vector3" "Third argument to MAKE-DISPLACED-VECTOR ~a an exact integer" #t) ("make_displaced_vector4" "Second argument to MAKE-DISPLACED-VECTOR is out of bounds" #f) ("make_displaced_vector5" "Third argument to MAKE-DISPLACED-VECTOR is out of bounds" #f) ("vector_length" "Argument to VECTOR-LENGTH ~a a vector" #t) ("vector_ref1" "First argument to VECTOR-REF ~a a vector" #t) ("vector_ref2" "Second argument to VECTOR-REF ~a an exact integer" #t) ("vector_ref3" "Second argument to VECTOR-REF is out of bounds" #f) ("vector_set1" "First argument to VECTOR-SET! ~a a vector" #t) ("vector_set2" "Second argument to VECTOR-SET! ~a an exact integer" #t) ("vector_set3" "Second argument to VECTOR-SET! is out of bounds" #f) ("call_with_current_continuation" "First argument to CALL-WITH-CURRENT-CONTINUATION ~a a procedure of one argument" #t) ("open_input_file1" "Argument to OPEN-INPUT-FILE ~a a string" #t) ("open_input_file2" "OPEN-INPUT-FILE cannot open file" #f) ("open_output_file1" "Argument to OPEN-OUTPUT-FILE ~a a string" #t) ("open_output_file2" "OPEN-OUTPUT-FILE cannot open file" #f) ("close_input_port1" "Argument to CLOSE-INPUT-PORT ~a an input port" #t) ("close_input_port2" "CLOSE-INPUT-PORT cannot close input port" #f) ("close_output_port1" "Argument to CLOSE-OUTPUT-PORT ~a an output port" #t) ("close_output_port2" "CLOSE-OUTPUT-PORT cannot close output port" #f) ("read_char1" "Argument to READ-CHAR1 ~a an input port" #t) ("peek_char1" "Argument to PEEK-CHAR1 ~a an input port" #t) ("char_ready1" "Argument to CHAR-READY?1 ~a an input port" #t) ("write_char1" "First argument to WRITE-CHAR2 ~a a character" #t) ("write_char2" "Second argument to WRITE-CHAR2 ~a an output port" #t) ("panic" "Argument to PANIC ~a a string" #t) ("integer_to_string" "Argument to INTEGER->STRING ~a an exact integer" #t) ("integer_to_input_port" "Argument to INTEGER->INPUT-PORT ~a an exact integer" #t) ("integer_to_output_port" "Argument to INTEGER->OUTPUT-PORT ~a an exact integer" #t) ("integer_to_pointer" "Argument to INTEGER->POINTER ~a an exact integer" #t) ("infinity" "Argument to INFINITY? ~a a flonum" #t))) (define *errors-used* #f) (define *warnings* #f) (define (compile-error-procedure-prototypes) (newlines-between (map (lambda (error) ;; conventions: ERROR (set! *c:panic?* #t) ;; needs work: To use code-generation abstractions. (space-between "void" (c:noreturn-prototype (c:error (first error))))) *errors-used*))) (define (compile-error-procedures) (newlines-between (map (lambda (error) ;; conventions: ERROR (set! *c:panic?* #t) ;; needs work: To use code-generation abstractions. (space-between "void" (c:header (c:error (first error))) (braces-around (c:panic (c:string (if (eq? (third error) #t) (format #f (second error) "is not") (second error))))))) *errors-used*))) (define (restore? e/r) (cond ((environment? e/r) (and (has-region? e/r) (reentrant? e/r))) ((result? e/r) (restore? (result-environment e/r))) (else (fuck-up)))) (define (compile-restore e/r) ;; needs work: Returning from a procedure should restore all in-lined ;; reentrant regions that have self tail calls to that procedure. ;; Because we don't do this (yet), we need HAS-EXTERNAL-CALL? to ;; prevent allocation on such regions because otherwise there ;; would be a memory leak when we exit from such a procedure. (cond ((environment? e/r) (if (and (has-region? e/r) (reentrant? e/r)) (newline-between (cond (*treadmarks?* (include! "Tmk") ;Tmk_lock_acquire (c:gosub "Tmk_lock_acquire" (c:0))) (else (c:noop))) (if *expandable-regions?* (c:while (c:boolean-or (c:< (c:sfp e/r) (c:& (c:subscript (c:-> (c:region e/r) (c:data)) (c:0)))) (c:> (c:sfp e/r) (c:& (c:subscript (c:-> (c:region e/r) (c:data)) (c:region-size e/r))))) (newline-between (semicolon-after ;; needs work: To use code-generation abstractions. (space-between "struct" (c:region e/r) (star-before (c:region)))) (c::= (c:region) (c:region e/r)) (c::= (c:region-size e/r) (c:-> (c:region e/r) (c:region-size))) (c::= (c:region e/r) (c:-> (c:region e/r) (c:region))) (if *memory-messages?* (c:printf (c:string (format #f "Freeing region segment for ~a~%" (environment-name e/r)))) (c:noop)) (c:free (c:region) (has-nonatomic-region? e/r)))) (c:noop)) (c::= (c:fp e/r) (c:sfp e/r)) (cond (*treadmarks?* (include! "Tmk") ;Tmk_lock_release (c:gosub "Tmk_lock_release" (c:0))) (else (c:noop)))) (c:noop))) ((result? e/r) (compile-restore (result-environment e/r))) (else (fuck-up)))) (define (result-accessed? r) (unless (return? r) (fuck-up)) (expression-accessed? (expression-body (environment-expression (result-environment r))))) (define (compile-return r) (if (and (return? r) (or (environment-returns? (result-environment r)) (environment-passes-parameters-globally? (result-environment r)))) (newline-between (compile-restore r) (if (or (fictitious? (result-type-set r)) (not (result-accessed? r))) (c:return) (c:return (c:r (result-environment r))))) (c:noop))) (define (zero-value c u w) (if *eq?-forgery?* ;; This zeros out the value field so that EQ? forgery works. ;; needs work: This can be eliminated if there is never any EQ? forgery. (let* ((size (reduce max (map type-size (members-that (lambda (u) (or (not (char-type? u)) (not (fictitious? u)))) w)) ;; This can't happen if the type set isn't fictitious, ;; monomorphic, or tag only. #f)) (fixnum-size (quotient size *fixnum-size*)) (char-size (remainder size *fixnum-size*))) ;; conventions: SIZE FIXNUM-SIZE CHAR-SIZE (if (or (eq? u #f) (not (= size (type-size u)))) (newline-between (newlines-between (map-n (lambda (i) (c::= (c:raw-subscript (c:fixnum*-cast (c:& (c:. c "value"))) (c:fixnum i)) (c:0))) fixnum-size)) (newlines-between (map-n (lambda (i) (c::= (c:raw-subscript (c:char*-cast (c:& (c:. c "value"))) (c:fixnum (+ (* fixnum-size *fixnum-size*) i))) (c:0))) char-size))) (c:noop))) (c:noop))) (define (move-general r c w w2 p?) ;; W is the source representation type set ;; W2 is the source restricted type set (let ((us (intersectionq (members w) (members w2)))) (cond ((discard? r) (if p? (c:noop) (semicolon-after c))) ((and (return? r) (not (result-accessed? r))) (newline-between (if p? (c:noop) (semicolon-after c)) (compile-return r))) ((antecedent? r) ;; needs work: I'm not sure whether uniqueness screws up here. (if (every false-type? us) (if (some false-type? us) (newline-between (if p? (c:noop) (semicolon-after c)) (compile-goto (result-l2 r) (result-l0 r))) (if p? (c:noop) (semicolon-after c))) (if (some false-type? us) (let ((u (first (remove-if-not false-type? us)))) (c:if (cond ((fake? w) (fuck-up)) ((monomorphic? w) (fuck-up)) ((tag-only? w) (c:== (c:tag c w) (c:type-tag u))) ((squeezed? w) (squeeze-tag-test c u w)) ((squished? w) (squish-tag-test c u w)) (else (c:== (c:tag c w) (c:type-tag u)))) (compile-goto (result-l2 r) (result-l0 r)) (compile-goto (result-l1 r) (result-l0 r)) #t)) (newline-between (if p? (c:noop) (semicolon-after c)) (compile-goto (result-l1 r) (result-l0 r)))))) (else (let* ((c1 (result-c r)) (w1 (result-type-set r)) ;; note: This was added because of uniqueness. With uniqueness, it ;; is possible for the source to be widened and contain ;; members that the more precise analysis determines can't ;; really occur so that they may be absent from the ;; destination. (us (if *uniqueness?* (intersectionq (members w1) us) us))) (define (move c) (cond ((return? r) (if (or (environment-returns? (result-environment r)) (environment-passes-parameters-globally? (result-environment r))) ;; needs work: This will replicate the COMPILE-RESTORE in both ;; branches of an IF or in all branches of a dispatch. (newline-between ;; needs work: This potentially can do the COMPILE-RESTORE before ;; evaluating C. (compile-restore r) (c:return c)) (c:noop))) (else (c::= c1 c)))) (unless (every (lambda (u) (member? u w1)) us) (fuck-up)) (cond ((or (fake? w1) (null? us)) (newline-between (if p? (c:noop) (semicolon-after c)) (compile-return r))) ((monomorphic? w1) (move (c:value c (the-member w1) w))) ((tag-only? w1) (cond ((fake? w) (move (c:type-tag (the-member w)))) ((monomorphic? w) (unless (char-type? (the-member w)) (fuck-up)) ;; note: Converting from character to tag-only used to be free but now ;; requires a left shift when there is some squishing. This is ;; the price to pay for universal type tags. ;; This assumes that *TAG* is unsigned so that << does a logical ;; shift. The call to C:UNSIGNED-CHAR-CAST is in case *CHAR* is ;; signed to force << to be a logical shift without a prior sign ;; extend. The call to C:TYPE-SET-CAST is to prevent any overflow in ;; the logical shift. (move (c:<< (c:type-set-cast (c:unsigned-char-cast c) w1) (c:fixnum *worst-alignment*)))) ((tag-only? w) (move c)) ((squeezed? w) (move (c:squeezed->tag-cast c w))) ;; This works because of universal type tags. This assumes that ;; casting from *SQUISHED* to *TAG* does not modify the bit pattern. ((squished? w) (move (c:type-set-cast c w1))) (else (move (c:tag c w))))) ((squeezed? w1) (cond ((fake? w) (move (c:type-set-cast (c:type-tag (the-member w)) w1))) ((monomorphic? w) (move (squeeze (c:value c (the-member w) w) (the-member w) w1))) ((tag-only? w) (move (c:tag->squeezed-cast c w w1))) ((squeezed? w) (if (eq? (squeezed-member w1) (squeezed-member w)) (move c) ;; The squeezed members can only differ in the case of narrowing ;; when the only values being moved are the non-squeezed types. (move (c:type-set-cast c w1)))) ((squished? w) (move (c:type-set-cast (if (and (member? (squeezed-member w1) w) (not (zero? (squish-tag (squeezed-member w1) w)))) (if (every (lambda (u) (or (char-type? u) (fictitious? u))) us) (strip-known-squish-tag c (squeezed-member w1) w) (strip-squish-tag c w)) c) w1))) (else (let ((u1 (squeezed-member w1))) (if (some (lambda (u) (eq? u u1)) us) (if (every (lambda (u) (eq? u u1)) us) (move (squeeze (c:value c u1 w) u1 w1)) (newline-between (c:/**/ "MOVE: branching general to squeezed") (c:if (c:== (c:tag c w) (c:type-tag u1)) (move (squeeze (c:value c u1 w) u1 w1)) (move (c:tag->squeezed-cast c w w1)) #t))) (move (c:tag->squeezed-cast c w w1))))))) ((squished? w1) (cond ((fake? w) (move (c:type-set-cast (c:type-tag (the-member w)) w1))) ((monomorphic? w) (move (squish (c:value c (the-member w) w) (the-member w) w1))) ;; This works because of universal type tags. This assumes that ;; casting from *TAG* to *SQUISHED* does not modify the bit pattern. ((tag-only? w) (move (c:type-set-cast (c:tag c w) w1))) ((squeezed? w) (if (or (every (lambda (u) (or (char-type? u) (fictitious? u))) us) (zero? (squish-tag (squeezed-member w) w1))) (move (c:type-set-cast c w1)) (if (some (lambda (u) (or (char-type? u) (fictitious? u))) us) (newline-between (c:/**/ "MOVE: branching squeezed to squished") (c:if (c:>= c (c:type-set-cast (c:value-offset) w)) (move (squish (c:value c (squeezed-member w) w) (squeezed-member w) w1)) (move (c:type-set-cast c w1)) #t)) (move (squish (c:value c (squeezed-member w) w) (squeezed-member w) w1))))) ((squished? w) (cond ((and (every (lambda (u) (or (char-type? u) (fictitious? u) (= (squish-tag u w) (squish-tag u w1)))) us) (= (squish-alignment w) (squish-alignment w1))) (move c)) (else (unless (or (= (squish-alignment w) (squish-alignment w1)) (every (lambda (u) (or (char-type? u) (fictitious? u) (fixnum-type? u) ;; needs work: Can be extended to allow ;; squishing a singleton ;; immediate structure if its ;; slot is squished. (degenerate-vector-type? u))) us)) (unimplemented #f "This case of squished-to-squished is not (yet) implemented")) (if (or (not (some (lambda (u) (or (char-type? u) (fictitious? u))) us)) (and (= (squish-alignment w) (squish-alignment w1)) (every (lambda (u) (or (not (zero? (squish-tag u w))) (zero? (squish-tag u w1)))) us))) (newline-between (c:/**/ "MOVE: squished to squished") (move (c:+ ;; needs work: This is wrong. Only the non-pointer values ;; need to be shifted. But fortunately this ;; doesn't cause a problem since if both W and W1 ;; can contain the same pointer values then they ;; will have the same squish alignment because ;; all pointer values have the same alignment. ;; This is checked by the above panic. (c:squished-cast (cond ((= (squish-alignment w) (squish-alignment w1)) (strip-squish-tag c w)) ((< (squish-alignment w) (squish-alignment w1)) (c:<< (c:signed-squished-cast (strip-squish-tag c w)) (c:fixnum (- (squish-alignment w1) (squish-alignment w))))) (else (c:>> (c:signed-squished-cast (strip-squish-tag c w)) (c:fixnum (- (squish-alignment w) (squish-alignment w1))))))) (c:subscript ;; needs work: To use code-generation abstractions. (list "\"" (reduce string-append (let ((alist (map (lambda (u) (cons (squish-tag u w) (squish-tag u w1))) us))) (map-n (lambda (i) (let ((c (number->string (cdr (or (assv i alist) (cons 0 0)))))) (when (> (string-length c) 2) (fuck-up)) (string-append "\\" (make-string (- 3 (string-length c)) #\0) c))) (+ (reduce max (map car alist) 0) 1))) "") "\"") (extract-squish-tag c w))))) (newline-between (c:/**/ "MOVE: branching squished to squished") (c:if (c:boolean-or (c:!=0 (extract-squish-tag c w)) (c:>= c (c:type-set-cast (c:value-offset) w))) (move (c:+ ;; needs work: This is wrong. Only the non-pointer values ;; need to be shifted. But fortunately this ;; doesn't cause a problem since if both W and ;; W1 can contain the same pointer values then ;; they will have the same squish alignment ;; because all pointer values have the same ;; alignment. This is checked by the above ;; panic. (c:squished-cast (cond ((= (squish-alignment w) (squish-alignment w1)) (strip-squish-tag c w)) ((< (squish-alignment w) (squish-alignment w1)) (c:<< (c:signed-squished-cast (strip-squish-tag c w)) (c:fixnum (- (squish-alignment w1) (squish-alignment w))))) (else (c:>> (c:signed-squished-cast (strip-squish-tag c w)) (c:fixnum (- (squish-alignment w) (squish-alignment w1))))))) (c:subscript ;; needs work: To use code-generation abstractions. (list "\"" (reduce string-append (let ((alist (map (lambda (u) (cons (squish-tag u w) (squish-tag u w1))) (remove-if (lambda (u) (or (char-type? u) (fictitious? u))) us)))) (map-n (lambda (i) (let ((c (number->string (cdr (or (assv i alist) (cons 0 0)))))) (when (> (string-length c) 2) (fuck-up)) (string-append "\\" (make-string (- 3 (string-length c)) #\0) c))) (+ (reduce max (map car alist) 0) 1))) "") "\"") (extract-squish-tag c w)))) (move c) #t)))))) (else (newline-between (if (or (every (lambda (u) (or (char-type? u) (fictitious? u))) us) (null? (rest us))) (c:noop) (c:/**/ "MOVE: dispatching general to squished")) (nonchecking-type-switch (lambda (u) (some (lambda (u1) (eq? u u1)) us)) w r c (lambda (u) (move (if (or (char-type? u) (fictitious? u)) ;; This works because of universal type tags. This ;; assumes that casting from *TAG* to *SQUISHED* ;; does not modify the bit pattern. (c:type-set-cast (c:tag c w) w1) (squish (c:value c u w) u w1))))))))) (else (cond ((fake? w) (newline-between (zero-value c1 #f w1) (c::= (c:tag c1 w1) (c:type-tag (the-member w))) (compile-return r))) ((monomorphic? w) (newline-between (if (char-type? (the-member w)) ;; note: Converting from character to general used to be free ;; but now requires a left shift when there is some ;; squishing. This is the price to pay for universal type ;; tags. ;; This assumes that *TAG* is unsigned so that << does a logical ;; shift. The call to C:UNSIGNED-CHAR-CAST is in case *CHAR* is ;; signed to force << to be a logical shift without a prior sign ;; extend. The call to C:TAG-CAST is to prevent any overflow in ;; the logical shift. (newline-between (zero-value c1 #f w1) (c::= (c:tag c1 w1) (c:<< (c:tag-cast (c:unsigned-char-cast (c:value c (the-member w) w))) (c:fixnum *worst-alignment*)))) (newline-between (zero-value c1 (the-member w) w1) (c::= (c:tag c1 w1) (c:type-tag (the-member w))) (c::= (c:value c1 (the-member w) w1) (c:value c (the-member w) w)))) (compile-return r))) ((tag-only? w) (newline-between (zero-value c1 #f w1) (c::= (c:tag c1 w1) (c:tag c w)) (compile-return r))) ((squeezed? w) (newline-between (if (every (lambda (u) (or (char-type? u) (fictitious? u))) us) (newline-between (zero-value c1 #f w1) (c::= (c:tag c1 w1) (c:squeezed->tag-cast c w))) (if (some (lambda (u) (or (char-type? u) (fictitious? u))) us) (newline-between (c:/**/ "MOVE: branching squeezed to general") (c:if (c:>= c (c:type-set-cast (c:value-offset) w)) (newline-between (zero-value c1 (squeezed-member w) w1) (c::= (c:tag c1 w1) (c:type-tag (squeezed-member w))) (c::= (c:value c1 (squeezed-member w) w1) c)) (newline-between (zero-value c1 #f w1) (c::= (c:tag c1 w1) (c:squeezed->tag-cast c w))) #t)) (newline-between (zero-value c1 (squeezed-member w) w1) (c::= (c:tag c1 w1) (c:type-tag (squeezed-member w))) (c::= (c:value c1 (squeezed-member w) w1) c)))) (compile-return r))) ((squished? w) (newline-between (if (or (every (lambda (u) (or (char-type? u) (fictitious? u))) us) (null? (rest us))) (c:noop) (c:/**/ "MOVE: dispatching squished to general")) (nonchecking-type-switch (lambda (u) (some (lambda (u1) (eq? u u1)) us)) w r c (lambda (u) (if (or (char-type? u) (fictitious? u)) ;; This works because of universal type tags. This assumes ;; that casting from *SQUISHED* to *TAG* does not modify the ;; bit pattern. (newline-between (zero-value c1 #f w1) (c::= (c:tag c1 w1) (c:tag-cast c)) (compile-return r)) (newline-between (zero-value c1 u w1) (c::= (c:tag c1 w1) (c:type-tag u)) (c::= (c:value c1 u w1) (c:value c u w)) (compile-return r))))))) (else (cond ((eq? w w1) (move c)) ((and *forgery?* (= (type-set-size w) (type-set-size w1))) (move (c:forgery-cast c w1))) (else (newline-between (if (or (every (lambda (u) (or (char-type? u) (fictitious? u))) us) (null? (rest us))) (c:noop) (c:/**/ "MOVE: dispatching general to general")) ;; This works because of universal type tags. (c::= (c:tag c1 w1) (c:tag c w)) (nonchecking-type-switch (lambda (u) (some (lambda (u1) (eq? u u1)) us)) w r c (lambda (u) (if (or (char-type? u) (fictitious? u)) (newline-between (zero-value c1 #f w1) (compile-return r)) (newline-between (zero-value c1 u w1) (c::= (c:value c1 u w1) (c:value c u w)) (compile-return r))))))))))))))))) (define (move r c w) (move-general r c w w #t)) (define (move-strict r c w) (move-general r (c:protect c) w w #f)) (define (move-access r c w w2) (move-general r c w w2 #t)) (define (widen-type r c u) (let ((w (create-anonymous-type-set u))) (set-type-set-fictitious?! w (case *closure-conversion-method* ((baseline conventional) #f) ((lightweight) (or (void? w) (and (not (multimorphic? w)) (must-be? fictitious? w)))) (else (fuck-up)))) (move-general r c w w #t))) (define (widen r c m) (cond ((discard? r) (c:noop)) ((antecedent? r) ;; note: The following checks for EQ?-ness between procedures. (if (eq? m false-type?) (compile-goto (result-l2 r) (result-l0 r)) (compile-goto (result-l1 r) (result-l0 r)))) (else (widen-type r c (the-member-that m (result-type-set r)))))) (define (move-displaced-vector r u c1 c2) (cond ((discard? r) (c:noop)) ((and (return? r) (not (result-accessed? r))) ;; note: C2 is not evaluated here. This is OK because in all uses of ;; MOVE-DISPLACED-VECTOR C2 does not need to be strict. (compile-return r)) ((antecedent? r) (compile-goto (result-l1 r) (result-l0 r))) (else (let ((c (result-c r)) (w (result-type-set r))) (when (or (squeezed? w) (squished? w)) (unimplemented #f "Squeezing or squishing a displaced vector is not (yet) implemented")) (unless (member? u w) (fuck-up)) (cond ((and (return? r) (monomorphic? w) (degenerate-vector-type? (the-member w))) (if (or (environment-returns? (result-environment r)) (environment-passes-parameters-globally? (result-environment r))) (newline-between ;; note: This potentially can do the COMPILE-RESTORE before ;; evaluating C2. This is OK because in all uses of ;; MOVE-DISPLACED-VECTOR C2 does not need to be strict. (compile-restore r) (c:return c2)) (c:noop))) ((and (return? r) (tag-only? w)) (if (or (environment-returns? (result-environment r)) (environment-passes-parameters-globally? (result-environment r))) (newline-between (compile-restore r) (c:return (c:type-tag u))) (c:noop))) (else (newline-between (if (or (monomorphic? w) (squeezed? w) (squished? w)) (c:noop) (c::= (c:tag c w) (c:type-tag u))) (c::= (value-vector-length c u w) c2) (if (degenerate-vector-type? u) (c:noop) (c::= (value-vector-elements c u w) c1)) (compile-return r)))))))) (define *ti* #f) (define (allocate-temporary w) (if (fictitious? w) 'void9 (let ((t (c:t *ti*))) (set! *ti* (+ *ti* 1)) (outside-body (c:declaration w t (c:noop))) t))) (define (compile-error c x/y p?) ;; needs work: Should give an indication of the call-site offset. (cond ((expression? x/y) (let ((error (assoc c *errors*))) ;; conventions: ERROR (unless error (fuck-up)) (when (and p? (not (third error))) (fuck-up)) (unless (memq error *errors-used*) (set! *errors-used* (cons error *errors-used*))) (when (third error) (cond ((expression-pathname x/y) (notify "~a:~s:~s:~a" (expression-pathname x/y) (expression-line-position x/y) (expression-character-position x/y) (cond ((eq? (third error) #t) (format #f (second error) (if p? "will not be" "might not be"))) ((string? (third error)) ((if p? fourth third) error)) (else (fuck-up))))) (else (notify "In ~a" (environment-name (expression-environment x/y))) (notify (cond ((eq? (third error) #t) (format #f (second error) (if p? "will not be" "might not be"))) ((string? (third error)) ((if p? fourth third) error)) (else (fuck-up)))))) (set! *warnings* (cons (list (expression-index x/y) (replace-true-and-false-with-t-and-nil p?) (cond ((eq? (third error) #t) (format #f (second error) (if p? "will not be" "might not be"))) ((string? (third error)) ((if p? fourth third) error)) (else (fuck-up))) x/y) *warnings*))) (c:no-return (newline-between (cond ((expression-pathname x/y) (c:backtrace (c:string (expression-pathname x/y)) (c:fixnum (expression-line-position x/y)) (c:fixnum (expression-character-position x/y)))) ((empty? (expression-environment x/y)) (c:backtrace-internal (c:string "top level"))) (else (c:backtrace-internal (c:string (environment-name (expression-environment x/y)))))) (c:gosub (c:error c)))))) ((call-site? x/y) (compile-error c (call-site-expression x/y) p?)) (else (fuck-up)))) (define (compile-comparison r y cs ws c1 c2) ;; needs work: The code size generated can be exponential in the number of ;; arguments. ;; needs work: To handle rectangular numbers. (let loop ((cs cs) (ws ws) (cs1 '()) (us '())) (if (null? cs) (let ((cs1 (reverse cs1))) (compile-test r (apply c:&& (map (lambda (c2 c3 u1 u2) (c1 c2 c3 u1 u2)) (but-last cs1) (rest cs1) (but-last us) (rest us))))) (type-switch number-type? (first ws) r (first cs) (lambda (u) (loop (rest cs) (rest ws) (cons (c:value (first cs) u (first ws)) cs1) (cons u us))) (lambda (p?) (compile-error c2 y p?)))))) (define (compile-arithmetic m r y cs ws u1 c1 c2) ;; needs work: The code size generated can be exponential in the number of ;; arguments. (let loop ((cs0 cs) (ws0 ws) (cs '()) (us '())) (define (arithmetic-result-type us) (if (null? (rest (rest us))) (u1 (second us) (first us)) (u1 (arithmetic-result-type (rest us)) (first us)))) (define (compile-arithmetic-internal cs us ws) (if (null? (rest (rest cs))) (c1 (second cs) (second us) (first cs) (first us)) (c1 (compile-arithmetic-internal (rest cs) (rest us) (rest ws)) (arithmetic-result-type (rest us)) (first cs) (first us)))) (if (null? ws0) (widen-type r (compile-arithmetic-internal cs us (reverse ws)) (arithmetic-result-type us)) (type-switch m (first ws0) r (first cs0) (lambda (u) (loop (rest cs0) (rest ws0) (cons (c:value (first cs0) u (first ws0)) cs) (cons u us))) (lambda (p?) (compile-error c2 y p?)))))) (define (compile-allocate e y c c1 p?) ;; needs work: To use code-generation abstractions. (cond ((region-allocation? e) (if *expandable-regions?* (newline-between (cond (*treadmarks?* (include! "Tmk") ;Tmk_lock_acquire (c:gosub "Tmk_lock_acquire" (c:0))) (else (c:noop))) (c:if (c:> (c:+ (c:fp e) c) ;needs work: To check for overflow. (c:& (c:subscript (c:-> (c:region e) (c:data)) (c:region-size e)))) (newline-between (semicolon-after (space-between "struct" (c:region e) (star-before (c:region)))) ;; needs work: needs abstraction for initialized declaration (semicolon-after (space-between *length* (unparenthesize (c:= (c:region-size) (c:big-region-size e))))) (c:if (c:> c (c:region-size)) (c::= (c:region-size) c) (c:noop) #t) (if *memory-messages?* (c:printf (c:string (format #f "Allocating region segment for ~a~%" (environment-name e)))) (c:noop)) (c::= (c:region) (c:cast (space-between "struct" (c:region e) "*") (c:malloc ;; needs work: To check for overflow. (c:+ (c:sizeof (space-between "struct" (c:region e))) ;; Overflow can't occur. (c:- (c:region-size) (c:1))) (has-nonatomic-region? e)))) (if *memory-checks?* (c:if (c:==null (c:region)) (compile-error "out_of_memory" y #f) (c:noop) #t) (c:noop)) (c::= (c:-> (c:region) (c:region)) (c:region e)) (if (reentrant? e) (c::= (c:-> (c:region) (c:region-size)) (c:region-size e)) (c:noop)) (c::= (c:region-size e) (c:region-size)) (c::= (c:region e) (c:region)) (c::= (c:fp e) (c:& (c:subscript (c:-> (c:region) (c:data)) (c:0)))) ;; needs work: There is a bug here. If the region_size was ;; bumped for a large object then there is no slack ;; for alignment adjustment. (c:align (c:fp e))) (c:noop) #f) (c1 (c:fp e) (lambda (c) (c:noop))) ;; needs work: To check for overflow. (c:+= (c:fp e) (if (zero? *allocation-alignment*) c ;; needs work: To check for overflow. (c:+ c ;; Overflow can't occur. (c:& (c:- (c:fixnum (expt 2 *allocation-alignment*)) (c:% c (c:fixnum (expt 2 *allocation-alignment*)))) (c:fixnum (- (expt 2 *allocation-alignment*) 1)))))) (cond (*treadmarks?* (include! "Tmk") ;Tmk_lock_release (c:gosub "Tmk_lock_release" (c:0))) (else (c:noop)))) (newline-between (cond (*treadmarks?* (include! "Tmk") ;Tmk_lock_acquire (c:gosub "Tmk_lock_acquire" (c:0))) (else (c:noop))) (c1 (c:fp e) (lambda (c) (c:noop))) (if *memory-checks?* (c:if (c:> (c:+ (c:fp e) c) ;needs work: To check for overflow. (c:& (c:subscript (c:region e) (c:big-region-size e)))) (compile-error "out_of_memory" y #f) (c:noop) #f) (c:noop)) ;; needs work: To check for overflow. (c:+= (c:fp e) ;; needs work: To check for overflow. (if (zero? *allocation-alignment*) c (c:+ c ;; Overflow can't occur. (c:& (c:- (c:fixnum (expt 2 *allocation-alignment*)) (c:% c (c:fixnum (expt 2 *allocation-alignment*)))) (c:fixnum (- (expt 2 *allocation-alignment*) 1)))))) (cond (*treadmarks?* (include! "Tmk") ;Tmk_lock_release (c:gosub "Tmk_lock_release" (c:0))) (else (c:noop)))))) ((stack-allocation? e) ;; needs work: Might not work for COMPILE-ALLOCATE-HEADED-VECTOR because of ;; the nested braces. It is possible but tedious to fix this. (c1 (c:alloca c) (lambda (c2) (if *memory-checks?* (c:if ;; note: This assumes that alloca returns NULL upon stack ;; overflow. (c:==null c2) (compile-error "out_of_memory" y #f) (c:noop) #f) (c:noop))))) ((heap-allocation? e) (c1 ((if p? c:gc-malloc-atomic c:gc-malloc) c) (lambda (c2) (if *memory-checks?* (c:if ;; note: This assumes that GC_malloc and GC_malloc_atomic return ;; NULL when there is no more memory. (c:==null c2) (compile-error "out_of_memory" y #f) (c:noop) #f) (c:noop))))) (else (fuck-up)))) (define (compile-allocate-string c1 w1 c2 y) ;; needs work: To use code-generation abstractions. (let ((u (the-member-that string-type? w1))) (compile-allocate (cdr (assq u (expression-type-allocation-alist (call-site-expression y)))) y ;; needs work: To check for overflow. (c:* (c:+ c2 (c:1)) (c:sizeof *char*)) (lambda (c3 c4) (newline-between (widen (create-accessor-result w1 c1) (c:type-cast c3 u) string-type?) (c4 (c:value c1 u w1)) (c::= (value-string-ref c1 u w1 c2) (c:nul)))) #t))) (define (compile-allocate-structure c u w y) ;; needs work: What happens if the structure is fictitious? (when (fictitious? u) (fuck-up)) (if (structure-type-immediate? u) (cond ((fictitious? w) (fuck-up)) ((monomorphic? w) (c:noop)) ((tag-only? w) (fuck-up)) ((squeezed? w) (fuck-up)) ((squished? w) (fuck-up)) (else (c::= (c:tag c w) (c:type-tag u)))) (compile-allocate (cdr (assq u (expression-type-allocation-alist (call-site-expression y)))) y (c:sizeof (c:type& u "")) (lambda (c1 c2) (newline-between (widen-type (create-accessor-result w c) (c:type-cast c1 u) u) (c2 (c:value c u w)))) (type-atomic? u)))) (define (compile-allocate-headed-vector c1 u1 w1 c2 y) ;; needs work: To use code-generation abstractions. (if (degenerate-vector-type? u1) (cond ((fictitious? w1) (fuck-up)) ((monomorphic? w1) (c::= (value-vector-length c1 u1 w1) c2)) ((tag-only? w1) (fuck-up)) ((squeezed? w1) (fuck-up)) ((squished? w1) (c::= (vector-length-accessor c1 u1) (squish c2 u1 w1))) (else (c::= (value-vector-length c1 u1 w1) c2))) (compile-allocate (cdr (assq u1 (expression-type-allocation-alist (call-site-expression y)))) y ;; needs work: To check for overflow. (c:+ (c:sizeof (space-between "struct" (c:u u1))) ;; needs work: To check for overflow. (c:* (c:- c2 (c:1)) (c:sizeof (c:type-set (headed-vector-type-element u1) "")))) (lambda (c3 c4) (newline-between (widen-type (create-accessor-result w1 c1) (c:type-cast c3 u1) u1) (c4 (c:value c1 u1 w1)) (c::= (value-vector-length c1 u1 w1) c2))) (type-atomic? u1)))) (define (compile-allocate-closure-level e) ;; needs work: To use code-generation abstractions. (case *closure-representation* ((immediate-flat) (unimplemented #f "Immediate flat closures are not (yet) implemented")) ((indirect-flat) (unimplemented #f "Indirect flat closures are not (yet) implemented")) ((immediate-display indirect-display) (compile-allocate (allocation e) (environment-expression e) (c:sizeof (space-between "struct" (c:e e))) (lambda (c1 c2) (newline-between (c::= (c:e e) (c:cast (space-between "struct" (c:e e) "*") c1)) (c2 (c:e e)))) (environment-atomic? e))) ((linked) ;; Closures and displays are confluent with linked closures. (compile-allocate (allocation e) (environment-expression e) (c:sizeof (space-between "struct" (c:p e))) (lambda (c1 c2) (newline-between (c::= (c:e e) (c:cast (space-between "struct" (c:p e) "*") c1)) (c2 (c:e e)))) (environment-atomic? e))) (else (fuck-up)))) (define (compile-regions) ;; needs work: To use code-generation abstractions. (newlines-between (map (lambda (e) (if (has-region? e) (if *expandable-regions?* (newline-between (c:define (c:big-region-size e) "65536") (semicolon-after (newline-between (space-between "struct" (c:region e)) (braces-around (newline-between (semicolon-after (space-between "struct" (c:region e) (star-before (c:region)))) (if (reentrant? e) (semicolon-after (space-between *length* (c:region-size))) (c:noop)) (semicolon-after (space-between (c:byte) (c:raw-subscript (c:data) (c:1)))))))) (semicolon-after (newline-between "struct" (space-between (braces-around (newline-between (semicolon-after (space-between "struct" (c:region e) (star-before (c:region)))) (if (reentrant? e) (semicolon-after (space-between *length* (c:region-size))) (c:noop)) (semicolon-after (space-between (c:byte) (c:raw-subscript (c:data) (c:big-region-size e)))))) (c:initial-region e)))) ;; needs work: needs abstraction for initialized declaration (semicolon-after (space-between "struct" (c:region e) (unparenthesize (c:= (star-before (c:region e)) (c:cast (space-between "struct" (c:region e) "*") (c:& (c:initial-region e))))))) (if (reentrant? e) (newline-between ;; needs work: needs abstraction for initialized declaration (semicolon-after (space-between *length* (unparenthesize (c:= (c:region-size e) (c:big-region-size e))))) ;; needs work: needs abstraction for initialized declaration (semicolon-after (space-between (c:byte) (unparenthesize (c:= (star-before (c:fp e)) (c:& (c:subscript (c:. (c:initial-region e) (c:data)) (c:0)))))))) (newline-between (semicolon-after (space-between *length* (c:region-size e))) (semicolon-after (space-between (c:byte) (star-before (c:fp e))))))) (newline-between (c:define (c:big-region-size e) "8388608") (semicolon-after (space-between (c:byte) (c:raw-subscript (c:region e) (c:big-region-size e)))) ;; needs work: needs abstraction for initialized declaration (semicolon-after (space-between (c:byte) (if (reentrant? e) (unparenthesize (c:= (star-before (c:fp e)) (c:region e))) (star-before (c:fp e))))))) (c:noop))) *es*))) (define (compile-region-distribution) ;; needs work: To use code-generation abstractions. (newlines-between (map (lambda (e) (if (has-region? e) (cond (*expandable-regions?* (include! "Tmk") ;Tmk_distribute (newline-between (c:gosub "Tmk_distribute_hack" (c:& (c:initial-region e)) (c:sizeof (c:initial-region e))) (c:gosub "Tmk_distribute_hack" (c:& (c:region e)) (c:sizeof (c:region e))) (c:gosub "Tmk_distribute_hack" (c:& (c:region-size e)) (c:sizeof (c:region-size e))) (c:gosub "Tmk_distribute_hack" (c:& (c:fp e)) (c:sizeof (c:fp e))))) (else (include! "Tmk") ;Tmk_distribute (newline-between (c:gosub "Tmk_distribute_hack" (c:& (c:region e)) (c:sizeof (c:region e))) (c:gosub "Tmk_distribute_hack" (c:& (c:fp e)) (c:sizeof (c:fp e)))))) (c:noop))) *es*))) (define (compile-closures) ;; needs work: To use code-generation abstractions. (newlines-between (map (lambda (e) (case *closure-representation* ((immediate-flat) (unimplemented #f "Immediate flat closures are not (yet) implemented")) ((indirect-flat) (unimplemented #f "Indirect flat closures are not (yet) implemented")) ((immediate-display indirect-display) (if (has-parent-parameter? e) (semicolon-after (newline-between (space-between "struct" (c:p e)) (braces-around (newlines-between (map (lambda (e) (semicolon-after (space-between "struct" (c:e e) (star-before (c:e e))))) (ancestors e)))))) (c:noop))) ((linked) (c:noop)) (else (fuck-up)))) *es*))) (define (compile-type-declarations) ;; Check to see that the type declaration precedence graph is acyclic. ;; needs work: This double nested loop can be made more efficient. (when (some (lambda (w) (some (lambda (u) (and (structure-type-immediate? u) (memq w (structure-type-slots u)) (member? u w))) *structure-types*)) *ws*) (fuck-up)) ;; needs work: To use code-generation abstractions. (newline-between ;; Nonheaded and displaced vectors come first, in any order, because they ;; reference everything else with * and are always referenced without *. (newlines-between (map (lambda (u) (if (degenerate-vector-type? u) (c:noop) (semicolon-after (newline-between (space-between "struct" (c:u u)) (braces-around (newline-between (semicolon-after (space-between *length* "length")) (semicolon-after (c:type-set (nonheaded-vector-type-element u) (star-before "element"))))))))) *nonheaded-vector-types*)) (newlines-between (map (lambda (u) (if (degenerate-vector-type? u) (c:noop) (semicolon-after (newline-between (space-between "struct" (c:u u)) (braces-around (newline-between (semicolon-after (space-between *length* "length")) (semicolon-after (c:type-set (vector-type-element (displaced-vector-type-displaced-vector-type u)) (star-before "element"))))))))) *displaced-vector-types*)) (newlines-between (map (lambda (u/w) (cond ((type-set? u/w) (semicolon-after (newline-between (space-between "struct" (c:w u/w)) (braces-around (newline-between (semicolon-after (space-between *tag* "tag")) (if (has-union? u/w) (semicolon-after (newline-between "union" (space-between (braces-around (newlines-between (map (lambda (u) (semicolon-after (c:type u (c:u u)))) (members-that (lambda (u) (and (not (char-type? u)) (not (fictitious? u)))) u/w)))) "value"))) (semicolon-after (c:type (the-member-that (lambda (u) (and (not (char-type? u)) (not (fictitious? u)))) u/w) "value")))))))) ((structure-type? u/w) (semicolon-after (newline-between (space-between "struct" (c:u u/w)) (braces-around (newlines-between (map-indexed (lambda (w i) (if (fictitious? w) (c:noop) (semicolon-after (c:type-set w (c:s i))))) (structure-type-slots u/w))))))) (else (fuck-up)))) (topological-sort (lambda (u/w1 u/w2) (or ;; Immediate structures must come before unions that contain them. (and (structure-type? u/w1) (structure-type-immediate? u/w1) (type-set? u/w2) (member? u/w1 u/w2)) ;; Immediate structures must come before structures that have them ;; as slots. (and (structure-type? u/w1) (structure-type-immediate? u/w1) (structure-type? u/w2) (memq u/w1 (map the-member (remove-if-not monomorphic? (structure-type-slots u/w2))))) ;; Unions must come before structures that have them as slots. (and (type-set? u/w1) (structure-type? u/w2) (memq u/w1 (structure-type-slots u/w2))))) (append (remove-if fictitious? *structure-types*) (remove-if (lambda (w) (or (fictitious? w) (monomorphic? w) (tag-only? w) (squeezed? w) (squished? w))) *ws*))))) ;; Headed vectors come last, in any order, because they reference ;; everything else without * and are always referenced with *. (newlines-between (map (lambda (u) (if (degenerate-vector-type? u) (c:noop) (semicolon-after (newline-between (space-between "struct" (c:u u)) (braces-around (newline-between (semicolon-after (space-between *length* "length")) (semicolon-after (c:type-set (headed-vector-type-element u) (c:raw-subscript "element" "1"))))))))) *headed-vector-types*)))) (define (compile-closure-levels) ;; needs work: To use code-generation abstractions. (newlines-between (map (lambda (e) (if (has-closure? e) (case *closure-representation* ((immediate-flat) (unimplemented #f "Immediate flat closures are not (yet) implemented")) ((indirect-flat) (unimplemented #f "Indirect flat closures are not (yet) implemented")) ((immediate-display indirect-display) (semicolon-after (newline-between (space-between "struct" (c:e e)) (braces-around (newlines-between (map (lambda (g) (semicolon-after (c:type-set (variable-type-set g) (c:a g)))) (remove-if-not slotted? (variables e)))))))) ((linked) (semicolon-after (newline-between (space-between "struct" (c:p e)) (braces-around (newline-between (if (has-parent-slot? e) (semicolon-after (space-between "struct" (c:p (parent-slot e)) (star-before (c:p (parent-slot e))))) (c:noop)) (newlines-between (map (lambda (g) (semicolon-after (c:type-set (variable-type-set g) (c:a g)))) (remove-if-not slotted? (variables e))))))))) (else (fuck-up))) (c:noop))) *es*))) (define (compile-global-variables) (newlines-between (map (lambda (g) (c:declaration (variable-type-set g) (c:a g) (symbol->string (variable-name g)))) (remove-if-not global? *gs*)))) (define (compile-global-variable-distribution) (newlines-between (map (lambda (g) (include! "Tmk") ;Tmk_distribute (c:gosub "Tmk_distribute_hack" (c:& (c:a g)) (c:sizeof (c:a g)))) (remove-if-not global? *gs*)))) (define (compile-prototype-variables e) (when (unique-call-site? e) (fuck-up)) (if (environment-passes-parameters-globally? e) '() (let ((cs (map (lambda (g) (c:type-set (variable-type-set g) "")) (remove-if-not (lambda (g) (or (local? g) (slotted? g))) (variables e))))) (if (has-parent-parameter? e) (cons (c:type (environment-type e) "") cs) cs)))) (define (compile-parameter-variables e) (when (unique-call-site? e) (fuck-up)) (if (environment-passes-parameters-globally? e) '() (let ((cs (map (lambda (g) (c:type-set (variable-type-set g) (c:a g))) (remove-if-not (lambda (g) (or (local? g) (slotted? g))) (variables e))))) (if (has-parent-parameter? e) (cons (c:type (environment-type e) (c:p e)) cs) cs)))) (define (compile-in-lined-variables e) ;; needs work: Can eliminate the nonslotted nonparameter variable of an OR ;; that has been optimized away. (newlines-between (map (lambda (g) (c:declaration (variable-type-set g) (c:a g) (symbol->string (variable-name g)))) (remove-if-not (lambda (g) (or (local? g) (slotted? g))) (sort (reduce append (map variables (properly-in-lined-environments e)) '()) < variable-index))))) (define (spill-slotted-variables e) (newline-between (case *closure-representation* ((immediate-flat indirect-flat indirect-display immediate-display) (c:noop)) ((linked) (if (has-parent-slot? e) (c::= (c:-> (c:e e) (c:p (parent-slot e))) (parent-accessor e)) (c:noop))) (else (fuck-up))) (newlines-between (map (lambda (g) (case *closure-representation* ((immediate-flat) (unimplemented #f "Immediate flat closures are not (yet) implemented")) ((indirect-flat) (unimplemented #f "Indirect flat closures are not (yet) implemented")) ((indirect-display immediate-display linked) (c::= (c:-> (c:e e) (c:a g)) (c:a g))) (else (fuck-up)))) (remove-if-not slotted? (variables e)))))) (define *statements-per-constant-initialization-procedure* 3000) (define (compile-constant-initialization-procedure-prototypes) (newlines-between (map-n (lambda (i) (space-between "void" (c:prototype (c:initialize-constants i)))) (inexact->exact (ceiling (/ (length *inside-main*) (exact->inexact *statements-per-constant-initialization-procedure*))))))) (define (compile-native-procedure-prototypes) (newlines-between (map (lambda (e) (if (unique-call-site? e) (c:noop) (let* ((cs (compile-prototype-variables e)) (c (apply (if (or (environment-returns? e) (environment-passes-parameters-globally? e) ;; needs work: This is a bit overly conservative. (some environment-passes-parameters-globally? (callees e))) c:prototype c:noreturn-prototype) (c:f e) cs))) (newline-between (if (or (fictitious? (return-type-set e)) (not (expression-accessed? (expression-body (environment-expression e))))) ;; needs work: To use code-generation abstractions. (space-between "void" c) (c:type-set (return-type-set e) c)) (if (environment-passes-parameters-globally? e) (newline-between (if (has-parent-parameter? e) (semicolon-after (c:type (environment-type e) (c:d e))) (c:noop)) (newlines-between (map (lambda (g) (space-between (semicolon-after (c:type-set (variable-type-set g) (c:b g))) (c:/**/ (symbol->string (variable-name g))))) (remove-if-not (lambda (g) (or (local? g) (slotted? g))) (variables e))))) (c:noop)))))) *es*))) (define (compile-foreign-procedure-prototypes) (newlines-between (map (lambda (u) (if (foreign-procedure-type-called? u) (cond ((foreign-procedure-type-include u) (include! (foreign-procedure-type-include u)) (c:noop)) (else (c:foreign-type (foreign-procedure-type-result u) (apply (if (foreign-procedure-returns? u) c:prototype c:noreturn-prototype) (foreign-procedure-type-name u) (map (lambda (f) (c:foreign-type f "")) (foreign-procedure-type-parameters u)))))) (c:noop))) *foreign-procedure-types*))) (define *li* #f) (define (allocate-label) (let ((l (c:l *li*))) (set! *li* (+ *li* 1)) l)) (define (compile-goto l1 l2) (cond ((eq? l1 l2) (c:noop)) (else (unless l1 (fuck-up)) (c:goto l1)))) (define (unreturnify r) (if (return? r) (if (result-accessed? r) (create-accessor-result (result-type-set r) (result-c r)) *discard*) r)) (define (contains? c1 c2) (or (eq? c1 c2) (and (pair? c1) (or (contains? (car c1) c2) (contains? (cdr c1) c2))))) (define (compile-foreign-call r y u ts ws) (let ((ts (if (converted? y) (rest ts) ts)) (ws (if (converted? y) (rest ws) ws))) (let loop ((fs1 (foreign-procedure-type-parameters u)) (ts1 ts) (us1 '()) (ws1 ws)) (if (null? fs1) (move-strict r (apply c:call (foreign-procedure-type-name u) (map c:value ts (reverse us1) ws)) (foreign-procedure-return-type-set u)) (type-switch (foreign-type? (first fs1)) (first ws1) r (first ts1) (lambda (u0) (loop (rest fs1) (rest ts1) (cons u0 us1) (rest ws1))) (lambda (p?) (compile-error "foreign_call" y p?))))))) (define (compile-pair+ r y ts ws t w) (cond ((discard? r) (c:noop)) ((antecedent? r) (compile-goto (result-l1 r) (result-l0 r))) ((null? ws) (move r t w)) (else (let loop ((uss (map members ws)) (w1 (result-type-set r)) (us1 '()) (ws1 '())) (if (null? uss) (let loop ((ts (reverse ts)) (ws (reverse ws)) (ts1 (reverse (cons (result-c r) (map allocate-temporary (rest (reverse ws1)))))) (us1 us1) (ws1 ws1) (c (c:noop)) (t t) (w w)) (if (null? ts) (newline-between c (compile-return r)) (let ((t2 (first ts)) (w2 (first ws)) (t1 (first ts1)) (u1 (first us1)) (w1 (first ws1))) (loop (rest ts) (rest ws) (rest ts1) (rest us1) (rest ws1) (newline-between c (cond ((or (fictitious? w1) (and (return? r) (not (result-accessed? r)))) (c:noop)) ((fictitious? u1) (widen-type (create-accessor-result w1 t1) 'void10 u1)) (else (newline-between (compile-allocate-structure t1 u1 w1 y) (move (create-accessor-result (pair-type-car u1) (value-car t1 u1 w1)) t2 w2) (move (create-accessor-result (pair-type-cdr u1) (value-cdr t1 u1 w1)) t w))))) t1 w1)))) (let ((u1 (the-member-that (pair+-type? uss (members w) (call-site-expression y)) w1))) (loop (rest uss) (pair-type-cdr u1) (cons u1 us1) (cons w1 ws1)))))))) (define (compile-initialize-region e) (if (has-region? e) (if (reentrant? e) (c::= (c:sfp e) (c:fp e)) (newline-between (cond (*treadmarks?* (include! "Tmk") ;Tmk_lock_acquire (c:gosub "Tmk_lock_acquire" (c:0))) (else (c:noop))) (if *expandable-regions?* (newline-between (c:while (c:!= (c:region e) ;; needs work: To use code-generation abstractions. (c:cast (space-between "struct" (c:region e) "*") (c:& (c:initial-region e)))) (newline-between (semicolon-after ;; needs work: To use code-generation abstractions. (space-between "struct" (c:region e) (star-before (c:region)))) (c::= (c:region) (c:region e)) (c::= (c:region e) (c:-> (c:region e) (c:region))) (if *memory-messages?* (c:printf (c:string (format #f "Freeing region segment for ~a~%" (environment-name e)))) (c:noop)) (c:free (c:region) (has-nonatomic-region? e)))) (c::= (c:region-size e) (c:big-region-size e)) (c::= (c:fp e) (c:& (c:subscript (c:-> (c:region e) (c:data)) (c:0))))) (c::= (c:fp e) (c:region e))) (c:align (c:fp e)) (cond (*treadmarks?* (include! "Tmk") ;Tmk_lock_release (c:gosub "Tmk_lock_release" (c:0))) (else (c:noop))))) (c:noop))) (define (gather e0 y ts ws t w ts1 gs) (let loop ((ts ts) (ws ws) (t t) (w w) (ts1 ts1) (gs gs)) (if (null? gs) (type-switch null-type? w *discard* t (lambda (u) (c:noop)) (lambda (p?) (compile-error "call" y p?))) (let* ((g (first gs)) (c (cond ((and (pair? ts1) (or (local? g) (slotted? g))) (first ts1)) ((and (eq? ts1 #t) (not (global? g))) (c:b g)) ;; note: This must assign to the parameters and not the ;; slots since the self-tail-call entry point can't ;; come after the closure level allocation and spill ;; since that would unsoundly overwrite the existing ;; closure. cpstak.sc is an example of this. (else (c:a g))))) (if (null? ws) (if (and (rest? e0) (null? (rest gs))) (if (or (local? g) (global? g) (slotted? g)) (move (create-accessor-result (variable-type-set g) c) t w) (c:noop)) (type-switch pair-type? w *discard* t (lambda (u) (newline-between (if (or (local? g) (global? g) (slotted? g)) (move (create-accessor-result (variable-type-set g) c) (value-car t u w) (pair-type-car u)) (c:noop)) (loop ts ws (value-cdr t u w) (pair-type-cdr u) (if (and (pair? ts1) (or (local? g) (slotted? g))) (rest ts1) ts1) (rest gs)))) (lambda (p?) (compile-error "call" y p?)))) (if (and (rest? e0) (null? (rest gs))) (if (or (local? g) (global? g) (slotted? g)) (compile-pair+ (create-accessor-result (variable-type-set g) c) y ts ws t w) (c:noop)) ;; This is written this way, in a non-factored fashion, so that ;; the last call to LOOP, which is the common case, is a tail ;; call. When this was previously written in a factored fashion ;; Trotsky would give a stack overflow when compiling ;; benchmarks-to-latex.sc which is the only example, except for ;; Marx, that I tried under Trotsky that had included ;; QobiScheme. (If (and (or (local? g) (global? g) (slotted? g)) (not (eq? c (first ts)))) (newline-between (move (create-accessor-result (variable-type-set g) c) (first ts) (first ws)) (loop (rest ts) (rest ws) t w (if (and (pair? ts1) (or (local? g) (slotted? g))) (rest ts1) ts1) (rest gs))) (loop (rest ts) (rest ws) t w (if (and (pair? ts1) (or (local? g) (slotted? g))) (rest ts1) ts1) (rest gs))))))))) (define (compile-call r y t0 u0 w0 t1 w1 ts ws t w) ;; There is something slightly inefficient with the way rest arguments are ;; handled. Currently they are allocated by the caller, not the callee. So ;; if they never leave the callee they could have been allocated on the region ;; or the stack frame of the callee but they aren't. Instead, they will be ;; allocated on the region or the stack frame of the caller. If the caller ;; calls the callee in a loop before returning, this can delay storage ;; reclamation. It is for this same reason that you don't want the caller to ;; allocate the environment but rather you want the callee to allocate the ;; environment, which is how it is done now. Also, having the callee allocate ;; the environment and/or rest argument factors out common code. (cond ((primitive-procedure-type? u0) (when (can-be-non? null-type? w) (fuck-up)) (if (some void? ws) (compile-error "void_primitive_procedure_call" y #t) ((primitive-procedure-compile-call (cdr (assq (primitive-procedure-type-name u0) *primitive-procedure-handlers*))) r y u0 ts ws t w (lambda (m) (compile-predicate m r (first ws) (first ts))) t1 w1 (if (>= (length ws) 1) (first ts) #f) (if (>= (length ws) 1) (first ws) #f) (if (>= (length ws) 2) (second ts) #f) (if (>= (length ws) 2) (second ws) #f) (if (>= (length ws) 3) (third ts) #f) (if (>= (length ws) 3) (third ws) #f)))) ((native-procedure-type? u0) (let* ((e (expression-environment (call-site-expression y))) (e0 (callee-environment u0 y)) (x0 (environment-expression e0)) (gs (variables e0))) (cond ((not (called? e0)) ;; We should never get here because the callee or the arguments don't ;; return. Actually, if we ever fix up the unlinking of structures then ;; E0 should not even exist at this point. (c:noop)) ((noop? e0) (compile-return r)) ((can-be-self-tail-call-to? y e0) (newline-between ;; I'm not sure that the following is needed. (if (has-parent-parameter? e0) (c::= (c:p e0) (c:value t0 u0 w0)) (c:noop)) (gather e0 y ts ws t w #f gs) (c:goto (c:h e0)))) ((unique-call-site? e0) (newline-between (if (has-parent-parameter? e0) (c::= (c:p e0) (c:value t0 u0 w0)) (c:noop)) (gather e0 y ts ws t w #f gs) (newline-between (compile-initialize-region e0) (if (has-self-tail-call? e0) (c:: (c:h e0)) (c:noop)) ;; note: The self-tail-call entry point can't come after the closure ;; level allocation and spill since that would unsoundly ;; overwrite the existing closure. ;; cpstak.sc is an example of this. (if (has-closure? e0) (newline-between (compile-allocate-closure-level e0) (spill-slotted-variables e0)) (c:noop)) (if (restore? e0) (newline-between (compile (unreturnify r) (expression-body x0)) (compile-restore e0) (compile-return r)) (compile r (expression-body x0)))))) ((environment-passes-parameters-globally? e0) (let* ((c (c:call (c:f e0)))) (newline-between (if (has-parent-parameter? e0) (c::= (c:d e0) (c:value t0 u0 w0)) (c:noop)) (gather e0 y ts ws t w #t gs) (if (expression-accessed? (expression-body (environment-expression e0))) (if (or (discard? r) (antecedent? r) (eq? (result-type-set r) (return-type-set e0))) (if (and (return? r) (restore? r)) (newline-between (move-strict (unreturnify r) c (return-type-set e0)) (compile-return r)) (move-strict r c (return-type-set e0))) (let ((t (allocate-temporary (return-type-set e0)))) (newline-between (move-strict (create-accessor-result (return-type-set e0) t) c (return-type-set e0)) (move r t (return-type-set e0))))) (newline-between (semicolon-after c) (compile-return r)))))) (else (let* ((ts1 (if (and (must-be? null-type? w) (not (rest? e0))) ;; This is a small amount of copy propagation. (removeq #f (map (lambda (g w t) (if (or (local? g) (slotted? g)) (if (eq? w (variable-type-set g)) t (allocate-temporary (variable-type-set g))) #f)) gs ws ts)) (removeq #f (map (lambda (g) (if (or (local? g) (slotted? g)) (allocate-temporary (variable-type-set g)) #f)) gs)))) (c (if (has-parent-parameter? e0) (apply c:call (c:f e0) (c:value t0 u0 w0) ts1) (apply c:call (c:f e0) ts1)))) (newline-between (gather e0 y ts ws t w ts1 gs) (if (expression-accessed? (expression-body (environment-expression e0))) (if (or (discard? r) (antecedent? r) (eq? (result-type-set r) (return-type-set e0))) (if (and (return? r) (restore? r)) (newline-between (move-strict (unreturnify r) c (return-type-set e0)) (compile-return r)) (move-strict r c (return-type-set e0))) (let ((t (allocate-temporary (return-type-set e0)))) (newline-between (move-strict (create-accessor-result (return-type-set e0) t) c (return-type-set e0)) (move r t (return-type-set e0))))) (newline-between (semicolon-after c) (if (and (native-procedure-type? u0) (converted-continuation? (callee-environment u0 y))) ;; This case was instituted to fix the bug in except.sc. I'm ;; not sure that this is the correct was to fix the bug. And I ;; don't know if we need to do a compile-restore here. (c:return) (compile-return r)))))))))) ((foreign-procedure-type? u0) (when (can-be-non? null-type? w) (unimplemented y "APPLY of a foreign procedure is not (yet) implemented")) (cond ((not (foreign-procedure-type-called? u0)) ;; We should never get here because the callee or the arguments don't ;; return. (c:noop)) ((some void? ws) (compile-error "void_foreign_procedure_call" y #t)) (else (compile-foreign-call r y u0 ts ws)))) ((continuation-type? u0) ;; needs work: A call to a continuation should restore all intervening ;; reentrant regions. Because we don't do this (yet), we need ;; HAS-EXTERNAL-CALL? to prevent allocation on intervening ;; reentrant regions because otherwise there would be a memory ;; leak when a call to this continuation occurs. (when (can-be-non? null-type? w) (unimplemented y "APPLY of a continuation is not (yet) implemented")) (let ((t1 (if (converted? y) (second ts) (first ts))) (w1 (if (converted? y) (second ws) (first ws)))) (cond ((not (continuation-type-continuation-accessed? u0)) ;; We should never get here because the callee or the arguments don't ;; return. (c:noop)) ((goto? y u0) (newline-between ;; needs work: EXPRESSION-RESULT might not be set yet since we might ;; not yet have COMPILEd ;; (CONTINUATION-TYPE-ALLOCATING-EXPRESSION U0). (move (expression-result (continuation-type-allocating-expression u0)) t1 w1) (if (return? (expression-result (continuation-type-allocating-expression u0))) (c:noop) (c:goto (c:x (continuation-type-allocating-expression u0)))))) (else (newline-between (move (if (or (fictitious? (expression-type-set (continuation-type-allocating-expression u0))) (not (expression-accessed? (continuation-type-allocating-expression u0)))) *discard* (create-accessor-result (expression-type-set (continuation-type-allocating-expression u0)) (c:v (continuation-type-allocating-expression u0)))) t1 w1) (c:longjmp (c:* (c:value t0 u0 w0)) (c:1))))))) (else (fuck-up)))) (define (continuation-argument-type-set u y) (unless (native-procedure-type? u) (fuck-up)) (first-parameter-type-set (callee-environment u (recreate-call-site y 'continuation-argument)))) (define (compile-converted-call r y t0 u0 w0 ts ws t w) (unless (procedure-type? u0) (fuck-up)) (when (continuation-type? u0) (unimplemented y "unimplemented")) (cond ;; CALL/CC==(LAMBDA (C X) (X C C)) (((primitive-procedure-type-named? 'call-with-current-continuation) u0) (when (can-be-non? null-type? w) (fuck-up)) (when #f ;debugging (when (can-be? (lambda (u2) (and ((compatible-procedure? (list (first ws)) *null* (recreate-call-site y 'first-argument)) u2) (not (converted? (callee-environment u2 y))))) (second ws)) (unimplemented y "unimplemented"))) (type-switch (compatible-procedure? (list (first ws) (first ws)) *null* (recreate-call-site y 'first-argument)) (second ws) r (second ts) (lambda (u2) (compile-converted-call r (recreate-call-site y 'first-argument) (second ts) u2 (second ws) (list (first ts) (first ts)) (list (first ws) (first ws)) 'void11 *null*)) (lambda (p?) (compile-error "call_with_current_continuation" y p?)))) ((and (native-procedure-type? u0) (converted? (callee-environment u0 y))) (compile-call r y t0 u0 w0 (first ts) (first ws) ts ws t w)) (((needs-implicit-continuation-call? ws w y) u0) (let* ((w1 (minp subtype-set? (map (lambda (u) (continuation-argument-type-set u y)) (members (first ws))))) (t1 (allocate-temporary w1))) (when (can-be-non? (lambda (u) (subtype-set? w1 (continuation-argument-type-set u y))) (first ws)) (fuck-up)) (newline-between (compile-call (if (fictitious? w1) *discard* (create-accessor-result w1 t1)) y t0 u0 w0 (first ts) (first ws) (rest ts) (rest ws) t w) ;; This relies on the fact that the implicit continuation call is never ;; done through APPLY. (type-switch (compatible-procedure? (list w1) *null* (recreate-call-site y 'continuation-argument)) (first ws) r (first ts) (lambda (u1) (compile-call r (recreate-call-site y 'continuation-argument) (first ts) u1 (first ws) #f #f (list t1) (list w1) 'void12 *null*)) (lambda (p?) (c:noop)))))) (else (compile-call r y t0 u0 w0 (first ts) (first ws) (rest ts) (rest ws) t w)))) (define (compile-antecedent x l1 l2 l0) ;; If the antecedent is true branch to L1 otherwise branch to L2 assuming ;; that L0 is the immediately following label so that no branch is generated ;; to that label and flow falls through instead. ;; needs work: To ignore body of a lambda expression that appears in an ;; optimized antecedent. ;; needs work: To not generate constants that are used in an optimized ;; antecedent. (compile (create-antecedent-result (expression-type-set x) l1 l2 l0) x)) (define (and-expression? x) ;; (IF x y #F) (and (eq? (expression-kind x) 'if) (eq? (expression-kind (expression-alternate x)) 'false-constant))) (define (or-expression? x) ;; ((LAMBDA (X) (IF X X y)) x) (and (eq? (expression-kind x) 'call) (= (length (expression-arguments x)) 1) (let ((w (expression-type-set (expression-callee x)))) (and (monomorphic? w) (let ((u (the-member w))) (and (native-procedure-type? u) ((compatible-call? x) u) (let ((e0 (callee-environment u (create-call-site x)))) (and (called? e0) (not (noop? e0)) (unique-call-site? e0) (let ((x0 (environment-expression e0))) (and (not (rest? x0)) (= (length (variables x0)) 1) (let ((x1 (expression-body x0))) (and (eq? (expression-kind x1) 'if) (eq? (expression-kind (expression-antecedent x1)) 'access) (eq? (expression-kind (expression-consequent x1)) 'access) (eq? (expression-variable (expression-antecedent x1)) (expression-variable (expression-consequent x1))) (eq? (expression-variable (expression-antecedent x1)) (first (variables x0))))))))))))))) (define (not-expression? x) ;; (NOT x) (and (eq? (expression-kind x) 'call) (= (length (expression-arguments x)) 1) (can-be? (primitive-procedure-type-named? 'not) (expression-type-set (expression-callee x))) (must-be? (primitive-procedure-type-named? 'not) (expression-type-set (expression-callee x))))) (define (maybe-mark-no-return x c) (let ((c (newline-between (if (expression-pathname x) (c:/**/ (string-append "x" (number->string (expression-index x)) " " (strip-directory (expression-pathname x)) ":" (number->string (expression-line-position x)) ":" (number->string (expression-character-position x)))) (c:/**/ (string-append "x" (number->string (expression-index x))))) c))) (if (expression-returns? x) c (c:no-return c)))) (define (compile r x) (clock-sample) ;To prevent overflow. (set-expression-result! x r) (maybe-mark-no-return x (let ((e (expression-environment x))) (if (and (not (antecedent? r)) (must-be? boolean-type? (expression-type-set x)) (can-be-non? true-type? (expression-type-set x)) (can-be-non? false-type? (expression-type-set x)) (or (and-expression? x) (or-expression? x) (not-expression? x))) (let* ((l1 (allocate-label)) (l2 (allocate-label)) (l3 (allocate-label)) (c (compile-antecedent x l1 l2 l1))) (newline-between c (if (contains? c l1) (c:: l1) (c:noop)) (return-true r) (if (return? r) (c:noop) (compile-goto l3 l2)) (c:: l2) (return-false r) (if (return? r) (c:noop) (c:: l3)))) (case (expression-kind x) ((null-constant) (widen r 'void13 null-type?)) ((true-constant) (return-true r)) ((false-constant) (return-false r)) ((char-constant) (widen r (c:character (expression-constant x)) char-type?)) ((fixnum-constant) (widen r (c:fixnum (expression-constant x)) fixnum-type?)) ((flonum-constant) (widen r (c:flonum (expression-constant x)) flonum-type?)) ((rectangular-constant) (unimplemented y "Cannot (yet) handle rectangular constants")) ((string-constant) (when (some (lambda (c) (zero? (char->integer c))) (string->list (expression-constant x))) (unimplemented x "Strings that contain ASCII NULs are not (yet) implemented")) (widen r (c:string (expression-constant x)) string-type?)) ((symbol-constant) (cond (*treat-all-symbols-as-external?* (unless (memq (expression-constant x) *symbols*) (set! *symbols* (append *symbols* (list (expression-constant x)))) (outside-main ;; needs work: needs abstraction for initialized declaration (semicolon-after (space-between *char* (unparenthesize (c:= (star-before (c:q (positionq (expression-constant x) *symbols*))) (c:string (symbol->string (expression-constant x))))))))) (widen r (c:q (positionq (expression-constant x) *symbols*)) (lambda (u) (and (external-symbol-type? u) (eq? (external-symbol-type-displaced-string-type u) ))))) (else (widen r 'void14 (internal-symbol-type-named? (expression-constant x)))))) ((pair-constant) ;; This is THE-MEMBER-THAT and not THE-MEMBER because when ;; *INDEX-CONSTANT-STRUCTURE-TYPES-BY-EXPRESSION?* is true the ;; expression type set might not be a singleton. (let ((u (the-member-that (lambda (u) (and (pair-type? u) (subtype-set? (expression-type-set (car (expression-constant x))) (pair-type-car u)) (subtype-set? (expression-type-set (cdr (expression-constant x))) (pair-type-cdr u)))) (expression-type-set x)))) (if (fictitious? u) (widen-type r 'void15 u) (let ((w1 (pair-type-car u)) (w2 (pair-type-cdr u))) (if (structure-type-immediate? u) (cond ((discard? r) (c:noop)) ((antecedent? r) (compile-goto (result-l1 r) (result-l0 r))) ((and (return? r) (not (result-accessed? r))) (compile-return r)) (else (newline-between (if (and (multimorphic? (result-type-set r)) (not (squeezed? (result-type-set r))) (not (squished? (result-type-set r)))) (c::= (c:tag (result-c r) (result-type-set r)) (c:type-tag u)) (c:noop)) (if (fictitious? w1) (c:noop) (compile (create-accessor-result w1 (value-car (result-c r) u (result-type-set r))) (car (expression-constant x)))) (if (fictitious? w2) (c:noop) (compile (create-accessor-result w2 (value-cdr (result-c r) u (result-type-set r))) (cdr (expression-constant x)))) (compile-return r)))) (let ((t (c:t *ti*))) (set! *ti* (+ *ti* 1)) (outside-main (semicolon-after (c:type& u t))) (unless (fictitious? w1) (inside-main (compile (create-accessor-result w1 (c:. t (c:s 0))) (car (expression-constant x))))) (unless (fictitious? w2) (inside-main (compile (create-accessor-result w2 (c:. t (c:s 1))) (cdr (expression-constant x))))) (widen-type r (c:& t) u))))))) ((vector-constant) ;; This is THE-MEMBER-THAT and not THE-MEMBER because when ;; *INDEX-CONSTANT-HEADED-VECTOR-TYPES-BY-EXPRESSION?* is true the ;; expression type set might not be a singleton. (let ((u (the-member-that (lambda (u) (and (headed-vector-type? u) (every-vector (lambda (x) (subtype-set? (expression-type-set x) (headed-vector-type-element u))) (expression-constant x)))) (expression-type-set x)))) (if (degenerate-vector-type? u) (widen-type r (c:fixnum (vector-length (expression-constant x))) u) ;; needs work: To use code-generation abstractions. (let ((t (c:t *ti*)) (w1 (headed-vector-type-element u))) (set! *ti* (+ *ti* 1)) (outside-main (semicolon-after (newline-between "struct" (space-between (braces-around (newline-between (semicolon-after (space-between *length* "length")) (semicolon-after (c:type-set w1 (c:raw-subscript "element" (c:fixnum (max 1 (vector-length (expression-constant x))))))))) t)))) (inside-main (c::= (c:. t "length") (c:fixnum (vector-length (expression-constant x))))) (for-each-n (lambda (i) (inside-main (compile (create-accessor-result w1 (c:subscript (c:. t "element") (c:fixnum i))) (vector-ref (expression-constant x) i)))) (vector-length (expression-constant x))) (widen-type r (c:type-cast (c:& t) u) u))))) ((lambda converted-lambda converted-continuation) (let ((u (the-member (expression-type-set x)))) (cond ((discard? r) (c:noop)) ((antecedent? r) (compile-goto (result-l1 r) (result-l0 r))) ((and (return? r) (not (result-accessed? r))) (compile-return r)) ((fictitious? u) (widen-type r 'void16 u)) (else (case *closure-representation* ((immediate-flat) (unimplemented x "Immediate flat closures are not (yet) implemented")) ((indirect-flat) (unimplemented x "Indirect flat closures are not (yet) implemented")) ((immediate-display) (when (or (squeezed? (result-type-set r)) (squished? (result-type-set r))) (fuck-up)) (newline-between (if (multimorphic? (result-type-set r)) (c::= (c:tag (result-c r) (result-type-set r)) (c:type-tag u)) (c:noop)) (newlines-between (map (lambda (e1) (c::= (c:. (c:value (result-c r) u (result-type-set r)) (c:e e1)) (if (eq? e1 e) (c:e e1) (c:. (c:p e) (c:e e1))))) (ancestors u))))) ((indirect-display) ;; needs work: To allocate the closure. (unimplemented x "Indirect display closures are not (yet) implemented") (when (or (squeezed? (result-type-set r)) (squished? (result-type-set r))) (fuck-up)) (newline-between (if (multimorphic? (result-type-set r)) (c::= (c:tag (result-c r) (result-type-set r)) (c:type-tag u)) (c:noop)) (newlines-between (map (lambda (e1) (c::= (c:-> (c:value (result-c r) u (result-type-set r)) (c:e e1)) (if (eq? e1 e) (c:e e1) (c:-> (c:p e) (c:e e1))))) (ancestors u))))) ((linked) (widen-type r (lambda-accessor u e) u)) (else (fuck-up))))))) ((set!) (newline-between (compile (if (and (or (local? (expression-variable x)) (global? (expression-variable x)) (slotted? (expression-variable x))) (nontrivial-reference? x) (executed? x)) (create-accessor-result (variable-type-set (expression-variable x)) (accessor (expression-variable x) e)) *discard*) (expression-source x)) (if (expression-returns? x) (compile-return r) (c:noop)))) ((if) (if (and (antecedent? r) (and-expression? x)) (if (reached? (expression-consequent x)) (if (reached? (expression-alternate x)) (let* ((l3 (allocate-label)) (c (compile-antecedent (expression-antecedent x) l3 (result-l2 r) l3))) (newline-between c (if (contains? c l3) (c:: l3) (c:noop)) (compile-antecedent (expression-consequent x) (result-l1 r) (result-l2 r) (result-l0 r)))) (let* ((l3 (allocate-label)) (c (compile-antecedent (expression-antecedent x) l3 #f l3))) (newline-between c (if (contains? c l3) (c:: l3) (c:noop)) (compile-antecedent (expression-consequent x) (result-l1 r) (result-l2 r) (result-l0 r))))) (if (reached? (expression-alternate x)) (compile-antecedent (expression-antecedent x) #f (result-l2 r) (result-l0 r)) (compile-antecedent (expression-antecedent x) #f #f (result-l0 r)))) (let ((w (expression-type-set (expression-antecedent x)))) (if (reached? (expression-consequent x)) (if (reached? (expression-alternate x)) (if (or (return? r) ;; needs work: This is an attempt to eliminate ;; the dead branch around the ;; alternate if the consequent is a ;; self tail call. But it sometimes ;; fails as in kilo/browse.sc. The ;; reason this fails is because the ;; consequent is not a self tail ;; call but an IF whose both reached ;; branches are self tail calls, a ;; call to an in in-lined procedure ;; whose body is a self tail call, ;; or some combination thereof. ;; Anyway, should also eliminate the ;; dead branch when the consequent ;; doesn't return as would be the ;; case if it were a call to a ;; continuation. ;; This can't be ANTECEDENT? here ;; because antecedent results can ;; fall through. (must-be-self-tail-call? (expression-consequent x))) (let* ((l1 (allocate-label)) (l2 (allocate-label)) (c (compile-antecedent (expression-antecedent x) l1 l2 l1))) (newline-between c (if (contains? c l1) (c:: l1) (c:noop)) (compile r (expression-consequent x)) (c:: l2) (compile r (expression-alternate x)))) (let* ((l1 (allocate-label)) (l2 (allocate-label)) (l3 (allocate-label)) (c (compile-antecedent (expression-antecedent x) l1 l2 l1))) (newline-between c (if (contains? c l1) (c:: l1) (c:noop)) (compile r (expression-consequent x)) (compile-goto l3 l2) (c:: l2) (compile r (expression-alternate x)) (c:: l3)))) (let* ((l1 (allocate-label)) (c (compile-antecedent (expression-antecedent x) l1 #f l1))) (newline-between c (if (contains? c l1) (c:: l1) (c:noop)) (compile r (expression-consequent x))))) (if (reached? (expression-alternate x)) (let* ((l1 (allocate-label)) (c (compile-antecedent (expression-antecedent x) #f l1 l1))) (newline-between c (if (contains? c l1) (c:: l1) (c:noop)) (compile r (expression-alternate x)))) (newline-between (compile-antecedent (expression-antecedent x) #f #f #f) (if (expression-returns? (expression-antecedent x)) (compile-error "void_if" x #t) (c:noop)))))))) ((primitive-procedure) (widen-type r 'void17 (the-member (expression-type-set x)))) ((foreign-procedure) (widen-type r 'void18 (the-member (expression-type-set x)))) ((access) (if (expression-accessed? x) (cond ((and (hidden? (expression-variable x)) (not (discard? r)) (not (antecedent? r))) (case *closure-representation* ((immediate-flat) (unimplemented x "Immediate flat closures are not (yet) implemented")) ((indirect-flat) (unimplemented x "Indirect flat closures are not (yet) implemented")) ((immediate-display) (when (or (squeezed? (result-type-set r)) (squished? (result-type-set r))) (fuck-up)) (let ((u (the-member (variable-type-set (expression-variable x))))) (newline-between (if (multimorphic? (result-type-set r)) (c::= (c:tag (result-c r) (result-type-set r)) (c:type-tag u)) (c:noop)) (newlines-between (map (lambda (e1) (c::= (c:. (c:value (result-c r) u (result-type-set r)) (c:e e1)) (if (eq? e1 e) (c:e e1) (c:. (c:p e) (c:e e1))))) (ancestors u)))))) ((indirect-display) ;; note: Accessing a hidden variable with indirect ;; display closures requires consing. ;; needs work: To allocate the closure. (unimplemented x "Indirect display closures are not (yet) implemented") (when (or (squeezed? (result-type-set r)) (squished? (result-type-set r))) (fuck-up)) (let ((u (the-member (variable-type-set (expression-variable x))))) (newline-between (if (multimorphic? (result-type-set r)) (c::= (c:tag (result-c r) (result-type-set r)) (c:type-tag u)) (c:noop)) (newlines-between (map (lambda (e1) (c::= (c:-> (c:value (result-c r) u (result-type-set r)) (c:e e1)) (if (eq? e1 e) (c:e e1) (c:-> (c:p e) (c:e e1))))) (ancestors u)))))) ((linked) (move-access r (accessor (expression-variable x) e) (variable-type-set (expression-variable x)) (expression-type-set x))) (else (fuck-up)))) (else (move-access r (if (or (fictitious? (variable-type-set (expression-variable x))) (hidden? (expression-variable x))) 'void19 (accessor (expression-variable x) e)) (variable-type-set (expression-variable x)) (expression-type-set x)))) (compile-return r))) ((call converted-call) (cond ((and (antecedent? r) (or-expression? x)) (let* ((u (the-member (expression-type-set (expression-callee x)))) (e0 (callee-environment u (create-call-site x))) (x0 (environment-expression e0)) (x1 (expression-body x0)) (x2 (first (expression-arguments x))) (e1 (expression-environment x))) (if (reached? (expression-consequent x1)) (if (reached? (expression-alternate x1)) (let* ((l3 (allocate-label)) (c (compile-antecedent x2 (result-l1 r) l3 l3))) (newline-between c (if (contains? c l3) (c:: l3) (c:noop)) (compile-initialize-region e0) (if (has-parent-parameter? e0) (case *closure-representation* ((immediate-flat) (unimplemented x "Immediate flat closures are not (yet) implemented")) ((indirect-flat) (unimplemented x "Indirect flat closures are not (yet) implemented")) ((immediate-display) (newlines-between (map (lambda (e) (c::= (c:. (c:p e0) (c:e e)) (if (eq? e e1) (c:e e) (c:. (c:p e1) (c:e e))))) (ancestors u)))) ((indirect-display) ;; needs work: To allocate the closure. (unimplemented x "Indirect display closures are not (yet) implemented") (newlines-between (map (lambda (e) (c::= (c:-> (c:p e0) (c:e e)) (if (eq? e e1) (c:e e) (c:-> (c:p e1) (c:e e))))) (ancestors u)))) ((linked) (c::= (c:p e0) (lambda-accessor u e))) (else (fuck-up))) (c:noop)) ;; needs work: There can be a memory leak here if E0 is ;; reentrant and has a region because there ;; is no (COMPILE-RESTORE E0). (compile-antecedent (expression-alternate x1) (result-l1 r) (result-l2 r) (result-l0 r)))) (compile-antecedent x2 (result-l1 r) #f (result-l0 r))) (if (reached? (expression-alternate x1)) (let* ((l3 (allocate-label)) (c (compile-antecedent x2 #f l3 l3))) (newline-between c (if (contains? c l3) (c:: l3) (c:noop)) (compile-initialize-region e0) (if (has-parent-parameter? e0) (case *closure-representation* ((immediate-flat) (unimplemented x "Immediate flat closures are not (yet) implemented")) ((indirect-flat) (unimplemented x "Indirect flat closures are not (yet) implemented")) ((immediate-display) (newlines-between (map (lambda (e) (c::= (c:. (c:p e0) (c:e e)) (if (eq? e e1) (c:e e) (c:. (c:p e1) (c:e e))))) (ancestors u)))) ((indirect-display) ;; needs work: To allocate the closure. (unimplemented x "Indirect display closures are not (yet) implemented") (newlines-between (map (lambda (e) (c::= (c:-> (c:p e0) (c:e e)) (if (eq? e e1) (c:e e) (c:-> (c:p e1) (c:e e))))) (ancestors u)))) ((linked) (c::= (c:p e0) (lambda-accessor u e))) (else (fuck-up))) (c:noop)) ;; needs work: There can be a memory leak here if E0 is ;; reentrant and has a region because there ;; is no (COMPILE-RESTORE E0). (compile-antecedent (expression-alternate x1) (result-l1 r) (result-l2 r) (result-l0 r)))) (compile-antecedent x2 #f #f (result-l0 r)))))) ((and (antecedent? r) (not-expression? x)) (compile-antecedent (first (expression-arguments x)) (result-l2 r) (result-l1 r) (result-l0 r))) (else (let* ((w0 (expression-type-set (expression-callee x))) (ws (map expression-type-set (expression-arguments x))) (t0 (allocate-temporary w0)) (ts (map allocate-temporary ws))) (newline-between ;; needs work: Should not evaluate any arguments if callee doesn't ;; return and should not evaluate an argument that ;; follows an argument that doesn't return. This ;; assumes a left-to-right evaluation order. As Olin ;; Shivers pointed out, since evaluation order is ;; unspecified you can abort if any subexpression ;; doesn't return. But given the way the propagator ;; works, we can only determine whether an expression ;; returns by asserting it as used. So we have to pick ;; some order and it might as well be left to right. ;; note: The callee is evaluated after the arguments in attempt to ;; match the Scheme->C argument evaluation order. (newlines-between ;; note: This is a kludge to reverse the evaluation order of ;; rest arguments in attempt to match the Scheme->C ;; argument evaluation order. ((if (and (monomorphic? w0) (native-procedure-type? (the-member w0)) (called? (the-member w0)) (rest? (the-member w0))) reverse identity) (map (lambda (w t x) (compile (if (expression-accessed? x) (create-accessor-result w t) *discard*) x)) ws ts (expression-arguments x)))) (compile (if (expression-accessed? (expression-callee x)) (create-accessor-result w0 t0) *discard*) (expression-callee x)) (if (executed? x) (if (void? w0) (compile-error "void_call" x #t) (type-switch (compatible-call? x) w0 r t0 (lambda (u0) (if (converted? x) (compile-converted-call r (create-call-site x) t0 u0 w0 ts ws 'void20 *null*) (compile-call r (create-call-site x) t0 u0 w0 #f #f ts ws 'void21 *null*))) (lambda (p?) (compile-error "call" x p?)))) (c:noop))))))) (else (fuck-up))))))) (define (compile-native-procedures) (newlines-between (map (lambda (e) (if (unique-call-site? e) (c:noop) (let ((x (environment-expression e))) (set! *outside-body* '()) ;; note: This can't be beta converted since it modifies ;; *OUTSIDE-BODY*. (let* ((c (compile (create-return-result e (expression-type-set (expression-body x))) (expression-body x))) (c (newline-between (apply c:header (c:f e) (compile-parameter-variables e)) (braces-around (newline-between (if (or (fictitious? (return-type-set e)) (not (expression-accessed? (expression-body (environment-expression e))))) (c:noop) (c:declaration (return-type-set e) (c:r e) (c:noop))) (if (environment-passes-parameters-globally? e) (newline-between (if (has-parent-parameter? e) ;; needs work: needs abstraction for initialized ;; declaration (semicolon-after (c:type (environment-type e) (unparenthesize (c:= (c:p e) (c:d e))))) (c:noop)) (newlines-between (map (lambda (g) (space-between ;; needs work: needs abstraction for initialized ;; declaration (semicolon-after (c:type-set (variable-type-set g) (unparenthesize (c:= (c:a g) (c:b g))))) (c:/**/ (symbol->string (variable-name g))))) (remove-if-not (lambda (g) (or (local? g) (slotted? g))) (variables e))))) (c:noop)) (newlines-between (map (lambda (e1) (if (and (not (noop? e1)) (has-region? e1) (reentrant? e1)) (semicolon-after (space-between (c:byte) (star-before (c:sfp e1)))) (c:noop))) ;; This assumes that the IN-LINED-IN? relation is ;; reflexive. (in-lined-environments e))) (compile-in-lined-variables e) (newlines-between (reverse *outside-body*)) (newlines-between (map (lambda (e1) (if (and (not (noop? e1)) (has-closure? e1)) (semicolon-after ;; needs work: To use code-generation ;; abstractions. (space-between "struct" (case *closure-representation* ((immediate-flat) (unimplemented x "Immediate flat closures are not (yet) implemented")) ((indirect-flat) (unimplemented x "Indirect flat closures are not (yet) implemented")) ((immediate-display) (c:e e1)) ((indirect-display) (c:e e1)) ((linked) (c:p e1)) (else (fuck-up))) (star-before (c:e e1)))) (c:noop))) ;; This assumes that the IN-LINED-IN? relation is ;; reflexive. (in-lined-environments e))) (newlines-between (map (lambda (e1) (if (and (not (noop? e1)) (has-parent-parameter? e1)) (semicolon-after (c:type (environment-type e1) (c:p e1))) (c:noop))) (properly-in-lined-environments e))) (compile-initialize-region e) ;; note: The self-tail-call entry point can't come after the ;; closure level allocation and spill since that would ;; unsoundly overwrite the existing closure. ;; cpstak.sc is an example of this. (if (has-self-tail-call? e) (c:: (c:h e)) (c:noop)) (if (has-closure? e) (newline-between (compile-allocate-closure-level e) (spill-slotted-variables e)) (c:noop)) c))))) (newline-between (if (or (substring? "/*" (environment-name e)) (substring? "*/" (environment-name e))) (c:noop) (c:/**/ (environment-name e))) (if (or (fictitious? (return-type-set e)) (not (expression-accessed? (expression-body (environment-expression e))))) ;; needs work: To use code-generation abstractions. (space-between "void" c) (c:type-set (return-type-set e) c))))))) *es*))) (define (compile-offsets) (let ((us (sort (remove-if (lambda (u) (zero? (type-use-count u))) (append (list ) *internal-symbol-types* *external-symbol-types* *primitive-procedure-types* *native-procedure-types* *foreign-procedure-types* *continuation-types* *string-types* *structure-types* *headed-vector-types* *nonheaded-vector-types* *displaced-vector-types*)) > type-use-count))) (newline-between (newlines-between (map-indexed (lambda (u i) (c:define (c:type-tag u) (c:fixnum (* (+ i (if *char-type-used?* 256 0)) (expt 2 *worst-alignment*))))) us)) (c:define (c:value-offset) (c:fixnum (* (+ (length us) (if *char-type-used?* 256 0)) (expt 2 *worst-alignment*)))) (if *char-type-used?* (c:define (c:char-offset) (c:fixnum (* 256 (expt 2 *worst-alignment*)))) (c:noop))))) (define (compile-constant-initialization-procedures) (newlines-between (map-n (lambda (i) (newline-between (space-between "void" (c:header (c:initialize-constants i))) (braces-around (newlines-between (sublist (reverse *inside-main*) (* *statements-per-constant-initialization-procedure* i) (min (* *statements-per-constant-initialization-procedure* (+ i 1)) (length *inside-main*))))))) (inexact->exact (ceiling (/ (length *inside-main*) (exact->inexact *statements-per-constant-initialization-procedure*))))))) (define (compile-constant-initialization-procedure-calls) (newlines-between (map-n (lambda (i) (c:gosub (c:initialize-constants i))) (inexact->exact (ceiling (/ (length *inside-main*) (exact->inexact *statements-per-constant-initialization-procedure*))))))) (define (compile-assertions) ;; needs work: To use code-generation abstractions. (newline-between (if *char-alignment?* (c:assert (c:== (c:alignof (lambda (c) (space-between *char* c))) (c:fixnum (expt 2 *char-alignment*)))) (c:noop)) (if *fixnum-alignment?* (c:assert (c:== (c:alignof (lambda (c) (space-between *fixnum* c))) (c:fixnum (expt 2 *fixnum-alignment*)))) (c:noop)) (if *flonum-alignment?* (c:assert (c:== (c:alignof (lambda (c) (space-between *flonum* c))) (c:fixnum (expt 2 *flonum-alignment*)))) (c:noop)) (if *rectangular-alignment?* (c:assert (c:== (c:alignof (lambda (c) (space-between "struct" "rectangular" c))) (c:fixnum (expt 2 *flonum-alignment*)))) (c:noop)) (if *void*-alignment?* (c:assert (c:== (c:alignof (lambda (c) (space-between "void" (star-before c)))) (c:fixnum (expt 2 *pointer-alignment*)))) (c:noop)) (if *char*-alignment?* (c:assert (c:== (c:alignof (lambda (c) (space-between *char* (star-before c)))) (c:fixnum (expt 2 *pointer-alignment*)))) (c:noop)) (if *file*-alignment?* (c:assert (c:== (c:alignof (lambda (c) (space-between *file* (star-before c)))) (c:fixnum (expt 2 *pointer-alignment*)))) (c:noop)) (if *jmpbuf*-alignment?* (c:assert (c:== (c:alignof (lambda (c) (space-between *jmpbuf* (star-before c)))) (c:fixnum (expt 2 *pointer-alignment*)))) (c:noop)) (if *length-alignment?* (c:assert (c:== (c:alignof (lambda (c) (space-between *length* c))) (c:fixnum (expt 2 *length-alignment*)))) (c:noop)) (if *tag-alignment?* (c:assert (c:== (c:alignof (lambda (c) (space-between *tag* c))) (c:fixnum (expt 2 *tag-alignment*)))) (c:noop)) (if *squished-alignment?* (c:assert (c:== (c:alignof (lambda (c) (space-between *squished* c))) (c:fixnum (expt 2 *squished-alignment*)))) (c:noop)) (if *file-alignment?* (c:assert (c:== (c:alignof (lambda (c) (space-between *file* c))) (c:fixnum (expt 2 *file-alignment*)))) (c:noop)) (if *jmpbuf-alignment?* (c:assert (c:== (c:alignof (lambda (c) (space-between *jmpbuf* c))) (c:fixnum (expt 2 *jmpbuf-alignment*)))) (c:noop)) (newlines-between (map (lambda (u) (c:assert (c:== (c:alignof (lambda (c) (c:type u c))) (c:fixnum (expt 2 (type-alignment u)))))) (append (remove-if-not native-procedure-type-alignment? *native-procedure-types*) (remove-if-not structure-type-alignment? *structure-types*) (remove-if-not headed-vector-type-alignment? *headed-vector-types*) (remove-if-not nonheaded-vector-type-alignment? *nonheaded-vector-types*) (remove-if-not displaced-vector-type-alignment? *displaced-vector-types*)))) (case *closure-representation* ((immediate-flat immediate-display) (c:noop)) ((indirect-flat indirect-display) (newlines-between (map (lambda (u) (c:assert (c:== (c:alignof (lambda (c) (space-between "struct" (c:p u) c))) (c:fixnum (expt 2 (type-alignment& u)))))) (remove-if-not native-procedure-type-alignment&? *native-procedure-types*)))) ((linked) (newlines-between (map (lambda (e) (if (and (or (eq? *closure-conversion-method* 'baseline) (eq? *closure-conversion-method* 'conventional)) (not (environment? e))) (c:noop) (c:assert (c:== (c:alignof (lambda (c) (space-between "struct" (c:p e) c))) (c:fixnum (expt 2 (type-alignment& (find-if (lambda (u) (and (called? u) (not (noop? u)) (has-parent-parameter? u) (eq? e (parent-parameter u)))) *native-procedure-types*)))))))) (remove-duplicatesq (map parent-parameter (remove-if-not native-procedure-type-alignment&? ;; This is just because of *CLOSURE-CONVERSION-METHOD*. (remove-if (lambda (u) (or (not (called? u)) (noop? u))) *native-procedure-types*))))))) (else (fuck-up))) (newlines-between (map (lambda (u) (if (and (or (eq? *closure-conversion-method* 'baseline) (eq? *closure-conversion-method* 'conventional)) (or (not (environment? (native-procedure-type-narrow-prototype u))) (not (environment-used? (narrow-prototype u))) (not (environment? (parent-parameter u))) (not (environment-used? (parent-parameter u))))) (c:noop) (c:assert (c:== (c:alignof (lambda (c) (space-between "struct" (case *closure-representation* ((immediate-flat immediate-display) (fuck-up)) ((indirect-flat indirect-display) (c:p u)) ((linked) (c:p (parent-parameter u))) (else (fuck-up))) c))) (c:fixnum (expt 2 (type-alignment& u))))))) (remove-if-not native-procedure-type-alignment&? *native-procedure-types*))) (newlines-between (map (lambda (u) (c:assert (c:== (c:alignof (lambda (c) (c:type& u c))) (c:fixnum (expt 2 (type-alignment& u)))))) (remove-if-not structure-type-alignment&? *structure-types*))) (newlines-between (map (lambda (u) (c:assert (c:== (c:alignof (lambda (c) (space-between "struct" (c:u u) c))) (c:fixnum (expt 2 (type-alignment& u)))))) (remove-if-not headed-vector-type-alignment&? *headed-vector-types*))) (newlines-between (map (lambda (w) (c:assert (c:== (c:alignof (lambda (c) (c:type-set w c))) (c:fixnum (expt 2 (type-set-alignment w)))))) (remove-if-not type-set-alignment? *ws*))) (if *char-size?* (c:assert (c:== (c:sizeof *char*) (c:fixnum *char-size*))) (c:noop)) (if *fixnum-size?* (c:assert (c:== (c:sizeof *fixnum*) (c:fixnum *fixnum-size*))) (c:noop)) (if *flonum-size?* (c:assert (c:== (c:sizeof *flonum*) (c:fixnum *flonum-size*))) (c:noop)) (if *rectangular-size?* (c:assert (c:== (c:sizeof (list "struct" "rectangular")) (c:fixnum (* 2 *flonum-size*)))) (c:noop)) (if *void*-size?* (c:assert (c:== (c:sizeof (space-between "void" "*")) (c:fixnum *pointer-size*))) (c:noop)) (if *char*-size?* (c:assert (c:== (c:sizeof (space-between *char* "*")) (c:fixnum *pointer-size*))) (c:noop)) (if *file*-size?* (c:assert (c:== (c:sizeof (space-between *file* "*")) (c:fixnum *pointer-size*))) (c:noop)) (if *jmpbuf*-size?* (c:assert (c:== (c:sizeof (space-between *jmpbuf* "*")) (c:fixnum *pointer-size*))) (c:noop)) (if *length-size?* (c:assert (c:== (c:sizeof *length*) (c:fixnum *length-size*))) (c:noop)) (if *tag-size?* (c:assert (c:== (c:sizeof *tag*) (c:fixnum *tag-size*))) (c:noop)) (if (and *squish?* *squished-size?*) (c:assert (c:== (c:sizeof *squished*) (c:fixnum *squished-size*))) (c:noop)) (if (and *squish?* *squished-size?*) (c:assert (c:== (c:sizeof *signed-squished*) (c:fixnum *squished-size*))) (c:noop)) (newlines-between (map (lambda (u) (c:assert (c:== (c:sizeof (c:type u "")) (c:fixnum (type-size u))))) (append (remove-if-not native-procedure-type-size? *native-procedure-types*) (remove-if-not structure-type-size? *structure-types*) (remove-if-not headed-vector-type-size? *headed-vector-types*) (remove-if-not nonheaded-vector-type-size? *nonheaded-vector-types*) (remove-if-not displaced-vector-type-size? *displaced-vector-types*)))) (newlines-between (map (lambda (w) (c:assert (c:== (c:sizeof (c:type-set w "")) (c:fixnum (type-set-size w))))) (remove-if-not type-set-size? *ws*))))) (define-structure primitive-procedure compatible-procedure? truly-compatible-procedure? consequent-contexts alternate-contexts propagate-call! promote! compile-call) (define *primitive-procedure-handlers* '()) (define (zero-arguments-compatible? u0 ws w) (when (can-be-non? null-type? w) (fuck-up)) (= (length ws) 0)) (define (one-argument-compatible? u0 ws w) (when (can-be-non? null-type? w) (fuck-up)) (= (length ws) 1)) (define (two-arguments-compatible? u0 ws w) (when (can-be-non? null-type? w) (fuck-up)) (= (length ws) 2)) (define (three-arguments-compatible? u0 ws w) (when (can-be-non? null-type? w) (fuck-up)) (= (length ws) 3)) (define (n-arguments-compatible? u0 ws w) (when (can-be-non? null-type? w) (fuck-up)) (= (length ws) (second (primitive-procedure-type-arguments u0)))) (define (one-or-two-arguments-compatible? u0 ws w) (when (can-be-non? null-type? w) (fuck-up)) (or (one-argument-compatible? u0 ws w) (two-arguments-compatible? u0 ws w))) (define (zero-or-more-arguments-compatible? u0 ws w) (when (can-be-non? null-type? w) (fuck-up)) (>= (length ws) 0)) (define (one-or-more-arguments-compatible? u0 ws w) (when (can-be-non? null-type? w) (fuck-up)) (>= (length ws) 1)) (define (two-or-more-arguments-compatible? u0 ws w) (when (can-be-non? null-type? w) (fuck-up)) (>= (length ws) 2)) (define (zero-arguments-truly-compatible?) (lambda (ws w) (when (can-be-non? null-type? w) (fuck-up)) #t)) (define (one-argument-truly-compatible? m) (lambda (ws w) (when (can-be-non? null-type? w) (fuck-up)) (and (= (length ws) 1) (can-be? m (first ws))))) (define (two-arguments-truly-compatible? m1 m2) (lambda (ws w) (when (can-be-non? null-type? w) (fuck-up)) (and (= (length ws) 2) (can-be? m1 (first ws)) (can-be? m2 (second ws))))) (define (three-arguments-truly-compatible? m1 m2 m3) (lambda (ws w) (when (can-be-non? null-type? w) (fuck-up)) (and (= (length ws) 3) (can-be? m1 (first ws)) (can-be? m2 (second ws)) (can-be? m3 (third ws))))) (define (n-arguments-truly-compatible?) (lambda (ws w) (when (can-be-non? null-type? w) (fuck-up)) #t)) (define (one-or-two-arguments-truly-compatible? m1 m2) (lambda (ws w) (when (can-be-non? null-type? w) (fuck-up)) (or (and (= (length ws) 1) (can-be? m1 (first ws))) (and (= (length ws) 2) (can-be? m1 (first ws)) (can-be? m2 (second ws)))))) (define (all-arguments-truly-compatible? m) (lambda (ws w) (when (can-be-non? null-type? w) (fuck-up)) (every (lambda (w) (can-be? m w)) ws))) (define (zero-arguments-propagate! p) ;; conventions: P (lambda (ws w) (when (can-be-non? null-type? w) (fuck-up)) (unless (= (length ws) 0) (fuck-up)) (p))) (define (one-argument-propagate! p) ;; conventions: P (lambda (ws w) (when (can-be-non? null-type? w) (fuck-up)) (unless (= (length ws) 1) (fuck-up)) (p (first ws)))) (define (two-arguments-propagate! p) ;; conventions: P (lambda (ws w) (when (can-be-non? null-type? w) (fuck-up)) (unless (= (length ws) 2) (fuck-up)) (p (first ws) (second ws)))) (define (three-arguments-propagate! p) ;; conventions: P (lambda (ws w) (when (can-be-non? null-type? w) (fuck-up)) (unless (= (length ws) 3) (fuck-up)) (p (first ws) (second ws) (third ws)))) (define (n-arguments-propagate! p) ;; conventions: P (lambda (ws w) (when (can-be-non? null-type? w) (fuck-up)) (p ws))) (define (one-or-two-arguments-propagate! p1 p2) ;; conventions: P1 P2 (lambda (ws w) (when (can-be-non? null-type? w) (fuck-up)) (cond ((= (length ws) 1) (p1 (first ws))) ((= (length ws) 2) (p2 (first ws) (second ws))) (else (fuck-up))))) (define (all-arguments-propagate! p) ;; conventions: P (lambda (ws w) (when (can-be-non? null-type? w) (fuck-up)) (p ws))) ;;; needs work: Every instance of WIDEN and WIDEN-TYPE in this file must be ;;; checked for the case when the RESULT-KIND is DISCARD or ;;; ANTECEDENT. If the generated C code could raise an exception ;;; then one should use the strict option (P?=#F) to MOVE-GENERAL. ;;; This is technically not required by R4RS. (define-primitive-procedure structure? one-argument-compatible? (one-argument-truly-compatible? type?) (list (structure-type-named? (first (primitive-procedure-type-arguments u0)))) (list (lambda (u) (not ((structure-type-named? (first (primitive-procedure-type-arguments u0))) u)))) (one-argument-propagate! (lambda (w1) (when (and (can-be? (structure-type-named? (first (primitive-procedure-type-arguments u0))) w1) (can-be-non? (structure-type-named? (first (primitive-procedure-type-arguments u0))) w1)) (for-each-member (lambda (u1) (set-type-type-tag-accessed?! u1 #t)) w1)) (propagate-type-predicate! (structure-type-named? (first (primitive-procedure-type-arguments u0)))))) #f (compile-type-predicate (structure-type-named? (first (primitive-procedure-type-arguments u0))))) (define-primitive-procedure make-structure n-arguments-compatible? (n-arguments-truly-compatible?) (map-n (lambda (i) type?) n) (map-n (lambda (i) type?) n) (n-arguments-propagate! (lambda (ws) (propagate-result! ( (first (primitive-procedure-type-arguments u0)) (second (primitive-procedure-type-arguments u0)) ;; note: This is suboptimal since type propagation is not yet ;; complete and APPLY-CLOSED-WORLD-ASSUMPTION! has not ;; been done yet. (map members ws) (call-site-expression y))))) (unless (or (discard? r) (antecedent? r) (and (return? r) (not (result-accessed? r)))) (let* ((w (result-type-set r)) (u (the-member-that (lambda (u) (and ((structure-type-named? (first (primitive-procedure-type-arguments u0))) u) (memq (call-site-expression y) (structure-type-allocating-expressions u)))) w))) (unless (fictitious? u) (for-each (lambda (w0 i w1) (promote! (if (fictitious? w0) *discard* (create-accessor-result w0 #f)) w1 w1)) (structure-type-slots u) (enumerate (length (structure-type-slots u))) ws)))) (cond ((discard? r) (c:noop)) ((antecedent? r) (return-true r)) ((and (return? r) (not (result-accessed? r))) (compile-return r)) (else (let* ((c (result-c r)) (w (result-type-set r)) (u (the-member-that (lambda (u) (and ((structure-type-named? (first (primitive-procedure-type-arguments u0))) u) (memq (call-site-expression y) (structure-type-allocating-expressions u)))) w))) (if (fictitious? u) (widen-type r 'void22 u) (newline-between (compile-allocate-structure c u w y) (newlines-between (map (lambda (w0 i t1 w1) (move (if (fictitious? w0) *discard* (create-accessor-result w0 (value-structure-ref c u w i))) t1 w1)) (structure-type-slots u) (enumerate (length (structure-type-slots u))) ts ws)) (compile-return r))))))) (define-primitive-procedure structure-ref one-argument-compatible? (one-argument-truly-compatible? (structure-type-named? (first (primitive-procedure-type-arguments u0)))) (list (structure-type-named? (first (primitive-procedure-type-arguments u0)))) (list (structure-type-named? (first (primitive-procedure-type-arguments u0)))) (one-argument-propagate! (lambda (w1) (for-each-member (lambda (u1) (when ((structure-type-named? (first (primitive-procedure-type-arguments u0))) u1) (list-set! (structure-type-structure-ref-accessed? u1) (second (primitive-procedure-type-arguments u0)) #t) (for-each-member propagate-result! (list-ref (structure-type-slots u1) (second (primitive-procedure-type-arguments u0)))))) w1))) (for-each-member (lambda (u1) (when ((structure-type-named? (first (primitive-procedure-type-arguments u0))) u1) (promote! r (list-ref (structure-type-slots u1) (second (primitive-procedure-type-arguments u0))) (list-ref (structure-type-slots u1) (second (primitive-procedure-type-arguments u0)))))) w1) (type-switch (structure-type-named? (first (primitive-procedure-type-arguments u0))) w1 r t1 (lambda (u1) (move r (value-structure-ref t1 u1 w1 (second (primitive-procedure-type-arguments u0))) (list-ref (structure-type-slots u1) (second (primitive-procedure-type-arguments u0))))) (lambda (p?) (compile-error "structure_ref" y p?)))) (define-primitive-procedure structure-set! two-arguments-compatible? (two-arguments-truly-compatible? (structure-type-named? (first (primitive-procedure-type-arguments u0))) type?) (list (structure-type-named? (first (primitive-procedure-type-arguments u0))) type?) (list (structure-type-named? (first (primitive-procedure-type-arguments u0))) type?) (two-arguments-propagate! (lambda (w1 w2) (for-each-member (lambda (u1) (when ((structure-type-named? (first (primitive-procedure-type-arguments u0))) u1) (set-structure-type-immediate?! u1 #f) (assert-subset! w2 (list-ref (structure-type-slots u1) (second (primitive-procedure-type-arguments u0)))))) w1))) (for-each-member (lambda (u1) (when ((structure-type-named? (first (primitive-procedure-type-arguments u0))) u1) (promote! (if (fictitious? (list-ref (structure-type-slots u1) (second (primitive-procedure-type-arguments u0)))) *discard* (create-accessor-result (list-ref (structure-type-slots u1) (second (primitive-procedure-type-arguments u0))) #f)) w2 w2))) w1) (type-switch (structure-type-named? (first (primitive-procedure-type-arguments u0))) w1 r t1 (lambda (u1) (newline-between (move (if (fictitious? (list-ref (structure-type-slots u1) (second (primitive-procedure-type-arguments u0)))) *discard* (create-accessor-result (list-ref (structure-type-slots u1) (second (primitive-procedure-type-arguments u0))) (value-structure-ref t1 u1 w1 (second (primitive-procedure-type-arguments u0))))) t2 w2) (compile-return r))) (lambda (p?) (compile-error "structure_set" y p?)))) (define-primitive-procedure not one-argument-compatible? (one-argument-truly-compatible? type?) (list false-type?) (list (lambda (u) (not (false-type? u)))) (one-argument-propagate! (lambda (w1) (when (and (can-be? false-type? w1) (can-be-non? false-type? w1)) (for-each-member (lambda (u1) (set-type-type-tag-accessed?! u1 #t)) w1)) (propagate-type-predicate! false-type?))) #f (compile-type-predicate false-type?)) (define-primitive-procedure boolean? one-argument-compatible? (one-argument-truly-compatible? type?) (list boolean-type?) (list (lambda (u) (not (boolean-type? u)))) (one-argument-propagate! (lambda (w1) (when (and (can-be? boolean-type? w1) (can-be-non? boolean-type? w1)) (for-each-member (lambda (u1) (set-type-type-tag-accessed?! u1 #t)) w1)) (propagate-type-predicate! boolean-type?))) #f (compile-type-predicate boolean-type?)) (define-primitive-procedure eq? two-arguments-compatible? (two-arguments-truly-compatible? type? type?) (list type? type?) (list type? type?) (two-arguments-propagate! (lambda (w1 w2) (let ((p0? (and (not (void? w1)) (not (void? w2)) (or ;; This is suboptimal. W1 or W2 might have multiple members now ;; that will be merged into a monotype by ;; APPLY-CLOSED-WORLD-ASSUMPTION!. (multimorphic? w1) (multimorphic? w2) ;; This is suboptimal. A structure or a native procedure might ;; in the end be fictitious but we can't know that at this ;; point. (not (necessarily-fictitious? (the-member w1))) (not (necessarily-fictitious? (the-member w2))) ;; This is suboptimal. The members of W1 and W2 might be ;; equated by APPLY-CLOSED-WORLD-ASSUMPTION!. (not (eq? (the-member w1) (the-member w2)))))) ;; needs work: This is unsound. There might be a U1 in W1 and a U2 in ;; W2 that are not EQ? but that will become EQ? as a ;; result of APPLY-CLOSED-WORLD-ASSUMPTION!. (p1? (can-be? (lambda (u1) (member? u1 w2)) w1))) (when p1? (propagate-result! )) (when p0? (propagate-result! )) (when (and p0? p1?) (for-each-member (lambda (u1) (set-type-eq?-accessed?! u1 #t)) w1) (for-each-member (lambda (u2) (set-type-eq?-accessed?! u2 #t)) w2) (for-each-member (lambda (u1) (when (structure-type? u1) (set-structure-type-immediate?! u1 #f))) w1) (for-each-member (lambda (u2) (when (structure-type? u2) (set-structure-type-immediate?! u2 #f))) w2))))) #f (let ((us (intersectionq (members w1) (members w2)))) (if (or (null? us) (cond ((converted? y) (unless (and (eq? (expression-kind (call-site-expression y)) 'converted-call) (eq? (expression-kind (expression-callee (call-site-expression y))) 'converted-continuation) (list? (expression-parameters (expression-callee (call-site-expression y)))) (not (null? (expression-parameters (expression-callee (call-site-expression y)))))) (fuck-up)) (must-be? false-type? (variable-type-set (first (expression-parameters (expression-callee (call-site-expression y))))))) (else (must-be? false-type? (expression-type-set (call-site-expression y)))))) (return-false r) (cond ((fake? w1) (cond ((fake? w2) ;; Must be true since fictitious type sets are monotypes and the ;; intersection is non empty. (return-true r)) ((monomorphic? w2) ;; Nonfictitious monotypes are disjoint with fictitious type ;; sets. (fuck-up)) ((tag-only? w2) (compile-test r (c:== (c:type-tag (the-member w1)) (c:tag t2 w2)))) ((squeezed? w2) ;; Rectangulars, immediate closures, nonfictitious immediate ;; structures, nondegenerate nonheaded vectors, and ;; nondegenerate displaced vectors can't be squeezed so there ;; is no need to handle == on structs. (compile-test r (c:== (c:type-set-cast (c:type-tag (the-member w1)) w2) t2))) ((squished? w2) ;; Rectangulars, immediate closures, nonfictitious immediate ;; structures, nondegenerate nonheaded vectors, and ;; nondegenerate displaced vectors can't be squished so there ;; is no need to handle == on structs. (compile-test r (c:== (c:type-set-cast (c:type-tag (the-member w1)) w2) t2))) (else (compile-test r (c:== (c:type-tag (the-member w1)) (c:tag t2 w2)))))) ((monomorphic? w1) (compile-test r (cond ((fake? w2) ;; Nonfictitious monotypes are disjoint with fictitious type sets. (fuck-up)) ((monomorphic? w2) (c:==struct (c:value t1 (the-member w1) w1) (c:value t2 (the-member w2) w2) (the-member w1))) ((tag-only? w2) ;; CHAR is the only fictitious type that can be a nonfictitious ;; monotype. (unless (char-type? (the-member w1)) (fuck-up)) ;; Must cast T1 to be a type and not cast T2 to be a char since T2 ;; could have other tags in it besides characters. ;; This assumes that *TAG* is unsigned so that << does a logical ;; shift. The call to C:UNSIGNED-CHAR-CAST is in case *CHAR* is ;; signed to force << to be a logical shift without a prior sign ;; extend. The call to C:TYPE-SET-CAST is to prevent any overflow ;; in the logical shift. (c:== (c:<< (c:type-set-cast (c:unsigned-char-cast (c:value t1 (the-member w1) w1)) w2) (c:fixnum *worst-alignment*)) (c:tag t2 w2))) ((squeezed? w2) ;; Rectangulars, immediate closures, nonfictitious immediate ;; structures, nondegenerate nonheaded vectors, and nondegenerate ;; displaced vectors can't be squeezed so there is no need to ;; handle == on structs. (c:== (squeeze t1 (the-member w1) w2) t2)) ((squished? w2) ;; Rectangulars, immediate closures, nonfictitious immediate ;; structures, nondegenerate nonheaded vectors, and nondegenerate ;; displaced vectors can't be squeezed so there is no need to ;; handle == on structs. (c:== (squish t1 (the-member w1) w2) t2)) (else (if (char-type? (the-member w1)) (c:== (c:value t1 (the-member w1) w1) (c:value t2 (the-member w1) w2)) (c:&& (c:== (c:type-tag (the-member w1)) (c:tag t2 w2)) (c:==struct (c:value t1 (the-member w1) w1) (c:value t2 (the-member w1) w2) (the-member w1)))))))) ((tag-only? w1) (compile-test r (cond ((fake? w2) (c:== (c:tag t1 w1) (c:type-tag (the-member w2)))) ((monomorphic? w2) ;; CHAR is the only fictitious type that can be a nonfictitious ;; monotype. (unless (char-type? (the-member w2)) (fuck-up)) ;; Must cast T2 to be a type and not cast T1 to be a char since T1 ;; could have other tags in it besides characters. ;; This assumes that *TAG* is unsigned so that << does a logical ;; shift. The call to C:UNSIGNED-CHAR-CAST is in case *CHAR* is ;; signed to force << to be a logical shift without a prior sign ;; extend. The call to C:TYPE-SET-CAST is to prevent any overflow ;; in the logical shift. (c:== (c:tag t1 w1) (c:<< (c:type-set-cast (c:unsigned-char-cast (c:value t2 (the-member w2) w2)) w1) (c:fixnum *worst-alignment*)))) ((tag-only? w2) (c:== (c:tag t1 w1) (c:tag t2 w2))) ((squeezed? w2) ;; Rectangulars, immediate closures, nonfictitious immediate ;; structures, nondegenerate nonheaded vectors, and nondegenerate ;; displaced vectors can't be squeezed so there is no need to ;; handle == on structs. (c:== (c:tag->squeezed-cast t1 w1 w2) t2)) ((squished? w2) ;; Rectangulars, immediate closures, nonfictitious immediate ;; structures, nondegenerate nonheaded vectors, and nondegenerate ;; displaced vectors can't be squished so there is no need to ;; handle == on structs. (c:== (c:type-set-cast (c:tag t1 w1) w2) t2)) (else (c:== (c:tag t1 w1) (c:tag t2 w2)))))) ((squeezed? w1) ;; Rectangulars, immediate closures, nonfictitious immediate ;; structures, nondegenerate nonheaded vectors, and nondegenerate ;; displaced vectors can't be squeezed so there is no need to handle ;; == on structs. (compile-test r (cond ((fake? w2) (c:== t1 (c:type-set-cast (c:type-tag (the-member w2)) w1))) ((monomorphic? w2) (c:== t1 (squeeze t2 (the-member w2) w1))) ((tag-only? w2) (c:== t1 (c:tag->squeezed-cast t2 w2 w1))) ((squeezed? w2) (if (eq? (squeezed-member w1) (squeezed-member w2)) (c:== t1 t2) (c:== (c:type-set-cast t1 w2) t2))) ((squished? w2) (if (can-be? (lambda (u1) (and (or (char-type? u1) (fictitious? u1)) (member? u1 w2))) w1) (if (member? (squeezed-member w1) w2) ;; The two type sets share both fictitious and ;; nonfictitious members. (if (zero? (squish-tag (squeezed-member w1) w2)) ;; In this case the matching nonfictitious members have ;; squish tag zero so checking for matching fictitious ;; and nonfictitious members can be done with a single ;; comparison. (c:== (c:type-set-cast t1 w2) t2) ;; In the general case need to check for either matching ;; fictitious or nonfictitious members. (c:boolean-or ;; This checks for matching fictitious members. (c:== (c:type-set-cast t1 w2) t2) ;; This checks for matching nonfictitious members. (c:== (squish t1 (squeezed-member w1) w2) t2))) ;; The two type sets share only fictitious members. ;; Note that the squeezed argument will always have squish ;; tag zero (as a natural consequence of the squeezed ;; representation) and the squished argument will have ;; squish tag zero only when it is a pointer and not a ;; fixnum so there can't be a mixup. (c:== (c:type-set-cast t1 w2) t2)) (if (member? (squeezed-member w1) w2) ;; The two type sets share only nonfictitious members. This ;; makes sure that the two arguments have squish tags prior ;; to comparison. (c:== (squish t1 (squeezed-member w1) w2) t2) ;; The two type sets don't share any members. (fuck-up)))) (else (cond ((every (lambda (u) (or (char-type? u) (fictitious? u))) us) ;; In the case where the only possible match is for ;; nonfictitious variants it is not necessary to check for ;; matches along fictitious variants. (c:&& (c:== (c:tag t2 w2) (c:type-tag (squeezed-member w1))) (c:== t1 (c:value t2 (squeezed-member w1) w2)))) ((some (lambda (u) (or (char-type? u) (fictitious? u))) us) (c:boolean-or (c:== t1 (c:tag->squeezed-cast t2 w2 w1)) (c:&& (c:== (c:tag t2 w2) (c:type-tag (squeezed-member w1))) (c:== t1 (c:value t2 (squeezed-member w1) w2))))) ;; In the case where the only possible match is for fictitious ;; variants it is not necessary to check for matches along ;; nonfictitious variants. (else (c:== t1 (c:tag->squeezed-cast t2 w2 w1)))))))) ((squished? w1) ;; Rectangulars, immediate closures, nonfictitious immediate ;; structures, nondegenerate nonheaded vectors, and nondegenerate ;; displaced vectors can't be squished so there is no need to handle ;; == on structs. (compile-test r (cond ((fake? w2) (c:== t1 (c:type-set-cast (c:type-tag (the-member w2)) w1))) ((monomorphic? w2) (c:== t1 (squish t2 (the-member w2) w1))) ((tag-only? w2) (c:== t1 (c:type-set-cast (c:tag t2 w2) w1))) ((squeezed? w2) (if (can-be? (lambda (u2) (and (or (char-type? u2) (fictitious? u2)) (member? u2 w1))) w2) (if (member? (squeezed-member w2) w1) ;; The two type sets share both fictitious and nonfictitious ;; members. (if (zero? (squish-tag (squeezed-member w2) w1)) ;; In this case the matching nonfictitious members have ;; squish tag zero so checking for matching fictitious ;; and nonfictitious members can be done with a single ;; comparison. (c:== t1 (c:type-set-cast t2 w1)) ;; In the general case need to check for matching ;; fictitious and nonfictitious members. (c:boolean-or ;; This checks for matching fictitious members. (c:== t1 (c:type-set-cast t2 w1)) ;; This checks for matching nonfictitious members. (c:== t1 (squish t2 (squeezed-member w2) w1)))) ;; The two type sets share only fictitious members. ;; Note that the squeezed argument will always have squish ;; tag zero (as a natural consequence of the squeezed ;; representation) and the squished argument will have ;; squish tag zero only when it is a pointer and not a ;; fixnum so there can't be a mixup. (c:== t1 (c:type-set-cast t2 w1))) (if (member? (squeezed-member w2) w1) ;; The two type sets share only nonfictitious members. This ;; makes sure that the two arguments have squish tags prior ;; to comparison. (c:== t1 (squish t2 (squeezed-member w2) w1)) ;; The two type sets don't share any members. (fuck-up)))) ((squished? w2) (cond ((and (every (lambda (u) (or (char-type? u) (fictitious? u) (= (squish-tag u w1) (squish-tag u w2)))) us) (= (squish-alignment w1) (squish-alignment w2))) (c:== t1 t2)) ((and (must-be? (lambda (u1) (or (char-type? u1) (fictitious? u1) (member? u1 w2))) w1) (must-be? (lambda (u2) (or (char-type? u2) (fictitious? u2) (member? u2 w1))) w2)) (c:== t1 t2)) ((some (lambda (u) (or (char-type? u) (fictitious? u))) us) (apply c:boolean-or (cons (if (and (can-be? (lambda (u1) (and (not (char-type? u1)) (not (fictitious? u1)) (zero? (squish-tag u1 w1)))) w1) (can-be? (lambda (u2) (and (not (char-type? u2)) (not (fictitious? u2)) (zero? (squish-tag u2 w2)))) w2)) (c:&& (c:==0 (extract-squish-tag t1 w1)) (c:< t1 (c:value-offset)) (c:== t1 t2)) (c:&& (c:==0 (extract-squish-tag t1 w1)) (c:== t1 t2))) (map (lambda (u) (if (= (squish-tag u w1) (squish-tag u w2)) (c:&& (c:== (extract-squish-tag t1 w1) (c:fixnum (squish-tag u w1))) (c:== t1 t2)) (c:&& (c:== (extract-squish-tag t1 w1) (c:fixnum (squish-tag u w1))) (c:== (extract-squish-tag t2 w2) (c:fixnum (squish-tag u w2))) (c:== (c:value t1 u w1) (c:value t2 u w2))))) (remove-if (lambda (u) (or (char-type? u) (fictitious? u))) us))))) (else (apply c:boolean-or (map (lambda (u) (if (= (squish-tag u w1) (squish-tag u w2)) (c:&& (c:== (extract-squish-tag t1 w1) (c:fixnum (squish-tag u w1))) (c:== t1 t2)) (c:&& (c:== (extract-squish-tag t1 w1) (c:fixnum (squish-tag u w1))) (c:== (extract-squish-tag t2 w2) (c:fixnum (squish-tag u w2))) (c:== (c:value t1 u w1) (c:value t2 u w2))))) us))))) (else (apply c:boolean-or (cons (c:== t1 (c:type-set-cast (c:tag t2 w2) w1)) (map (lambda (u) (c:&& (c:== (c:type-tag u) (c:tag t2 w2)) (c:== (c:value t1 u w1) (c:value t2 u w2)))) (remove-if (lambda (u) (or (char-type? u) (fictitious? u))) us)))))))) (else (cond ((fake? w2) (compile-test r (c:== (c:tag t1 w1) (c:type-tag (the-member w2))))) ((monomorphic? w2) (compile-test r (if (char-type? (the-member w2)) (c:== (c:value t1 (the-member w2) w1) (c:value t2 (the-member w2) w2)) (c:&& (c:== (c:tag t1 w1) (c:type-tag (the-member w2))) (c:==struct (c:value t1 (the-member w2) w1) (c:value t2 (the-member w2) w2) (the-member w2)))))) ((tag-only? w2) (compile-test r (c:== (c:tag t1 w1) (c:tag t2 w2)))) ((squeezed? w2) ;; Rectangulars, immediate closures, nonfictitious immediate ;; structures, nondegenerate nonheaded vectors, and nondegenerate ;; displaced vectors can't be squeezed so there is no need to handle ;; == on structs. (compile-test r (cond ((every (lambda (u) (or (char-type? u) (fictitious? u))) us) ;; In the case where the only possible match is for nonfictitious ;; variants it is not necessary to check for matches along ;; fictitious variants. (c:&& (c:== (c:tag t1 w1) (c:type-tag (squeezed-member w2))) (c:== (c:value t1 (squeezed-member w2) w1) t2))) ((some (lambda (u) (or (char-type? u) (fictitious? u))) us) (c:boolean-or (c:== (c:tag->squeezed-cast t1 w1 w2) t2) (c:&& (c:== (c:tag t1 w1) (c:type-tag (squeezed-member w2))) (c:== (c:value t1 (squeezed-member w2) w1) t2)))) ;; In the case where the only possible match is for fictitious ;; variants it is not necessary to check for matches along ;; nonfictitious variants. (else (c:== (c:tag->squeezed-cast t1 w1 w2) t2))))) ((squished? w2) ;; Rectangulars, immediate closures, nonfictitious immediate ;; structures, nondegenerate nonheaded vectors, and nondegenerate ;; displaced vectors can't be squished so there is no need to handle ;; == on structs. (compile-test r (apply c:boolean-or (cons (c:== (c:type-set-cast (c:tag t1 w1) w2) t2) (map (lambda (u) (c:&& (c:== (c:tag t1 w1) (c:type-tag u)) (c:== (c:value t1 u w1) (c:value t2 u w2)))) (remove-if (lambda (u) (or (char-type? u) (fictitious? u))) us)))))) (else (if (every (lambda (u) (or (char-type? u) (fictitious? u))) us) ;; In the case where the only possible match is for fictitious ;; variants it is not necessary to check for matches along ;; nonfictitious variants. (compile-test r (c:== (c:tag t1 w1) (c:tag t2 w2))) (if (and *eq?-forgery?* (= (type-set-size w1) (type-set-size w2))) (let* ((size (reduce max (map type-size (members-that (lambda (u) (and (not (char-type? u)) (not (fictitious? u)))) w1)) ;; This can't happen if the type set isn't ;; fictitious, monomorphic, or tag only. #f)) (fixnum-size (quotient size *fixnum-size*)) (char-size (remainder size *fixnum-size*))) ;; conventions: SIZE FIXNUM-SIZE CHAR-SIZE (compile-test r (apply c:&& (cons (c:== (c:tag t1 w1) (c:tag t2 w2)) (append (map-n (lambda (i) (c:== (c:raw-subscript (c:fixnum*-cast (c:& (c:. t1 "value"))) (c:fixnum i)) (c:raw-subscript (c:fixnum*-cast (c:& (c:. t2 "value"))) (c:fixnum i)))) fixnum-size) (map-n (lambda (i) (c:== (c:raw-subscript (c:char*-cast (c:& (c:. t1 "value"))) (c:fixnum (+ (* fixnum-size *fixnum-size*) i))) (c:raw-subscript (c:char*-cast (c:& (c:. t2 "value"))) (c:fixnum (+ (* fixnum-size *fixnum-size*) i))))) char-size)))))) (newline-between (c:/**/ "EQ: dispatching general to general") (c:if (c:== (c:tag t1 w1) (c:tag t2 w2)) (nonerror-type-switch (lambda (u1) (and (not (char-type? u1)) (not (fictitious? u1)))) w1 r t1 (lambda (u1) (if (member? u1 w2) (compile-test r (c:==struct (c:value t1 u1 w1) (c:value t2 u1 w2) u1)) (return-false r))) (lambda (p?) (return-true r))) (return-false r) #f))))))))))) (define-primitive-procedure null? one-argument-compatible? (one-argument-truly-compatible? type?) (list null-type?) (list (lambda (u) (not (null-type? u)))) (one-argument-propagate! (lambda (w1) (when (and (can-be? null-type? w1) (can-be-non? null-type? w1)) (for-each-member (lambda (u1) (set-type-type-tag-accessed?! u1 #t)) w1)) (propagate-type-predicate! null-type?))) #f (compile-type-predicate null-type?)) (define-primitive-procedure symbol? one-argument-compatible? (one-argument-truly-compatible? type?) (list symbol-type?) (list (lambda (u) (not (symbol-type? u)))) (one-argument-propagate! (lambda (w1) (when (and (can-be? symbol-type? w1) (can-be-non? symbol-type? w1)) (for-each-member (lambda (u1) (set-type-type-tag-accessed?! u1 #t)) w1)) (propagate-type-predicate! symbol-type?))) #f (compile-type-predicate symbol-type?)) (define-primitive-procedure symbol->string one-argument-compatible? (one-argument-truly-compatible? symbol-type?) (list symbol-type?) (list symbol-type?) (one-argument-propagate! (lambda (w1) (propagate-result! ))) #f (let ((w (result-type-set r))) (type-switch symbol-type? w1 r t1 (lambda (u1) (cond ((internal-symbol-type? u1) (widen r (c:string (symbol->string (internal-symbol-type-name u1))) string-type?)) ((external-symbol-type? u1) (widen r (c:value t1 u1 w1) string-type?)) (else (fuck-up)))) (lambda (p?) (compile-error "symbol_string" y p?))))) (define-primitive-procedure string->uninterned-symbol one-argument-compatible? (one-argument-truly-compatible? string-type?) (list string-type?) (list string-type?) (one-argument-propagate! (lambda (w1) (for-each-member (lambda (u1) (when (string-type? u1) (propagate-result! ( u1)))) w1))) #f (type-switch string-type? w1 r t1 (lambda (u1) (widen r (c:value t1 u1 w1) (lambda (u) (and (external-symbol-type? u) (eq? (external-symbol-type-displaced-string-type u) u1))))) (lambda (p?) (compile-error "string_to_uninterned_symbol" y p?)))) (define-primitive-procedure number? one-argument-compatible? (one-argument-truly-compatible? type?) (list number-type?) (list (lambda (u) (not (number-type? u)))) (one-argument-propagate! (lambda (w1) (when (and (can-be? number-type? w1) (can-be-non? number-type? w1)) (for-each-member (lambda (u1) (set-type-type-tag-accessed?! u1 #t)) w1)) (propagate-type-predicate! number-type?))) #f (compile-type-predicate number-type?)) (define-primitive-procedure real? one-argument-compatible? (one-argument-truly-compatible? type?) (list number-type?) (list (lambda (u) (or (not (number-type? u)) (and (not (fixnum-type? u)) (not (flonum-type? u)))))) (one-argument-propagate! (lambda (w1) (when (and (can-be? number-type? w1) (can-be-non? nonrectangular-number-type? w1)) (for-each-member (lambda (u1) (set-type-type-tag-accessed?! u1 #t)) w1)) (when (can-be? number-type? w1) (propagate-result! )) (when (can-be-non? nonrectangular-number-type? w1) (propagate-result! )))) #f (type-switch type? w1 r t1 (lambda (u1) (cond ((nonrectangular-number-type? u1) (return-true r)) ((rectangular-type? u1) (compile-test r (c:==0.0 (c:i (c:value t1 u1 w1))))) (else (return-false r)))) (lambda (p?) (fuck-up)))) (define-primitive-procedure integer? one-argument-compatible? (one-argument-truly-compatible? type?) (list number-type?) (list (lambda (u) (or (not (number-type? u)) (not (fixnum-type? u))))) (one-argument-propagate! (lambda (w1) (when (and (can-be? number-type? w1) (can-be-non? fixnum-type? w1)) (for-each-member (lambda (u1) (set-type-type-tag-accessed?! u1 #t)) w1)) (when (can-be? number-type? w1) (propagate-result! )) (when (can-be-non? fixnum-type? w1) (propagate-result! )))) #f (type-switch type? w1 r t1 (lambda (u1) (cond ((fixnum-type? u1) (return-true r)) ((flonum-type? u1) (compile-test r (c:== (c:value t1 u1 w1) (c:rint (c:value t1 u1 w1))))) ((rectangular-type? u1) (compile-test r (c:&& (c:==0.0 (c:i (c:value t1 u1 w1))) (c:== (c:r (c:value t1 u1 w1)) (c:rint (c:r (c:value t1 u1 w1))))))) (else (return-false r)))) (lambda (p?) (fuck-up)))) (define-primitive-procedure exact? one-argument-compatible? (one-argument-truly-compatible? number-type?) (list fixnum-type?) (list (lambda (u) (and (number-type? u) (not (fixnum-type? u))))) (one-argument-propagate! (lambda (w1) (when (can-be? fixnum-type? w1) (propagate-result! )) (when (or (can-be? flonum-type? w1) (can-be? rectangular-type? w1)) (propagate-result! )))) #f (type-switch number-type? w1 r t1 (lambda (u1) (compile-time-test r (exact-type? u1))) (lambda (p?) (compile-error "exact" y p?)))) (define-primitive-procedure inexact? one-argument-compatible? (one-argument-truly-compatible? number-type?) (list (lambda (u) (and (number-type? u) (not (fixnum-type? u))))) (list fixnum-type?) (one-argument-propagate! (lambda (w1) (when (or (can-be? flonum-type? w1) (can-be? rectangular-type? w1)) (propagate-result! )) (when (can-be? fixnum-type? w1) (propagate-result! )))) #f (type-switch number-type? w1 r t1 (lambda (u1) (compile-time-test r (inexact-type? u1))) (lambda (p?) (compile-error "inexact" y p?)))) (define-primitive-procedure = two-or-more-arguments-compatible? (all-arguments-truly-compatible? number-type?) (map-n (lambda (i) number-type?) n) (map-n (lambda (i) number-type?) n) (all-arguments-propagate! (lambda (ws) (propagate-result! ) (propagate-result! ))) #f (compile-comparison r y ts ws (lambda (c1 c2 u1 u2) (if (rectangular-type? u1) (if (rectangular-type? u2) (c:&& (c:== (c:r c1) (c:r c2)) (c:== (c:i c1) (c:i c2))) (c:&& (c:== (c:r c1) c2) (c:==0.0 (c:i c1)))) (if (rectangular-type? u2) (c:&& (c:== c1 (c:r c2)) (c:==0.0 (c:i c2))) (c:== c1 c2)))) "eql")) (define-primitive-procedure < two-or-more-arguments-compatible? (all-arguments-truly-compatible? number-type?) (map-n (lambda (i) number-type?) n) (map-n (lambda (i) number-type?) n) (all-arguments-propagate! (lambda (ws) (propagate-result! ) (propagate-result! ))) #f (compile-comparison r y ts ws (lambda (c1 c2 u1 u2) (c:< c1 c2)) "lt")) (define-primitive-procedure > two-or-more-arguments-compatible? (all-arguments-truly-compatible? number-type?) (map-n (lambda (i) number-type?) n) (map-n (lambda (i) number-type?) n) (all-arguments-propagate! (lambda (ws) (propagate-result! ) (propagate-result! ))) #f (compile-comparison r y ts ws (lambda (c1 c2 u1 u2) (c:> c1 c2)) "gt")) (define-primitive-procedure <= two-or-more-arguments-compatible? (all-arguments-truly-compatible? number-type?) (map-n (lambda (i) number-type?) n) (map-n (lambda (i) number-type?) n) (all-arguments-propagate! (lambda (ws) (propagate-result! ) (propagate-result! ))) #f (compile-comparison r y ts ws (lambda (c1 c2 u1 u2) (c:<= c1 c2)) "le")) (define-primitive-procedure >= two-or-more-arguments-compatible? (all-arguments-truly-compatible? number-type?) (map-n (lambda (i) number-type?) n) (map-n (lambda (i) number-type?) n) (all-arguments-propagate! (lambda (ws) (propagate-result! ) (propagate-result! ))) #f (compile-comparison r y ts ws (lambda (c1 c2 u1 u2) (c:>= c1 c2)) "ge")) (define-primitive-procedure zero? ;; Extension to R4RS: ZERO? can apply to pointers, strings, and ports. one-argument-compatible? (one-argument-truly-compatible? (lambda (u1) (or (number-type? u1) (pointer-type? u1) (string-type? u1) (input-port-type? u1) (output-port-type? u1)))) (list (lambda (u) (or (number-type? u) (pointer-type? u) (string-type? u) (input-port-type? u) (output-port-type? u)))) (list (lambda (u) (or (number-type? u) (pointer-type? u) (string-type? u) (input-port-type? u) (output-port-type? u)))) (one-argument-propagate! (lambda (w1) (propagate-result! ) (propagate-result! ))) #f (type-switch (lambda (u1) (or (number-type? u1) (pointer-type? u1) (string-type? u1) (input-port-type? u1) (output-port-type? u1))) w1 r t1 (lambda (u1) (cond ((or (pointer-type? u1) (string-type? u1) (input-port-type? u1) (output-port-type? u1)) (compile-test r (c:==null (c:value t1 u1 w1)))) ((fixnum-type? u1) (compile-test r (c:==0 (c:value t1 u1 w1)))) ((flonum-type? u1) (compile-test r (c:==0.0 (c:value t1 u1 w1)))) ((rectangular-type? u1) (compile-test r (c:&& (c:==0.0 (c:r (c:value t1 u1 w1))) (c:==0.0 (c:i (c:value t1 u1 w1)))))) (else (fuck-up)))) (lambda (p?) (compile-error "zero" y p?)))) (define-primitive-procedure positive? one-argument-compatible? (one-argument-truly-compatible? number-type?) (list number-type?) (list number-type?) (one-argument-propagate! (lambda (w1) (propagate-result! ) (propagate-result! ))) #f (type-switch number-type? w1 r t1 (lambda (u1) (cond ((fixnum-type? u1) (compile-test r (c:>0 (c:value t1 u1 w1)))) ((flonum-type? u1) (compile-test r (c:>0.0 (c:value t1 u1 w1)))) ((rectangular-type? u1) (newline-between (if *type-checks?* (c:if (c:!=0.0 (c:i (c:value t1 u1 w1))) (compile-error "positive" y #f) (c:noop) #f) (c:noop)) (compile-test r (c:>0.0 (c:r (c:value t1 u1 w1)))))) (else (fuck-up)))) (lambda (p?) (compile-error "positive" y p?)))) (define-primitive-procedure negative? one-argument-compatible? (one-argument-truly-compatible? number-type?) (list number-type?) (list number-type?) (one-argument-propagate! (lambda (w1) (propagate-result! ) (propagate-result! ))) #f (type-switch number-type? w1 r t1 (lambda (u1) (cond ((fixnum-type? u1) (compile-test r (c:<0 (c:value t1 u1 w1)))) ((flonum-type? u1) (compile-test r (c:<0.0 (c:value t1 u1 w1)))) ((rectangular-type? u1) (newline-between (if *type-checks?* (c:if (c:!=0.0 (c:i (c:value t1 u1 w1))) (compile-error "negative" y #f) (c:noop) #f) (c:noop)) (compile-test r (c:<0.0 (c:r (c:value t1 u1 w1)))))) (else (fuck-up)))) (lambda (p?) (compile-error "negative" y p?)))) (define-primitive-procedure max one-or-more-arguments-compatible? (all-arguments-truly-compatible? number-type?) (map-n (lambda (i) number-type?) n) (map-n (lambda (i) number-type?) n) (all-arguments-propagate! (lambda (ws) (when (every (lambda (w) (can-be? fixnum-type? w)) ws) (propagate-result! )) (when (and (every (lambda (w) (can-be? nonrectangular-number-type? w)) ws) (some (lambda (w) (can-be? flonum-type? w)) ws)) (propagate-result! )) (when (and (every (lambda (w) (can-be? number-type? w)) ws) (some (lambda (w) (can-be? rectangular-type? w)) ws)) (propagate-result! )))) #f (if (null? (rest ws)) (type-switch number-type? w1 r t1 (lambda (u1) (cond ((fixnum-type? u1) (widen r (c:value t1 u1 w1) fixnum-type?)) ((flonum-type? u1) (widen r (c:value t1 u1 w1) flonum-type?)) ;; needs work: To handle rectangular numbers. (else (fuck-up)))) (lambda (p?) (compile-error "max" y p?))) (compile-arithmetic number-type? r y ts ws ;; needs work: To handle rectangular numbers. (lambda (u1 u2) ;; This is a violation of the no-<...>-after-type-propagation principle. (if (and (fixnum-type? u1) (fixnum-type? u2)) )) ;; needs work: To handle rectangular numbers. (lambda (c1 u1 c2 u2) (if (and (fixnum-type? u1) (fixnum-type? u2)) (c:imax c1 c2) (c:rmax c1 c2))) "max"))) (define-primitive-procedure min one-or-more-arguments-compatible? (all-arguments-truly-compatible? number-type?) (map-n (lambda (i) number-type?) n) (map-n (lambda (i) number-type?) n) (all-arguments-propagate! (lambda (ws) (when (every (lambda (w) (can-be? fixnum-type? w)) ws) (propagate-result! )) (when (and (every (lambda (w) (can-be? nonrectangular-number-type? w)) ws) (some (lambda (w) (can-be? flonum-type? w)) ws)) (propagate-result! )) (when (and (every (lambda (w) (can-be? number-type? w)) ws) (some (lambda (w) (can-be? rectangular-type? w)) ws)) (propagate-result! )))) #f (if (null? (rest ws)) (type-switch number-type? w1 r t1 (lambda (u1) (cond ((fixnum-type? u1) (widen r (c:value t1 u1 w1) fixnum-type?)) ((flonum-type? u1) (widen r (c:value t1 u1 w1) flonum-type?)) ;; needs work: To handle rectangular numbers. (else (fuck-up)))) (lambda (p?) (compile-error "min" y p?))) (compile-arithmetic number-type? r y ts ws ;; needs work: To handle rectangular numbers. (lambda (u1 u2) ;; This is a violation of the no-<...>-after-type-propagation principle. (if (and (fixnum-type? u1) (fixnum-type? u2)) )) ;; needs work: To handle rectangular numbers. (lambda (c1 u1 c2 u2) (if (and (fixnum-type? u1) (fixnum-type? u2)) (c:imin c1 c2) (c:rmin c1 c2))) "min"))) (define-primitive-procedure + zero-or-more-arguments-compatible? (all-arguments-truly-compatible? number-type?) (map-n (lambda (i) number-type?) n) (map-n (lambda (i) number-type?) n) (all-arguments-propagate! (lambda (ws) (cond ((null? ws) (propagate-result! )) (else (when (every (lambda (w) (can-be? fixnum-type? w)) ws) (propagate-result! )) (when (and (every (lambda (w) (can-be? nonrectangular-number-type? w)) ws) (some (lambda (w) (can-be? flonum-type? w)) ws)) (propagate-result! )) (when (and (every (lambda (w) (can-be? number-type? w)) ws) (some (lambda (w) (can-be? rectangular-type? w)) ws)) (propagate-result! )))))) #f (cond ((null? ws) (widen r (c:0) fixnum-type?)) ((null? (rest ws)) (type-switch number-type? w1 r t1 (lambda (u1) (widen-type r (c:value t1 u1 w1) u1)) (lambda (p?) (compile-error "plus" y p?)))) (else (compile-arithmetic number-type? r y ts ws (lambda (u1 u2) ;; This is a violation of the no-<...>-after-type-propagation principle. (cond ((and (fixnum-type? u1) (fixnum-type? u2)) ) ((or (rectangular-type? u1) (rectangular-type? u2)) ) (else ))) (lambda (c1 u1 c2 u2) (cond ((and (fixnum-type? u1) (fixnum-type? u2)) (when *overflow-checks?* (unimplemented y "Safe exact arithmetic is not (yet) implemented")) (c:+ c1 c2)) ((rectangular-type? u1) (if (rectangular-type? u2) (c:pluscc c1 c2) (c:pluscr c1 c2))) ((rectangular-type? u2) (c:plusrc c1 c2)) (else (c:+ c1 c2)))) "plus")))) (define-primitive-procedure * zero-or-more-arguments-compatible? (all-arguments-truly-compatible? number-type?) (map-n (lambda (i) number-type?) n) (map-n (lambda (i) number-type?) n) (all-arguments-propagate! (lambda (ws) (cond ((null? ws) (propagate-result! )) (else (when (every (lambda (w) (can-be? fixnum-type? w)) ws) (propagate-result! )) (when (and (every (lambda (w) (can-be? nonrectangular-number-type? w)) ws) (some (lambda (w) (can-be? flonum-type? w)) ws)) (propagate-result! )) (when (and (every (lambda (w) (can-be? number-type? w)) ws) (some (lambda (w) (can-be? rectangular-type? w)) ws)) (propagate-result! )))))) #f (cond ((null? ws) (widen r (c:1) fixnum-type?)) ((null? (rest ws)) (type-switch number-type? w1 r t1 (lambda (u1) (widen-type r (c:value t1 u1 w1) u1)) (lambda (p?) (compile-error "times" y p?)))) (else (compile-arithmetic number-type? r y ts ws (lambda (u1 u2) ;; This is a violation of the no-<...>-after-type-propagation principle. (cond ((and (fixnum-type? u1) (fixnum-type? u2)) ) ((or (rectangular-type? u1) (rectangular-type? u2)) ) (else ))) (lambda (c1 u1 c2 u2) (cond ((and (fixnum-type? u1) (fixnum-type? u2)) (when *overflow-checks?* (unimplemented y "Safe exact arithmetic is not (yet) implemented")) (c:* c1 c2)) ((rectangular-type? u1) (if (rectangular-type? u2) (c:timescc c1 c2) (c:timescr c1 c2))) ((rectangular-type? u2) (c:timesrc c1 c2)) (else (c:* c1 c2)))) "times")))) (define-primitive-procedure - one-or-more-arguments-compatible? (all-arguments-truly-compatible? number-type?) (map-n (lambda (i) number-type?) n) (map-n (lambda (i) number-type?) n) (all-arguments-propagate! (lambda (ws) (when (every (lambda (w) (can-be? fixnum-type? w)) ws) (propagate-result! )) (when (and (every (lambda (w) (can-be? nonrectangular-number-type? w)) ws) (some (lambda (w) (can-be? flonum-type? w)) ws)) (propagate-result! )) (when (and (every (lambda (w) (can-be? number-type? w)) ws) (some (lambda (w) (can-be? rectangular-type? w)) ws)) (propagate-result! )))) #f (if (null? (rest ws)) (type-switch number-type? w1 r t1 (lambda (u1) (cond ((fixnum-type? u1) (when *overflow-checks?* (unimplemented y "Safe exact arithmetic is not (yet) implemented")) (widen r (c:- (c:value t1 u1 w1)) fixnum-type?)) ((flonum-type? u1) (widen r (c:- (c:value t1 u1 w1)) flonum-type?)) ((rectangular-type? u1) (widen r (c:negc (c:value t1 u1 w1)) rectangular-type?)) (else (fuck-up)))) (lambda (p?) (compile-error "minus" y p?))) (compile-arithmetic number-type? r y ts ws (lambda (u1 u2) ;; This is a violation of the no-<...>-after-type-propagation principle. (cond ((and (fixnum-type? u1) (fixnum-type? u2)) ) ((or (rectangular-type? u1) (rectangular-type? u2)) ) (else ))) (lambda (c1 u1 c2 u2) (cond ((and (fixnum-type? u1) (fixnum-type? u2)) (when *overflow-checks?* (unimplemented y "Safe exact arithmetic is not (yet) implemented")) (c:- c1 c2)) ((rectangular-type? u1) (if (rectangular-type? u2) (c:minuscc c1 c2) (c:minuscr c1 c2))) ((rectangular-type? u2) (c:minusrc c1 c2)) (else (c:- c1 c2)))) "minus"))) (define-primitive-procedure / ;; note: / will always produce a flonum result, even if given fixnum arguments ;; that could produce a fixnum result. This is allowed by R4RS since ;; / is not included in the table on the top of page 20, the table that ;; specifies which procedures must return exact results when given ;; exact arguments. If we did allow / to return a fixnum then it would ;; have to return a union of a fixnum and a flonum since whether or not ;; a fixnum could be returned would depend on whether or not the ;; denominator divides the numerator. This is beyond the scope of the ;; type system. It is preferable not to have a union type and not to ;; require run-time divisability checks. one-or-more-arguments-compatible? (all-arguments-truly-compatible? number-type?) (map-n (lambda (i) number-type?) n) (map-n (lambda (i) number-type?) n) (all-arguments-propagate! (lambda (ws) (when (every (lambda (w) (can-be? nonrectangular-number-type? w)) ws) (propagate-result! )) (when (and (every (lambda (w) (can-be? number-type? w)) ws) (some (lambda (w) (can-be? rectangular-type? w)) ws)) (propagate-result! )))) #f (if (null? (rest ws)) (type-switch number-type? w1 r t1 (lambda (u1) (cond ((nonrectangular-number-type? u1) (widen r (c:/ (c:1.0) (c:value t1 u1 w1)) flonum-type?)) ((rectangular-type? u1) (widen r (c:recipc (c:value t1 u1 w1)) rectangular-type?)) (else (fuck-up)))) (lambda (p?) (compile-error "divide" y p?))) (compile-arithmetic number-type? r y ts ws (lambda (u1 u2) (if (or (rectangular-type? u1) (rectangular-type? u2)) ;; This is a violation of the no-<...>-after-type-propagation ;; principle. )) (lambda (c1 u1 c2 u2) (cond ((and (fixnum-type? u1) (fixnum-type? u2)) (c:/ (c:flonum-cast c1) (c:flonum-cast c2))) ((rectangular-type? u1) (if (rectangular-type? u2) (c:dividecc c1 c2) (c:dividecr c1 c2))) ((rectangular-type? u2) (c:dividerc c1 c2)) (else (c:/ c1 c2)))) "divide"))) (define-primitive-procedure quotient ;; needs work: To handle +inf, -inf, and NaN arguments. ;; needs work: To check for division by zero. two-arguments-compatible? (two-arguments-truly-compatible? number-type? number-type?) (list number-type? number-type?) (list number-type? number-type?) (two-arguments-propagate! (lambda (w1 w2) (when (and (can-be? fixnum-type? w1) (can-be? fixnum-type? w2)) (propagate-result! )) (when (or (and (or (can-be? flonum-type? w1) (can-be? rectangular-type? w1)) (can-be? number-type? w2)) (and (can-be? number-type? w1) (or (can-be? flonum-type? w2) (can-be? rectangular-type? w2)))) (propagate-result! )))) #f (type-switch number-type? w1 r t1 (lambda (u1) (type-switch number-type? w2 r t2 (lambda (u2) (newline-between (if *type-checks?* (newline-between (cond ((flonum-type? u1) (c:if (c:!= (c:value t1 u1 w1) (c:rint (c:value t1 u1 w1))) (compile-error "quotient1" y #f) (c:noop) #f)) ((rectangular-type? u1) (c:if (c:boolean-or (c:!=0.0 (c:i (c:value t1 u1 w1))) (c:!= (c:r (c:value t1 u1 w1)) (c:rint (c:r (c:value t1 u1 w1))))) (compile-error "quotient1" y #f) (c:noop) #f)) (else (c:noop))) (cond ((flonum-type? u2) (c:if (c:!= (c:value t2 u2 w2) (c:rint (c:value t2 u2 w2))) (compile-error "quotient2" y #f) (c:noop) #f)) ((rectangular-type? u2) (c:if (c:boolean-or (c:!=0.0 (c:i (c:value t2 u2 w2))) (c:!= (c:r (c:value t2 u2 w2)) (c:rint (c:r (c:value t2 u2 w2))))) (compile-error "quotient2" y #f) (c:noop) #f)) (else (c:noop)))) (c:noop)) (widen r (c:/ (cond ((fixnum-type? u1) (c:value t1 u1 w1)) ((flonum-type? u1) (c:fixnum-cast (c:value t1 u1 w1))) ((rectangular-type? u1) (c:fixnum-cast (c:r (c:value t1 u1 w1)))) (else (fuck-up))) (cond ((fixnum-type? u2) (c:value t2 u2 w2)) ((flonum-type? u2) (c:fixnum-cast (c:value t2 u2 w2))) ((rectangular-type? u2) (c:fixnum-cast (c:r (c:value t2 u2 w2)))) (else (fuck-up)))) (if (and (fixnum-type? u1) (fixnum-type? u2)) fixnum-type? flonum-type?)))) (lambda (p?) (compile-error "quotient2" y p?)))) (lambda (p?) (compile-error "quotient1" y p?)))) (define-primitive-procedure remainder ;; needs work: To handle +inf, -inf, and NaN arguments. ;; needs work: To check for division by zero. two-arguments-compatible? (two-arguments-truly-compatible? number-type? number-type?) (list number-type? number-type?) (list number-type? number-type?) (two-arguments-propagate! (lambda (w1 w2) (when (and (can-be? fixnum-type? w1) (can-be? fixnum-type? w2)) (propagate-result! )) (when (or (and (or (can-be? flonum-type? w1) (can-be? rectangular-type? w1)) (can-be? number-type? w2)) (and (can-be? number-type? w1) (or (can-be? flonum-type? w2) (can-be? rectangular-type? w2)))) (propagate-result! )))) #f (type-switch number-type? w1 r t1 (lambda (u1) (type-switch number-type? w2 r t2 (lambda (u2) (newline-between (if *type-checks?* (newline-between (cond ((flonum-type? u1) (c:if (c:!= (c:value t1 u1 w1) (c:rint (c:value t1 u1 w1))) (compile-error "remainder1" y #f) (c:noop) #f)) ((rectangular-type? u1) (c:if (c:boolean-or (c:!=0.0 (c:i (c:value t1 u1 w1))) (c:!= (c:r (c:value t1 u1 w1)) (c:rint (c:r (c:value t1 u1 w1))))) (compile-error "remainder1" y #f) (c:noop) #f)) (else (c:noop))) (cond ((flonum-type? u2) (c:if (c:!= (c:value t2 u2 w2) (c:rint (c:value t2 u2 w2))) (compile-error "remainder2" y #f) (c:noop) #f)) ((rectangular-type? u2) (c:if (c:boolean-or (c:!=0.0 (c:i (c:value t2 u2 w2))) (c:!= (c:r (c:value t2 u2 w2)) (c:rint (c:r (c:value t2 u2 w2))))) (compile-error "remainder2" y #f) (c:noop) #f)) (else (c:noop)))) (c:noop)) (widen r (c:% (cond ((fixnum-type? u1) (c:value t1 u1 w1)) ((flonum-type? u1) (c:fixnum-cast (c:value t1 u1 w1))) ((rectangular-type? u1) (c:fixnum-cast (c:r (c:value t1 u1 w1)))) (else (fuck-up))) (cond ((fixnum-type? u2) (c:value t2 u2 w2)) ((flonum-type? u2) (c:fixnum-cast (c:value t2 u2 w2))) ((rectangular-type? u2) (c:fixnum-cast (c:r (c:value t2 u2 w2)))) (else (fuck-up)))) (if (and (fixnum-type? u1) (fixnum-type? u2)) fixnum-type? flonum-type?)))) (lambda (p?) (compile-error "remainder2" y p?)))) (lambda (p?) (compile-error "remainder1" y p?)))) (define-primitive-procedure << ;; needs work: To handle +inf, -inf, and NaN arguments. ;; needs work: To check for overflow. two-arguments-compatible? (two-arguments-truly-compatible? number-type? number-type?) (list number-type? number-type?) (list number-type? number-type?) (two-arguments-propagate! (lambda (w1 w2) (when (and (can-be? fixnum-type? w1) (can-be? fixnum-type? w2)) (propagate-result! )) (when (or (and (or (can-be? flonum-type? w1) (can-be? rectangular-type? w1)) (can-be? number-type? w2)) (and (can-be? number-type? w1) (or (can-be? flonum-type? w2) (can-be? rectangular-type? w2)))) (propagate-result! )))) #f (type-switch number-type? w1 r t1 (lambda (u1) (type-switch number-type? w2 r t2 (lambda (u2) (newline-between (if *type-checks?* (newline-between (cond ((flonum-type? u1) (c:if (c:!= (c:value t1 u1 w1) (c:rint (c:value t1 u1 w1))) (compile-error "lsh1" y #f) (c:noop) #f)) ((rectangular-type? u1) (c:if (c:boolean-or (c:!=0.0 (c:i (c:value t1 u1 w1))) (c:!= (c:r (c:value t1 u1 w1)) (c:rint (c:r (c:value t1 u1 w1))))) (compile-error "lsh1" y #f) (c:noop) #f)) (else (c:noop))) (cond ((flonum-type? u2) (c:if (c:!= (c:value t2 u2 w2) (c:rint (c:value t2 u2 w2))) (compile-error "lsh2" y #f) (c:noop) #f)) ((rectangular-type? u2) (c:if (c:boolean-or (c:!=0.0 (c:i (c:value t2 u2 w2))) (c:!= (c:r (c:value t2 u2 w2)) (c:rint (c:r (c:value t2 u2 w2))))) (compile-error "lsh2" y #f) (c:noop) #f)) (else (c:noop)))) (c:noop)) (widen r (c:<< (cond ((fixnum-type? u1) (c:value t1 u1 w1)) ((flonum-type? u1) (c:fixnum-cast (c:value t1 u1 w1))) ((rectangular-type? u1) (c:fixnum-cast (c:r (c:value t1 u1 w1)))) (else (fuck-up))) (cond ((fixnum-type? u2) (c:value t2 u2 w2)) ((flonum-type? u2) (c:fixnum-cast (c:value t2 u2 w2))) ((rectangular-type? u2) (c:fixnum-cast (c:r (c:value t2 u2 w2)))) (else (fuck-up)))) (if (and (fixnum-type? u1) (fixnum-type? u2)) fixnum-type? flonum-type?)))) (lambda (p?) (compile-error "lsh2" y p?)))) (lambda (p?) (compile-error "lsh1" y p?)))) (define-primitive-procedure >> ;; needs work: To handle +inf, -inf, and NaN arguments. two-arguments-compatible? (two-arguments-truly-compatible? number-type? number-type?) (list number-type? number-type?) (list number-type? number-type?) (two-arguments-propagate! (lambda (w1 w2) (when (and (can-be? fixnum-type? w1) (can-be? fixnum-type? w2)) (propagate-result! )) (when (or (and (or (can-be? flonum-type? w1) (can-be? rectangular-type? w1)) (can-be? number-type? w2)) (and (can-be? number-type? w1) (or (can-be? flonum-type? w2) (can-be? rectangular-type? w2)))) (propagate-result! )))) #f (type-switch number-type? w1 r t1 (lambda (u1) (type-switch number-type? w2 r t2 (lambda (u2) (newline-between (if *type-checks?* (newline-between (cond ((flonum-type? u1) (c:if (c:!= (c:value t1 u1 w1) (c:rint (c:value t1 u1 w1))) (compile-error "rsh1" y #f) (c:noop) #f)) ((rectangular-type? u1) (c:if (c:boolean-or (c:!=0.0 (c:i (c:value t1 u1 w1))) (c:!= (c:r (c:value t1 u1 w1)) (c:rint (c:r (c:value t1 u1 w1))))) (compile-error "rsh1" y #f) (c:noop) #f)) (else (c:noop))) (cond ((flonum-type? u2) (c:if (c:!= (c:value t2 u2 w2) (c:rint (c:value t2 u2 w2))) (compile-error "rsh2" y #f) (c:noop) #f)) ((rectangular-type? u2) (c:if (c:boolean-or (c:!=0.0 (c:i (c:value t2 u2 w2))) (c:!= (c:r (c:value t2 u2 w2)) (c:rint (c:r (c:value t2 u2 w2))))) (compile-error "rsh2" y #f) (c:noop) #f)) (else (c:noop)))) (c:noop)) (widen r (c:>> (cond ((fixnum-type? u1) (c:value t1 u1 w1)) ((flonum-type? u1) (c:fixnum-cast (c:value t1 u1 w1))) ((rectangular-type? u1) (c:fixnum-cast (c:r (c:value t1 u1 w1)))) (else (fuck-up))) (cond ((fixnum-type? u2) (c:value t2 u2 w2)) ((flonum-type? u2) (c:fixnum-cast (c:value t2 u2 w2))) ((rectangular-type? u2) (c:fixnum-cast (c:r (c:value t2 u2 w2)))) (else (fuck-up)))) (if (and (fixnum-type? u1) (fixnum-type? u2)) fixnum-type? flonum-type?)))) (lambda (p?) (compile-error "rsh2" y p?)))) (lambda (p?) (compile-error "rsh1" y p?)))) (define-primitive-procedure bitwise-not ;; needs work: To handle inexact numbers. one-argument-compatible? (one-argument-truly-compatible? fixnum-type?) (list fixnum-type?) (list fixnum-type?) (one-argument-propagate! (lambda (w1) (propagate-result! ))) #f (type-switch fixnum-type? w1 r t1 (lambda (u1) (widen r (c:~ (c:value t1 u1 w1)) fixnum-type?)) (lambda (p?) (compile-error "bitwise_not" y p?)))) (define-primitive-procedure bitwise-and ;; needs work: To handle inexact numbers. zero-or-more-arguments-compatible? (all-arguments-truly-compatible? fixnum-type?) (map-n (lambda (i) fixnum-type?) n) (map-n (lambda (i) fixnum-type?) n) (all-arguments-propagate! (lambda (ws) (propagate-result! ))) #f (cond ((null? ws) (widen r (c:~ (c:0)) fixnum-type?)) ((null? (rest ws)) (type-switch fixnum-type? w1 r t1 (lambda (u1) (widen r (c:value t1 u1 w1) fixnum-type?)) (lambda (p?) (compile-error "bitwise_and" y p?)))) (else (compile-arithmetic fixnum-type? r y ts ws ;; This is a violation of the no-<...>-after-type-propagation ;; principle. (lambda (u1 u2) ) (lambda (c1 u1 c2 u2) (c:& c1 c2)) "bitwise_and")))) (define-primitive-procedure bitwise-or ;; needs work: To handle inexact numbers. zero-or-more-arguments-compatible? (all-arguments-truly-compatible? fixnum-type?) (map-n (lambda (i) fixnum-type?) n) (map-n (lambda (i) fixnum-type?) n) (all-arguments-propagate! (lambda (ws) (propagate-result! ))) #f (cond ((null? ws) (widen r (c:0) fixnum-type?)) ((null? (rest ws)) (type-switch fixnum-type? w1 r t1 (lambda (u1) (widen r (c:value t1 u1 w1) fixnum-type?)) (lambda (p?) (compile-error "bitwise_or" y p?)))) (else (compile-arithmetic fixnum-type? r y ts ws ;; This is a violation of the no-<...>-after-type-propagation ;; principle. (lambda (u1 u2) ) (lambda (c1 u1 c2 u2) (c:bitwise-or c1 c2)) "bitwise_or")))) (define-primitive-procedure bitwise-xor ;; needs work: To handle inexact numbers. zero-or-more-arguments-compatible? (all-arguments-truly-compatible? fixnum-type?) (map-n (lambda (i) fixnum-type?) n) (map-n (lambda (i) fixnum-type?) n) (all-arguments-propagate! (lambda (ws) (propagate-result! ))) #f (cond ((null? ws) (widen r (c:0) fixnum-type?)) ((null? (rest ws)) (type-switch fixnum-type? w1 r t1 (lambda (u1) (widen r (c:value t1 u1 w1) fixnum-type?)) (lambda (p?) (compile-error "bitwise_xor" y p?)))) (else (compile-arithmetic fixnum-type? r y ts ws ;; This is a violation of the no-<...>-after-type-propagation ;; principle. (lambda (u1 u2) ) (lambda (c1 u1 c2 u2) (c:^ c1 c2)) "bitwise_xor")))) (define-primitive-procedure floor ;; needs work: To handle +inf, -inf, and NaN arguments. one-argument-compatible? (one-argument-truly-compatible? number-type?) (list number-type?) (list number-type?) (one-argument-propagate! (lambda (w1) (when (can-be? fixnum-type? w1) (propagate-result! )) (when (or (can-be? flonum-type? w1) (can-be? rectangular-type? w1)) (propagate-result! )))) #f (type-switch number-type? w1 r t1 (lambda (u1) (cond ((fixnum-type? u1) (widen r (c:value t1 u1 w1) fixnum-type?)) ((flonum-type? u1) (widen r (c:floor (c:value t1 u1 w1)) flonum-type?)) ((rectangular-type? u1) (newline-between (if *type-checks?* (c:if (c:!=0.0 (c:i (c:value t1 u1 w1))) (compile-error "floor" y #f) (c:noop) #f) (c:noop)) (widen r (c:floor (c:r (c:value t1 u1 w1))) flonum-type?))) (else (fuck-up)))) (lambda (p?) (compile-error "floor" y p?)))) (define-primitive-procedure ceiling ;; needs work: To handle +inf, -inf, and NaN arguments. one-argument-compatible? (one-argument-truly-compatible? number-type?) (list number-type?) (list number-type?) (one-argument-propagate! (lambda (w1) (when (can-be? fixnum-type? w1) (propagate-result! )) (when (or (can-be? flonum-type? w1) (can-be? rectangular-type? w1)) (propagate-result! )))) #f (type-switch number-type? w1 r t1 (lambda (u1) (cond ((fixnum-type? u1) (widen r (c:value t1 u1 w1) fixnum-type?)) ((flonum-type? u1) (widen r (c:ceil (c:value t1 u1 w1)) flonum-type?)) ((rectangular-type? u1) (newline-between (if *type-checks?* (c:if (c:!=0.0 (c:i (c:value t1 u1 w1))) (compile-error "ceiling" y #f) (c:noop) #f) (c:noop)) (widen r (c:ceil (c:r (c:value t1 u1 w1))) flonum-type?))) (else (fuck-up)))) (lambda (p?) (compile-error "ceiling" y p?)))) (define-primitive-procedure truncate ;; needs work: To handle +inf, -inf, and NaN arguments. one-argument-compatible? (one-argument-truly-compatible? number-type?) (list number-type?) (list number-type?) (one-argument-propagate! (lambda (w1) (when (can-be? fixnum-type? w1) (propagate-result! )) (when (or (can-be? flonum-type? w1) (can-be? rectangular-type? w1)) (propagate-result! )))) #f (type-switch number-type? w1 r t1 (lambda (u1) (cond ((fixnum-type? u1) (widen r (c:value t1 u1 w1) fixnum-type?)) ((flonum-type? u1) (widen r (c:?: (c:<0.0 (c:value t1 u1 w1)) (c:ceil (c:value t1 u1 w1)) (c:floor (c:value t1 u1 w1))) flonum-type?)) ((rectangular-type? u1) (newline-between (if *type-checks?* (c:if (c:!=0.0 (c:i (c:value t1 u1 w1))) (compile-error "truncate" y #f) (c:noop) #f) (c:noop)) (widen r (c:?: (c:<0.0 (c:r (c:value t1 u1 w1))) (c:ceil (c:r (c:value t1 u1 w1))) (c:floor (c:r (c:value t1 u1 w1)))) flonum-type?))) (else (fuck-up)))) (lambda (p?) (compile-error "truncate" y p?)))) (define-primitive-procedure round ;; needs work: To handle +inf, -inf, and NaN arguments. one-argument-compatible? (one-argument-truly-compatible? number-type?) (list number-type?) (list number-type?) (one-argument-propagate! (lambda (w1) (when (can-be? fixnum-type? w1) (propagate-result! )) (when (or (can-be? flonum-type? w1) (can-be? rectangular-type? w1)) (propagate-result! )))) #f (type-switch number-type? w1 r t1 (lambda (u1) (cond ((fixnum-type? u1) (widen r (c:value t1 u1 w1) fixnum-type?)) ((flonum-type? u1) (widen r (c:rint (c:value t1 u1 w1)) flonum-type?)) ((rectangular-type? u1) (newline-between (if *type-checks?* (c:if (c:!=0.0 (c:i (c:value t1 u1 w1))) (compile-error "round" y #f) (c:noop) #f) (c:noop)) (widen r (c:rint (c:r (c:value t1 u1 w1))) flonum-type?))) (else (fuck-up)))) (lambda (p?) (compile-error "round" y p?)))) (define-primitive-procedure exp ;; needs work: To handle +inf, -inf, and NaN arguments. one-argument-compatible? (one-argument-truly-compatible? number-type?) (list number-type?) (list number-type?) (one-argument-propagate! (lambda (w1) (propagate-result! ))) #f (type-switch number-type? w1 r t1 (lambda (u1) (cond ((nonrectangular-number-type? u1) (widen r (c:exp (c:value t1 u1 w1)) flonum-type?)) ((rectangular-type? u1) (unimplemented y "EXP on rectangular arguments is not (yet) implemented")) (else (fuck-up)))) (lambda (p?) (compile-error "exp" y p?)))) (define-primitive-procedure log ;; needs work: To handle negative, zero, +inf, and NaN arguments. ;; needs work: If this were implemented properly and supported rectangular ;; results we would have two choices: either always return a ;; rectangular result or return a union of a rectangular and a ;; flonum. The former is undesirable since that would cause ;; rectangular pollution. The later is undesirable since that ;; would cause union type pollution and require run-time checking ;; of whether the argument is negative. There is no way with the ;; current type system to force the result of LOG to be a monotype ;; flonum. Thus we currently violate R4RS in this regard. ;; note: Since LOG is not included in the table on the top of page 20 of R4RS ;; it can return inexact results even when given exact arguments that ;; could otherwise yield an exact result. This licenses never returning ;; a fixnum. one-argument-compatible? (one-argument-truly-compatible? number-type?) (list number-type?) (list number-type?) (one-argument-propagate! (lambda (w1) (propagate-result! ))) #f (type-switch number-type? w1 r t1 (lambda (u1) (cond ((nonrectangular-number-type? u1) (widen r (c:log (c:value t1 u1 w1)) flonum-type?)) ((rectangular-type? u1) (unimplemented y "LOG on rectangular arguments is not (yet) implemented")) (else (fuck-up)))) (lambda (p?) (compile-error "log" y p?)))) (define-primitive-procedure sin ;; needs work: To handle +inf, -inf, and NaN arguments. one-argument-compatible? (one-argument-truly-compatible? number-type?) (list number-type?) (list number-type?) (one-argument-propagate! (lambda (w1) (propagate-result! ))) #f (type-switch number-type? w1 r t1 (lambda (u1) (cond ((nonrectangular-number-type? u1) (widen r (c:sin (c:value t1 u1 w1)) flonum-type?)) ((rectangular-type? u1) (unimplemented y "SIN on rectangular arguments is not (yet) implemented")) (else (fuck-up)))) (lambda (p?) (compile-error "sin" y p?)))) (define-primitive-procedure cos ;; needs work: To handle +inf, -inf, and NaN arguments. one-argument-compatible? (one-argument-truly-compatible? number-type?) (list number-type?) (list number-type?) (one-argument-propagate! (lambda (w1) (propagate-result! ))) #f (type-switch number-type? w1 r t1 (lambda (u1) (cond ((nonrectangular-number-type? u1) (widen r (c:cos (c:value t1 u1 w1)) flonum-type?)) ((rectangular-type? u1) (unimplemented y "COS on rectangular arguments is not (yet) implemented")) (else (fuck-up)))) (lambda (p?) (compile-error "cos" y p?)))) (define-primitive-procedure tan ;; needs work: To handle +inf, -inf, and NaN arguments. one-argument-compatible? (one-argument-truly-compatible? number-type?) (list number-type?) (list number-type?) (one-argument-propagate! (lambda (w1) (propagate-result! ))) #f (type-switch number-type? w1 r t1 (lambda (u1) (cond ((nonrectangular-number-type? u1) (widen r (c:tan (c:value t1 u1 w1)) flonum-type?)) ((rectangular-type? u1) (unimplemented y "TAN on rectangular arguments is not (yet) implemented")) (else (fuck-up)))) (lambda (p?) (compile-error "tan" y p?)))) (define-primitive-procedure asin ;; needs work: To handle >1, <-1, and NaN arguments. ;; needs work: If this were implemented properly and supported rectangular ;; results we would have two choices: either always return a ;; rectangular result or return a union of a rectangular and a ;; flonum. The former is undesirable since that would cause ;; rectangular pollution. The later is undesirable since that ;; would cause union type pollution and require run-time checking ;; of whether the argument is <-1 or >1. There is no way with the ;; current type system to force the result of ASIN to be a ;; monotype flonum. Thus we currently violate R4RS in this regard. ;; note: Since ASIN is not included in the table on the top of page 20 of R4RS ;; it can return inexact results even when given exact arguments that ;; could otherwise yield an exact result. This licenses never returning ;; a fixnum. one-argument-compatible? (one-argument-truly-compatible? number-type?) (list number-type?) (list number-type?) (one-argument-propagate! (lambda (w1) (propagate-result! ))) #f (type-switch number-type? w1 r t1 (lambda (u1) (cond ((nonrectangular-number-type? u1) (widen r (c:asin (c:value t1 u1 w1)) flonum-type?)) ((rectangular-type? u1) (unimplemented y "ASIN on rectangular arguments is not (yet) implemented")) (else (fuck-up)))) (lambda (p?) (compile-error "asin" y p?)))) (define-primitive-procedure acos ;; needs work: To handle >1, <-1, and NaN arguments. ;; needs work: If this were implemented properly and supported rectangular ;; results we would have two choices: either always return a ;; rectangular result or return a union of a rectangular and a ;; flonum. The former is undesirable since that would cause ;; rectangular pollution. The later is undesirable since that ;; would cause union type pollution and require run-time checking ;; of whether the argument is <-1 or >1. There is no way with the ;; current type system to force the result of ACOS to be a ;; monotype flonum. Thus we currently violate R4RS in this regard. ;; note: Since ACOS is not included in the table on the top of page 20 of R4RS ;; it can return inexact results even when given exact arguments that ;; could otherwise yield an exact result. This licenses never returning ;; a fixnum. one-argument-compatible? (one-argument-truly-compatible? number-type?) (list number-type?) (list number-type?) (one-argument-propagate! (lambda (w1) (propagate-result! ))) #f (type-switch number-type? w1 r t1 (lambda (u1) (cond ((nonrectangular-number-type? u1) (widen r (c:acos (c:value t1 u1 w1)) flonum-type?)) ((rectangular-type? u1) (unimplemented y "ACOS on rectangular arguments is not (yet) implemented")) (else (fuck-up)))) (lambda (p?) (compile-error "acos" y p?)))) (define-primitive-procedure atan ;; needs work: To handle +inf, -inf, and NaN arguments. one-or-two-arguments-compatible? (one-or-two-arguments-truly-compatible? number-type? number-type?) (list number-type? number-type?) (list number-type? number-type?) (one-or-two-arguments-propagate! (lambda (w1) (propagate-result! )) (lambda (w1 w2) (propagate-result! ))) #f (if (= (length ws) 1) (type-switch number-type? w1 r t1 (lambda (u1) (cond ((nonrectangular-number-type? u1) (widen r (c:atan (c:value t1 u1 w1)) flonum-type?)) ((rectangular-type? u1) (unimplemented y "ATAN on rectangular arguments is not (yet) implemented")) (else (fuck-up)))) (lambda (p?) (compile-error "atan1" y p?))) (type-switch number-type? w1 r t1 (lambda (u1) (cond ((nonrectangular-number-type? u1) (type-switch number-type? w2 r t2 (lambda (u2) (cond ((nonrectangular-number-type? u2) (widen r (c:atan2 (c:value t1 u1 w1) (c:value t2 u2 w2)) flonum-type?)) ((rectangular-type? u2) (unimplemented y "ATAN on rectangular arguments is not (yet) implemented")) (else (fuck-up)))) (lambda (p?) (compile-error "atan3" y p?)))) ((rectangular-type? u1) (unimplemented y "ATAN on rectangular arguments is not (yet) implemented")) (else (fuck-up)))) (lambda (p?) (compile-error "atan2" y p?))))) (define-primitive-procedure sqrt ;; needs work: To handle negative, +inf, and NaN arguments. ;; needs work: If this were implemented properly and supported rectangular ;; results we would have two choices: either always return a ;; rectangular result or return a union of a rectangular and a ;; flonum. The former is undesirable since that would cause ;; rectangular pollution. The later is undesirable since that ;; would cause union type pollution and require run-time checking ;; of whether the argument is negative. There is no way with the ;; current type system to force the result of SQRT to be a ;; monotype flonum. Thus we currently violate R4RS in this regard. ;; note: Since SQRT is not included in the table on the top of page 20 of R4RS ;; it can return inexact results even when given exact arguments that ;; could otherwise yield an exact result. This licenses never returning ;; a fixnum. one-argument-compatible? (one-argument-truly-compatible? number-type?) (list number-type?) (list number-type?) (one-argument-propagate! (lambda (w1) (propagate-result! ))) #f (type-switch number-type? w1 r t1 (lambda (u1) (cond ((nonrectangular-number-type? u1) (widen r (c:sqrt (c:value t1 u1 w1)) flonum-type?)) ((rectangular-type? u1) (unimplemented y "SQRT on rectangular arguments is not (yet) implemented")) (else (fuck-up)))) (lambda (p?) (compile-error "sqrt" y p?)))) (define-primitive-procedure expt ;; needs work: To handle negative, zero, +inf, and NaN first argument. ;; needs work: To handle -inf, +inf, and NaN second argument. ;; needs work: If this were implemented properly and supported rectangular ;; results we would have two choices: either always return a ;; rectangular result or return a union of a rectangular, a ;; flonum, and a fixnum. The former is undesirable since that ;; would cause rectangular pollution. The later is undesirable ;; since that would cause union type pollution and require ;; run-time checking of whether the first argument is negative ;; and whether the first argument is an integer raised to the ;; second argument. There is no way with the current type system ;; to force the result of EXPT to be a flonum or a fixnum. Thus ;; we currently violate R4RS in this regard. ;; note: Unfortunately, EXPT is listed in the table on the top of page 20 of ;; R4RS so it must return an exact result when given exact arguments ;; that can produce an exact result. Because of this, the output can ;; never be a fixnum monotype and must be a union of a fixnum and a ;; flonum. Furthermore, there must be run-time checking when both ;; arguments are fixnums. Bummer. I may change this someday to violate ;; R4RS in this regard and have EXPT always return a flonum monotype and ;; eliminate ipow(). two-arguments-compatible? (two-arguments-truly-compatible? number-type? number-type?) (list number-type? number-type?) (list number-type? number-type?) (two-arguments-propagate! (lambda (w1 w2) (when (and (can-be? fixnum-type? w1) (can-be? fixnum-type? w2)) (propagate-result! )) (when (and (can-be? number-type? w1) (can-be? number-type? w2)) (propagate-result! )))) #f (type-switch number-type? w1 r t1 (lambda (u1) (type-switch number-type? w2 r t2 (lambda (u2) (cond ((and (fixnum-type? u1) (fixnum-type? u2)) (c:if (c:<0 (c:value t2 u2 w2)) (widen r (c:pow (c:value t1 u1 w1) (c:value t2 u2 w2)) flonum-type?) (widen r (c:ipow (c:value t1 u1 w1) (c:value t2 u2 w2)) fixnum-type?) #f)) ((or (rectangular-type? u1) (rectangular-type? u2)) (unimplemented y "EXPT on rectangular arguments is not (yet) implemented")) ((and (nonrectangular-number-type? u1) (nonrectangular-number-type? u2)) (widen r (c:pow (c:value t1 u1 w1) (c:value t2 u2 w2)) flonum-type?)) (else (fuck-up)))) (lambda (p?) (compile-error "expt2" y p?)))) (lambda (p?) (compile-error "expt1" y p?)))) (define-primitive-procedure exact->inexact one-argument-compatible? (one-argument-truly-compatible? number-type?) (list number-type?) (list number-type?) (one-argument-propagate! (lambda (w1) (when (can-be? nonrectangular-number-type? w1) (propagate-result! )) (when (can-be? rectangular-type? w1) (propagate-result! )))) #f (type-switch number-type? w1 r t1 (lambda (u1) (cond ((fixnum-type? u1) (widen r (c:flonum-cast (c:value t1 u1 w1)) flonum-type?)) ((flonum-type? u1) (widen r (c:value t1 u1 w1) flonum-type?)) ((rectangular-type? u1) (widen r (c:value t1 u1 w1) rectangular-type?)) (else (fuck-up)))) (lambda (p?) (compile-error "exact_to_inexact" y p?)))) (define-primitive-procedure inexact->exact one-argument-compatible? (one-argument-truly-compatible? number-type?) (list number-type?) (list number-type?) (one-argument-propagate! (lambda (w1) (propagate-result! ))) #f (type-switch number-type? w1 r t1 (lambda (u1) (cond ((fixnum-type? u1) (widen r (c:value t1 u1 w1) fixnum-type?)) ((flonum-type? u1) (widen r (c:fixnum-cast (c:value t1 u1 w1)) fixnum-type?)) ((rectangular-type? u1) (newline-between (c:if (c:!=0.0 (c:i (c:value t1 u1 w1))) (compile-error "inexact_to_exact2" y #f) (c:noop) #f) (widen r (c:fixnum-cast (c:r (c:value t1 u1 w1))) fixnum-type?))) (else (fuck-up)))) (lambda (p?) (compile-error "inexact_to_exact1" y p?)))) (define-primitive-procedure char? one-argument-compatible? (one-argument-truly-compatible? type?) (list char-type?) (list (lambda (u) (not (char-type? u)))) (one-argument-propagate! (lambda (w1) (when (and (can-be? char-type? w1) (can-be-non? char-type? w1)) (for-each-member (lambda (u1) (set-type-type-tag-accessed?! u1 #t)) w1)) (propagate-type-predicate! char-type?))) #f (compile-type-predicate char-type?)) (define-primitive-procedure char->integer one-argument-compatible? (one-argument-truly-compatible? char-type?) (list char-type?) (list char-type?) (one-argument-propagate! (lambda (w1) (propagate-result! ))) #f (type-switch char-type? w1 r t1 (lambda (u1) (widen r (c:fixnum-cast (c:unsigned-char-cast (c:value t1 u1 w1))) fixnum-type?)) (lambda (p?) (compile-error "char_to_integer" y p?)))) (define-primitive-procedure integer->char one-argument-compatible? (one-argument-truly-compatible? fixnum-type?) (list fixnum-type?) (list fixnum-type?) (one-argument-propagate! (lambda (w1) (propagate-result! ))) #f (type-switch fixnum-type? w1 r t1 (lambda (u1) (newline-between (if *bounds-checks?* (c:if (c:boolean-or (c:<0 (c:value t1 u1 w1)) (c:>= (c:value t1 u1 w1) (c:256))) (compile-error "integer_to_char2" y #f) (c:noop) #f) (c:noop)) (widen r (c:unsigned-char-cast (c:value t1 u1 w1)) char-type?))) (lambda (p?) (compile-error "integer_to_char1" y p?)))) (define-primitive-procedure string? one-argument-compatible? (one-argument-truly-compatible? type?) (list string-type?) (list (lambda (u) (not (string-type? u)))) (one-argument-propagate! (lambda (w1) (when (and (can-be? string-type? w1) (can-be-non? string-type? w1)) (for-each-member (lambda (u1) (set-type-type-tag-accessed?! u1 #t)) w1)) (propagate-type-predicate! string-type?))) #f (compile-type-predicate string-type?)) (define-primitive-procedure make-string one-or-two-arguments-compatible? (one-or-two-arguments-truly-compatible? fixnum-type? char-type?) (list fixnum-type? char-type?) (list fixnum-type? char-type?) (one-or-two-arguments-propagate! (lambda (w1) (propagate-result! ( (call-site-expression y)))) (lambda (w1 w2) (propagate-result! ( (call-site-expression y))))) ;; needs work: This doesn't check that the size of the string is nonnegative. #f (cond ((discard? r) (type-switch fixnum-type? w1 r t1 (lambda (u1) (if (= (length ws) 2) (type-switch char-type? w2 r t2 (lambda (u2) (c:noop)) (lambda (p?) (compile-error "make_string2" y p?))) (c:noop))) (lambda (p?) (compile-error "make_string1" y p?)))) ((antecedent? r) (type-switch fixnum-type? w1 r t1 (lambda (u1) (if (= (length ws) 2) (type-switch char-type? w2 r t2 (lambda (u2) (return-true r)) (lambda (p?) (compile-error "make_string2" y p?))) (return-true r))) (lambda (p?) (compile-error "make_string1" y p?)))) ((and (return? r) (not (result-accessed? r))) (type-switch fixnum-type? w1 r t1 (lambda (u1) (if (= (length ws) 2) (type-switch char-type? w2 r t2 (lambda (u2) (compile-return r)) (lambda (p?) (compile-error "make_string2" y p?))) (compile-return r))) (lambda (p?) (compile-error "make_string1" y p?)))) (else (let ((c (result-c r)) (w (result-type-set r))) (type-switch fixnum-type? w1 r t1 (lambda (u1) (if (= (length ws) 2) (type-switch char-type? w2 r t2 (lambda (u2) (newline-between (compile-allocate-string c w (c:value t1 u1 w1) y) (let ((t (c:t *ti*))) (set! *ti* (+ *ti* 1)) (outside-body ;; needs work: To use code-generation abstractions. (semicolon-after (space-between *char* (star-before t)))) (c:for (c:= t (c:& (value-string-ref c (the-member-that string-type? w) w (c:0)))) (c:< t (c:& (value-string-ref c (the-member-that string-type? w) w (c:value t1 u1 w1)))) (c:++ t) (c::= (c:* t) (c:value t2 u2 w2)))) (compile-return r))) (lambda (p?) (compile-error "make_string2" y p?))) ;; note: This is necessary since due to C bogosity, one can't ;; determine the length of an uninitialized string since it ;; might contain nulls. (newline-between (compile-allocate-string c w (c:value t1 u1 w1) y) (let ((t (c:t *ti*))) (set! *ti* (+ *ti* 1)) (outside-body ;; needs work: To use code-generation abstractions. (semicolon-after (space-between *char* (star-before t)))) (c:for (c:= t (c:& (value-string-ref c (the-member-that string-type? w) w (c:0)))) (c:< t (c:& (value-string-ref c (the-member-that string-type? w) w (c:value t1 u1 w1)))) (c:++ t) (c::= (c:* t) (c:character #\space)))) (compile-return r)))) (lambda (p?) (compile-error "make_string1" y p?))))))) (define-primitive-procedure string zero-or-more-arguments-compatible? (all-arguments-truly-compatible? char-type?) (map-n (lambda (i) char-type?) n) (map-n (lambda (i) char-type?) n) (all-arguments-propagate! (lambda (ws) (propagate-result! ( (call-site-expression y))))) #f (let loop ((ts1 ts) (us '()) (ws1 ws)) (if (null? ts1) (cond ((discard? r) (c:noop)) ((antecedent? r) (return-true r)) ((and (return? r) (not (result-accessed? r))) (compile-return r)) (else (let ((c (result-c r)) (us (reverse us)) (w (result-type-set r))) (newline-between (compile-allocate-string c w (c:fixnum (length ws)) y) (newlines-between (map-n (lambda (i) (c::= (value-string-ref c (the-member-that string-type? w) w (c:fixnum i)) (c:value (list-ref ts i) (list-ref us i) (list-ref ws i)))) (length ws))) (compile-return r))))) (type-switch char-type? (first ws1) r (first ts1) (lambda (u1) (loop (rest ts1) (cons u1 us) (rest ws1))) (lambda (p?) (compile-error "string" y p?)))))) (define-primitive-procedure string-length one-argument-compatible? (one-argument-truly-compatible? string-type?) (list string-type?) (list string-type?) (one-argument-propagate! (lambda (w1) (for-each-member (lambda (u1) (when (string-type? u1) (set-string-type-string-length-accessed?! u1 #t))) w1) (propagate-result! ))) #f (type-switch string-type? w1 r t1 (lambda (u1) (widen r (value-string-length t1 u1 w1) fixnum-type?)) (lambda (p?) (compile-error "string_length" y p?)))) (define-primitive-procedure string-ref two-arguments-compatible? (two-arguments-truly-compatible? string-type? fixnum-type?) (list string-type? fixnum-type?) (list string-type? fixnum-type?) (two-arguments-propagate! (lambda (w1 w2) (for-each-member (lambda (u1) (when (string-type? u1) (set-string-type-string-ref-accessed?! u1 #t))) w1) (propagate-result! ))) #f (type-switch string-type? w1 r t1 (lambda (u1) (type-switch fixnum-type? w2 r t2 (lambda (u2) (newline-between (if *bounds-checks?* (c:if (c:boolean-or (c:<0 (c:value t2 u2 w2)) (c:>= (c:value t2 u2 w2) (value-string-length t1 u1 w1))) (compile-error "string_ref3" y #f) (c:noop) #f) (c:noop)) (widen r (value-string-ref t1 u1 w1 (c:value t2 u2 w2)) char-type?))) (lambda (p?) (compile-error "string_ref2" y p?)))) (lambda (p?) (compile-error "string_ref1" y p?)))) (define-primitive-procedure string-set! three-arguments-compatible? (three-arguments-truly-compatible? string-type? fixnum-type? char-type?) (list string-type? fixnum-type? char-type?) (list string-type? fixnum-type? char-type?) (three-arguments-propagate! (lambda (w1 w2 w3) #f)) #f (type-switch string-type? w1 r t1 (lambda (u1) (type-switch fixnum-type? w2 r t2 (lambda (u2) (newline-between (if *bounds-checks?* (c:if (c:boolean-or (c:<0 (c:value t2 u2 w2)) (c:>= (c:value t2 u2 w2) (value-string-length t1 u1 w1))) (compile-error "string_set4" y #f) (c:noop) #f) (c:noop)) (type-switch char-type? w3 r t3 (lambda (u3) (newline-between (c::= (value-string-ref t1 u1 w1 (c:value t2 u2 w2)) (c:value t3 u3 w3)) (compile-return r))) (lambda (p?) (compile-error "string_set3" y p?))))) (lambda (p?) (compile-error "string_set2" y p?)))) (lambda (p?) (compile-error "string_set1" y p?)))) (define-primitive-procedure vector? one-argument-compatible? (one-argument-truly-compatible? type?) (list vector-type?) (list (lambda (u) (not (vector-type? u)))) (one-argument-propagate! (lambda (w1) (when (and (can-be? vector-type? w1) (can-be-non? vector-type? w1)) (for-each-member (lambda (u1) (set-type-type-tag-accessed?! u1 #t)) w1)) (propagate-type-predicate! vector-type?))) #f (compile-type-predicate vector-type?)) (define-primitive-procedure make-vector one-or-two-arguments-compatible? (one-or-two-arguments-truly-compatible? fixnum-type? type?) (list fixnum-type? type?) (list fixnum-type? type?) (one-or-two-arguments-propagate! (lambda (w1) (propagate-result! ( ;; note: This is suboptimal since type propagation is not yet complete ;; and APPLY-CLOSED-WORLD-ASSUMPTION! has not been done yet. '() (call-site-expression y)))) (lambda (w1 w2) (propagate-result! ( ;; note: This is suboptimal since type propagation is not yet complete ;; and APPLY-CLOSED-WORLD-ASSUMPTION! has not been done yet. (members w2) (call-site-expression y))))) (unless (or (discard? r) (antecedent? r) (and (return? r) (not (result-accessed? r)))) (let* ((w (result-type-set r)) (u (the-member-that (lambda (u) (and (headed-vector-type? u) (memq (call-site-expression y) (headed-vector-type-allocating-expressions u)))) w))) (for-each-member (lambda (u1) (when (and (fixnum-type? u1) (= (length ws) 2) (not (fictitious? (headed-vector-type-element u)))) (for-each-member (lambda (u2) (promote! (create-accessor-result (headed-vector-type-element u) #f) w2 w2)) w2))) w1))) ;; needs work: This doesn't check that the size of the vector is nonnegative. (cond ((discard? r) (type-switch fixnum-type? w1 r t1 (lambda (u1) (c:noop)) (lambda (p?) (compile-error "make_vector" y p?)))) ((antecedent? r) (type-switch fixnum-type? w1 r t1 (lambda (u1) (return-true r)) (lambda (p?) (compile-error "make_vector" y p?)))) ((and (return? r) (not (result-accessed? r))) (type-switch fixnum-type? w1 r t1 (lambda (u1) (compile-return r)) (lambda (p?) (compile-error "make_vector" y p?)))) (else (let* ((c (result-c r)) (w (result-type-set r)) (u (the-member-that (lambda (u) (and (headed-vector-type? u) (memq (call-site-expression y) (headed-vector-type-allocating-expressions u)))) w))) (type-switch fixnum-type? w1 r t1 (lambda (u1) (newline-between (compile-allocate-headed-vector c u w (c:value t1 u1 w1) y) (if (and (= (length ws) 2) (not (fictitious? (headed-vector-type-element u)))) (type-switch type? w2 r t2 (lambda (u2) (let ((t (c:t *ti*))) (set! *ti* (+ *ti* 1)) (outside-body ;; note: This violates the abstraction. (list 'c:declaration t (semicolon-after (c:type-set (headed-vector-type-element u) (star-before t))) #f)) (newline-between (c:for (c:= t (c:& (value-vector-ref c u w (c:0)))) (c:< t (c:& (value-vector-ref c u w (c:value t1 u1 w1)))) (c:++ t) (move (create-accessor-result (headed-vector-type-element u) (parentheses-around (star-before t))) t2 w2)) (compile-return r)))) (lambda (p?) (fuck-up))) (compile-return r)))) (lambda (p?) (compile-error "make_vector" y p?))))))) (define-primitive-procedure make-displaced-vector three-arguments-compatible? (three-arguments-truly-compatible? vector-type? fixnum-type? fixnum-type?) (list vector-type? fixnum-type? fixnum-type?) (list vector-type? fixnum-type? fixnum-type?) (three-arguments-propagate! (lambda (w1 w2 w3) (for-each-member (lambda (u1) (when (vector-type? u1) (propagate-result! ( u1)))) w1))) #f (let ((w (result-type-set r))) (type-switch vector-type? w1 r t1 (lambda (u1) (let ((u (the-member-that (lambda (u) (and (displaced-vector-type? u) (eq? u (displaced-vector-type-displaced-vector-type u1)))) w))) (type-switch fixnum-type? w2 r t2 (lambda (u2) (type-switch fixnum-type? w3 r t3 (lambda (u3) (newline-between (if *bounds-checks?* (c:if (c:boolean-or (c:<0 (c:value t2 u2 w2)) (c:>= (c:value t2 u2 w2) (value-vector-length t1 u1 w1))) (compile-error "make_displaced_vector4" y #f) (c:noop) #f) (c:noop)) (cond (*bounds-checks?* (when *overflow-checks?* (unimplemented y "Safe exact arithmetic is not (yet) implemented")) (c:if (c:boolean-or (c:<0 (c:value t3 u3 w3)) (c:> (c:+ (c:value t2 u2 w2) (c:value t3 u3 w3)) (value-vector-length t1 u1 w1))) (compile-error "make_displaced_vector5" y #f) (c:noop) #f)) (else (c:noop))) (move-displaced-vector r u (c:& (value-vector-ref t1 u1 w1 (c:value t2 u2 w2))) (c:value t2 u3 w3)))) (lambda (p?) (compile-error "make_displaced_vector3" y p?)))) (lambda (p?) (compile-error "make_displaced_vector2" y p?))))) (lambda (p?) (compile-error "make_displaced_vector1" y p?))))) (define-primitive-procedure vector zero-or-more-arguments-compatible? (all-arguments-truly-compatible? type?) (map-n (lambda (i) type?) n) (map-n (lambda (i) type?) n) (all-arguments-propagate! (lambda (ws) (propagate-result! ( ;; note: This is suboptimal since type propagation is not yet complete ;; and APPLY-CLOSED-WORLD-ASSUMPTION! has not been done yet. (reduce unionq (map members ws) '()) (call-site-expression y))))) (unless (or (discard? r) (antecedent? r) (and (return? r) (not (result-accessed? r)))) (let* ((w (result-type-set r)) (u (the-member-that (lambda (u) (and (headed-vector-type? u) (memq (call-site-expression y) (headed-vector-type-allocating-expressions u)))) w))) (for-each (lambda (w) (promote! (if (degenerate-vector-type? u) *discard* (create-accessor-result (headed-vector-type-element u) #f)) w w)) ws))) (cond ((discard? r) (c:noop)) ((antecedent? r) (return-true r)) ((and (return? r) (not (result-accessed? r))) (compile-return r)) (else (let* ((c (result-c r)) (w (result-type-set r)) (u (the-member-that (lambda (u) (and (headed-vector-type? u) (memq (call-site-expression y) (headed-vector-type-allocating-expressions u)))) w))) (newline-between (compile-allocate-headed-vector c u w (c:fixnum (length ws)) y) (newlines-between (map-n (lambda (i) (move (if (degenerate-vector-type? u) *discard* (create-accessor-result (headed-vector-type-element u) (value-vector-ref c u w (c:fixnum i)))) (list-ref ts i) (list-ref ws i))) (length ws))) (compile-return r)))))) (define-primitive-procedure vector-length one-argument-compatible? (one-argument-truly-compatible? vector-type?) (list vector-type?) (list vector-type?) (one-argument-propagate! (lambda (w1) (for-each-member (lambda (u1) (cond ((headed-vector-type? u1) (set-headed-vector-type-vector-length-accessed?! u1 #t)) ((nonheaded-vector-type? u1) (set-nonheaded-vector-type-vector-length-accessed?! u1 #t)) ((displaced-vector-type? u1) (set-displaced-vector-type-vector-length-accessed?! u1 #t)))) w1) (propagate-result! ))) #f (type-switch vector-type? w1 r t1 (lambda (u1) (widen r (value-vector-length t1 u1 w1) fixnum-type?)) (lambda (p?) (compile-error "vector_length" y p?)))) (define-primitive-procedure vector-ref two-arguments-compatible? (two-arguments-truly-compatible? vector-type? fixnum-type?) (list vector-type? fixnum-type?) (list vector-type? fixnum-type?) (two-arguments-propagate! (lambda (w1 w2) (for-each-member (lambda (u1) (cond ((headed-vector-type? u1) (set-headed-vector-type-vector-ref-accessed?! u1 #t)) ((nonheaded-vector-type? u1) (set-nonheaded-vector-type-vector-ref-accessed?! u1 #t)) ((displaced-vector-type? u1) (set-displaced-vector-type-vector-ref-accessed?! u1 #t)))) w1) (for-each-member (lambda (u1) (when (vector-type? u1) (for-each-member propagate-result! (vector-type-element u1)))) w1))) (for-each-member (lambda (u1) (when (vector-type? u1) (for-each-member (lambda (u2) (when (fixnum-type? u2) (promote! r (vector-type-element u1) (vector-type-element u1)))) w2))) w1) (type-switch vector-type? w1 r t1 (lambda (u1) (type-switch fixnum-type? w2 r t2 (lambda (u2) (newline-between (if *bounds-checks?* (c:if (c:boolean-or (c:<0 (c:value t2 u2 w2)) (c:>= (c:value t2 u2 w2) (value-vector-length t1 u1 w1))) (compile-error "vector_ref3" y #f) (c:noop) #f) (c:noop)) (move r (value-vector-ref t1 u1 w1 (c:value t2 u2 w2)) (vector-type-element u1)))) (lambda (p?) (compile-error "vector_ref2" y p?)))) (lambda (p?) (compile-error "vector_ref1" y p?)))) (define-primitive-procedure vector-set! three-arguments-compatible? (three-arguments-truly-compatible? vector-type? fixnum-type? type?) (list vector-type? fixnum-type? type?) (list vector-type? fixnum-type? type?) (three-arguments-propagate! (lambda (w1 w2 w3) (for-each-member (lambda (u1) (when (vector-type? u1) (assert-subset! w3 (vector-type-element u1)))) w1))) (for-each-member (lambda (u1) (when (vector-type? u1) (for-each-member (lambda (u2) (when (fixnum-type? u2) (promote! (if (degenerate-vector-type? u1) *discard* (create-accessor-result (vector-type-element u1) #f)) w3 w3))) w2))) w1) (type-switch vector-type? w1 r t1 (lambda (u1) (type-switch fixnum-type? w2 r t2 (lambda (u2) (newline-between (if *bounds-checks?* (c:if (c:boolean-or (c:<0 (c:value t2 u2 w2)) (c:>= (c:value t2 u2 w2) (value-vector-length t1 u1 w1))) (compile-error "vector_set3" y #f) (c:noop) #f) (c:noop)) (move (if (degenerate-vector-type? u1) *discard* (create-accessor-result (vector-type-element u1) (value-vector-ref t1 u1 w1 (c:value t2 u2 w2)))) t3 w3) (compile-return r))) (lambda (p?) (compile-error "vector_set2" y p?)))) (lambda (p?) (compile-error "vector_set1" y p?)))) (define-primitive-procedure procedure? one-argument-compatible? (one-argument-truly-compatible? type?) (list procedure-type?) (list (lambda (u) (not (procedure-type? u)))) (one-argument-propagate! (lambda (w1) (when (and (can-be? procedure-type? w1) (can-be-non? procedure-type? w1)) (for-each-member (lambda (u1) (set-type-type-tag-accessed?! u1 #t)) w1)) (propagate-type-predicate! procedure-type?))) #f (compile-type-predicate procedure-type?)) (define-primitive-procedure apply two-or-more-arguments-compatible? ;; needs work: To abstract. (lambda (ws w) (when (can-be-non? null-type? w) (fuck-up)) (and (can-be? (truly-compatible-procedure? (if (converted? y) (cons w0 (but-last (rest ws))) (but-last (rest ws))) (last ws) (recreate-call-site y 'first-argument)) (first ws)) (can-be? list-type? (last ws)))) ;; needs work: This could be made more precise. (cons procedure-type? (append (map-n (lambda (i) type?) (- n 2)) (list list-type?))) ;; needs work: This could be made more precise. (cons procedure-type? (append (map-n (lambda (i) type?) (- n 2)) (list list-type?))) ;; needs work: To abstract. (lambda (ws w) (when (can-be-non? null-type? w) (fuck-up)) (when #f ;debugging (when (can-be? continuation-type? (first ws)) (unimplemented y "Passing continuations as the first argument of APPLY is not (yet) implemented"))) (propagate-call! (recreate-call-site y 'first-argument) (first ws) (if (converted? y) (cons w0 (rest (but-last ws))) (rest (but-last ws))) (last ws))) #f (if (void? w1) (compile-error "void_call" y #t) (type-switch (compatible-procedure? (if (converted? y) (cons w0 (but-last (rest ws))) (but-last (rest ws))) (last ws) (recreate-call-site y 'first-argument)) w1 r t1 (lambda (u1) (if (converted? y) (compile-converted-call r (recreate-call-site y 'first-argument) t1 u1 w1 (cons t0 (but-last (rest ts))) (cons w0 (but-last (rest ws))) (last ts) (last ws)) (compile-call r (recreate-call-site y 'first-argument) t1 u1 w1 t0 w0 (but-last (rest ts)) (but-last (rest ws)) (last ts) (last ws)))) (lambda (p?) (compile-error "call" y p?))))) (define-primitive-procedure call-with-current-continuation one-argument-compatible? (one-argument-truly-compatible? (truly-compatible-procedure? (if (converted? y) (list w0 w0) (list (create-anonymous-type-set ( (call-site-expression y))))) *null* (recreate-call-site y 'first-argument))) (list (truly-compatible-procedure? (if (converted? y) (list w0 w0) (list (create-anonymous-type-set ( (call-site-expression y))))) *null* (recreate-call-site y 'first-argument))) (list (truly-compatible-procedure? (if (converted? y) (list w0 w0) (list (create-anonymous-type-set ( (call-site-expression y))))) *null* (recreate-call-site y 'first-argument))) (one-argument-propagate! (lambda (w1) (when #f ;debugging (when (can-be? continuation-type? w1) (unimplemented y "Passing continuations as the first argument of CALL-WITH-CURRENT-CONTINUATION is not (yet) implemented"))) (propagate-call! (recreate-call-site y 'first-argument) w1 (if (converted? y) (list w0 w0) (list (create-anonymous-type-set ( (call-site-expression y))))) *null*))) (let ((w (result-type-set r))) (when (converted? y) (fuck-up)) (newline-between (when (can-be? (lambda (u1) (and (native-procedure-type? u1) ((truly-compatible-procedure? (if (converted? y) (list w0 w0) (list (create-anonymous-type-set ( (call-site-expression y))))) *null* (recreate-call-site y 'first-argument)) u1) (some (lambda (e) (can-be? (lambda (u4) (and (eq? u4 ( (call-site-expression y))) (some (lambda (y) (not (goto? y u4))) (continuation-type-call-sites u4)))) (first-parameter-type-set (environment-expression e)))) (narrow-clones u1)))) w1) (for-each-member (lambda (u1) (when ((compatible-procedure? (list (create-anonymous-type-set ( (call-site-expression y)))) *null* (recreate-call-site y 'first-argument)) u1) (let ((w3 (create-anonymous-type-set ( (call-site-expression y))))) (promote-call! (if (or (discard? r) (fictitious? w)) *discard* (create-accessor-result w (c:v (call-site-expression y)))) (recreate-call-site y 'first-argument) u1 (list w3) *null*) (promote! r w w)))) w1)))) (let ((w (result-type-set r))) (when (converted? y) (fuck-up)) (newline-between (cond ((can-be? (lambda (u1) (and (native-procedure-type? u1) ((truly-compatible-procedure? (if (converted? y) (list w0 w0) (list (create-anonymous-type-set ( (call-site-expression y))))) *null* (recreate-call-site y 'first-argument)) u1) (some (lambda (e) (can-be? (lambda (u4) (and (eq? u4 ( (call-site-expression y))) (some (lambda (y) (not (goto? y u4))) (continuation-type-call-sites u4)))) (first-parameter-type-set (environment-expression e)))) (narrow-clones u1)))) w1) (include! "setjmp") ;jmp_buf (unless (or (discard? r) (fictitious? w)) (outside-main (c:declaration w (c:v (call-site-expression y)) (c:noop)))) ;; needs work: To use code-generation abstractions. (outside-body (semicolon-after (space-between *jmpbuf* (c:j (call-site-expression y))))) (type-switch (compatible-procedure? (list (create-anonymous-type-set ( (call-site-expression y)))) *null* (recreate-call-site y 'first-argument)) w1 r t1 (lambda (u1) (let* ((w3 (create-anonymous-type-set ( (call-site-expression y)))) (t3 (allocate-temporary w3))) (newline-between (c:if (c:setjmp (c:j (call-site-expression y))) (c:noop) (newline-between (widen (create-accessor-result w3 t3) (c:& (c:j (call-site-expression y))) (lambda (u) (and (continuation-type? u) (eq? (continuation-type-allocating-expression u) (call-site-expression y))))) (compile-call (if (or (discard? r) (fictitious? w)) *discard* (create-accessor-result w (c:v (call-site-expression y)))) (recreate-call-site y 'first-argument) t1 u1 w1 t0 w0 (list t3) (list w3) 'void23 *null*)) #t) (if (or (discard? r) (fictitious? w)) (compile-return r) (move r (c:v (call-site-expression y)) w))))) (lambda (p?) (compile-error "call_with_current_continuation" y p?)))) (else (type-switch (compatible-procedure? (list (create-anonymous-type-set ( (call-site-expression y)))) *null* (recreate-call-site y 'first-argument)) w1 r t1 (lambda (u1) (let* ((w3 (create-anonymous-type-set ( (call-site-expression y)))) (t3 (allocate-temporary w3))) (compile-call r (recreate-call-site y 'first-argument) t1 u1 w1 t0 w0 (list t3) (list w3) 'void24 *null*))) (lambda (p?) (compile-error "call_with_current_continuation" y p?))))) (if (can-be? (lambda (u1) (and (native-procedure-type? u1) ((truly-compatible-procedure? (if (converted? y) (list w0 w0) (list (create-anonymous-type-set ( (call-site-expression y))))) *null* (recreate-call-site y 'first-argument)) u1) (some (lambda (e) (can-be? (lambda (u4) (and (eq? u4 ( (call-site-expression y))) (some (lambda (y) (goto? y u4)) (continuation-type-call-sites u4)))) (first-parameter-type-set (environment-expression e)))) (narrow-clones u1)))) w1) (c:: (c:x (call-site-expression y))) (c:noop))))) (define-primitive-procedure input-port? one-argument-compatible? (one-argument-truly-compatible? type?) (list input-port-type?) (list (lambda (u) (not (input-port-type? u)))) (one-argument-propagate! (lambda (w1) (when (and (can-be? input-port-type? w1) (can-be-non? input-port-type? w1)) (for-each-member (lambda (u1) (set-type-type-tag-accessed?! u1 #t)) w1)) (propagate-type-predicate! input-port-type?))) #f (compile-type-predicate input-port-type?)) (define-primitive-procedure output-port? one-argument-compatible? (one-argument-truly-compatible? type?) (list output-port-type?) (list (lambda (u) (not (output-port-type? u)))) (one-argument-propagate! (lambda (w1) (when (and (can-be? output-port-type? w1) (can-be-non? output-port-type? w1)) (for-each-member (lambda (u1) (set-type-type-tag-accessed?! u1 #t)) w1)) (propagate-type-predicate! output-port-type?))) #f (compile-type-predicate output-port-type?)) (define-primitive-procedure open-input-file one-argument-compatible? (one-argument-truly-compatible? string-type?) (list string-type?) (list string-type?) (one-argument-propagate! (lambda (w1) (propagate-result! ))) #f (type-switch string-type? w1 r t1 (lambda (u1) (if *runtime-checks?* (if (or (discard? r) (antecedent? r) (and (return? r) (not (result-accessed? r)))) (let ((t (allocate-temporary *input-port*))) (newline-between (widen (create-accessor-result *input-port* t) (c:fopen (c:value t1 u1 w1) (c:string "r")) input-port-type?) (c:if (c:==null (c:value t (the-member *input-port*) *input-port*)) (compile-error "open_input_file2" y #f) (c:noop) #f) (compile-return r))) (newline-between (widen (unreturnify r) (c:fopen (c:value t1 u1 w1) (c:string "r")) input-port-type?) (c:if (c:==null (c:value (result-c r) (the-member-that input-port-type? (result-type-set r)) (result-type-set r))) (compile-error "open_input_file2" y #f) (c:noop) #f) (compile-return r))) (widen r (c:fopen (c:value t1 u1 w1) (c:string "r")) input-port-type?))) (lambda (p?) (compile-error "open_input_file1" y p?)))) (define-primitive-procedure open-output-file one-argument-compatible? (one-argument-truly-compatible? string-type?) (list string-type?) (list string-type?) (one-argument-propagate! (lambda (w1) (propagate-result! ))) #f (type-switch string-type? w1 r t1 (lambda (u1) (if *runtime-checks?* (if (or (discard? r) (antecedent? r) (and (return? r) (not (result-accessed? r)))) (let ((t (allocate-temporary *output-port*))) (newline-between (widen (create-accessor-result *output-port* t) (c:fopen (c:value t1 u1 w1) (c:string "w")) output-port-type?) (c:if (c:==null (c:value t (the-member *output-port*) *output-port*)) (compile-error "open_output_file2" y #f) (c:noop) #f) (compile-return r))) (newline-between (widen (unreturnify r) (c:fopen (c:value t1 u1 w1) (c:string "w")) output-port-type?) (c:if (c:==null (c:value (result-c r) (the-member-that output-port-type? (result-type-set r)) (result-type-set r))) (compile-error "open_output_file2" y #f) (c:noop) #f) (compile-return r))) (widen r (c:fopen (c:value t1 u1 w1) (c:string "w")) output-port-type?))) (lambda (p?) (compile-error "open_output_file1" y p?)))) (define-primitive-procedure close-input-port one-argument-compatible? (one-argument-truly-compatible? input-port-type?) (list input-port-type?) (list input-port-type?) (one-argument-propagate! (lambda (w1) #f)) #f (type-switch input-port-type? w1 r t1 (lambda (u1) (if *runtime-checks?* (c:if (c:fclose (c:value t1 u1 w1)) (compile-error "close_input_port2" y #f) (compile-return r) #t) (newline-between (semicolon-after (c:fclose (c:value t1 u1 w1))) (compile-return r)))) (lambda (p?) (compile-error "close_input_port1" y p?)))) (define-primitive-procedure close-output-port one-argument-compatible? (one-argument-truly-compatible? output-port-type?) (list output-port-type?) (list output-port-type?) (one-argument-propagate! (lambda (w1) #f)) #f (type-switch output-port-type? w1 r t1 (lambda (u1) (if *runtime-checks?* (c:if (c:fclose (c:value t1 u1 w1)) (compile-error "close_output_port2" y #f) (compile-return r) #t) (newline-between (semicolon-after (c:fclose (c:value t1 u1 w1))) (compile-return r)))) (lambda (p?) (compile-error "close_output_port1" y p?)))) (define-primitive-procedure read-char1 one-argument-compatible? (one-argument-truly-compatible? input-port-type?) (list input-port-type?) (list input-port-type?) (one-argument-propagate! (lambda (w1) (propagate-result! ) (propagate-result! ))) #f (type-switch input-port-type? w1 r t1 (lambda (u1) (c:if (c:==eof (c:= (c:c) (c:getc (c:value t1 u1 w1)))) (widen r 'void25 eof-object-type?) (widen r (c:c) char-type?) #t)) (lambda (p?) (compile-error "read_char1" y p?)))) (define-primitive-procedure peek-char1 one-argument-compatible? (one-argument-truly-compatible? input-port-type?) (list input-port-type?) (list input-port-type?) (one-argument-propagate! (lambda (w1) (propagate-result! ) (propagate-result! ))) #f (type-switch input-port-type? w1 r t1 (lambda (u1) (c:if (c:==eof (c:= (c:c) (c:ungetc (c:getc (c:value t1 u1 w1)) (c:value t1 u1 w1)))) (widen r 'void26 eof-object-type?) (widen r (c:c) char-type?) #t)) (lambda (p?) (compile-error "peek_char1" y p?)))) (define-primitive-procedure eof-object? one-argument-compatible? (one-argument-truly-compatible? type?) (list eof-object-type?) (list (lambda (u) (not (eof-object-type? u)))) (one-argument-propagate! (lambda (w1) (when (and (can-be? eof-object-type? w1) (can-be-non? eof-object-type? w1)) (for-each-member (lambda (u1) (set-type-type-tag-accessed?! u1 #t)) w1)) (propagate-type-predicate! eof-object-type?))) #f (compile-type-predicate eof-object-type?)) (define-primitive-procedure char-ready?1 one-argument-compatible? (one-argument-truly-compatible? input-port-type?) (list input-port-type?) (list input-port-type?) (one-argument-propagate! (lambda (w1) (propagate-result! ) (propagate-result! ))) #f (type-switch input-port-type? w1 r t1 (lambda (u1) (compile-test r (c:input-waiting (c:value t1 u1 w1)))) (lambda (p?) (compile-error "char_ready1" y p?)))) (define-primitive-procedure standard-input-port zero-arguments-compatible? (zero-arguments-truly-compatible?) '() '() (zero-arguments-propagate! (lambda () (propagate-result! ))) #f (widen r (c:stdin) input-port-type?)) (define-primitive-procedure standard-output-port zero-arguments-compatible? (zero-arguments-truly-compatible?) '() '() (zero-arguments-propagate! (lambda () (propagate-result! ))) #f (widen r (c:stdout) output-port-type?)) (define-primitive-procedure write-char2 two-arguments-compatible? (two-arguments-truly-compatible? char-type? output-port-type?) (list char-type? output-port-type?) (list char-type? output-port-type?) (two-arguments-propagate! (lambda (w1 w2) #f)) #f (type-switch char-type? w1 r t1 (lambda (u1) (type-switch output-port-type? w2 r t2 (lambda (u2) (newline-between (c:putc (c:value t1 u1 w1) (c:value t2 u2 w2)) (compile-return r))) (lambda (p?) (compile-error "write_char2" y p?)))) (lambda (p?) (compile-error "write_char1" y p?)))) (define-primitive-procedure panic one-argument-compatible? (one-argument-truly-compatible? string-type?) (list string-type?) (list string-type?) (one-argument-propagate! (lambda (w1) #f)) #f (type-switch string-type? w1 r t1 (lambda (u1) (c:panic (c:value t1 u1 w1))) (lambda (p?) (compile-error "panic" y p?)))) (define-primitive-procedure pointer? one-argument-compatible? (one-argument-truly-compatible? type?) (list pointer-type?) (list (lambda (u) (not (pointer-type? u)))) (one-argument-propagate! (lambda (w1) (when (and (can-be? pointer-type? w1) (can-be-non? pointer-type? w1)) (for-each-member (lambda (u1) (set-type-type-tag-accessed?! u1 #t)) w1)) (propagate-type-predicate! pointer-type?))) #f (compile-type-predicate pointer-type?)) (define-primitive-procedure integer->string one-argument-compatible? (one-argument-truly-compatible? fixnum-type?) (list fixnum-type?) (list fixnum-type?) (one-argument-propagate! (lambda (w1) (propagate-result! ))) #f (type-switch fixnum-type? w1 r t1 (lambda (u1) (widen r (c:char*-cast (c:value t1 u1 w1)) string-type?)) (lambda (p?) (compile-error "integer_to_string" y p?)))) (define-primitive-procedure integer->input-port one-argument-compatible? (one-argument-truly-compatible? fixnum-type?) (list fixnum-type?) (list fixnum-type?) (one-argument-propagate! (lambda (w1) (propagate-result! ))) #f (type-switch fixnum-type? w1 r t1 (lambda (u1) (widen r (c:file*-cast (c:value t1 u1 w1)) input-port-type?)) (lambda (p?) (compile-error "integer_to_input_port" y p?)))) (define-primitive-procedure integer->output-port one-argument-compatible? (one-argument-truly-compatible? fixnum-type?) (list fixnum-type?) (list fixnum-type?) (one-argument-propagate! (lambda (w1) (propagate-result! ))) #f (type-switch fixnum-type? w1 r t1 (lambda (u1) (widen r (c:file*-cast (c:value t1 u1 w1)) output-port-type?)) (lambda (p?) (compile-error "integer_to_output_port" y p?)))) (define-primitive-procedure integer->pointer one-argument-compatible? (one-argument-truly-compatible? fixnum-type?) (list fixnum-type?) (list fixnum-type?) (one-argument-propagate! (lambda (w1) (propagate-result! ))) #f (type-switch fixnum-type? w1 r t1 (lambda (u1) (widen r (c:void*-cast (c:value t1 u1 w1)) pointer-type?)) (lambda (p?) (compile-error "integer_to_pointer" y p?)))) (define-primitive-procedure clocks-per-second zero-arguments-compatible? (zero-arguments-truly-compatible?) '() '() (zero-arguments-propagate! (lambda () (propagate-result! ))) #f (widen r (c:clocks-per-second) fixnum-type?)) (define-primitive-procedure rand-max zero-arguments-compatible? (zero-arguments-truly-compatible?) '() '() (zero-arguments-propagate! (lambda () (propagate-result! ))) #f (widen r (c:rand-max) fixnum-type?)) (define-primitive-procedure pointer-size zero-arguments-compatible? (zero-arguments-truly-compatible?) '() '() (zero-arguments-propagate! (lambda () (propagate-result! ))) #f (widen r (c:pointer-size) fixnum-type?)) (define-primitive-procedure infinity? one-argument-compatible? (one-argument-truly-compatible? flonum-type?) (list flonum-type?) (list flonum-type?) (one-argument-propagate! (lambda (w1) (propagate-result! ) (propagate-result! ))) #f (type-switch flonum-type? w1 r t1 (lambda (u1) (compile-test r (c:==infinity (c:value t1 u1 w1)))) (lambda (p?) (compile-error "infinity" y p?)))) (define-primitive-procedure fork ;; note: FORK will fail miserably if you escape by calling a continuation. two-arguments-compatible? (two-arguments-truly-compatible? (truly-compatible-procedure? (if (converted? y) (list w0) '()) *null* (recreate-call-site y 'first-argument)) (truly-compatible-procedure? (if (converted? y) (list w0) '()) *null* (recreate-call-site y 'second-argument))) (list (truly-compatible-procedure? (if (converted? y) (list w0) '()) *null* (recreate-call-site y 'first-argument)) (truly-compatible-procedure? (if (converted? y) (list w0) '()) *null* (recreate-call-site y 'second-argument))) (list (truly-compatible-procedure? (if (converted? y) (list w0) '()) *null* (recreate-call-site y 'first-argument)) (truly-compatible-procedure? (if (converted? y) (list w0) '()) *null* (recreate-call-site y 'second-argument))) (two-arguments-propagate! (lambda (w1 w2) (propagate-call! (recreate-call-site y 'first-argument) w1 (if (converted? y) (list w0) '()) *null*) (propagate-call! (recreate-call-site y 'second-argument) w2 (if (converted? y) (list w0) '()) *null*))) ;; needs work: I can't remember what promotors do and thus can't figure out ;; if FORK needs one and, if so, how to write it. #f ;; needs work: To use code-generation abstractions. (begin (set! *program-has-pthreads?* #t) (include! "pthread") ;pthread_t pthread_create pthread_join (when (converted? y) (unimplemented y "Converted calls to FORK are not (yet) implemented")) (braces-around (newline-between (semicolon-after "pthread_t thread") ;; note: This uses GNU C internal functions. "void *branch(void *ignore)" (braces-around (newline-between (if (void? w1) (compile-error "void_call" y #t) (type-switch (compatible-procedure? '() *null* (recreate-call-site y 'first-argument)) w1 (unreturnify r) t1 (lambda (u1) (compile-call (unreturnify r) (recreate-call-site y 'first-argument) t1 u1 w1 t0 w0 '() '() #f *null*)) (lambda (p?) (compile-error "call" y p?)))) (semicolon-after "return NULL"))) (semicolon-after "pthread_create(&thread, NULL, &branch, NULL)") (if (void? w2) (compile-error "void_call" y #t) (type-switch (compatible-procedure? '() *null* (recreate-call-site y 'second-argument)) w2 (unreturnify r) t2 (lambda (u2) (compile-call (unreturnify r) (recreate-call-site y 'second-argument) t2 u2 w2 t0 w0 '() '() #f *null*)) (lambda (p?) (compile-error "call" y p?)))) (semicolon-after "pthread_join(thread, NULL)") (compile-return r))))) (define-primitive-procedure mutex ;; note: MUTEX will not unlock the mutex if you escape by calling a ;; continuation. one-argument-compatible? (one-argument-truly-compatible? (truly-compatible-procedure? (if (converted? y) (list w0) '()) *null* (recreate-call-site y 'first-argument))) (list (truly-compatible-procedure? (if (converted? y) (list w0) '()) *null* (recreate-call-site y 'first-argument))) (list (truly-compatible-procedure? (if (converted? y) (list w0) '()) *null* (recreate-call-site y 'first-argument))) (one-argument-propagate! (lambda (w1) (propagate-call! (recreate-call-site y 'first-argument) w1 (if (converted? y) (list w0) '()) *null*))) ;; needs work: I can't remember what promotors do and thus can't figure out ;; if MUTEX needs one and, if so, how to write it. #f ;; needs work: To use code-generation abstractions. (begin (set! *program-has-pthreads?* #t) ;; pthread_mutex_t pthread_mutex_lock pthread_mutex_unlock ;; PTHREAD_MUTEX_INITIALIZER (include! "pthread") (when (converted? y) (unimplemented y "Converted calls to MUTEX are not (yet) implemented")) (outside-main (semicolon-after (space-between "pthread_mutex_t" (c:mutex (call-site-expression y)) "=" "PTHREAD_MUTEX_INITIALIZER"))) (newline-between ;; needs work: Can use PTHREAD_MUTEX_INITIALIZER to make a fast mutex when ;; this expression isn't in a recursive path ;; in the call graph. ;; needs work: For now, under Linux PTHREAD_RECURSIVE_MUTEX_INITIALIZER_NP ;; is broken. (c:gosub "pthread_mutex_lock" (c:& (c:mutex (call-site-expression y)))) (if (void? w1) (compile-error "void_call" y #t) (type-switch (compatible-procedure? '() *null* (recreate-call-site y 'first-argument)) w1 r t1 (lambda (u1) (compile-call r (recreate-call-site y 'first-argument) t1 u1 w1 t0 w0 '() '() #f *null*)) (lambda (p?) (compile-error "call" y p?)))) (c:gosub "pthread_mutex_unlock" (c:& (c:mutex (call-site-expression y)))) (compile-return r)))) (define *list->vector* #f) (define *append* #f) (define *cons* #f) (define *eqv?* #f) ;;; Backquote (define (contains-unquote? s) (or (and (sx-list? s) (= (sx-length s) 2) (or (sx-eq? (sx-first s) 'unquote) (sx-eq? (sx-first s) 'unquote-splicing))) (and (sx-vector? s) (sx-some-vector contains-unquote? s)) (and (sx-pair? s) (or (contains-unquote? (sx-car s)) (contains-unquote? (sx-cdr s)))))) (define (expand-quasiquote s) ;; needs work: This encapsulation loses the line and character positions of ;; the quasiquote expression that is being rewritten. (encapsulate (if (contains-unquote? s) (cond ((and (sx-list? s) (= (sx-length s) 2) (or (sx-eq? (sx-first s) 'unquote) (sx-eq? (sx-first s) 'unquote-splicing))) s) ((sx-vector? s) (let ((ss (map expand-quasiquote (sx-vector->list s)))) (if (some (lambda (s) (sx-eq? (sx-first s) 'unquote-splicing)) ss) (list 'unquote `(,*list->vector* (,*append* ,@(map (lambda (s) (case (sx-datum (sx-first s)) ((unquote) `(,*cons* ,(sx-second s) '())) ((unquote-splicing) (sx-second s)) ((quote) `'(,(sx-second s))) (else (fuck-up)))) ss)))) (list 'unquote `((primitive-procedure vector) ,@(map (lambda (s) (if (sx-eq? (sx-first s) 'unquote) (sx-second s) s)) ss)))))) ((sx-pair? s) (let ((s1 (expand-quasiquote (sx-car s))) (s2 (expand-quasiquote (sx-cdr s)))) (case (sx-datum (sx-first s1)) ((unquote) (case (sx-datum (sx-first s2)) ((unquote) (list 'unquote `(,*cons* ,(sx-second s1) ,(sx-second s2)))) ((unquote-splicing) (syntax-error s "Improper UNQUOTE-SPLICING")) ((quote) (list 'unquote `(,*cons* ,(sx-second s1) ,s2))) (else (fuck-up)))) ((unquote-splicing) (case (sx-datum (sx-first s2)) ((unquote) ;; needs work: This doesn't handle the case `(,@A . ,B) where B is ;; not a list. (list 'unquote `(,*append* ,(sx-second s1) ,(sx-second s2)))) ((unquote-splicing) (syntax-error s "Improper UNQUOTE-SPLICING")) ((quote) ;; needs work: This doesn't handle the case `(,@A . B). (list 'unquote `(,*append* ,(sx-second s1) ,s2))) (else (fuck-up)))) ((quote) (case (sx-datum (sx-first s2)) ((unquote) (list 'unquote `(,*cons* ,s1 ,(sx-second s2)))) ((unquote-splicing) (syntax-error s "Improper UNQUOTE-SPLICING")) ((quote) `'(,(sx-second s1) . ,(sx-second s2))) (else (fuck-up)))) (else (fuck-up))))) (else `',s)) `',s))) ;;; DEFINEs (define (defined-variables ss) (let loop ((ss ss) (ss1 '())) (cond ((null? ss) ss1) ((and (sx-pair? (first ss)) (sx-eq? (sx-first (first ss)) 'define)) ;; Extension to R4RS: undefined defines. (cond ((and (or (= (sx-length (first ss)) 2) (= (sx-length (first ss)) 3)) (sx-symbol? (sx-second (first ss)))) (loop (rest ss) (if (memq (sx-datum (sx-second (first ss))) (map sx-datum ss1)) ss1 (cons (sx-second (first ss)) ss1)))) ((and (>= (sx-length (first ss)) 2) (sx-pair? (sx-second (first ss)))) (loop (rest ss) (if (memq (sx-datum (sx-first (sx-second (first ss)))) (map sx-datum ss1)) ss1 (cons (sx-first (sx-second (first ss))) ss1)))) (else (syntax-error (first ss) "Improper DEFINE")))) (else (loop (rest ss) ss1))))) (define (body s) (cond ((and (sx-list? s) (sx-pair? s) (sx-eq? (sx-first s) 'begin)) (let ((ss (body-list (sx-rest s)))) (if (every (lambda (s) (and (sx-list? s) (sx-pair? s) (sx-eq? (sx-first s) 'define))) ss) ss ;; needs work: This encapsulation loses the line and character ;; positions of the BEGIN expression that is being ;; rewritten. (list (encapsulate `(begin ,@ss)))))) ((and (sx-list? s) (sx-pair? s) (macro? (sx-first s))) (body (expand-macro s))) (else (list s)))) (define (body-list s) (reduce append (sx-map body s) '())) (define (macroexpand-body s) ;; Extension to R4RS: definitions can appear more places. (unless (s-expression-macroexpand-body s) (set-s-expression-macroexpand-body! s (let ((ss (body-list (sx-rest (sx-rest s))))) ;; needs work: This encapsulation loses the line and character positions of ;; the lambda expression that is being rewritten. (encapsulate (if (some (lambda (s) (and (sx-list? s) (sx-pair? s) (sx-eq? (sx-first s) 'define))) ss) (let ((ss1 (defined-variables ss)) (ss (map (lambda (s) (if (and (sx-pair? s) (sx-eq? (sx-first s) 'define)) (if (sx-symbol? (sx-second s)) `(set! ,(sx-second s) ,(sx-third s)) `(set! ,(sx-first (sx-second s)) (lambda ,(sx-rest (sx-second s)) ,@(sx-unlist (sx-rest (sx-rest s)))))) s)) (remove-if (lambda (s) (and (sx-pair? s) (sx-eq? (sx-first s) 'define) (= (sx-length s) 2))) ss)))) (cond ((null? ss) `(,(sx-first s) ,(sx-second s))) ((null? (rest ss)) `(,(sx-first s) ,(sx-second s) ((lambda ,ss1 ,(last ss)) ,@(map (lambda (s) '((lambda ()))) ss1)))) (else `(,(sx-first s) ,(sx-second s) ((lambda ,ss1 ;; note: This transformation relies on left-to-right argument ;; evaluation order. ((lambda ,(map (lambda (s) (gensym "hunoz")) (but-last ss)) ,(last ss)) ,@(but-last ss))) ,@(map (lambda (s) '((lambda ()))) ss1)))))) (if (or (null? ss) (null? (rest ss))) s `(,(sx-first s) ,(sx-second s) ;; note: This transformation relies on left-to-right argument ;; evaluation order. ((lambda ,(map (lambda (s) (gensym "hunoz")) (but-last ss)) ,(last ss)) ,@(but-last ss))))))))) (s-expression-macroexpand-body s)) ;;; list of features supported by cond-expand (define *srfi-0-features* '(stalin srfi-0 chicken-stalin)) ;;; The macros (define *macros* '()) (define *r4rs-macros* (list (list 'cond-expand (lambda (s) (define (check x) (cond ((sx-list? x) (case (sx-datum (sx-first x)) ((and) (sx-every check (sx-rest x))) ((or) (sx-some check (sx-rest x))) ((not) (unless (and (sx-list? x) (= (sx-length x) 2)) (syntax-error x "Improper COND-EXPAND clause")) (not (check (sx-second x)))) (else (syntax-error x "Improper COND-EXPAND clause")))) ((memq (sx-datum x) *srfi-0-features*) #t) (else #f))) (let loop ((clauses (sx-rest s))) (if (sx-null? clauses) (syntax-error s "No matching COND-EXPAND clause") (let ((clause (sx-first clauses))) (cond ((and (sx-pair? clause) (sx-eq? (sx-first clause) 'else)) `(begin ,@(sx-unlist (sx-rest clause)))) ((check (sx-first clause)) `(begin ,@(sx-unlist (sx-rest clause))) ) (else (loop (sx-rest clauses))))))))) (list 'cond (lambda (s) (unless (and (sx-every (lambda (s) (and (sx-list? s) (sx-pair? s))) (sx-rest s)) (or (= (sx-length s) 1) (and (sx-every (lambda (s) (or (< (sx-length s) 2) (not (sx-eq? (sx-second s) '=>)) (= (sx-length s) 3))) (sx-rest s)) (every (lambda (s) (not (sx-eq? (sx-first s) 'else))) (rest (reverse (rest (sx-unlist s)))))))) (syntax-error s "Improper COND")) (cond ((= (sx-length s) 1) '((lambda ()))) ((sx-eq? (sx-first (sx-second s)) 'else) `(begin ,@(sx-unlist (sx-rest (sx-second s))))) ((sx-null? (sx-rest (sx-second s))) `(or ,(sx-first (sx-second s)) (cond ,@(sx-unlist (sx-rest (sx-rest s)))))) ((and (= (sx-length (sx-second s)) 3) (sx-eq? (sx-second (sx-second s)) '=>)) (let ((v (gensym "v"))) ;; conventions: V `(let ((,v ,(sx-first (sx-second s)))) (if ,v (,(sx-third (sx-second s)) ,v) (cond ,@(sx-unlist (sx-rest (sx-rest s)))))))) (else `(if ,(sx-first (sx-second s)) (begin ,@(sx-unlist (sx-rest (sx-second s)))) (cond ,@(sx-unlist (sx-rest (sx-rest s))))))))) (list 'case (lambda (s) (unless (and (>= (sx-length s) 2) (sx-every (lambda (s) (and (sx-list? s) (sx-pair? s))) (sx-rest (sx-rest s))) (or (= (sx-length s) 2) (and (every (lambda (s) (sx-list? (sx-first s))) (rest (reverse (rest (rest (sx-unlist s)))))) (or (sx-eq? (sx-first (sx-last s)) 'else) (sx-list? (sx-first (sx-last s))))))) (syntax-error s "Improper CASE")) (let ((v (gensym "v"))) ;; conventions: V `(let ((,v ,(sx-second s))) ,(if (and (>= (sx-length s) 3) (sx-eq? (sx-first (sx-last s)) 'else)) `(cond ,@(map (lambda (s) `((or ,@(sx-map (lambda (s) `(,*eqv?* ,v ',s)) (sx-first s))) ,@(sx-unlist (sx-rest s)))) (but-last (rest (rest (sx-unlist s))))) ,(sx-last s)) `(cond ,@(sx-map (lambda (s) `((or ,@(sx-map (lambda (s) `(,*eqv?* ,v ',s)) (sx-first s))) ,@(sx-unlist (sx-rest s)))) (sx-rest (sx-rest s))))))))) (list 'and (lambda (s) (cond ((= (sx-length s) 1) #t) ((= (sx-length s) 2) (sx-second s)) (else `(if ,(sx-second s) (and ,@(sx-unlist (sx-rest (sx-rest s)))) #f))))) (list 'or (lambda (s) (cond ((= (sx-length s) 1) #f) ((= (sx-length s) 2) (sx-second s)) (else (let ((v (gensym "v"))) ;; conventions: V `(let ((,v ,(sx-second s))) (if ,v ,v (or ,@(sx-unlist (sx-rest (sx-rest s))))))))))) (list 'let ;; Extension to R4RS: Binding can be symbol. (lambda (s) (unless (and (>= (sx-length s) 2) (or (and (sx-list? (sx-second s)) (sx-every (lambda (s) (or (sx-symbol? s) (and (sx-list? s) (= (sx-length s) 2)))) (sx-second s))) (and (sx-symbol? (sx-second s)) (>= (sx-length s) 3) (sx-list? (sx-third s)) (sx-every (lambda (s) (or (sx-symbol? s) (and (sx-list? s) (= (sx-length s) 2)))) (sx-third s))))) (syntax-error s "Improper LET")) (if (sx-list? (sx-second s)) ;; note: This is more complicated than it has to be in attempt to ;; match the Scheme->C argument evaluation order. `((lambda ,(map (lambda (s) (if (sx-symbol? s) s (sx-first s))) (reverse (sx-unlist (sx-second s)))) ,@(sx-unlist (sx-rest (sx-rest s)))) ,@(map (lambda (s) (if (sx-symbol? s) '((lambda ())) (sx-second s))) (reverse (sx-unlist (sx-second s))))) `((letrec ((,(sx-second s) (lambda ,(sx-map (lambda (s) (if (sx-symbol? s) s (sx-first s))) (sx-third s)) ,@(sx-unlist (sx-rest (sx-rest (sx-rest s))))))) ,(sx-second s)) ,@(sx-map (lambda (s) (if (sx-symbol? s) '((lambda ())) (sx-second s))) (sx-third s)))))) (list 'let* ;; Extension to R4RS: Binding can be symbol. (lambda (s) (unless (and (>= (sx-length s) 2) (sx-list? (sx-second s)) (sx-every (lambda (s) (or (sx-symbol? s) (and (sx-list? s) (= (sx-length s) 2)))) (sx-second s))) (syntax-error s "Improper LET*")) (if (sx-null? (sx-second s)) `(begin ,@(sx-unlist (sx-rest (sx-rest s)))) `(let (,(sx-first (sx-second s))) (let* ,(sx-rest (sx-second s)) ,@(sx-unlist (sx-rest (sx-rest s)))))))) (list 'letrec ;; Extension to R4RS: Binding can be symbol. (lambda (s) (unless (and (>= (sx-length s) 2) (sx-list? (sx-second s)) (sx-every (lambda (s) (or (sx-symbol? s) (and (sx-list? s) (= (sx-length s) 2)))) (sx-second s))) (syntax-error s "Improper LETREC")) `(let ,(sx-map (lambda (s) (if (sx-symbol? s) `(,s ((lambda ()))) `(,(sx-first s) ((lambda ()))))) (sx-second s)) ,@(map (lambda (s) `(set! ,(sx-first s) ,(sx-second s))) (remove-if sx-symbol? (sx-unlist (sx-second s)))) ,@(sx-unlist (sx-rest (sx-rest s)))))) (list 'begin (lambda (s) `((lambda () ,@(sx-unlist (sx-rest s)))))) (list 'do (lambda (s) ;; Extension to R4RS: Iterators can be empty. (unless (and (>= (sx-length s) 3) (sx-list? (sx-second s)) (sx-every (lambda (s) (and (sx-list? s) (or (= (sx-length s) 2) (= (sx-length s) 3)))) (sx-second s)) (sx-list? (sx-third s)) (>= (sx-length (sx-third s)) 1)) (syntax-error s "Improper DO")) (let ((loop (gensym "loop"))) ;; conventions: LOOP `(letrec ((,loop (lambda ,(sx-map sx-first (sx-second s)) (if ,(sx-first (sx-third s)) (begin ,@(sx-unlist (sx-rest (sx-third s)))) (begin ,@(sx-unlist (sx-rest (sx-rest (sx-rest s)))) (,loop ,@(sx-map (lambda (s) (if (= (sx-length s) 2) (sx-first s) (sx-third s))) (sx-second s)))))))) (,loop ,@(sx-map sx-second (sx-second s))))))) (list 'delay (lambda (s) (unless (= (sx-length s) 2) (syntax-error s "Improper DELAY")) `((lambda (proc) (let ((result-ready? #f) (result #f)) (lambda () (if result-ready? result (let ((x (proc))) (if result-ready? result (begin (set! result-ready? #t) (set! result x) result))))))) (lambda () ,(sx-second s))))) (list 'quasiquote (lambda (s) (unless (= (sx-length s) 2) (syntax-error s "Improper QUASIQUOTE")) (let ((s (expand-quasiquote (sx-second s)))) (case (sx-datum (sx-first s)) ((unquote) (sx-second s)) ((unquote-splicing) (syntax-error s "Improper UNQUOTE-SPLICING")) ((quote) s) (else (fuck-up)))))) (list 'unquote (lambda (s) (syntax-error s "UNQUOTE not inside QUASIQUOTE"))) (list 'unquote-splicing (lambda (s) (syntax-error s "UNQUOTE-SPLICING not inside QUASIQUOTE"))))) ;;; The Scheme library (define *read* '(define (read . port) ;; needs work: Long predecimal point digit strings can overflow. ;; needs work: Mantissa can overflow or underflow even though exponent ;; would prevent that overflow or underflow. ;; needs work: Can't read largest negative number. ;; needs work: To handle polar numbers with @. ;; needs work: To handle rectangular numbers with i. ;; needs work: To handle ratios with /. ;; needs work: To handle numbers with embedded #. ;; needs work: To handle exactness with #e and #i. ;; needs work: To handle structures. (set! port (if (null? port) (current-input-port) (car port))) ;; needs work: The DOT and CLOSE gensyms should be extracted and bound by a ;; LET that is outside the DEFINE of READ. (let ((dot (string->uninterned-symbol (string-copy "dot"))) (close (string->uninterned-symbol (string-copy "close")))) (let read ((state 'object)) (define (read-exact-binary-integer n) (let ((c (peek-char port))) (cond ((eof-object? c) n) ((char=? c #\0) (read-char port) (read-exact-binary-integer (* 2 n))) ((char=? c #\1) (read-char port) (read-exact-binary-integer (+ (* 2 n) 1))) (else n)))) (define (read-exact-octal-integer n) (let ((c (peek-char port))) (cond ((eof-object? c) n) ((and (char>=? c #\0) (char<=? c #\7)) (read-char port) (read-exact-octal-integer (+ (* 8 n) (- (char->integer c) (char->integer #\0))))) (else n)))) (define (read-exact-decimal-integer n) (let ((c (peek-char port))) (cond ((eof-object? c) n) ((char-numeric? c) (read-char port) (read-exact-decimal-integer (+ (* 10 n) (- (char->integer c) (char->integer #\0))))) (else n)))) (define (read-exact-hexadecimal-integer n) (let ((c (peek-char port))) (cond ((eof-object? c) n) ((char-numeric? c) (read-char port) (read-exact-hexadecimal-integer (+ (* 16 n) (- (char->integer c) (char->integer #\0))))) ((and (char>=? c #\a) (char<=? c #\f)) (read-char port) (read-exact-hexadecimal-integer (+ (* 16 n) (- (char->integer c) (char->integer #\a)) 10))) ((and (char>=? c #\A) (char<=? c #\F)) (read-char port) (read-exact-hexadecimal-integer (+ (* 16 n) (- (char->integer c) (char->integer #\A)) 10))) (else n)))) (define (read-inexact-number n m) (let ((c1 (peek-char port))) (cond ((eof-object? c1) n) ((char-numeric? c1) (read-char port) (read-inexact-number (+ n (/ (- (char->integer c1) (char->integer #\0)) m)) (* m 10.0))) ((or (char=? c1 #\e) (char=? c1 #\E) (char=? c1 #\s) (char=? c1 #\S) (char=? c1 #\f) (char=? c1 #\F) (char=? c1 #\d) (char=? c1 #\D) (char=? c1 #\l) (char=? c1 #\L)) (read-char port) (let ((c2 (read-char port))) (if (eof-object? c2) (panic "EOF while reading exponent")) (cond ((char-numeric? c2) (* n (expt 10.0 (read-exact-decimal-integer (- (char->integer c2) (char->integer #\0)))))) ((char=? c2 #\+) (let ((c3 (read-char port))) (if (eof-object? c3) (panic "EOF while reading exponent")) (if (not (char-numeric? c3)) (panic "Unfinished exponent")) (* n (expt 10.0 (read-exact-decimal-integer (- (char->integer c3) (char->integer #\0))))))) ((char=? c2 #\-) (let ((c3 (read-char port))) (if (eof-object? c3) (panic "EOF while reading exponent")) (if (not (char-numeric? c3)) (panic "Unfinished exponent")) (* n (expt 10.0 (- (read-exact-decimal-integer (- (char->integer c3) (char->integer #\0)))))))) (else (panic "Unfinished exponent"))))) (else n)))) (define (read-number n) (let ((c1 (peek-char port))) (cond ((eof-object? c1) n) ((char-numeric? c1) (read-char port) (read-number (+ (* 10 n) (- (char->integer c1) (char->integer #\0))))) ((char=? c1 #\.) (read-char port) (read-inexact-number (exact->inexact n) 10.0)) ((or (char=? c1 #\e) (char=? c1 #\E) (char=? c1 #\s) (char=? c1 #\S) (char=? c1 #\f) (char=? c1 #\F) (char=? c1 #\d) (char=? c1 #\D) (char=? c1 #\l) (char=? c1 #\L)) (read-char port) (let ((c2 (read-char port))) (if (eof-object? c2) (panic "EOF while reading exponent")) (cond ((char-numeric? c2) (* (exact->inexact n) (expt 10.0 (read-exact-decimal-integer (- (char->integer c2) (char->integer #\0)))))) ((char=? c2 #\+) (let ((c3 (read-char port))) (if (eof-object? c3) (panic "EOF while reading exponent")) (if (not (char-numeric? c3)) (panic "Unfinished exponent")) (* (exact->inexact n) (expt 10.0 (read-exact-decimal-integer (- (char->integer c3) (char->integer #\0))))))) ((char=? c2 #\-) (let ((c3 (read-char port))) (if (eof-object? c3) (panic "EOF while reading exponent")) (if (not (char-numeric? c3)) (panic "Unfinished exponent")) (* (exact->inexact n) (expt 10.0 (- (read-exact-decimal-integer (- (char->integer c3) (char->integer #\0)))))))) (else (panic "Unfinished exponent"))))) (else n)))) (define (char-initial? c) (or (char-alphabetic? c) (char=? c #\~) (char=? c #\!) (char=? c #\$) (char=? c #\%) (char=? c #\^) (char=? c #\&) (char=? c #\*) (char=? c #\_) (char=? c #\/) (char=? c #\:) (char=? c #\<) (char=? c #\=) (char=? c #\>) (char=? c #\?))) (define (char-subsequent? c) (or (char-initial? c) (char-numeric? c) (char=? c #\+) (char=? c #\-) (char=? c #\.))) (define (read-symbol s) ;; needs work: To eliminate LIST-REVERSE. (let ((c (peek-char port))) (cond ((eof-object? c) (string->symbol (list->string (list-reverse s)))) ((char-subsequent? c) (read-char port) (read-symbol (cons (char-downcase c) s))) (else (string->symbol (list->string (list-reverse s))))))) (define (lookup-character-name s) (let loop ((names '(((#\e #\c #\a #\p #\s) . #\space) ((#\e #\n #\i #\l #\w #\e #\n) . #\newline)))) (if (null? names) (panic "Unrecognized character name")) (if (let loop? ((s s) (name (car (car names)))) (or (and (null? s) (null? name)) (and (not (null? s)) (not (null? name)) (char-ci=? (car s) (car name)) (loop? (cdr s) (cdr name))))) (cdr (car names)) (loop (cdr names))))) (define (read-character-name s) (let ((c (peek-char port))) (cond ((eof-object? c) (lookup-character-name s)) ((char-alphabetic? c) (read-char port) (read-character-name (cons c s))) (else (if (and (not (null? s)) (null? (cdr s))) (car s) (lookup-character-name s)))))) (let ((c1 (read-char port))) (cond ((eof-object? c1) ;; note: Manually split EQV? here by removing CASE. (cond ((eq? state 'object) c1) ((eq? state 'list) (panic "EOF while reading list")) ((eq? state 'vector) (panic "EOF while reading vector")) ((eq? state 'quote) (panic "EOF while reading quoted object")) ((eq? state 'quasiquote) (panic "EOF while reading quasiquoted object")) ((eq? state 'unquote-splicing) (panic "EOF while reading unquote-slicing object")) ((eq? state 'unquote) (panic "EOF while reading unquoted object")) ((eq? state 'close) (panic "EOF while reading pair")) (else (panic "This shouldn't happen")))) ((char=? c1 #\;) (let loop () (if (let ((c (read-char port))) (and (not (eof-object? c)) (not (char=? c #\newline)))) (loop))) (read state)) ((char=? c1 #\)) (if (and (not (eq? state 'list)) (not (eq? state 'vector)) (not (eq? state 'close))) (panic "Mismatched closing parenthesis")) close) ((char-whitespace? c1) (read state)) ((eq? state 'close) (panic "Only one object allowed after dot")) ((char=? c1 #\') (list 'quote (read 'quote))) ((char=? c1 #\`) (list 'quasiquote (read 'quasiquote))) ((char=? c1 #\,) (let ((c2 (peek-char port))) (if (eof-object? c2) (panic "EOF after dot")) (cond ((char=? c2 #\@) (read-char port) (list 'unquote-splicing (read 'unquote-splicing))) (else (list 'unquote (read 'unquote)))))) ((char=? c1 #\() (let loop ((s '())) (let ((e (read 'list))) ;; needs work: To eliminate LIST-REVERSE. (cond ((eq? e dot) (if (null? s) (panic "Dot cannot be first element of list")) (let* ((e1 (read 'object)) (e2 (read 'close))) (let loop ((s (cdr s)) (c (cons (car s) e1))) (if (null? s) c (loop (cdr s) (cons (car s) c)))))) ((eq? e close) (list-reverse s)) (else (loop (cons e s))))))) ((char=? c1 #\#) (let ((c2 (read-char port))) (if (eof-object? c2) (panic "EOF after sharp sign")) (cond ((or (char=? c2 #\t) (char=? c2 #\T)) #t) ((or (char=? c2 #\f) (char=? c2 #\F)) #f) ((or (char=? c2 #\b) (char=? c2 #\B)) (let ((c3 (read-char port))) (if (eof-object? c3) (panic "EOF while reading binary number")) (cond ((char=? c3 #\0) (read-exact-binary-integer 0)) ((char=? c3 #\1) (read-exact-binary-integer 1)) ((char=? c3 #\+) (let ((c4 (read-char port))) (if (eof-object? c4) (panic "EOF while reading binary number")) (cond ((char=? c4 #\0) (read-exact-binary-integer 0)) ((char=? c4 #\1) (read-exact-binary-integer 1)) (else (panic "Unfinished binary number"))))) ((char=? c3 #\-) (let ((c4 (read-char port))) (if (eof-object? c4) (panic "EOF while reading binary number")) (cond ((char=? c4 #\0) (- (read-exact-binary-integer 0))) ((char=? c4 #\1) (- (read-exact-binary-integer 1))) (else (panic "Unfinished binary number"))))) (else (panic "Unfinished binary number"))))) ((or (char=? c2 #\o) (char=? c2 #\O)) (let ((c3 (read-char port))) (if (eof-object? c3) (panic "EOF while reading octal number")) (cond ((and (char>=? c3 #\0) (char<=? c3 #\7)) (read-exact-octal-integer (- (char->integer c3) (char->integer #\0)))) ((char=? c3 #\+) (let ((c4 (read-char port))) (if (eof-object? c4) (panic "EOF while reading octal number")) (if (or (char? c4 #\7)) (panic "Unfinished octal number")) (read-exact-octal-integer (- (char->integer c4) (char->integer #\0))))) ((char=? c3 #\-) (let ((c4 (read-char port))) (if (eof-object? c4) (panic "EOF while reading octal number")) (if (or (char? c4 #\7)) (panic "Unfinished octal number")) (- (read-exact-octal-integer (- (char->integer c4) (char->integer #\0)))))) (else (panic "Unfinished octal number"))))) ((or (char=? c2 #\d) (char=? c2 #\D)) (let ((c3 (read-char port))) (if (eof-object? c3) (panic "EOF while reading decimal number")) (cond ((char=? c3 #\+) (let ((c4 (read-char port))) (if (eof-object? c4) (panic "EOF while reading decimal number")) (cond ((char-numeric? c4) (read-number (- (char->integer c4) (char->integer #\0)))) ((char=? c4 #\.) (let ((c5 (read-char port))) (if (eof-object? c5) (panic "EOF while reading decimal number")) (if (not (char-numeric? c5)) (panic "Unfinished decimal number")) (read-inexact-number (/ (- (char->integer c5) (char->integer #\0)) 10.0) 100.0))) (else (panic "Unfinished decimal number"))))) ((char=? c3 #\-) (let ((c4 (read-char port))) (if (eof-object? c4) (panic "EOF while reading decimal number")) (cond ((char-numeric? c4) (- (read-number (- (char->integer c4) (char->integer #\0))))) ((char=? c4 #\.) (let ((c5 (read-char port))) (if (eof-object? c5) (panic "EOF while reading decimal number")) (if (not (char-numeric? c5)) (panic "Unfinished decimal number")) (- (read-inexact-number (/ (- (char->integer c5) (char->integer #\0)) 10.0) 100.0)))) (else (panic "Unfinished decimal number"))))) ((char=? c3 #\.) (let ((c4 (read-char port))) (if (eof-object? c4) (panic "EOF while reading decimal number")) (if (not (char-numeric? c4)) (panic "Unfinished decimal number")) (read-inexact-number (/ (- (char->integer c4) (char->integer #\0)) 10.0) 100.0))) ((char-numeric? c3) (read-number (- (char->integer c3) (char->integer #\0)))) (else (panic "Unfinished decimal number"))))) ((or (char=? c2 #\x) (char=? c2 #\X)) (let ((c3 (read-char port))) (if (eof-object? c3) (panic "EOF while reading hexadecimal number")) (cond ((char-numeric? c3) (read-exact-hexadecimal-integer (- (char->integer c3) (char->integer #\0)))) ((and (char>=? c3 #\a) (char<=? c3 #\f)) (read-exact-hexadecimal-integer (+ (- (char->integer c3) (char->integer #\a)) 10))) ((and (char>=? c3 #\A) (char<=? c3 #\F)) (read-exact-hexadecimal-integer (+ (- (char->integer c3) (char->integer #\A)) 10))) ((char=? c3 #\+) (let ((c4 (read-char port))) (if (eof-object? c4) (panic "EOF while reading hexadecimal number")) (cond ((char-numeric? c4) (read-exact-hexadecimal-integer (- (char->integer c4) (char->integer #\0)))) ((and (char>=? c4 #\a) (char<=? c4 #\f)) (read-exact-hexadecimal-integer (+ (- (char->integer c4) (char->integer #\a)) 10))) ((and (char>=? c4 #\A) (char<=? c4 #\F)) (read-exact-hexadecimal-integer (+ (- (char->integer c4) (char->integer #\A)) 10))) (else (panic "Unfinished hexadecimal number"))))) ((char=? c3 #\-) (let ((c4 (read-char port))) (if (eof-object? c4) (panic "EOF while reading hexadecimal number")) (cond ((char-numeric? c4) (- (read-exact-hexadecimal-integer (- (char->integer c4) (char->integer #\0))))) ((and (char>=? c4 #\a) (char<=? c4 #\f)) (- (read-exact-hexadecimal-integer (+ (- (char->integer c4) (char->integer #\a)) 10)))) ((and (char>=? c4 #\A) (char<=? c4 #\F)) (- (read-exact-hexadecimal-integer (+ (- (char->integer c4) (char->integer #\A)) 10)))) (else (panic "Unfinished hexadecimal number"))))) (else (panic "Unfinished hexadecimal number"))))) ((char=? c2 #\() (let loop ((s '())) (let ((e (read 'vector))) ;; needs work: To eliminate LIST-REVERSE. (if (eq? e close) (list->vector (list-reverse s)) (loop (cons e s)))))) ((char=? c2 #\\) (let ((c3 (read-char port))) (if (eof-object? c3) (panic "EOF while reading character constant")) (if (char-alphabetic? c3) (read-character-name (list c3)) c3))) (else (panic "Improper character after sharp sign"))))) ((char=? c1 #\") ;; needs work: To eliminate LIST-REVERSE. (let loop ((s '())) (let ((c (read-char port))) (if (eof-object? c) (panic "EOF while reading string")) (cond ((char=? c #\\) (let ((c1 (read-char port))) (if (eof-object? c1) (panic "EOF after backslash in string")) (loop (cons c1 s)))) ((char=? c #\") (list->string (list-reverse s))) (else (loop (cons c s))))))) ((char=? c1 #\+) (let ((c2 (peek-char port))) (cond ((eof-object? c2) '+) ((char-numeric? c2) (read-char port) (read-number (- (char->integer c2) (char->integer #\0)))) ((char=? c2 #\.) (read-char port) (let ((c3 (peek-char port))) (cond ((eof-object? c3) '+.) ((char-numeric? c3) (read-char port) (read-inexact-number (/ (- (char->integer c3) (char->integer #\0)) 10.0) 100.0)) ((char-subsequent? c3) (read-char port) (read-symbol (list (char-downcase c3) (char-downcase c2) (char-downcase c1)))) (else '+.)))) ((char-subsequent? c2) (read-char port) (read-symbol (list (char-downcase c2) (char-downcase c1)))) (else '+)))) ((char=? c1 #\-) (let ((c2 (peek-char port))) (cond ((eof-object? c2) '-) ((char-numeric? c2) (read-char port) (- (read-number (- (char->integer c2) (char->integer #\0))))) ((char=? c2 #\.) (read-char port) (let ((c3 (peek-char port))) (cond ((eof-object? c3) '-.) ((char-numeric? c3) (read-char port) (- (read-inexact-number (/ (- (char->integer c3) (char->integer #\0)) 10.0) 100.0))) ((char-subsequent? c3) (read-char port) (read-symbol (list (char-downcase c3) (char-downcase c2) (char-downcase c1)))) (else '-.)))) ((char-subsequent? c2) (read-char port) (read-symbol (list (char-downcase c2) (char-downcase c1)))) (else '-)))) ((char=? c1 #\.) (let ((c2 (peek-char port))) (if (eof-object? c2) (panic "EOF after dot")) (cond ((char-numeric? c2) (read-char port) (read-inexact-number (/ (- (char->integer c2) (char->integer #\0)) 10.0) 100.0)) ((char-subsequent? c2) (read-char port) (read-symbol (list (char-downcase c2) (char-downcase c1)))) ((eq? state 'list) dot) (else (panic "Dot allowed only inside list"))))) ((char-numeric? c1) (read-number (- (char->integer c1) (char->integer #\0)))) ((char-initial? c1) (read-symbol (list (char-downcase c1)))) (else (panic "Attempt to READ invalid character")))))))) (define *i/o* ;; needs work: ;; 1. DISPLAY-{STRING,EXACT-INTEGER,MANTISSA-EXPONENT,INEXACT-REAL}1, ;; WRITE1 ;; 2. recursive calls to DISPLAY-INEXACT-REAL2, WRITE2, and DISPLAY2 ;; should be optimized to not pass PORT ;; 3. check implementation of remainder and modulo ;; 4. rectangular numbers ;; 5. -0.0 ;; 6. should be able to print inexact numbers in non-scientific notation '(let ((buffer (make-vector 20)) ;enough for 64-bit numbers (the-current-input-port ((primitive-procedure standard-input-port))) (the-current-output-port ((primitive-procedure standard-output-port))) (write-methods '()) (display-methods '())) (define read-char1 (primitive-procedure read-char1)) (define peek-char1 (primitive-procedure peek-char1)) (define char-ready?1 (primitive-procedure char-ready?1)) (define write-char2 (primitive-procedure write-char2)) (define (display-string2 string port) (let ((n (string-length string))) (let loop ((i 0)) (if (< i n) (begin (write-char2 (string-ref string i) port) (loop (+ i 1))))))) (define (display-exact-integer2 number port) (cond ((positive? number) (let loop ((i 0) (number number)) (if (zero? number) (let loop ((i (- i 1))) (write-char2 (integer->char (+ (char->integer #\0) (vector-ref buffer i))) port) (if (not (zero? i)) (loop (- i 1)))) (begin (vector-set! buffer i (remainder number 10)) (loop (+ i 1) (quotient number 10)))))) ((negative? number) (write-char2 #\- port) (let loop ((i 0) (number number)) (if (zero? number) (let loop ((i (- i 1))) (write-char2 (integer->char (+ (char->integer #\0) (vector-ref buffer i))) port) (if (not (zero? i)) (loop (- i 1)))) (begin (vector-set! buffer i (- (remainder number 10))) (loop (+ i 1) (quotient number 10)))))) (else (write-char2 #\0 port)))) (define (display-mantissa-exponent2 mantissa exponent port) (let* ((float-digit (floor mantissa)) (digit (inexact->exact float-digit))) ;; needs work: This is a real kludge. (cond ((= digit 0) (display-mantissa-exponent2 (* 10.0 mantissa) (- exponent 1) port)) ((= digit 10) (display-mantissa-exponent2 (* 0.1 mantissa) (+ exponent 1) port)) (else (write-char2 (integer->char (+ (char->integer #\0) digit)) port) (write-char2 #\. port) (let loop ((mantissa (* 10.0 (- mantissa float-digit)))) (let* ((float-digit (floor mantissa)) (digit (inexact->exact float-digit))) (write-char2 (integer->char (+ (char->integer #\0) digit)) port) (let ((mantissa (* 10.0 (- mantissa float-digit)))) (if (not (zero? mantissa)) (loop mantissa))))) (if (not (zero? exponent)) (begin (write-char2 #\e port) (display-exact-integer2 exponent port))))))) (define (display-inexact-real2 number port) (cond ((not (= number number)) (display-string2 "#*NOT-A-NUMBER*" port)) (((primitive-procedure infinity?) number) (display-string2 "#*INFINITY*" port)) ((negative? number) (write-char2 #\- port) (display-inexact-real2 (- number) port)) ((zero? number) (display-string2 "0.0" port)) ((>= number 10.0) (let loop ((mantissa (* 0.1 number)) (exponent 1)) (if (>= mantissa 10.0) (loop (* 0.1 mantissa) (+ exponent 1)) (display-mantissa-exponent2 mantissa exponent port)))) ((< number 1.0) (let loop ((mantissa (* 10.0 number)) (exponent -1)) (if (< mantissa 1.0) (loop (* 10.0 mantissa) (- exponent 1)) (display-mantissa-exponent2 mantissa exponent port)))) (else (display-mantissa-exponent2 number 0 port)))) (define (write2 obj port) (cond ((null? obj) (display-string2 "()" port)) ((eq? obj #t) (display-string2 "#T" port)) ((not obj) (display-string2 "#F" port)) ((char? obj) ;; needs work: To handle other non printing characters. (cond ((char=? obj #\space) (display-string2 "#\\Space" port)) ((char=? obj #\newline) (display-string2 "#\\Newline" port)) (else (display-string2 "#\\" port) (write-char2 obj port)))) ((number? obj) (if (exact? obj) (display-exact-integer2 obj port) (display-inexact-real2 obj port))) ((input-port? obj) (display-string2 "#*INPUT-PORT*" port)) ((output-port? obj) (display-string2 "#*OUTPUT-PORT*" port)) ((eof-object? obj) (display-string2 "#*EOF-OBJECT*" port)) ((pointer? obj) (display-string2 "#*POINTER*" port)) ((symbol? obj) ;; needs work: Should slashify. (display-string2 (symbol->string obj) port)) ((procedure? obj) (display-string2 "#*PROCEDURE*" port)) ((string? obj) (write-char2 #\" port) (let ((n (string-length obj))) (let loop ((i 0)) (if (< i n) (let ((c (string-ref obj i))) (if (or (char=? c #\\) (char=? c #\")) (write-char2 #\\ port)) (write-char2 c port) (loop (+ i 1)))))) (write-char2 #\" port)) ((pair? obj) (write-char2 #\( port) (let loop ((obj obj)) (cond ((null? (cdr obj)) (write2 (car obj) port) (write-char2 #\) port)) ((pair? (cdr obj)) (write2 (car obj) port) (write-char2 #\space port) (loop (cdr obj))) (else (write2 (car obj) port) (display-string2 " . " port) (write2 (cdr obj) port) (write-char2 #\) port))))) ((vector? obj) (display-string2 "#(" port) (if (not (zero? (vector-length obj))) (begin (write2 (vector-ref obj 0) port) (let loop ((i 1)) (if (< i (vector-length obj)) (begin (write-char2 #\space port) (write2 (vector-ref obj i) port) (loop (+ i 1))))))) (write-char2 #\) port)) (else (let loop ((write-methods write-methods)) (cond ((null? write-methods) (display-string2 "#*UNKNOWN*" port)) (((car (car write-methods)) obj) ((cdr (car write-methods)) obj port)) (else (loop (cdr write-methods)))))))) (define (display2 obj port) (cond ((null? obj) (display-string2 "()" port)) ((eq? obj #t) (display-string2 "#T" port)) ((not obj) (display-string2 "#F" port)) ((char? obj) (write-char2 obj port)) ((number? obj) (if (exact? obj) (display-exact-integer2 obj port) (display-inexact-real2 obj port))) ((input-port? obj) (display-string2 "#*INPUT-PORT*" port)) ((output-port? obj) (display-string2 "#*OUTPUT-PORT*" port)) ((eof-object? obj) (display-string2 "#*EOF-OBJECT*" port)) ((pointer? obj) (display-string2 "#*POINTER*" port)) ((symbol? obj) (display-string2 (symbol->string obj) port)) ((procedure? obj) (display-string2 "#*PROCEDURE*" port)) ((string? obj) (display-string2 obj port)) ((pair? obj) (write-char2 #\( port) (let loop ((obj obj)) (cond ((null? (cdr obj)) (display2 (car obj) port) (write-char2 #\) port)) ((pair? (cdr obj)) (display2 (car obj) port) (write-char2 #\space port) (loop (cdr obj))) (else (display2 (car obj) port) (display-string2 " . " port) (display2 (cdr obj) port) (write-char2 #\) port))))) ((vector? obj) (display-string2 "#(" port) (if (not (zero? (vector-length obj))) (begin (display2 (vector-ref obj 0) port) (let loop ((i 1)) (if (< i (vector-length obj)) (begin (write-char2 #\space port) (display2 (vector-ref obj i) port) (loop (+ i 1))))))) (write-char2 #\) port)) (else (let loop ((display-methods display-methods)) (cond ((null? display-methods) (display-string2 "#*UNKNOWN*" port)) (((car (car display-methods)) obj) ((cdr (car display-methods)) obj port)) (else (loop (cdr display-methods)))))))) (set! number->string ;; Bengt Kleberg contributed the enhancements to ;; NUMBER->STRING to support the optional radix argument. (lambda (number . optional-radix) (let* ((radix-exact (if (null? optional-radix) 10 (let ((probably-radix (car optional-radix))) (if (and (integer? probably-radix) (exact? probably-radix) (or (= probably-radix 10) (and (integer? number) (exact? number) (or (= probably-radix 2) (= probably-radix 8) (= probably-radix 16))))) probably-radix (panic "Attempt to call NUMBER->STRING with invalid radix"))))) (radix-inexact (exact->inexact radix-exact)) (radix-inverted (/ radix-inexact))) ;; needs work: To handle optional radix argument better. (define (hex-digit->char digit) (vector-ref '#(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\A #\B #\C #\D #\E #\F) digit)) (define (mantissa-exponent->characters mantissa exponent) (let* ((float-digit (floor mantissa)) (digit (inexact->exact float-digit))) ;; needs work: This is a real kludge. (cond ((= digit 0) (mantissa-exponent->characters (* radix-inexact mantissa) (- exponent 1))) ((= digit radix-exact) (mantissa-exponent->characters (* radix-inverted mantissa) (+ exponent 1))) (else (cons (hex-digit->char digit) (cons #\. (let loop ((mantissa (* radix-inexact (- mantissa float-digit)))) (let* ((float-digit (floor mantissa)) (digit (inexact->exact float-digit))) (cons (hex-digit->char digit) (let ((mantissa (* radix-inexact (- mantissa float-digit)))) (if (zero? mantissa) (if (zero? exponent) '() (cons #\e (cond ((positive? exponent) (let loop ((exponent exponent) (characters '())) (if (zero? exponent) characters (loop (quotient exponent radix-exact) (cons (hex-digit->char (remainder exponent radix-exact)) characters))))) ((negative? exponent) (let loop ((exponent exponent) (characters '())) (if (zero? exponent) (cons #\- characters) (loop (quotient exponent radix-exact) (cons (hex-digit->char (- (remainder exponent radix-exact))) characters)))))))) (loop mantissa)))))))))))) ;; NUMBER->STRING body (cond ((inexact? number) (cond ((not (= number number)) "#*NOT-A-NUMBER*") (((primitive-procedure infinity?) number) "#*INFINITY*") ((negative? number) (let ((number (- number))) (cond ((not (= number number)) "-#*NOT-A-NUMBER*") (((primitive-procedure infinity?) number) "-#*INFINITY*") ((>= number radix-inexact) (let loop ((mantissa (* radix-inverted number)) (exponent 1)) (if (>= mantissa radix-inexact) (loop (* radix-inverted mantissa) (+ exponent 1)) (list->string (cons #\- (mantissa-exponent->characters mantissa exponent)))))) ((< number 1.0) (let loop ((mantissa (* radix-inexact number)) (exponent -1)) (if (< mantissa 1.0) (loop (* radix-inexact mantissa) (- exponent 1)) (list->string (cons #\- (mantissa-exponent->characters mantissa exponent)))))) (else (list->string (cons #\- (mantissa-exponent->characters number 0))))))) ((zero? number) "0.0") ((>= number radix-inexact) (let loop ((mantissa (* radix-inverted number)) (exponent 1)) (if (>= mantissa radix-inexact) (loop (* radix-inverted mantissa) (+ exponent 1)) (list->string (mantissa-exponent->characters mantissa exponent))))) ((< number 1.0) (let loop ((mantissa (* radix-inexact number)) (exponent -1)) (if (< mantissa 1.0) (loop (* radix-inexact mantissa) (- exponent 1)) (list->string (mantissa-exponent->characters mantissa exponent))))) (else (list->string (mantissa-exponent->characters number 0))))) ((positive? number) (let loop ((number number) (characters '())) (if (zero? number) (list->string characters) (loop (quotient number radix-exact) (cons (hex-digit->char (remainder number radix-exact)) characters))))) ((negative? number) (let loop ((number number) (characters '())) (if (zero? number) (list->string (cons #\- characters)) (loop (quotient number radix-exact) (cons (hex-digit->char (- (remainder number radix-exact))) characters))))) (else "0"))))) (set! string->number (lambda (string) ;; needs work: Long predecimal point digit strings can overflow. ;; needs work: Mantissa can overflow or underflow even though exponent ;; would prevent that overflow or underflow. ;; needs work: Can't parse largest negative number. ;; needs work: To handle polar numbers with @. ;; needs work: To handle rectangular numbers with i. ;; needs work: To handle ratios with /. ;; needs work: To handle numbers with embedded #. ;; needs work: To handle exactness with #e and #i. ;; needs work: To handle optional radix argument. (let ((i 0) (l (string-length string))) (define (negate n) (if n (- n) #f)) (define (parse-exact-binary-integer n) (if (= i l) n (let ((c (string-ref string i))) (set! i (+ i 1)) (cond ((char=? c #\0) (parse-exact-binary-integer (* 2 n))) ((char=? c #\1) (parse-exact-binary-integer (+ (* 2 n) 1))) (else #f))))) (define (parse-exact-octal-integer n) (if (= i l) n (let ((c (string-ref string i))) (set! i (+ i 1)) (cond ((and (char>=? c #\0) (char<=? c #\7)) (parse-exact-octal-integer (+ (* 8 n) (- (char->integer c) (char->integer #\0))))) (else #f))))) (define (parse-exact-decimal-integer n) (if (= i l) n (let ((c (string-ref string i))) (set! i (+ i 1)) (cond ((char-numeric? c) (parse-exact-decimal-integer (+ (* 10 n) (- (char->integer c) (char->integer #\0))))) (else #f))))) (define (parse-exact-hexadecimal-integer n) (if (= i l) n (let ((c (string-ref string i))) (set! i (+ i 1)) (cond ((char-numeric? c) (parse-exact-hexadecimal-integer (+ (* 16 n) (- (char->integer c) (char->integer #\0))))) ((and (char>=? c #\a) (char<=? c #\f)) (parse-exact-hexadecimal-integer (+ (* 16 n) (- (char->integer c) (char->integer #\a)) 10))) ((and (char>=? c #\A) (char<=? c #\F)) (parse-exact-hexadecimal-integer (+ (* 16 n) (- (char->integer c) (char->integer #\A)) 10))) (else #f))))) (define (parse-inexact-number n m) (if (= i l) n (let ((c1 (string-ref string i))) (set! i (+ i 1)) (cond ((char-numeric? c1) (parse-inexact-number (+ n (/ (- (char->integer c1) (char->integer #\0)) m)) (* m 10.0))) ((or (char=? c1 #\e) (char=? c1 #\E) (char=? c1 #\s) (char=? c1 #\S) (char=? c1 #\f) (char=? c1 #\F) (char=? c1 #\d) (char=? c1 #\D) (char=? c1 #\l) (char=? c1 #\L)) (if (= i l) #f (let ((c2 (string-ref string i))) (set! i (+ i 1)) (cond ((char-numeric? c2) (let ((k (parse-exact-decimal-integer (- (char->integer c2) (char->integer #\0))))) (if k (* n (expt 10.0 k)) #f))) ((char=? c2 #\+) (if (= i l) #f (let ((c3 (string-ref string i))) (set! i (+ i 1)) (if (char-numeric? c3) (let ((k (parse-exact-decimal-integer (- (char->integer c3) (char->integer #\0))))) (if k (* n (expt 10.0 k)) #f)) #f)))) ((char=? c2 #\-) (if (= i l) #f (let ((c3 (string-ref string i))) (set! i (+ i 1)) (if (char-numeric? c3) (let ((k (parse-exact-decimal-integer (- (char->integer c3) (char->integer #\0))))) (if k (* n (expt 10.0 (- k))) #f)) #f)))) (else #f))))) (else #f))))) (define (parse-number n) (if (= i l) n (let ((c1 (string-ref string i))) (set! i (+ i 1)) (cond ((char-numeric? c1) (parse-number (+ (* 10 n) (- (char->integer c1) (char->integer #\0))))) ((char=? c1 #\.) (parse-inexact-number (exact->inexact n) 10.0)) ((or (char=? c1 #\e) (char=? c1 #\E) (char=? c1 #\s) (char=? c1 #\S) (char=? c1 #\f) (char=? c1 #\F) (char=? c1 #\d) (char=? c1 #\D) (char=? c1 #\l) (char=? c1 #\L)) (if (= i l) #f (let ((c2 (string-ref string i))) (set! i (+ i 1)) (cond ((char-numeric? c2) (let ((k (parse-exact-decimal-integer (- (char->integer c2) (char->integer #\0))))) (if k (* (exact->inexact n) (expt 10.0 k))))) ((char=? c2 #\+) (if (= i l) #f (let ((c3 (string-ref string i))) (set! i (+ i 1)) (if (char-numeric? c3) (let ((k (parse-exact-decimal-integer (- (char->integer c3) (char->integer #\0))))) (if k (* (exact->inexact n) (expt 10.0 k)) #f)) #f)))) ((char=? c2 #\-) (if (= i l) #f (let ((c3 (string-ref string i))) (set! i (+ i 1)) (if (char-numeric? c3) (let ((k (parse-exact-decimal-integer (- (char->integer c3) (char->integer #\0))))) (if k (* (exact->inexact n) (expt 10.0 (- k))) #f)) #f)))) (else #f))))) (else #f))))) (let loop () (if (= i l) #f (let ((c1 (string-ref string i))) (set! i (+ i 1)) (cond ((char-whitespace? c1) (loop)) ((char=? c1 #\#) (if (= i l) #f (let ((c2 (string-ref string i))) (set! i (+ i 1)) (cond ((or (char=? c2 #\b) (char=? c2 #\B)) (if (= i l) #f (let ((c3 (string-ref string i))) (set! i (+ i 1)) (cond ((char=? c3 #\0) (parse-exact-binary-integer 0)) ((char=? c3 #\1) (parse-exact-binary-integer 1)) ((char=? c3 #\+) (if (= i l) #f (let ((c4 (string-ref string i))) (set! i (+ i 1)) (cond ((char=? c4 #\0) (parse-exact-binary-integer 0)) ((char=? c4 #\1) (parse-exact-binary-integer 1)) (else #f))))) ((char=? c3 #\-) (if (= i l) #f (let ((c4 (string-ref string i))) (set! i (+ i 1)) (cond ((char=? c4 #\0) (negate (parse-exact-binary-integer 0))) ((char=? c4 #\1) (negate (parse-exact-binary-integer 1))) (else #f))))) (else #f))))) ((or (char=? c2 #\o) (char=? c2 #\O)) (if (= i l) #f (let ((c3 (string-ref string i))) (set! i (+ i 1)) (cond ((and (char>=? c3 #\0) (char<=? c3 #\7)) (parse-exact-octal-integer (- (char->integer c3) (char->integer #\0)))) ((char=? c3 #\+) (if (= i l) #f (let ((c4 (string-ref string i))) (set! i (+ i 1)) (if (and (char>=? c4 #\0) (char<=? c4 #\7)) (parse-exact-octal-integer (- (char->integer c4) (char->integer #\0))) #f)))) ((char=? c3 #\-) (if (= i l) #f (let ((c4 (string-ref string i))) (set! i (+ i 1)) (if (and (char>=? c4 #\0) (char<=? c4 #\7)) (negate (parse-exact-octal-integer (- (char->integer c4) (char->integer #\0)))) #f)))) (else #f))))) ((or (char=? c2 #\d) (char=? c2 #\D)) (if (= i l) #f (let ((c3 (string-ref string i))) (set! i (+ i 1)) (cond ((char=? c3 #\+) (if (= i l) #f (let ((c4 (string-ref string i))) (set! i (+ i 1)) (cond ((char-numeric? c4) (parse-number (- (char->integer c4) (char->integer #\0)))) ((char=? c4 #\.) (if (= i l) #f (let ((c5 (string-ref string i))) (set! i (+ i 1)) (if (char-numeric? c5) (parse-inexact-number (/ (- (char->integer c5) (char->integer #\0)) 10.0) 100.0) #f)))) (else #f))))) ((char=? c3 #\-) (if (= i l) #f (let ((c4 (string-ref string i))) (set! i (+ i 1)) (cond ((char-numeric? c4) (negate (parse-number (- (char->integer c4) (char->integer #\0))))) ((char=? c4 #\.) (if (= i l) #f (let ((c5 (string-ref string i))) (set! i (+ i 1)) (if (char-numeric? c5) (negate (parse-inexact-number (/ (- (char->integer c5) (char->integer #\0)) 10.0) 100.0)) #f)))) (else #f))))) ((char=? c3 #\.) (if (= i l) #f (let ((c4 (string-ref string i))) (set! i (+ i 1)) (if (char-numeric? c4) (parse-inexact-number (/ (- (char->integer c4) (char->integer #\0)) 10.0) 100.0) #f)))) ((char-numeric? c3) (parse-number (- (char->integer c3) (char->integer #\0)))) (else #f))))) ((or (char=? c2 #\x) (char=? c2 #\X)) (if (= i l) #f (let ((c3 (string-ref string i))) (set! i (+ i 1)) (cond ((char-numeric? c3) (parse-exact-hexadecimal-integer (- (char->integer c3) (char->integer #\0)))) ((and (char>=? c3 #\a) (char<=? c3 #\f)) (parse-exact-hexadecimal-integer (+ (- (char->integer c3) (char->integer #\a)) 10))) ((and (char>=? c3 #\A) (char<=? c3 #\F)) (parse-exact-hexadecimal-integer (+ (- (char->integer c3) (char->integer #\A)) 10))) ((char=? c3 #\+) (if (= i l) #f (let ((c4 (string-ref string i))) (set! i (+ i 1)) (cond ((char-numeric? c4) (parse-exact-hexadecimal-integer (- (char->integer c4) (char->integer #\0)))) ((and (char>=? c4 #\a) (char<=? c4 #\f)) (parse-exact-hexadecimal-integer (+ (- (char->integer c4) (char->integer #\a)) 10))) ((and (char>=? c4 #\A) (char<=? c4 #\F)) (parse-exact-hexadecimal-integer (+ (- (char->integer c4) (char->integer #\A)) 10))) (else #f))))) ((char=? c3 #\-) (if (= i l) #f (let ((c4 (string-ref string i))) (set! i (+ i 1)) (cond ((char-numeric? c4) (negate (parse-exact-hexadecimal-integer (- (char->integer c4) (char->integer #\0))))) ((and (char>=? c4 #\a) (char<=? c4 #\f)) (negate (parse-exact-hexadecimal-integer (+ (- (char->integer c4) (char->integer #\a)) 10)))) ((and (char>=? c4 #\A) (char<=? c4 #\F)) (negate (parse-exact-hexadecimal-integer (+ (- (char->integer c4) (char->integer #\A)) 10)))) (else #f))))) (else #f))))) (else #f))))) ((char=? c1 #\+) (if (= i l) #f (let ((c2 (string-ref string i))) (set! i (+ i 1)) (cond ((char-numeric? c2) (parse-number (- (char->integer c2) (char->integer #\0)))) ((char=? c2 #\.) (if (= i l) #f (let ((c3 (string-ref string i))) (set! i (+ i 1)) (if (char-numeric? c3) (parse-inexact-number (/ (- (char->integer c3) (char->integer #\0)) 10.0) 100.0) #f)))) (else #f))))) ((char=? c1 #\-) (if (= i l) #f (let ((c2 (string-ref string i))) (set! i (+ i 1)) (cond ((char-numeric? c2) (negate (parse-number (- (char->integer c2) (char->integer #\0))))) ((char=? c2 #\.) (if (= i l) #f (let ((c3 (string-ref string i))) (set! i (+ i 1)) (if (char-numeric? c3) (negate (parse-inexact-number (/ (- (char->integer c3) (char->integer #\0)) 10.0) 100.0)) #f)))) (else #f))))) ((char=? c1 #\.) (if (= i l) #f (let ((c2 (string-ref string i))) (set! i (+ i 1)) (if (char-numeric? c2) (parse-inexact-number (/ (- (char->integer c2) (char->integer #\0)) 10.0) 100.0) #f)))) ((char-numeric? c1) (parse-number (- (char->integer c1) (char->integer #\0)))) (else #f)))))))) (set! current-input-port (lambda () the-current-input-port)) (set! current-output-port (lambda () the-current-output-port)) (set! with-input-from-file (lambda (string thunk) (let* ((saved-input-port the-current-input-port) (result (call-with-input-file string (lambda (port) (set! the-current-input-port port) (thunk))))) (set! the-current-input-port saved-input-port) result))) (set! with-output-to-file (lambda (string thunk) (let* ((saved-output-port the-current-output-port) (result (call-with-output-file string (lambda (port) (set! the-current-output-port port) (thunk))))) (set! the-current-output-port saved-output-port) result))) (set! read-char (lambda &rest (cond ((null? &rest) (read-char1 the-current-input-port)) ((null? (cdr &rest)) (read-char1 (car &rest))) (else (panic "Attempt to call READ-CHAR with the wrong number of arguments"))))) (set! peek-char (lambda &rest (cond ((null? &rest) (peek-char1 the-current-input-port)) ((null? (cdr &rest)) (peek-char1 (car &rest))) (else (panic "Attempt to call PEEK-CHAR with the wrong number of arguments"))))) (set! char-ready? (lambda &rest (cond ((null? &rest) (char-ready?1 the-current-input-port)) ((null? (cdr &rest)) (char-ready?1 (car &rest))) (else (panic "Attempt to call CHAR-READY? with the wrong number of arguments"))))) (set! write (lambda (obj . &rest) (cond ((null? &rest) (write2 obj the-current-output-port)) ((null? (cdr &rest)) (write2 obj (car &rest))) (else (panic "Attempt to call WRITE with the wrong number of arguments"))))) (set! display (lambda (obj . &rest) (cond ((null? &rest) (display2 obj the-current-output-port)) ((null? (cdr &rest)) (display2 obj (car &rest))) (else (panic "Attempt to call DISPLAY with the wrong number of arguments"))))) (set! newline (lambda &rest (cond ((null? &rest) (write-char2 #\newline the-current-output-port)) ((null? (cdr &rest)) (write-char2 #\newline (car &rest))) (else (panic "Attempt to call NEWLINE with the wrong number of arguments"))))) (set! write-char (lambda (char . &rest) (cond ((null? &rest) (write-char2 char the-current-output-port)) ((null? (cdr &rest)) (write-char2 char (car &rest))) (else (panic "Attempt to call WRITE-CHAR with the wrong number of arguments"))))) (set! define-write-method (lambda (type? method) (set! write-methods (cons (cons type? method) write-methods)))) (set! define-display-method (lambda (type? method) (set! display-methods (cons (cons type? method) display-methods)))))) (define (scheme-library vs ss) ;; conventions: VS (encapsulate ;; 6. Standard procedures ;; 6.1 Booleans `(lambda (argv) (define (not obj) ((primitive-procedure not) obj)) (define (boolean? obj) ((primitive-procedure boolean?) obj)) ;; 6.2 Equivalence predicates (define (eqv? obj1 obj2) (or (eq? obj1 obj2) (and (number? obj1) (number? obj2) (= obj1 obj2)) (and (string? obj1) (string? obj2) (zero? (string-length obj1)) (zero? (string-length obj2))) (and (vector? obj1) (vector? obj2) (zero? (vector-length obj1)) (zero? (vector-length obj2))))) (define (eq? obj1 obj2) ((primitive-procedure eq?) obj1 obj2)) (define (equal? obj1 obj2) (or (eqv? obj1 obj2) (and (pair? obj1) (pair? obj2) (equal? (car obj1) (car obj2)) (equal? (cdr obj1) (cdr obj2))) (and (string? obj1) (string? obj2) (string=? obj1 obj2)) (and (vector? obj1) (vector? obj2) (= (vector-length obj1) (vector-length obj2)) (let loop? ((k 0)) (or (= k (vector-length obj1)) (and (equal? (vector-ref obj1 k) (vector-ref obj2 k)) (loop? (+ k 1)))))))) ;; 6.3 Pairs and lists (define (pair? obj) ((primitive-procedure structure? pair) obj)) (define (cons obj1 obj2) ((primitive-procedure make-structure pair 2) obj1 obj2)) (define (car pair) ((primitive-procedure structure-ref pair 0) pair)) (define (cdr pair) ((primitive-procedure structure-ref pair 1) pair)) (define (set-car! pair obj) ((primitive-procedure structure-set! pair 0) pair obj)) (define (set-cdr! pair obj) ((primitive-procedure structure-set! pair 1) pair obj)) (define (caar pair) (car (car pair))) (define (cadr pair) (car (cdr pair))) (define (cdar pair) (cdr (car pair))) (define (cddr pair) (cdr (cdr pair))) (define (caaar pair) (car (car (car pair)))) (define (caadr pair) (car (car (cdr pair)))) (define (cadar pair) (car (cdr (car pair)))) (define (caddr pair) (car (cdr (cdr pair)))) (define (cdaar pair) (cdr (car (car pair)))) (define (cdadr pair) (cdr (car (cdr pair)))) (define (cddar pair) (cdr (cdr (car pair)))) (define (cdddr pair) (cdr (cdr (cdr pair)))) (define (caaaar pair) (car (car (car (car pair))))) (define (caaadr pair) (car (car (car (cdr pair))))) (define (caadar pair) (car (car (cdr (car pair))))) (define (caaddr pair) (car (car (cdr (cdr pair))))) (define (cadaar pair) (car (cdr (car (car pair))))) (define (cadadr pair) (car (cdr (car (cdr pair))))) (define (caddar pair) (car (cdr (cdr (car pair))))) (define (cadddr pair) (car (cdr (cdr (cdr pair))))) (define (cdaaar pair) (cdr (car (car (car pair))))) (define (cdaadr pair) (cdr (car (car (cdr pair))))) (define (cdadar pair) (cdr (car (cdr (car pair))))) (define (cdaddr pair) (cdr (car (cdr (cdr pair))))) (define (cddaar pair) (cdr (cdr (car (car pair))))) (define (cddadr pair) (cdr (cdr (car (cdr pair))))) (define (cdddar pair) (cdr (cdr (cdr (car pair))))) (define (cddddr pair) (cdr (cdr (cdr (cdr pair))))) (define (null? obj) ((primitive-procedure null?) obj)) (define (list? x) (or (null? x) (and (pair? x) (let loop? ((slow x) (fast (cdr x))) (or (null? fast) (and (pair? fast) (and (not (eq? fast slow)) (let ((fast (cdr fast))) (or (null? fast) (and (pair? fast) (loop? (cdr slow) (cdr fast)))))))))))) (define (list . objs) objs) (define (list-length list) ;Extension to R4RS. (let loop ((k 0)) (cond ((null? list) k) (else (set! list (cdr list)) (loop (+ k 1)))))) (define (length s) ;Extension to R4RS. (cond ;; note: This was changed from LIST? to PAIR?/NULL? for efficiency ;; reasons. Now it will loop when given an infinite list. ((null? s) 0) ((pair? s) (list-length s)) ((string? s) (string-length s)) ((vector? s) (vector-length s)) (else (panic "Argument to LENGTH is not a list, string, or vector")))) (define (sublist list start end) ;Extension to R4RS. (if (zero? start) ;; needs work: To make tail recursive. (let loop ((list list) (k end)) (if (zero? k) '() (cons (car list) (loop (cdr list) (- k 1))))) (sublist (cdr list) (- start 1) (- end 1)))) (define (sub s start end) ;Extension to R4RS. (cond ;; note: This was changed from LIST? to PAIR?/NULL? for efficiency ;; reasons. Now it may loop when given an infinite list and may ;; fail to detect an error when given a pair that is not a list. ((null? s) (cond ((and (zero? start) (zero? end)) '()) (else (panic "Arguments to SUB out of bounds")))) ((pair? s) (sublist s start end)) ((string? s) (substring s start end)) ((vector? s) (subvector s start end)) (else (panic "First argument to SUB is not a list, string, or vector")))) (define (list-append . lists) ;Extension to R4RS. ;; needs work: To make tail recursive. ;; note: Support for multiple arguments incurs a penalty here. ;; note: This may loop when given an infinite list and may fail to detect ;; an error when given a pair that is not a list as other than the ;; last argument. (cond ((null? lists) '()) ((null? (cdr lists)) (car lists)) (else (let loop ((list1 (car lists)) (list2 (car (cdr lists))) (lists (cdr (cdr lists)))) (if (null? list1) (if (null? lists) list2 (loop list2 (car lists) (cdr lists))) (cons (car list1) (loop (cdr list1) list2 lists))))))) (define (append . ss) ;Extension to R4RS. ;; note: Support for multiple arguments incurs a penalty here. (cond ((null? ss) '()) ;; note: This was changed from LIST? to PAIR?/NULL? for efficiency ;; reasons. Now it may loop when given an infinite list and may ;; fail to detect an error when given a pair that is not a list as ;; other than the last argument. ((let loop ((ss ss)) (or (null? (cdr ss)) (and (or (null? (car ss)) (pair? (car ss))) (loop (cdr ss))))) (cond ((null? (cdr ss)) (car ss)) (else ;; needs work: To make tail recursive. (let loop ((list1 (car ss)) (list2 (car (cdr ss))) (lists (cdr (cdr ss)))) (if (null? list1) (if (null? lists) list2 (loop list2 (car lists) (cdr lists))) (cons (car list1) (loop (cdr list1) list2 lists))))))) ((let loop ((ss ss)) (or (null? ss) (and (string? (car ss)) (loop (cdr ss))))) (let* ((r (make-string (let loop ((k 0) (strings ss)) (if (null? strings) k (loop (+ k (string-length (car strings))) (cdr strings)))))) (k 0)) (let loop ((strings ss)) (if (not (null? strings)) (let ((n (string-length (car strings)))) (let loop ((l 0)) (if (not (= l n)) (begin (string-set! r k (string-ref (car strings) l)) (set! k (+ k 1)) (loop (+ l 1))))) (loop (cdr strings))))) r)) ((let loop ((ss ss)) (or (null? ss) (and (vector? (car ss)) (loop (cdr ss))))) (let* ((r (make-vector (let loop ((k 0) (vectors ss)) (if (null? vectors) k (loop (+ k (vector-length (car vectors))) (cdr vectors)))))) (k 0)) (let loop ((vectors ss)) (if (not (null? vectors)) (begin (let loop ((l 0)) (if (not (= l (vector-length (car vectors)))) (begin (vector-set! r k (vector-ref (car vectors) l)) (set! k (+ k 1)) (loop (+ l 1))))) (loop (cdr vectors))))) r)) (else (panic "Arguments to APPEND are not all lists, strings, or vectors")))) (define (list-reverse list) ;Extension to R4RS. (let loop ((list list) (r '())) (if (null? list) r (loop (cdr list) (cons (car list) r))))) (define (reverse s) ;Extension to R4RS. (cond ;; note: This was changed from LIST? to PAIR?/NULL? for efficiency ;; reasons. Now it will loop when given an infinite list. ((null? s) '()) ((pair? s) (list-reverse s)) ((string? s) (string-reverse s)) ((vector? s) (vector-reverse s)) (else (panic "Argument to REVERSE is not a list, string, or vector")))) (define (list-tail list k) (if (zero? k) list (list-tail (cdr list) (- k 1)))) (define (list-ref list k) (let loop () (cond ((zero? k) (car list)) (else (set! list (cdr list)) (set! k (- k 1)) (loop))))) (define (ref s k) ;Extension to R4RS. (cond ;; note: This was changed from LIST? to PAIR? for efficiency reasons. ;; Now it may loop when given an infinite list and may fail to ;; detect an error when given a pair that is not a list. ((pair? s) (list-ref s k)) ((string? s) (string-ref s k)) ((vector? s) (vector-ref s k)) (else (panic "First argument to REF is not a (nonempty) list, string, or vector")))) (define (memq obj list) (and (not (null? list)) (if (eq? obj (car list)) list (memq obj (cdr list))))) (define (memv obj list) (and (not (null? list)) (if (eqv? obj (car list)) list (memv obj (cdr list))))) (define (member obj list) (and (not (null? list)) (if (equal? obj (car list)) list (member obj (cdr list))))) (define (assq obj alist) (and (not (null? alist)) (if (eq? obj (car (car alist))) (car alist) (assq obj (cdr alist))))) (define (assv obj alist) (and (not (null? alist)) (if (eqv? obj (car (car alist))) (car alist) (assv obj (cdr alist))))) (define (assoc obj alist) (and (not (null? alist)) (if (equal? obj (car (car alist))) (car alist) (assoc obj (cdr alist))))) (define (list-set! list k obj) ;Extension to R4RS. (let loop () (cond ((zero? k) (set-car! list obj)) (else (set! list (cdr list)) (set! k (- k 1)) (loop))))) (define (ref! s k obj) ;Extension to R4RS. (cond ;; note: This was changed from LIST? to PAIR? for efficiency reasons. ;; Now it may loop when given an infinite list and may fail to ;; detect an error when given a pair that is not a list. ((pair? s) (list-set! s k obj)) ((string? s) (string-set! s k obj)) ((vector? s) (vector-set! s k obj)) (else (panic "First argument to REF! is not a (nonempty) list, string, or vector")))) (define (list-fill! list obj) ;Extension to R4RS. (let loop () (if (not (null? list)) (begin (set-car! list obj) (set! list (cdr list)) (loop))))) (define (fill! s obj) ;Extension to R4RS. (cond ;; note: This was changed from LIST? to PAIR?/NULL? for efficiency ;; reasons. Now it will loop when given an infinite list. ((null? s) '()) ((pair? s) (list-fill! s obj)) ((string? s) (string-fill! s obj)) ((vector? s) (vector-fill! s obj)) (else (panic "First argument to FILL! is not a list, string, or vector")))) (define (list-copy list) ;Extension to R4RS. ;; needs work: To make tail recursive. (if (null? list) '() (cons (car list) (list-copy (cdr list))))) (define (copy s) ;Extension to R4RS. (cond ;; note: This was changed from LIST? to PAIR?/NULL? for efficiency ;; reasons. Now it will loop when given an infinite list. ((null? s) '()) ((pair? s) (list-copy s)) ((string? s) (string-copy s)) ((vector? s) (vector-copy s)) (else (panic "Argument to COPY is not a list, string, or vector")))) ;; 6.4 Symbols (define (symbol? obj) ((primitive-procedure symbol?) obj)) (define (symbol->string symbol) ((primitive-procedure symbol->string) symbol)) (define (string->uninterned-symbol string) ;Extension to R4RS. ((primitive-procedure string->uninterned-symbol) string)) (define string->symbol (let ((package '())) (lambda (string) (cond ,@(map (lambda (v) `((string=? string ,(symbol->string v)) ',v)) vs) ;; This formulation relies on the fact that, with the current ;; implementation of STRING->UNINTERNED-SYMBOL, (EQ? X Y) implies ;; (EQ? (STRING->UNINTERNED-SYMBOL X) (STRING->UNINTERNED-SYMBOL Y)). ;; note: Manually split MEMBER here. (else (let ((found (let loop ((package package)) (and (not (null? package)) (if (string=? string (car package)) package (loop (cdr package))))))) (cond (found (string->uninterned-symbol (car found))) (else (set! package (cons (string-copy string) package)) (string->uninterned-symbol (car package)))))))))) ;; 6.5 Numbers ;; 6.5.5 Numerical operations (define (number? obj) ((primitive-procedure number?) obj)) (define complex? number?) (define (real? obj) ((primitive-procedure real?) obj)) (define rational? real?) (define (integer? obj) ((primitive-procedure integer?) obj)) (define (exact? z) ((primitive-procedure exact?) z)) (define (inexact? z) ((primitive-procedure inexact?) z)) (define (= z1 z2 . zs) (and ((primitive-procedure =) z1 z2) (let loop? ((z z2) (zs zs)) (or (null? zs) (and ((primitive-procedure =) z (car zs)) (loop? (car zs) (cdr zs))))))) (define (< x1 x2 . xs) (and ((primitive-procedure <) x1 x2) (let loop? ((x x2) (xs xs)) (or (null? xs) (and ((primitive-procedure <) x (car xs)) (loop? (car xs) (cdr xs))))))) (define (> x1 x2 . xs) (and ((primitive-procedure >) x1 x2) (let loop? ((x x2) (xs xs)) (or (null? xs) (and ((primitive-procedure >) x (car xs)) (loop? (car xs) (cdr xs))))))) (define (<= x1 x2 . xs) (and ((primitive-procedure <=) x1 x2) (let loop? ((x x2) (xs xs)) (or (null? xs) (and ((primitive-procedure <=) x (car xs)) (loop? (car xs) (cdr xs))))))) (define (>= x1 x2 . xs) (and ((primitive-procedure >=) x1 x2) (let loop? ((x x2) (xs xs)) (or (null? xs) (and ((primitive-procedure >=) x (car xs)) (loop? (car xs) (cdr xs))))))) (define (zero? z) ((primitive-procedure zero?) z)) (define (positive? x) ((primitive-procedure positive?) x)) (define (negative? x) ((primitive-procedure negative?) x)) (define (odd? n) (not (even? n))) (define (even? n) (zero? (remainder n 2))) (define (max x . xs) (if (null? xs) ((primitive-procedure max) x) (let loop ((xs (cdr xs)) (r ((primitive-procedure max) x (car xs)))) (if (null? xs) r (loop (cdr xs) ((primitive-procedure max) r (car xs))))))) (define (min x . xs) (if (null? xs) ((primitive-procedure min) x) (let loop ((xs (cdr xs)) (r ((primitive-procedure min) x (car xs)))) (if (null? xs) r (loop (cdr xs) ((primitive-procedure min) r (car xs))))))) (define (+ . zs) (if (null? zs) ((primitive-procedure +)) (let loop ((zs (cdr zs)) (r ((primitive-procedure +) (car zs)))) (if (null? zs) r (loop (cdr zs) ((primitive-procedure +) r (car zs))))))) (define (* . zs) (if (null? zs) ((primitive-procedure *)) (let loop ((zs (cdr zs)) (r ((primitive-procedure *) (car zs)))) (if (null? zs) r (loop (cdr zs) ((primitive-procedure *) r (car zs))))))) (define (- z . zs) (if (null? zs) ((primitive-procedure -) z) (let loop ((zs (cdr zs)) (r ((primitive-procedure -) z (car zs)))) (if (null? zs) r (loop (cdr zs) ((primitive-procedure -) r (car zs))))))) (define (/ z . zs) (if (null? zs) ((primitive-procedure /) z) (let loop ((zs (cdr zs)) (r ((primitive-procedure /) z (car zs)))) (if (null? zs) r (loop (cdr zs) ((primitive-procedure /) r (car zs))))))) (define (abs x) (if (negative? x) (- x) x)) (define (quotient n1 n2) ((primitive-procedure quotient) n1 n2)) (define (remainder n1 n2) ((primitive-procedure remainder) n1 n2)) (define (modulo n1 n2) (if (or (and (positive? n1) (negative? n2)) (and (negative? n1) (positive? n2))) (+ n2 (remainder n1 n2)) (remainder n1 n2))) ;; needs work: NUMERATOR DENOMINATOR (define (gcd . ns) ;; note: Support for multiple arguments incurs a penalty here. (cond ((null? ns) 0) ((null? (cdr ns)) (abs (car ns))) (else (let loop ((n1 (abs (car ns))) (n2 (abs (car (cdr ns)))) (ns (cdr (cdr ns))) (p? (or (inexact? (car ns)) (inexact? (car (cdr ns)))))) (if (zero? n2) (if (null? ns) (if p? (exact->inexact n1) n1) (loop n1 (abs (car ns)) (cdr ns) (or p? (inexact? (car ns))))) (let ((r (remainder n1 n2))) (if (zero? r) (if (null? ns) (if p? (exact->inexact n2) n2) (loop n2 (abs (car ns)) (cdr ns) (or p? (inexact? (car ns))))) (loop n2 r ns p?)))))))) (define (lcm . ns) ;; note: Support for multiple arguments incurs a penalty here. (cond ((null? ns) 1) ((null? (cdr ns)) (abs (car ns))) (else (let loop ((n1 (abs (car ns))) (n2 (abs (car (cdr ns)))) (ns (cdr (cdr ns))) (p? (or (inexact? (car ns)) (inexact? (car (cdr ns)))))) (let ((n (cond ((= n1 n2) n1) ((zero? (remainder n1 n2)) n1) ((zero? (remainder n2 n1)) n2) (else (* (quotient n1 (gcd n1 n2)) n2))))) (if (null? ns) (if p? (exact->inexact n) n) (loop n (abs (car ns)) (cdr ns) (or p? (inexact? (car ns)))))))))) (define (<< n1 n2) ((primitive-procedure <<) n1 n2)) ;Extension to R4RS. (define (>> n1 n2) ((primitive-procedure >>) n1 n2)) ;Extension to R4RS. (define (bitwise-not n) ;Extension to R4RS. ((primitive-procedure bitwise-not) n)) (define (bitwise-and . ns) ;Extension to R4RS. (if (null? ns) ((primitive-procedure bitwise-and)) (let loop ((ns (cdr ns)) (r ((primitive-procedure bitwise-and) (car ns)))) (if (null? ns) r (loop (cdr ns) ((primitive-procedure bitwise-and) r (car ns))))))) (define (bitwise-or . ns) ;Extension to R4RS. (if (null? ns) ((primitive-procedure bitwise-or)) (let loop ((ns (cdr ns)) (r ((primitive-procedure bitwise-or) (car ns)))) (if (null? ns) r (loop (cdr ns) ((primitive-procedure bitwise-or) r (car ns))))))) (define (bitwise-xor . ns) ;Extension to R4RS. (if (null? ns) ((primitive-procedure bitwise-xor)) (let loop ((ns (cdr ns)) (r ((primitive-procedure bitwise-xor) (car ns)))) (if (null? ns) r (loop (cdr ns) ((primitive-procedure bitwise-xor) r (car ns))))))) (define (floor x) ((primitive-procedure floor) x)) (define (ceiling x) ((primitive-procedure ceiling) x)) (define (truncate x) ((primitive-procedure truncate) x)) (define (round x) ((primitive-procedure round) x)) ;; needs work: RATIONALIZE (define (exp z) ((primitive-procedure exp) z)) (define (log z) ((primitive-procedure log) z)) (define (sin z) ((primitive-procedure sin) z)) (define (cos z) ((primitive-procedure cos) z)) (define (tan z) ((primitive-procedure tan) z)) (define (asin z) ((primitive-procedure asin) z)) (define (acos z) ((primitive-procedure acos) z)) (define (atan x . y) (cond ((null? y) ((primitive-procedure atan) x)) ((null? (cdr y)) ((primitive-procedure atan) x (car y))) (else (panic "Attempt to call ATAN with the wrong number of arguments")))) (define (sqrt z) ((primitive-procedure sqrt) z)) (define (expt z1 z2) ((primitive-procedure expt) z1 z2)) ;; needs work: MAKE-RECTANGULAR MAKE-POLAR REAL-PART IMAG-PART MAGNITUDE ;; ANGLE (define (exact->inexact z) ((primitive-procedure exact->inexact) z)) (define (inexact->exact z) ((primitive-procedure inexact->exact) z)) ;; 6.5.6 Numerical input and output (define number->string ((lambda ()))) ;Defined in *I/O*. (define string->number ((lambda ()))) ;Defined in *I/O*. ;; 6.6 Characters (define (char? obj) ((primitive-procedure char?) obj)) (define (char=? char1 char2 . chars) (let loop? ((char1 char1) (char2 char2) (chars chars)) (and (= (char->integer char1) (char->integer char2)) (or (null? chars) (loop? char2 (car chars) (cdr chars)))))) (define (charinteger char1) (char->integer char2)) (or (null? chars) (loop? char2 (car chars) (cdr chars)))))) (define (char>? char1 char2 . chars) (let loop? ((char1 char1) (char2 char2) (chars chars)) (and (> (char->integer char1) (char->integer char2)) (or (null? chars) (loop? char2 (car chars) (cdr chars)))))) (define (char<=? char1 char2 . chars) (let loop? ((char1 char1) (char2 char2) (chars chars)) (and (<= (char->integer char1) (char->integer char2)) (or (null? chars) (loop? char2 (car chars) (cdr chars)))))) (define (char>=? char1 char2 . chars) (let loop? ((char1 char1) (char2 char2) (chars chars)) (and (>= (char->integer char1) (char->integer char2)) (or (null? chars) (loop? char2 (car chars) (cdr chars)))))) (define (char-ci=? char1 char2 . chars) (let loop? ((char1 (char-upcase char1)) (char2 (char-upcase char2)) (chars chars)) (and (= (char->integer char1) (char->integer char2)) (or (null? chars) (loop? char2 (char-upcase (car chars)) (cdr chars)))))) (define (char-ciinteger char1) (char->integer char2)) (or (null? chars) (loop? char2 (char-upcase (car chars)) (cdr chars)))))) (define (char-ci>? char1 char2 . chars) (let loop? ((char1 (char-upcase char1)) (char2 (char-upcase char2)) (chars chars)) (and (> (char->integer char1) (char->integer char2)) (or (null? chars) (loop? char2 (char-upcase (car chars)) (cdr chars)))))) (define (char-ci<=? char1 char2 . chars) (let loop? ((char1 (char-upcase char1)) (char2 (char-upcase char2)) (chars chars)) (and (<= (char->integer char1) (char->integer char2)) (or (null? chars) (loop? char2 (char-upcase (car chars)) (cdr chars)))))) (define (char-ci>=? char1 char2 . chars) (let loop? ((char1 (char-upcase char1)) (char2 (char-upcase char2)) (chars chars)) (and (>= (char->integer char1) (char->integer char2)) (or (null? chars) (loop? char2 (char-upcase (car chars)) (cdr chars)))))) ;; Sven Hartrumpf contributed variations ;; on the next five definitions. (define char-alphabetic? (let ((char-alphabetic? '#(#f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #f #f #f #f #f #f #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #f #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #f #t #t #t #t #t #t #t #t))) (lambda (char) (vector-ref char-alphabetic? (char->integer char))))) (define char-numeric? (let ((char-numeric? '#(#f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #t #t #t #t #t #t #t #t #t #t #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f))) (lambda (char) (vector-ref char-numeric? (char->integer char))))) (define char-whitespace? (let ((char-whitespace? '#(#f #f #f #f #f #f #f #f #f #t #t #f #t #t #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #t #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f))) (lambda (char) (vector-ref char-whitespace? (char->integer char))))) (define char-upper-case? (let ((char-upper-case? '#(#f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #f #t #t #t #t #t #t #t #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f))) (lambda (letter) (vector-ref char-upper-case? (char->integer letter))))) (define char-lower-case? (let ((char-lower-case? '#(#f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #f #t #t #t #t #t #t #t #t))) (lambda (letter) (vector-ref char-lower-case? (char->integer letter))))) (define (char->integer char) ((primitive-procedure char->integer) char)) (define (integer->char k) ((primitive-procedure integer->char) k)) ;; Sven Hartrumpf contributed variations ;; on the next two definitions. (define char-upcase (let ((char-upcase '#(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 247 216 217 218 219 220 221 222 223))) (lambda (char) (integer->char (vector-ref char-upcase (char->integer char)))))) (define char-downcase (let ((char-downcase '#(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 215 248 249 250 251 252 253 254 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255))) (lambda (char) (integer->char (vector-ref char-downcase (char->integer char)))))) ;; 6.7 Strings (define (string? obj) ((primitive-procedure string?) obj)) (define (make-string k . char) (cond ((null? char) ((primitive-procedure make-string) k)) ((null? (cdr char)) ((primitive-procedure make-string) k (car char))) (else (panic "Attempt to call MAKE-STRING with the wrong number of arguments")))) (define (string . chars) (let ((r (make-string (list-length chars)))) (let loop ((k 0) (chars chars)) (if (null? chars) r (begin (string-set! r k (car chars)) (loop (+ k 1) (cdr chars))))))) (define (string-length string) ((primitive-procedure string-length) string)) (define (string-ref string k) ((primitive-procedure string-ref) string k)) (define (string-set! string k char) ((primitive-procedure string-set!) string k char)) (define (string=? string1 string2 . strings) (let loop? ((string1 string1) (string2 string2) (strings strings)) (let ((n (string-length string1))) (and (= n (string-length string2)) (let loop? ((k 0)) (or (= k n) (and (char=? (string-ref string1 k) (string-ref string2 k)) (loop? (+ k 1))))) (or (null? strings) (loop? string2 (car strings) (cdr strings))))))) (define (string-ci=? string1 string2 . strings) (let loop? ((string1 string1) (string2 string2) (strings strings)) (let ((n (string-length string1))) (and (= n (string-length string2)) (let loop? ((k 0)) (or (= k n) (and (char-ci=? (string-ref string1 k) (string-ref string2 k)) (loop? (+ k 1))))) (or (null? strings) (loop? string2 (car strings) (cdr strings))))))) (define (string? string1 string2 . strings) (let loop? ((string1 string1) (n1 (string-length string1)) (string2 string2) (n2 (string-length string2)) (strings strings)) (and (let loop? ((k 0)) (if (= k n2) (< k n1) (and (< k n1) (or (char>? (string-ref string1 k) (string-ref string2 k)) (and (char=? (string-ref string1 k) (string-ref string2 k)) (loop? (+ k 1))))))) (or (null? strings) (loop? string2 n2 (car strings) (string-length (car strings)) (cdr strings)))))) (define (string<=? string1 string2 . strings) (let loop? ((string1 string1) (n1 (string-length string1)) (string2 string2) (n2 (string-length string2)) (strings strings)) (and (let loop? ((k 0)) (if (= k n1) (<= k n2) (and (< k n2) (or (char=? string1 string2 . strings) (let loop? ((string1 string1) (n1 (string-length string1)) (string2 string2) (n2 (string-length string2)) (strings strings)) (and (let loop? ((k 0)) (if (= k n2) (<= k n1) (and (< k n1) (or (char>? (string-ref string1 k) (string-ref string2 k)) (and (char=? (string-ref string1 k) (string-ref string2 k)) (loop? (+ k 1))))))) (or (null? strings) (loop? string2 n2 (car strings) (string-length (car strings)) (cdr strings)))))) (define (string-ci? string1 string2 . strings) (let loop? ((string1 string1) (n1 (string-length string1)) (string2 string2) (n2 (string-length string2)) (strings strings)) (and (let loop? ((k 0)) (if (= k n2) (< k n1) (and (< k n1) (or (char-ci>? (string-ref string1 k) (string-ref string2 k)) (and (char-ci=? (string-ref string1 k) (string-ref string2 k)) (loop? (+ k 1))))))) (or (null? strings) (loop? string2 n2 (car strings) (string-length (car strings)) (cdr strings)))))) (define (string-ci<=? string1 string2 . strings) (let loop? ((string1 string1) (n1 (string-length string1)) (string2 string2) (n2 (string-length string2)) (strings strings)) (and (let loop? ((k 0)) (if (= k n1) (<= k n2) (and (< k n2) (or (char-ci=? string1 string2 . strings) (let loop? ((string1 string1) (n1 (string-length string1)) (string2 string2) (n2 (string-length string2)) (strings strings)) (and (let loop? ((k 0)) (if (= k n2) (<= k n1) (and (< k n1) (or (char-ci>? (string-ref string1 k) (string-ref string2 k)) (and (char-ci=? (string-ref string1 k) (string-ref string2 k)) (loop? (+ k 1))))))) (or (null? strings) (loop? string2 n2 (car strings) (string-length (car strings)) (cdr strings)))))) (define (substring string start end) (let ((r (make-string (- end start)))) (let loop ((k start)) (if (< k end) (begin (string-set! r (- k start) (string-ref string k)) (loop (+ k 1))))) r)) (define (string-append . strings) ;; note: Support for multiple arguments incurs a penalty here. (let* ((r (make-string (let loop ((k 0) (strings strings)) (if (null? strings) k (loop (+ k (string-length (car strings))) (cdr strings)))))) (k 0)) (let loop ((strings strings)) (if (not (null? strings)) (let ((n (string-length (car strings)))) (let loop ((l 0)) (if (not (= l n)) (begin (string-set! r k (string-ref (car strings) l)) (set! k (+ k 1)) (loop (+ l 1))))) (loop (cdr strings))))) r)) (define (string->list string) ;; needs work: To make tail recursive. (let ((n (string-length string))) (let loop ((k 0)) (if (= k n) '() (cons (string-ref string k) (loop (+ k 1))))))) (define (list->string list) (let ((r (make-string (list-length list)))) (let loop ((k 0)) (if (not (null? list)) (begin (string-set! r k (car list)) (set! list (cdr list)) (loop (+ k 1))))) r)) (define (string-copy string) (let* ((n (string-length string)) (r (make-string n))) (let loop ((k 0)) (if (not (= k n)) (begin (string-set! r k (string-ref string k)) (loop (+ k 1))))) r)) (define (string-fill! string char) (let ((n (string-length string))) (let loop ((k 0)) (if (not (= k n)) (begin (string-set! string k char) (loop (+ k 1))))))) (define (string-reverse string) ;Extension to R4RS. (let* ((n (string-length string)) (r (make-string n))) (let loop ((k 0)) (if (not (= k n)) (begin (string-set! r k (string-ref string (- (- n k) 1))) (loop (+ k 1))))) r)) ;; 6.8 Vectors (define (vector? obj) ((primitive-procedure vector?) obj)) (define (make-vector k . fill) (cond ((null? fill) ((primitive-procedure make-vector) k)) ((null? (cdr fill)) ((primitive-procedure make-vector) k (car fill))) (else (panic "Attempt to call MAKE-VECTOR with the wrong number of arguments")))) (define (make-displaced-vector vector k1 k2) ;Extension to R4RS. ((primitive-procedure make-displaced-vector) vector k1 k2)) (define (vector . objs) (let ((r (make-vector (list-length objs)))) (let loop ((k 0) (objs objs)) (if (null? objs) r (begin (vector-set! r k (car objs)) (loop (+ k 1) (cdr objs))))))) (define (vector-length vector) ((primitive-procedure vector-length) vector)) (define (vector-ref vector k) ((primitive-procedure vector-ref) vector k)) (define (vector-set! vector k obj) ((primitive-procedure vector-set!) vector k obj)) (define (vector->list vector) ;; needs work: To make tail recursive. (let loop ((k 0)) (if (= k (vector-length vector)) '() (cons (vector-ref vector k) (loop (+ k 1)))))) (define (list->vector list) (let ((r (make-vector (list-length list)))) (let loop ((k 0)) (if (not (null? list)) (begin (vector-set! r k (car list)) (set! list (cdr list)) (loop (+ k 1))))) r)) (define (vector-fill! vector obj) (let loop ((k 0)) (if (not (= k (vector-length vector))) (begin (vector-set! vector k obj) (loop (+ k 1)))))) (define (subvector vector start end) ;Extension to R4RS. (let ((r (make-vector (- end start)))) (let loop ((k 0)) (if (< k (- end start)) (begin (vector-set! r k (vector-ref vector (+ k start))) (loop (+ k 1))))) r)) (define (vector-append . vectors) ;Extension to R4RS. ;; note: Support for multiple arguments incurs a penalty here. (let* ((r (make-vector (let loop ((k 0) (vectors vectors)) (if (null? vectors) k (loop (+ k (vector-length (car vectors))) (cdr vectors)))))) (k 0)) (let loop ((vectors vectors)) (if (not (null? vectors)) (begin (let loop ((l 0)) (if (not (= l (vector-length (car vectors)))) (begin (vector-set! r k (vector-ref (car vectors) l)) (set! k (+ k 1)) (loop (+ l 1))))) (loop (cdr vectors))))) r)) (define (vector-reverse vector) ;Extension to R4RS. (let ((r (make-vector (vector-length vector)))) (let loop ((k 0)) (if (not (= k (vector-length vector))) (begin (vector-set! r k (vector-ref vector (- (- (vector-length vector) k) 1))) (loop (+ k 1))))) r)) (define (vector-copy vector) ;Extension to R4RS. (let ((r (make-vector (vector-length vector)))) (let loop ((k 0)) (if (not (= k (vector-length vector))) (begin (vector-set! r k (vector-ref vector k)) (loop (+ k 1))))) r)) ;; 6.9 Control features (define (procedure? obj) ((primitive-procedure procedure?) obj)) (define (apply proc arg1 . args) (if (null? args) ((primitive-procedure apply) proc arg1) (let loop ((arg1 (list arg1)) (args args)) (if (null? (cdr args)) (let loop ((arg1 (car args)) (args arg1)) (if (null? args) ((primitive-procedure apply) proc arg1) (loop (cons (car args) arg1) (cdr args)))) (loop (cons (car args) arg1) (cdr args)))))) (define (map proc list1 . lists) ;; note: Support for multiple arguments incurs a penalty here. (cond ;; note: This special-cases the one-argument case for speed. ((null? lists) (let loop ((list1 list1) (c '())) (if (null? list1) (list-reverse c) (loop (cdr list1) (cons (proc (car list1)) c))))) ;; note: This special-cases the two-argument case for speed. ((null? (cdr lists)) (let loop ((list1 list1) (list2 (car lists)) (c '())) (if (null? list1) (list-reverse c) (loop (cdr list1) (cdr list2) (cons (proc (car list1) (car list2)) c))))) (else (let loop ((list1 list1) (lists lists) (c '())) (if (null? list1) (list-reverse c) (loop (cdr list1) (let loop ((lists lists) (c '())) (if (null? lists) (list-reverse c) (loop (cdr lists) (cons (cdr (car lists)) c)))) (cons (apply proc (car list1) (let loop ((lists lists) (c '())) (if (null? lists) (list-reverse c) (loop (cdr lists) (cons (car (car lists)) c))))) c))))))) (define (for-each proc list1 . lists) ;; note: Support for multiple arguments incurs a penalty here. (cond ((null? lists) ;; note: This special-cases the one-argument case for speed. (let loop ((list1 list1)) (if (not (null? list1)) (begin (proc (car list1)) (loop (cdr list1)))))) ((null? (cdr lists)) ;; note: This special-cases the two-argument case for speed. (let loop ((list1 list1) (list2 (car lists))) (if (not (null? list1)) (begin (proc (car list1) (car list2)) (loop (cdr list1) (cdr list2)))))) (else (let loop ((list1 list1) (lists lists)) (if (not (null? list1)) (begin (apply proc (car list1) (let loop ((lists lists) (c '())) (if (null? lists) (list-reverse c) (loop (cdr lists) (cons (car (car lists)) c))))) (loop (cdr list1) (let loop ((lists lists) (c '())) (if (null? lists) (list-reverse c) (loop (cdr lists) (cons (cdr (car lists)) c))))))))))) (define (force promise) (promise)) (define (call-with-current-continuation proc) ((primitive-procedure call-with-current-continuation) proc)) ;; 6.10 Input and Output ;; 6.10.1 Ports (define (call-with-input-file string proc) (let* ((input-port (open-input-file string)) (r (proc input-port))) (close-input-port input-port) r)) (define (call-with-output-file string proc) (let* ((output-port (open-output-file string)) (r (proc output-port))) (close-output-port output-port) r)) (define (input-port? obj) ((primitive-procedure input-port?) obj)) (define (output-port? obj) ((primitive-procedure output-port?) obj)) (define current-input-port ((lambda ()))) ;Defined in *I/O*. (define current-output-port ((lambda ()))) ;Defined in *I/O*. (define with-input-from-file ((lambda ()))) ;Defined in *I/O*. (define with-output-to-file ((lambda ()))) ;Defined in *I/O*. (define (open-input-file filename) ((primitive-procedure open-input-file) filename)) (define (open-output-file filename) ((primitive-procedure open-output-file) filename)) (define (close-input-port port) ((primitive-procedure close-input-port) port)) (define (close-output-port port) ((primitive-procedure close-output-port) port)) ;; 6.10.2 Input ,*read* (define read-char ((lambda ()))) ;Defined in *I/O*. (define peek-char ((lambda ()))) ;Defined in *I/O*. (define (eof-object? obj) ((primitive-procedure eof-object?) obj)) (define char-ready? ((lambda ()))) ;Defined in *I/O*. ;; 6.10.3 Output (define write ((lambda ()))) ;Defined in *I/O*. (define display ((lambda ()))) ;Defined in *I/O*. (define newline ((lambda ()))) ;Defined in *I/O*. (define write-char ((lambda ()))) ;Defined in *I/O*. ;; Extension to R4RS. (define define-write-method ((lambda ()))) ;Defined in *I/O*. ;; Extension to R4RS. (define define-display-method ((lambda ()))) ;Defined in *I/O*. ,*i/o* (define (panic string) ;Extension to R4RS. ((primitive-procedure panic) string)) (define (pointer? obj) ;Extension to R4RS. ((primitive-procedure pointer?) obj)) ;; Extension to R4RS. (define (integer->string k) ((primitive-procedure integer->string) k)) (define (integer->input-port k) ;Extension to R4RS. ((primitive-procedure integer->input-port) k)) (define (integer->output-port k) ;Extension to R4RS. ((primitive-procedure integer->output-port) k)) ;; Extension to R4RS. (define (integer->pointer k) ((primitive-procedure integer->pointer) k)) ;; 6.10.4 System interface ;; needs work: LOAD TRANSCRIPT-ON TRANSCRIPT-OFF (define ,*list->vector* list->vector) (define ,*append* append) (define ,*cons* cons) (define ,*eqv?* eqv?) (let ((not not) (boolean? boolean?) (eqv? eqv?) (eq? eq?) (equal? equal?) (pair? pair?) (cons cons) (car car) (cdr cdr) (set-car! set-car!) (set-cdr! set-cdr!) (caar caar) (cadr cadr) (cdar cdar) (cddr cddr) (caaar caaar) (caadr caadr) (cadar cadar) (caddr caddr) (cdaar cdaar) (cdadr cdadr) (cddar cddar) (cdddr cdddr) (caaaar caaaar) (caaadr caaadr) (caadar caadar) (caaddr caaddr) (cadaar cadaar) (cadadr cadadr) (caddar caddar) (cadddr cadddr) (cdaaar cdaaar) (cdaadr cdaadr) (cdadar cdadar) (cdaddr cdaddr) (cddaar cddaar) (cddadr cddadr) (cdddar cdddar) (cddddr cddddr) (null? null?) (list? list?) (list list) (list-length list-length) (length length) (sublist sublist) (sub sub) (list-append list-append) (append append) (list-reverse list-reverse) (reverse reverse) (list-tail list-tail) (list-ref list-ref) (ref ref) (memq memq) (memv memv) (member member) (assq assq) (assv assv) (assoc assoc) (list-set! list-set!) (ref! ref!) (list-fill! list-fill!) (fill! fill!) (list-copy list-copy) (copy copy) (symbol? symbol?) (symbol->string symbol->string) (string->uninterned-symbol string->uninterned-symbol) (string->symbol string->symbol) (number? number?) (complex? complex?) (real? real?) (rational? rational?) (integer? integer?) (exact? exact?) (inexact? inexact?) (= =) (< <) (> >) (<= <=) (>= >=) (zero? zero?) (positive? positive?) (negative? negative?) (odd? odd?) (even? even?) (max max) (min min) (+ +) (* *) (- -) (/ /) (abs abs) (quotient quotient) (remainder remainder) (modulo modulo) (gcd gcd) (lcm lcm) (<< <<) (>> >>) (bitwise-not bitwise-not) (bitwise-and bitwise-and) (bitwise-or bitwise-or) (bitwise-xor bitwise-xor) (floor floor) (ceiling ceiling) (truncate truncate) (round round) (exp exp) (log log) (sin sin) (cos cos) (tan tan) (asin asin) (acos acos) (atan atan) (sqrt sqrt) (expt expt) (exact->inexact exact->inexact) (inexact->exact inexact->exact) (number->string number->string) (string->number string->number) (char? char?) (char=? char=?) (char? char>?) (char<=? char<=?) (char>=? char>=?) (char-ci=? char-ci=?) (char-ci? char-ci>?) (char-ci<=? char-ci<=?) (char-ci>=? char-ci>=?) (char-alphabetic? char-alphabetic?) (char-numeric? char-numeric?) (char-whitespace? char-whitespace?) (char-upper-case? char-upper-case?) (char-lower-case? char-lower-case?) (char->integer char->integer) (integer->char integer->char) (char-upcase char-upcase) (char-downcase char-downcase) (string? string?) (make-string make-string) (string string) (string-length string-length) (string-ref string-ref) (string-set! string-set!) (string=? string=?) (string-ci=? string-ci=?) (string? string>?) (string<=? string<=?) (string>=? string>=?) (string-ci? string-ci>?) (string-ci<=? string-ci<=?) (string-ci>=? string-ci>=?) (substring substring) (string-append string-append) (string->list string->list) (list->string list->string) (string-copy string-copy) (string-fill! string-fill!) (string-reverse string-reverse) (vector? vector?) (make-vector make-vector) (make-displaced-vector make-displaced-vector) (vector vector) (vector-length vector-length) (vector-ref vector-ref) (vector-set! vector-set!) (vector->list vector->list) (list->vector list->vector) (vector-fill! vector-fill!) (subvector subvector) (vector-append vector-append) (vector-reverse vector-reverse) (vector-copy vector-copy) (procedure? procedure?) (apply apply) (map map) (for-each for-each) (force force) (call-with-current-continuation call-with-current-continuation) (call-with-input-file call-with-input-file) (call-with-output-file call-with-output-file) (input-port? input-port?) (output-port? output-port?) (current-input-port current-input-port) (current-output-port current-output-port) (with-input-from-file with-input-from-file) (with-output-to-file with-output-to-file) (open-input-file open-input-file) (open-output-file open-output-file) (close-input-port close-input-port) (close-output-port close-output-port) (read read) (read-char read-char) (peek-char peek-char) (eof-object? eof-object?) (char-ready? char-ready?) (write write) (display display) (newline newline) (write-char write-char) (define-write-method define-write-method) (define-display-method define-display-method) (panic panic) (pointer? pointer?) (integer->string integer->string) (integer->input-port integer->input-port) (integer->output-port integer->output-port) (integer->pointer integer->pointer)) ,@ss)))) ;;; The C library (define *c:noreturn?* #f) (define *c:c?* #f) (define *c:panic?* #f) (define *c:backtrace?* #f) (define *c:backtrace-internal?* #f) (define *c:ipow?* #f) (define *c:input-waiting?* #f) (define *c:includes* #f) (define (include! include) (unless (member include *c:includes*) (set! *c:includes* (cons include *c:includes*)))) (define (c-library) ;; needs work: To use code-generation abstractions. (when *c:panic?* (set! *c:noreturn?* #t)) (when *c:panic?* (include! "stdio") ;fprintf stderr (include! "stdlib")) ;exit (when *c:backtrace?* (include! "stdio")) ;fprintf stderr (when *c:backtrace-internal?* (include! "stdio")) ;fprintf stderr (when *c:input-waiting?* (include! "sys/time") ;timeval (include! "unistd") ;fd_set FD_ZERO FD_SET select (include! "stdlib") ;NULL (include! "stdio")) ;FILE feof fileno (newline-between (newlines-between (map (lambda (include) (list "#include <" include ".h>")) *c:includes*)) (if *c:noreturn?* "#ifdef __GNUC__ #define NORETURN __attribute__ ((noreturn)) #else #define NORETURN #endif" "") (if (positive? *allocation-alignment*) (list "#define ALIGN(p) if (((" *squished* ")p)%" (c:fixnum (expt 2 *allocation-alignment*)) "!=0) p += " (c:fixnum (expt 2 *allocation-alignment*)) "-(((" *squished* ")p)%" (c:fixnum (expt 2 *allocation-alignment*)) ")") "") (list "#define IMIN(x,y) (xy?x:y) #define RMIN(x,y) (xy?x:y) struct rectangular {" *flonum* " r; " *flonum* " i;};") (if *c:c?* "int c;" "") (if *c:panic?* "void stalin_panic(char *message) NORETURN; void stalin_panic(char *message) {fprintf(stderr, \"%s\\n\", message); exit(-1);}" "") (if *c:backtrace?* "void backtrace(char *file_name, unsigned int line_number, unsigned int character_number); void backtrace(char *file_name, unsigned int line_number, unsigned int character_number) {fprintf(stderr, \"\\n%s:%d:%d:\", file_name, line_number, character_number);}" "") (if *c:backtrace-internal?* "void backtrace_internal(char *name); void backtrace_internal(char *name) {fprintf(stderr, \"\\nIn %s\\n\", name);}" "") (if *c:ipow?* (list "int ipow(int x, int y); int ipow(int x, int y) {int i, r = 1; for (i = 0; i0 if there is input, -1 if error */ {fd_set rfds; struct timeval tv; /* check stdio buffer first */ if (feof(f)) return 1; #ifdef __linux__ if ((f->_IO_read_end)>(f->_IO_read_ptr)) return 1; #else if ((f->_cnt)>0) return 1; #endif /* watch fd to see when it has input */ FD_ZERO(&rfds); FD_SET(fileno(f), &rfds); /* do not wait */ tv.tv_sec = 0; tv.tv_usec = 0; return select(fileno(f)+1, &rfds, NULL, NULL, &tv);}") "") (if *treadmarks?* "void Tmk_distribute_hack(const void *ptr, int size) { const char *p = ptr; while (size>0) { Tmk_distribute((void *)p, (size>65460)?65460:size); p += 65460; size -= 65460;}} int Tmk_get_NBARRIERS(void) {return TMK_NBARRIERS;} int Tmk_get_NPROCS(void) {return TMK_NPROCS;} int Tmk_get_proc_id(void) {return Tmk_proc_id;} int Tmk_get_NLOCKS(void) {return TMK_NLOCKS;}" ""))) (define *Scheme->C-compatibility-macros* (list (list 'when (lambda (s) (unless (>= (sx-length s) 2) (syntax-error s "Improper WHEN")) `(if ,(sx-second s) (begin ,@(sx-unlist (sx-rest (sx-rest s))))))) (list 'unless (lambda (s) (unless (>= (sx-length s) 2) (syntax-error s "Improper UNLESS")) `(if ,(sx-second s) ((lambda ())) (begin ,@(sx-unlist (sx-rest (sx-rest s))))))))) ;;; Derived from the t21oct97 archive of QobiScheme, updated to the ;;; m2feb98, r5feb98, m7dec98, m24jan00, f10mar00, h22apr00, f5may00, ;;; m12jun00, and m25jun01 archives. (define *QobiScheme-macros* (list (list 'define-structure (lambda (s) (unless (and (>= (sx-length s) 3) (sx-every sx-symbol? (sx-rest s))) (syntax-error s "Improper DEFINE-STRUCTURE")) (let ((type (sx-datum (sx-second s))) (slots (sx-unlist (sx-rest (sx-rest s))))) ;; conventions: TYPE SLOTS `(begin (define (,(string->symbol (string-append "make-" (symbol->string type))) ,@(map sx-datum slots)) ((primitive-procedure make-structure ,type ,(length slots)) ,@(map sx-datum slots))) (define (,(string->symbol (string-append (symbol->string type) "?")) obj) ((primitive-procedure structure? ,type) obj)) ,@(map-indexed (lambda (slot i) ;; conventions: SLOT I (let ((slot (sx-datum slot))) ;; conventions: SLOT `(begin (define (,(string->symbol (string-append (symbol->string type) "-" (symbol->string slot))) s) ((primitive-procedure structure-ref ,type ,i) s)) (define (,(string->symbol (string-append "set-" (symbol->string type) "-" (symbol->string slot) "!")) s x) ((primitive-procedure structure-set! ,type ,i) s x)) (define (,(string->symbol (string-append "local-set-" (symbol->string type) "-" (symbol->string slot) "!")) s x) (let ((p ((primitive-procedure structure-ref ,type ,i) s))) ;; conventions: P (upon-failure ((primitive-procedure structure-set! ,type ,i) s p))) ((primitive-procedure structure-set! ,type ,i) s x))))) slots) )))) (list 'while (lambda (s) (let ((loop (gensym "loop"))) ;changed ;; conventions: LOOP `(begin (define (,loop) (when ,(sx-second s) ,@(sx-unlist (sx-rest (sx-rest s))) (,loop))) (,loop))))) (list 'either (lambda (s) (cond ((sx-null? (sx-rest s)) '(fail)) ((sx-null? (sx-rest (sx-rest s))) (sx-second s)) (else `(if (a-boolean) ,(sx-second s) (either ,@(sx-unlist (sx-rest (sx-rest s))))))))) (list 'for-effects (lambda (s) (let ((return (gensym "return")) ;changed (old-fail (gensym "old-fail"))) ;changed ;; conventions: RETURN OLD-FAIL `(call-with-current-continuation (lambda (,return) (let ((,old-fail fail)) (set! fail (lambda () (set! fail ,old-fail) (,return #f))) (begin ,@(sx-unlist (sx-rest s))) (fail))))))) (list 'one-value (lambda (s) (unless (or (= (sx-length s) 2) (= (sx-length s) 3)) (syntax-error s "Improper ONE-VALUE")) (let ((s1 (sx-second s)) (s2 (if (= (sx-length s) 2) '(fail) (sx-third s))) (return (gensym "return")) ;changed (old-fail (gensym "old-fail"))) ;changed ;; conventions: S1 S2 RETURN OLD-FAIL `(call-with-current-continuation (lambda (,return) (let ((,old-fail fail)) (set! fail (lambda () (set! fail ,old-fail) (,return ,s2))) (let ((v ,s1)) (set! fail ,old-fail) v))))))) ;changed (list 'local-one-value ;; needs work: *FAIL?* can potentially be captured. (lambda (s) (unless (or (= (sx-length s) 2) (= (sx-length s) 3)) (syntax-error s "Improper LOCAL-ONE-VALUE")) (let ((s1 (sx-second s)) (s2 (if (= (sx-length s) 2) '(fail) (sx-third s))) (return (gensym "return")) ;changed (old-fail (gensym "old-fail")) ;changed (v (gensym "v"))) ;changed ;; conventions: S1 S2 RETURN OLD-FAIL V `(call-with-current-continuation (lambda (,return) (let ((,v #f) (,old-fail fail)) (set! fail (lambda () (set! fail ,old-fail) (,return (cond (*fail?* ,s2) (else (set! *fail?* #t) ,v))))) (set! ,v ,s1) (set! *fail?* #f) (fail))))))) (list 'all-values ;; needs work: To eliminate REVERSE. (lambda (s) (let ((values (gensym "values"))) ;changed ;; conventions: VALUEs `(let ((,values '())) (for-effects (set! ,values (cons (begin ,@(sx-unlist (sx-rest s))) ,values))) (reverse ,values))))) (list 'possibly? (lambda (s) (let ((return (gensym "return")) ;changed (old-fail (gensym "old-fail")) ;changed (v (gensym "v"))) ;changed ;; conventions: RETURN OLD-FAIL V `(call-with-current-continuation (lambda (,return) (let ((,old-fail fail)) (set! fail (lambda () (set! fail ,old-fail) (,return #f))) (let ((,v (begin ,@(sx-unlist (sx-rest s))))) (unless ,v (fail)) (set! fail ,old-fail) ,v))))))) ;changed (list 'necessarily? (lambda (s) (let ((return (gensym "return")) ;changed (old-fail (gensym "old-fail")) ;changed (v (gensym "v")) ;changed (u (gensym "u"))) ;changed ;; conventions: RETURN OLD-FAIL V U `(call-with-current-continuation (lambda (,return) (let ((,old-fail fail) (,u #t)) (set! fail (lambda () (set! fail ,old-fail) (,return ,u))) (let ((,v (begin ,@(sx-unlist (sx-rest s))))) (when ,v (set! ,u ,v) (fail)) (set! fail ,old-fail) #f))))))) ;changed (list 'upon-failure (lambda (s) (let ((old-fail (gensym "old-fail"))) ;changed ;; conventions: OLD-FAIL `(let ((,old-fail fail)) (set! fail (lambda () (set! fail ,old-fail) ,@(sx-unlist (sx-rest s)) (fail))))))) (list 'local-set! (lambda (s) (unless (= (sx-length s) 3) (syntax-error s "Improper LOCAL-SET!")) (let ((p (gensym "p"))) ;changed ;; conventions: P `(begin (let ((,p ,(sx-second s))) (upon-failure (set! ,(sx-second s) ,p))) (set! ,(sx-second s) ,(sx-third s)))))) (list 'lazy (lambda (s) (let ((args (gensym "args"))) ;changed ;; conventions: LAZY `(lambda ,args (apply ,(sx-second s) ,args))))) (list 'define-toggle-button (lambda (s) (unless (and (= (sx-length s) 6) (sx-symbol? (sx-fifth s))) (syntax-error s "Improper DEFINE-TOGGLE-BUTTON")) `(define-button ,(sx-second s) ,(sx-third s) ,(sx-fourth s) (lambda () ,(sx-fifth s)) (lambda () (set! ,(sx-fifth s) (not ,(sx-fifth s))) (redraw-buttons) (,(sx-sixth s)))))) (list 'define-radio-buttons (lambda (s) (unless (and (>= (sx-length s) 3) (sx-symbol? (sx-second s)) (sx-every (lambda (element) (and (sx-list? element) (= (sx-length element) 4) (sx-symbol? (sx-third element)))) (sx-rest (sx-rest (sx-rest s))))) (syntax-error s "Improper DEFINE-RADIO-BUTTONS")) `(begin ,@(sx-map (lambda (element) `(define-button ,(sx-first element) ,(sx-second element) ,(sx-fourth element) (lambda () (eq? ,(sx-second s) ',(sx-third element))) (lambda () (set! ,(sx-second s) ',(sx-third element)) (redraw-buttons) (,(sx-third s))))) (sx-rest (sx-rest (sx-rest s))))))) (list 'define-cycle-button (lambda (s) (unless (and (>= (sx-length s) 6) (sx-symbol? (sx-fourth s)) (sx-every (lambda (element) (and (sx-list? element) (= (sx-length element) 2) (sx-symbol? (sx-first element)))) (sx-rest (sx-rest (sx-rest (sx-rest (sx-rest s))))))) (syntax-error s "Improper DEFINE-CYCLE-BUTTON")) (let ((symbols (sx-map sx-first (sx-rest (sx-rest (sx-rest (sx-rest (sx-rest s)))))))) `(define-button ,(sx-second s) ,(sx-third s) (lambda () (case ,(sx-fourth s) ,@(sx-map (lambda (element) `((,(sx-first element)) ,(sx-second element))) (sx-rest (sx-rest (sx-rest (sx-rest (sx-rest s)))))) (else (fuck-up)))) #f (lambda () (set! ,(sx-fourth s) (case ,(sx-fourth s) ,@(map (lambda (s1 s2) `((,s1) (set! ,(sx-fourth s) ',s2))) symbols (append (rest symbols) (list (first symbols)))) (else (fuck-up)))) (redraw-buttons) (,(sx-fifth s))))))) (list 'define-integer-range-buttons (lambda (s) (unless (and (= (sx-length s) 11) (sx-symbol? (sx-sixth s))) (syntax-error s "Improper DEFINE-INTEGER-RANGE-BUTTONS")) `(begin (define-button ,(sx-second s) ,(sx-third s) ,(sx-ninth s) #f (lambda () (when (= ,(sx-sixth s) ,(sx-seventh s)) (abort)) (set! ,(sx-sixth s) (- ,(sx-sixth s) 1)) (redraw-buttons) (,(sx-eleventh s)))) (define-button ,(sx-fourth s) ,(sx-fifth s) ,(sx-tenth s) #f (lambda () (when (= ,(sx-sixth s) ,(sx-eighth s)) (abort)) (set! ,(sx-sixth s) (+ ,(sx-sixth s) 1)) (redraw-buttons) (,(sx-eleventh s))))))) (list 'define-display-pane-application ;; (DEFINE-DISPLAY-PANE-APPLICATION ;; NAME ;; DISPLAY-PANE-WIDTH ;; DISPLAY-PANE-HEIGHT ;; PRE-INITIALIZE-PROCEDURE ;; POST-INITIALIZE-PROCEDURE ;; FINALIZE-PROCEDURE ;; REDRAW-PROCEDURE) (lambda (s) `(define (,(sx-second s) arguments) (let* ((stalin? #t) (display-pane-width ,(sx-third s)) (display-pane-height ,(sx-fourth s)) (pre-initialize-procedure ,(sx-fifth s)) (post-initialize-procedure ,(sx-sixth s)) (finalize-procedure ,(sx-seventh s)) (redraw-procedure ,(sx-eighth s))) (set! *post-initialize-procedure* post-initialize-procedure) (set! *transcript-pane* #f) (set! *echo-pane* #f) (set! *status-pane* #f) (set! *message-pane* #f) (set! *display* (xopendisplay *display-name*)) ;; changed: NULL-POINTER?, FORMAT (when (zero? *display*) (panic (format #f "Cannot connect to X server: ~a" (xdisplayname *display-name*)))) (set! *screen* (xdefaultscreen *display*)) (set! *root-window* (xrootwindow *display* *screen*)) (set! *button-width* 0) (set! *button-height* 0) (cond (stalin? (set! *white-pixel* (xwhitepixel *display* *screen*)) (set! *black-pixel* (xblackpixel *display* *screen*))) (else (set! *background* (xallocnamedcolor *display* (xdefaultcolormap *display* *screen*) *background-color*)) (unless (= (first *background*) 1) (panic "Can't allocate background colorcell")) (set! *foreground* (xallocnamedcolor *display* (xdefaultcolormap *display* *screen*) *foreground-color*)) (unless (= (first *foreground*) 1) (panic "Can't allocate foreground colorcell")))) (set! *roman-font* (xloadqueryfont *display* *roman-font-name*)) ;; changed: NULL-POINTER?, FORMAT (when (zero? *roman-font*) (panic (format #f "Cannot open font: ~a" *roman-font-name*))) (set! *bold-font* (xloadqueryfont *display* *bold-font-name*)) ;; changed: NULL-POINTER?, FORMAT (when (zero? *bold-font*) (panic (format #f "Cannot open font: ~a" *bold-font-name*))) (set! *roman-height* (+ (xfontstruct-ascent *roman-font*) (xfontstruct-descent *roman-font*))) (set! *bold-height* (+ (xfontstruct-ascent *bold-font*) (xfontstruct-descent *bold-font*))) (set! *text-height* (+ (max (xfontstruct-ascent *roman-font*) (xfontstruct-ascent *bold-font*)) (max (xfontstruct-descent *roman-font*) (xfontstruct-descent *bold-font*)))) (set! *roman-baseline* (xfontstruct-descent *roman-font*)) (set! *bold-baseline* (xfontstruct-descent *bold-font*)) (set! *text-baseline* (max *roman-baseline* *bold-baseline*)) (set! *display-pane-width* display-pane-width) (set! *display-pane-height* display-pane-height) (set! *who-line-height* 0) (set! *window* (xcreatesimplewindow *display* *root-window* *window-position-x* *window-position-y* *display-pane-width* *display-pane-height* 1 (if stalin? *black-pixel* (xcolor-pixel (second *foreground*))) (if stalin? *white-pixel* (xcolor-pixel (second *background*))))) (xstorename *display* *window* *program*) (xseticonname *display* *window* *program*) (set! *display-pane* *window*) (xselectinput *display* *display-pane* (bit-or exposuremask pointermotionmask buttonpressmask buttonreleasemask keypressmask)) (set! *thin-gc* (xcreategc *display* *window* 0 (make-xgcvalues))) (xsetbackground *display* *thin-gc* (if stalin? *white-pixel* (xcolor-pixel (second *background*)))) (xsetforeground *display* *thin-gc* (if stalin? *black-pixel* (xcolor-pixel (second *foreground*)))) (xsetlineattributes *display* *thin-gc* 0 linesolid capround joinround) (set! *thin-flipping-gc* (xcreategc *display* *window* 0 (make-xgcvalues))) (xsetbackground *display* *thin-flipping-gc* (if stalin? *black-pixel* (xcolor-pixel (second *foreground*)))) (xsetforeground *display* *thin-flipping-gc* (if stalin? *white-pixel* (xcolor-pixel (second *background*)))) (xsetlineattributes *display* *thin-flipping-gc* 0 linesolid capround joinround) (xsetfunction *display* *thin-flipping-gc* gxxor) (set! *medium-gc* (xcreategc *display* *window* 0 (make-xgcvalues))) (xsetbackground *display* *medium-gc* (if stalin? *white-pixel* (xcolor-pixel (second *background*)))) (xsetforeground *display* *medium-gc* (if stalin? *black-pixel* (xcolor-pixel (second *foreground*)))) (xsetlineattributes *display* *medium-gc* 2 linesolid capround joinround) (set! *medium-flipping-gc* (xcreategc *display* *window* 0 (make-xgcvalues))) (xsetbackground *display* *medium-flipping-gc* (if stalin? *black-pixel* (xcolor-pixel (second *foreground*)))) (xsetforeground *display* *medium-flipping-gc* (if stalin? *white-pixel* (xcolor-pixel (second *background*)))) (xsetlineattributes *display* *medium-flipping-gc* 2 linesolid capround joinround) (xsetfunction *display* *medium-flipping-gc* gxxor) (set! *thick-gc* (xcreategc *display* *window* 0 (make-xgcvalues))) (xsetbackground *display* *thick-gc* (if stalin? *white-pixel* (xcolor-pixel (second *background*)))) (xsetforeground *display* *thick-gc* (if stalin? *black-pixel* (xcolor-pixel (second *foreground*)))) (xsetlineattributes *display* *thick-gc* 5 linesolid capround joinround) (set! *thick-flipping-gc* (xcreategc *display* *window* 0 (make-xgcvalues))) (xsetbackground *display* *thick-flipping-gc* (if stalin? *black-pixel* (xcolor-pixel (second *foreground*)))) (xsetforeground *display* *thick-flipping-gc* (if stalin? *white-pixel* (xcolor-pixel (second *background*)))) (xsetlineattributes *display* *thick-flipping-gc* 5 linesolid capround joinround) (xsetfunction *display* *thick-flipping-gc* gxxor) (set! *dashed-gc* (xcreategc *display* *window* 0 (make-xgcvalues))) (xsetbackground *display* *dashed-gc* (if stalin? *white-pixel* (xcolor-pixel (second *background*)))) (xsetforeground *display* *dashed-gc* (if stalin? *black-pixel* (xcolor-pixel (second *foreground*)))) (xsetlineattributes *display* *dashed-gc* 0 lineonoffdash capround joinround) (set! *dashed-flipping-gc* (xcreategc *display* *window* 0 (make-xgcvalues))) (xsetbackground *display* *dashed-flipping-gc* (if stalin? *black-pixel* (xcolor-pixel (second *foreground*)))) (xsetforeground *display* *dashed-flipping-gc* (if stalin? *white-pixel* (xcolor-pixel (second *background*)))) (xsetlineattributes *display* *dashed-flipping-gc* 0 lineonoffdash capround joinround) (xsetfunction *display* *dashed-flipping-gc* gxxor) (set! *roman-gc* (xcreategc *display* *window* 0 (make-xgcvalues))) (xsetbackground *display* *roman-gc* (if stalin? *white-pixel* (xcolor-pixel (second *background*)))) (xsetforeground *display* *roman-gc* (if stalin? *black-pixel* (xcolor-pixel (second *foreground*)))) (xsetfont *display* *roman-gc* (xfontstruct-fid *roman-font*)) (set! *bold-gc* (xcreategc *display* *window* 0 (make-xgcvalues))) (xsetbackground *display* *bold-gc* (if stalin? *white-pixel* (xcolor-pixel (second *background*)))) (xsetforeground *display* *bold-gc* (if stalin? *black-pixel* (xcolor-pixel (second *foreground*)))) (xsetfont *display* *bold-gc* (xfontstruct-fid *bold-font*)) (set! *bold-flipping-gc* (xcreategc *display* *window* 0 (make-xgcvalues))) (xsetbackground *display* *bold-flipping-gc* (if stalin? *black-pixel* (xcolor-pixel (second *foreground*)))) (xsetforeground *display* *bold-flipping-gc* (if stalin? *white-pixel* (xcolor-pixel (second *background*)))) (xsetfont *display* *bold-flipping-gc* (xfontstruct-fid *bold-font*)) (xsetlineattributes *display* *bold-flipping-gc* 0 linesolid capround joinround) (xsetfunction *display* *bold-flipping-gc* gxxor) (unless stalin? (set! *light-gray* (xallocnamedcolor *display* (xdefaultcolormap *display* *screen*) "Light Gray")) (unless (= (first *light-gray*) 1) (panic "Can't allocate light gray colorcell")) (set! *light-gray-gc* (xcreategc *display* *window* 0 (make-xgcvalues))) (xsetbackground *display* *light-gray-gc* (xcolor-pixel (second *background*))) (xsetforeground *display* *light-gray-gc* (xcolor-pixel (second *light-gray*))) (xsetlineattributes *display* *light-gray-gc* 0 linesolid capround joinround) (set! *gray* (xallocnamedcolor *display* (xdefaultcolormap *display* *screen*) "Gray")) (unless (= (first *gray*) 1) (panic "Can't allocate gray colorcell")) (set! *gray-gc* (xcreategc *display* *window* 0 (make-xgcvalues))) (xsetbackground *display* *gray-gc* (xcolor-pixel (second *background*))) (xsetforeground *display* *gray-gc* (xcolor-pixel (second *gray*))) (xsetlineattributes *display* *gray-gc* 0 linesolid capround joinround) (set! *red* (xallocnamedcolor *display* (xdefaultcolormap *display* *screen*) "Red")) (unless (= (first *red*) 1) (panic "Can't allocate red colorcell")) (set! *red-gc* (xcreategc *display* *window* 0 (make-xgcvalues))) (xsetbackground *display* *red-gc* (xcolor-pixel (second *background*))) (xsetforeground *display* *red-gc* (xcolor-pixel (second *red*))) (xsetfont *display* *red-gc* (xfontstruct-fid *roman-font*)) (xsetlineattributes *display* *red-gc* 0 linesolid capround joinround) (set! *dark-red* (xallocnamedcolor *display* (xdefaultcolormap *display* *screen*) "Dark Red")) (unless (= (first *dark-red*) 1) (panic "Can't allocate dark red colorcell")) (set! *dark-red-gc* (xcreategc *display* *window* 0 (make-xgcvalues))) (xsetbackground *display* *dark-red-gc* (xcolor-pixel (second *background*))) (xsetforeground *display* *dark-red-gc* (xcolor-pixel (second *dark-red*))) (xsetfont *display* *dark-red-gc* (xfontstruct-fid *roman-font*)) (xsetlineattributes *display* *dark-red-gc* 0 linesolid capround joinround) (set! *green* (xallocnamedcolor *display* (xdefaultcolormap *display* *screen*) "Green")) (unless (= (first *green*) 1) (panic "Can't allocate green colorcell")) (set! *green-gc* (xcreategc *display* *window* 0 (make-xgcvalues))) (xsetbackground *display* *green-gc* (xcolor-pixel (second *background*))) (xsetforeground *display* *green-gc* (xcolor-pixel (second *green*))) (xsetfont *display* *green-gc* (xfontstruct-fid *roman-font*)) (xsetlineattributes *display* *green-gc* 0 linesolid capround joinround) (set! *dark-green* (xallocnamedcolor *display* (xdefaultcolormap *display* *screen*) "Dark Green")) (unless (= (first *dark-green*) 1) (panic "Can't allocate dark green colorcell")) (set! *dark-green-gc* (xcreategc *display* *window* 0 (make-xgcvalues))) (xsetbackground *display* *dark-green-gc* (xcolor-pixel (second *background*))) (xsetforeground *display* *dark-green-gc* (xcolor-pixel (second *dark-green*))) (xsetfont *display* *dark-green-gc* (xfontstruct-fid *roman-font*)) (xsetlineattributes *display* *dark-green-gc* 0 linesolid capround joinround) (set! *blue* (xallocnamedcolor *display* (xdefaultcolormap *display* *screen*) "Blue")) (unless (= (first *blue*) 1) (panic "Can't allocate blue colorcell")) (set! *blue-gc* (xcreategc *display* *window* 0 (make-xgcvalues))) (xsetbackground *display* *blue-gc* (xcolor-pixel (second *background*))) (xsetforeground *display* *blue-gc* (xcolor-pixel (second *blue*))) (xsetfont *display* *blue-gc* (xfontstruct-fid *roman-font*)) (xsetlineattributes *display* *blue-gc* 0 linesolid capround joinround) (set! *yellow* (xallocnamedcolor *display* (xdefaultcolormap *display* *screen*) "Yellow")) (unless (= (first *yellow*) 1) (panic "Can't allocate yellow colorcell")) (set! *yellow-gc* (xcreategc *display* *window* 0 (make-xgcvalues))) (xsetbackground *display* *yellow-gc* (xcolor-pixel (second *background*))) (xsetforeground *display* *yellow-gc* (xcolor-pixel (second *yellow*))) (xsetfont *display* *yellow-gc* (xfontstruct-fid *roman-font*)) (xsetlineattributes *display* *yellow-gc* 0 linesolid capround joinround) (set! *violet* (xallocnamedcolor *display* (xdefaultcolormap *display* *screen*) "Violet")) (unless (= (first *violet*) 1) (panic "Can't allocate violet colorcell")) (set! *violet-gc* (xcreategc *display* *window* 0 (make-xgcvalues))) (xsetbackground *display* *violet-gc* (xcolor-pixel (second *background*))) (xsetforeground *display* *violet-gc* (xcolor-pixel (second *violet*))) (xsetfont *display* *violet-gc* (xfontstruct-fid *roman-font*)) (xsetlineattributes *display* *violet-gc* 0 linesolid capround joinround) (set! *orange* (xallocnamedcolor *display* (xdefaultcolormap *display* *screen*) "Orange")) (unless (= (first *orange*) 1) (panic "Can't allocate orange colorcell")) (set! *orange-gc* (xcreategc *display* *window* 0 (make-xgcvalues))) (xsetbackground *display* *orange-gc* (xcolor-pixel (second *background*))) (xsetforeground *display* *orange-gc* (xcolor-pixel (second *orange*))) (xsetfont *display* *orange-gc* (xfontstruct-fid *roman-font*)) (xsetlineattributes *display* *orange-gc* 0 linesolid capround joinround) (set! *dark-orange* (xallocnamedcolor *display* (xdefaultcolormap *display* *screen*) "Dark Orange")) (unless (= (first *dark-orange*) 1) (panic "Can't allocate dark orange colorcell")) (set! *dark-orange-gc* (xcreategc *display* *window* 0 (make-xgcvalues))) (xsetbackground *display* *dark-orange-gc* (xcolor-pixel (second *background*))) (xsetforeground *display* *dark-orange-gc* (xcolor-pixel (second *dark-orange*))) (xsetfont *display* *dark-orange-gc* (xfontstruct-fid *roman-font*)) (xsetlineattributes *display* *dark-orange-gc* 0 linesolid capround joinround)) (set! *color-gc* (xcreategc *display* *window* 0 (make-xgcvalues))) (xsetbackground *display* *color-gc* (if stalin? *white-pixel* (xcolor-pixel (second *background*)))) (xsetforeground *display* *color-gc* (if stalin? *black-pixel* (xcolor-pixel (second *foreground*)))) (xsetlineattributes *display* *color-gc* 0 linesolid capround joinround) (set! *window-methods* '()) (set! *abort-button* #f) (set! *abort-key* #f) (set! *comtab* (make-vector 256 #f)) (set! *help* '()) (define-key (control #\h) "Help" help-command) (set! *help* '()) (define-key (control #\n) "Scroll help window down one line" help-scroll-down-line-command) (define-key (control #\p) "Scroll help window up one line" help-scroll-up-line-command) (define-key (control #\v) "Scroll help window down one page" help-scroll-down-page-command) (define-key (meta #\v) "Scroll help window up one page" help-scroll-up-page-command) (define-key (meta #\<) "Scroll help window to beginning" help-scroll-beginning-command) (define-key (meta #\>) "Scroll help window to end" help-scroll-end-command) (set! *help-comtab* *comtab*) (set! *comtab* (make-vector 256 #f)) (set! *prefix* '()) (set! *status* "Tyi") (set! *message* "") (set! *redraw-procedure* redraw-procedure) (set! *buttons* '()) (set! *pause?* #f) (set! *help?* #f) (set! *clear-display-pane?* #t) (let ((hints (make-xwmhints))) (set-xwmhints-input! hints 1) ;changed (set-xwmhints-flags! hints inputhint) ;changed (xsetwmhints *display* *window* hints)) (let ((hints (make-xsizehints))) (when *window-position?* (set-xsizehints-x! hints *window-position-x*) ;changed (set-xsizehints-y! hints *window-position-y*)) ;changed (set-xsizehints-min_width! hints *display-pane-width*) ;changed (set-xsizehints-max_width! hints *display-pane-width*) ;changed (set-xsizehints-min_height! hints *display-pane-height*) ;changed (set-xsizehints-max_height! hints *display-pane-height*) ;changed (set-xsizehints-flags! hints (if *window-position?* (+ usposition pposition pminsize pmaxsize) (+ pminsize pmaxsize))) (xsetwmnormalhints *display* *window* hints)) (pre-initialize-procedure) (set-window-method! *display-pane* 'expose redraw-display-pane) (set-window-method! *display-pane* 'buttonpress region-handler) (when *transcript-pane* (set-window-method! *transcript-pane* 'expose redraw-transcript-pane)) (when *echo-pane* (set-window-method! *echo-pane* 'expose redraw-echo-pane)) (set! ;changed kill-application (lambda () (set! kill-application (lambda () #t)) (finalize-procedure) (when *display* (xfreegc *display* *thin-gc*) (xfreegc *display* *thin-flipping-gc*) (xfreegc *display* *medium-gc*) (xfreegc *display* *medium-flipping-gc*) (xfreegc *display* *thick-gc*) (xfreegc *display* *thick-flipping-gc*) (xfreegc *display* *dashed-gc*) (xfreegc *display* *dashed-flipping-gc*) (xfreegc *display* *roman-gc*) (xfreegc *display* *bold-gc*) (xfreegc *display* *bold-flipping-gc*) (unless stalin? (xfreegc *display* *light-gray-gc*) (xfreegc *display* *gray-gc*) (xfreegc *display* *red-gc*) (xfreegc *display* *dark-red-gc*) (xfreegc *display* *green-gc*) (xfreegc *display* *dark-green-gc*) (xfreegc *display* *blue-gc*) (xfreegc *display* *yellow-gc*) (xfreegc *display* *violet-gc*) (xfreegc *display* *orange-gc*) (xfreegc *display* *dark-orange-gc*) (xfreegc *display* *color-gc*) (xfreecolors *display* (xdefaultcolormap *display* *screen*) (unsigned-list->unsigneda (list (xcolor-pixel (second *background*)))) 1 0) (xfreecolors *display* (xdefaultcolormap *display* *screen*) (unsigned-list->unsigneda (list (xcolor-pixel (second *foreground*)))) 1 0) (xfreecolors *display* (xdefaultcolormap *display* *screen*) (unsigned-list->unsigneda (list (xcolor-pixel (second *light-gray*)))) 1 0) (xfreecolors *display* (xdefaultcolormap *display* *screen*) (unsigned-list->unsigneda (list (xcolor-pixel (second *gray*)))) 1 0) (xfreecolors *display* (xdefaultcolormap *display* *screen*) (unsigned-list->unsigneda (list (xcolor-pixel (second *red*)))) 1 0) (xfreecolors *display* (xdefaultcolormap *display* *screen*) (unsigned-list->unsigneda (list (xcolor-pixel (second *dark-red*)))) 1 0) (xfreecolors *display* (xdefaultcolormap *display* *screen*) (unsigned-list->unsigneda (list (xcolor-pixel (second *green*)))) 1 0) (xfreecolors *display* (xdefaultcolormap *display* *screen*) (unsigned-list->unsigneda (list (xcolor-pixel (second *dark-green*)))) 1 0) (xfreecolors *display* (xdefaultcolormap *display* *screen*) (unsigned-list->unsigneda (list (xcolor-pixel (second *blue*)))) 1 0) (xfreecolors *display* (xdefaultcolormap *display* *screen*) (unsigned-list->unsigneda (list (xcolor-pixel (second *yellow*)))) 1 0) (xfreecolors *display* (xdefaultcolormap *display* *screen*) (unsigned-list->unsigneda (list (xcolor-pixel (second *violet*)))) 1 0) (xfreecolors *display* (xdefaultcolormap *display* *screen*) (unsigned-list->unsigneda (list (xcolor-pixel (second *orange*)))) 1 0) (xfreecolors *display* (xdefaultcolormap *display* *screen*) (unsigned-list->unsigneda (list (xcolor-pixel (second *dark-orange*)))) 1 0)) (xunloadfont *display* (xfontstruct-fid *roman-font*)) (xunloadfont *display* (xfontstruct-fid *bold-font*)) (xdestroywindow *display* *window*) (xclosedisplay *display*) (set! *display* #f)) #t)) (xmapsubwindows *display* *window*) (xmapraised *display* *window*) (process-events) (kill-application))))) (list 'define-application ;; (DEFINE-APPLICATION ;; NAME ;; DISPLAY-PANE-WIDTH ;; DISPLAY-PANE-HEIGHT ;; TRANSCRIPT-LINES ;; BUTTON-ROWS ;; BUTTOM-COLUMNS ;; PRE-INITIALIZE-PROCEDURE ;; POST-INITIALIZE-PROCEDURE ;; FINALIZE-PROCEDURE ;; REDRAW-PROCEDURE ;; LISTENER-PROCEDURE) (lambda (s) `(define (,(sx-second s) arguments) (let* ((stalin? #t) (display-pane-width ,(sx-third s)) (display-pane-height ,(sx-fourth s)) (transcript-lines ,(sx-fifth s)) (button-rows ,(sx-sixth s)) (button-columns ,(sx-seventh s)) (button-width (if display-pane-width (- (quotient (+ display-pane-width 4) button-columns) 4) 100)) (width (if display-pane-width (+ display-pane-width 6) (+ (* button-columns (+ button-width 4)) 2))) (pre-initialize-procedure ,(sx-eighth s)) (post-initialize-procedure ,(sx-ninth s)) (finalize-procedure ,(sx-tenth s)) (redraw-procedure ,(sx-eleventh s)) (listener-procedure ,(if (= (sx-length s) 12) (sx-twelfth s) '(lambda () #f)))) (set! *post-initialize-procedure* post-initialize-procedure) (set! *transcript-pane* #f) (set! *echo-pane* #f) (set! *display* (xopendisplay *display-name*)) ;; changed: NULL-POINTER?, FORMAT (when (zero? *display*) (panic (format #f "Cannot connect to X server: ~a" (xdisplayname *display-name*)))) (set! *screen* (xdefaultscreen *display*)) (set! *root-window* (xrootwindow *display* *screen*)) (cond (stalin? (set! *white-pixel* (xwhitepixel *display* *screen*)) (set! *black-pixel* (xblackpixel *display* *screen*))) (else (set! *background* (xallocnamedcolor *display* (xdefaultcolormap *display* *screen*) *background-color*)) (unless (= (first *background*) 1) (panic "Can't allocate background colorcell")) (set! *foreground* (xallocnamedcolor *display* (xdefaultcolormap *display* *screen*) *foreground-color*)) (unless (= (first *foreground*) 1) (panic "Can't allocate foreground colorcell")))) (set! *roman-font* (xloadqueryfont *display* *roman-font-name*)) ;; changed: NULL-POINTER?, FORMAT (when (zero? *roman-font*) (panic (format #f "Cannot open font: ~a" *roman-font-name*))) (set! *bold-font* (xloadqueryfont *display* *bold-font-name*)) ;; changed: NULL-POINTER?, FORMAT (when (zero? *bold-font*) (panic (format #f "Cannot open font: ~a" *bold-font-name*))) (set! *roman-height* (+ (xfontstruct-ascent *roman-font*) (xfontstruct-descent *roman-font*))) (set! *bold-height* (+ (xfontstruct-ascent *bold-font*) (xfontstruct-descent *bold-font*))) (set! *text-height* (+ (max (xfontstruct-ascent *roman-font*) (xfontstruct-ascent *bold-font*)) (max (xfontstruct-descent *roman-font*) (xfontstruct-descent *bold-font*)))) (set! *roman-baseline* (xfontstruct-descent *roman-font*)) (set! *bold-baseline* (xfontstruct-descent *bold-font*)) (set! *text-baseline* (max *roman-baseline* *bold-baseline*)) (set! *button-width* button-width) (set! *button-height* (+ *text-height* 4)) (set! *display-pane-width* (- width 6)) (set! *display-pane-height* display-pane-height) (when transcript-lines (unless (zero? transcript-lines) (set! *transcript-pane-height* (+ (* transcript-lines *text-height*) 4))) (set! *echo-pane-height* (+ *text-height* 4))) (set! *who-line-height* (+ *text-height* 4)) (set! *status-pane-width* (+ (max (xtextwidth *roman-font* "Tyi" 3) (xtextwidth *roman-font* "Run" 3) (xtextwidth *roman-font* "Pause" 5) (xtextwidth *roman-font* "Track" 5)) 4)) (set! *window* (xcreatesimplewindow *display* *root-window* *window-position-x* *window-position-y* width (if transcript-lines (if (zero? transcript-lines) (+ (* button-rows (+ *button-height* 4)) *display-pane-height* *echo-pane-height* *who-line-height* 14) (+ (* button-rows (+ *button-height* 4)) *display-pane-height* *transcript-pane-height* *echo-pane-height* *who-line-height* 18)) (+ (* button-rows (+ *button-height* 4)) *display-pane-height* *who-line-height* 10)) 1 (if stalin? *black-pixel* (xcolor-pixel (second *foreground*))) (if stalin? *white-pixel* (xcolor-pixel (second *background*))))) (xstorename *display* *window* *program*) (xseticonname *display* *window* *program*) (xselectinput *display* *window* (bit-or exposuremask pointermotionmask buttonpressmask buttonreleasemask keypressmask)) (set! *display-pane* (xcreatesimplewindow *display* *window* 2 (+ (* button-rows (+ *button-height* 4)) 2) *display-pane-width* *display-pane-height* 1 (if stalin? *black-pixel* (xcolor-pixel (second *foreground*))) (if stalin? *white-pixel* (xcolor-pixel (second *background*))))) (xselectinput *display* *display-pane* (bit-or exposuremask pointermotionmask buttonpressmask buttonreleasemask keypressmask)) (when transcript-lines (unless (zero? transcript-lines) (set! *transcript-pane* (xcreatesimplewindow *display* *window* 2 (+ (* button-rows (+ *button-height* 4)) *display-pane-height* 6) *display-pane-width* *transcript-pane-height* 1 (if stalin? *black-pixel* (xcolor-pixel (second *foreground*))) (if stalin? *white-pixel* (xcolor-pixel (second *background*))))) (xselectinput *display* *transcript-pane* (bit-or exposuremask keypressmask))) (set! *echo-pane* (xcreatesimplewindow *display* *window* 2 (if (zero? transcript-lines) (+ (* button-rows (+ *button-height* 4)) *display-pane-height* 6) (+ (* button-rows (+ *button-height* 4)) *display-pane-height* *transcript-pane-height* 10)) *display-pane-width* *echo-pane-height* 1 (if stalin? *black-pixel* (xcolor-pixel (second *foreground*))) (if stalin? *white-pixel* (xcolor-pixel (second *background*))))) (xselectinput *display* *echo-pane* (bit-or exposuremask keypressmask))) (set! *status-pane* (xcreatesimplewindow *display* *window* 2 (+ (* button-rows (+ *button-height* 4)) *display-pane-height* (if transcript-lines (if (zero? transcript-lines) (+ *echo-pane-height* 10) (+ *transcript-pane-height* *echo-pane-height* 14)) 6)) *status-pane-width* *who-line-height* 1 (if stalin? *black-pixel* (xcolor-pixel (second *foreground*))) (if stalin? *white-pixel* (xcolor-pixel (second *background*))))) (xselectinput *display* *status-pane* (bit-or exposuremask keypressmask)) (set! *message-pane* (xcreatesimplewindow *display* *window* (+ *status-pane-width* 6) (+ (* button-rows (+ *button-height* 4)) *display-pane-height* (if transcript-lines (if (zero? transcript-lines) (+ *echo-pane-height* 10) (+ *transcript-pane-height* *echo-pane-height* 14)) 6)) (- width *status-pane-width* 10) *who-line-height* 1 (if stalin? *black-pixel* (xcolor-pixel (second *foreground*))) (if stalin? *white-pixel* (xcolor-pixel (second *background*))))) (xselectinput *display* *message-pane* (bit-or exposuremask keypressmask)) (set! *thin-gc* (xcreategc *display* *window* 0 (make-xgcvalues))) (xsetbackground *display* *thin-gc* (if stalin? *white-pixel* (xcolor-pixel (second *background*)))) (xsetforeground *display* *thin-gc* (if stalin? *black-pixel* (xcolor-pixel (second *foreground*)))) (xsetlineattributes *display* *thin-gc* 0 linesolid capround joinround) (set! *thin-flipping-gc* (xcreategc *display* *window* 0 (make-xgcvalues))) (xsetbackground *display* *thin-flipping-gc* (if stalin? *black-pixel* (xcolor-pixel (second *foreground*)))) (xsetforeground *display* *thin-flipping-gc* (if stalin? *white-pixel* (xcolor-pixel (second *background*)))) (xsetlineattributes *display* *thin-flipping-gc* 0 linesolid capround joinround) (xsetfunction *display* *thin-flipping-gc* gxxor) (set! *medium-gc* (xcreategc *display* *window* 0 (make-xgcvalues))) (xsetbackground *display* *medium-gc* (if stalin? *white-pixel* (xcolor-pixel (second *background*)))) (xsetforeground *display* *medium-gc* (if stalin? *black-pixel* (xcolor-pixel (second *foreground*)))) (xsetlineattributes *display* *medium-gc* 2 linesolid capround joinround) (set! *medium-flipping-gc* (xcreategc *display* *window* 0 (make-xgcvalues))) (xsetbackground *display* *medium-flipping-gc* (if stalin? *black-pixel* (xcolor-pixel (second *foreground*)))) (xsetforeground *display* *medium-flipping-gc* (if stalin? *white-pixel* (xcolor-pixel (second *background*)))) (xsetlineattributes *display* *medium-flipping-gc* 2 linesolid capround joinround) (xsetfunction *display* *medium-flipping-gc* gxxor) (set! *thick-gc* (xcreategc *display* *window* 0 (make-xgcvalues))) (xsetbackground *display* *thick-gc* (if stalin? *white-pixel* (xcolor-pixel (second *background*)))) (xsetforeground *display* *thick-gc* (if stalin? *black-pixel* (xcolor-pixel (second *foreground*)))) (xsetlineattributes *display* *thick-gc* 5 linesolid capround joinround) (set! *thick-flipping-gc* (xcreategc *display* *window* 0 (make-xgcvalues))) (xsetbackground *display* *thick-flipping-gc* (if stalin? *black-pixel* (xcolor-pixel (second *foreground*)))) (xsetforeground *display* *thick-flipping-gc* (if stalin? *white-pixel* (xcolor-pixel (second *background*)))) (xsetlineattributes *display* *thick-flipping-gc* 5 linesolid capround joinround) (xsetfunction *display* *thick-flipping-gc* gxxor) (set! *dashed-gc* (xcreategc *display* *window* 0 (make-xgcvalues))) (xsetbackground *display* *dashed-gc* (if stalin? *white-pixel* (xcolor-pixel (second *background*)))) (xsetforeground *display* *dashed-gc* (if stalin? *black-pixel* (xcolor-pixel (second *foreground*)))) (xsetlineattributes *display* *dashed-gc* 0 lineonoffdash capround joinround) (set! *dashed-flipping-gc* (xcreategc *display* *window* 0 (make-xgcvalues))) (xsetbackground *display* *dashed-flipping-gc* (if stalin? *black-pixel* (xcolor-pixel (second *foreground*)))) (xsetforeground *display* *dashed-flipping-gc* (if stalin? *white-pixel* (xcolor-pixel (second *background*)))) (xsetlineattributes *display* *dashed-flipping-gc* 0 lineonoffdash capround joinround) (xsetfunction *display* *dashed-flipping-gc* gxxor) (set! *roman-gc* (xcreategc *display* *window* 0 (make-xgcvalues))) (xsetbackground *display* *roman-gc* (if stalin? *white-pixel* (xcolor-pixel (second *background*)))) (xsetforeground *display* *roman-gc* (if stalin? *black-pixel* (xcolor-pixel (second *foreground*)))) (xsetfont *display* *roman-gc* (xfontstruct-fid *roman-font*)) (set! *bold-gc* (xcreategc *display* *window* 0 (make-xgcvalues))) (xsetbackground *display* *bold-gc* (if stalin? *white-pixel* (xcolor-pixel (second *background*)))) (xsetforeground *display* *bold-gc* (if stalin? *black-pixel* (xcolor-pixel (second *foreground*)))) (xsetfont *display* *bold-gc* (xfontstruct-fid *bold-font*)) (set! *bold-flipping-gc* (xcreategc *display* *window* 0 (make-xgcvalues))) (xsetbackground *display* *bold-flipping-gc* (if stalin? *black-pixel* (xcolor-pixel (second *foreground*)))) (xsetforeground *display* *bold-flipping-gc* (if stalin? *white-pixel* (xcolor-pixel (second *background*)))) (xsetfont *display* *bold-flipping-gc* (xfontstruct-fid *bold-font*)) (xsetlineattributes *display* *bold-flipping-gc* 0 linesolid capround joinround) (xsetfunction *display* *bold-flipping-gc* gxxor) (unless stalin? (set! *light-gray* (xallocnamedcolor *display* (xdefaultcolormap *display* *screen*) "Light Gray")) (unless (= (first *light-gray*) 1) (panic "Can't allocate light gray colorcell")) (set! *light-gray-gc* (xcreategc *display* *window* 0 (make-xgcvalues))) (xsetbackground *display* *light-gray-gc* (xcolor-pixel (second *background*))) (xsetforeground *display* *light-gray-gc* (xcolor-pixel (second *light-gray*))) (xsetlineattributes *display* *light-gray-gc* 0 linesolid capround joinround) (set! *gray* (xallocnamedcolor *display* (xdefaultcolormap *display* *screen*) "Gray")) (unless (= (first *gray*) 1) (panic "Can't allocate gray colorcell")) (set! *gray-gc* (xcreategc *display* *window* 0 (make-xgcvalues))) (xsetbackground *display* *gray-gc* (xcolor-pixel (second *background*))) (xsetforeground *display* *gray-gc* (xcolor-pixel (second *gray*))) (xsetlineattributes *display* *gray-gc* 0 linesolid capround joinround) (set! *red* (xallocnamedcolor *display* (xdefaultcolormap *display* *screen*) "Red")) (unless (= (first *red*) 1) (panic "Can't allocate red colorcell")) (set! *red-gc* (xcreategc *display* *window* 0 (make-xgcvalues))) (xsetbackground *display* *red-gc* (xcolor-pixel (second *background*))) (xsetforeground *display* *red-gc* (xcolor-pixel (second *red*))) (xsetfont *display* *red-gc* (xfontstruct-fid *roman-font*)) (xsetlineattributes *display* *red-gc* 0 linesolid capround joinround) (set! *dark-red* (xallocnamedcolor *display* (xdefaultcolormap *display* *screen*) "Dark Red")) (unless (= (first *dark-red*) 1) (panic "Can't allocate dark red colorcell")) (set! *dark-red-gc* (xcreategc *display* *window* 0 (make-xgcvalues))) (xsetbackground *display* *dark-red-gc* (xcolor-pixel (second *background*))) (xsetforeground *display* *dark-red-gc* (xcolor-pixel (second *dark-red*))) (xsetfont *display* *dark-red-gc* (xfontstruct-fid *roman-font*)) (xsetlineattributes *display* *dark-red-gc* 0 linesolid capround joinround) (set! *green* (xallocnamedcolor *display* (xdefaultcolormap *display* *screen*) "Green")) (unless (= (first *green*) 1) (panic "Can't allocate green colorcell")) (set! *green-gc* (xcreategc *display* *window* 0 (make-xgcvalues))) (xsetbackground *display* *green-gc* (xcolor-pixel (second *background*))) (xsetforeground *display* *green-gc* (xcolor-pixel (second *green*))) (xsetfont *display* *green-gc* (xfontstruct-fid *roman-font*)) (xsetlineattributes *display* *green-gc* 0 linesolid capround joinround) (set! *dark-green* (xallocnamedcolor *display* (xdefaultcolormap *display* *screen*) "Dark Green")) (unless (= (first *dark-green*) 1) (panic "Can't allocate dark green colorcell")) (set! *dark-green-gc* (xcreategc *display* *window* 0 (make-xgcvalues))) (xsetbackground *display* *dark-green-gc* (xcolor-pixel (second *background*))) (xsetforeground *display* *dark-green-gc* (xcolor-pixel (second *dark-green*))) (xsetfont *display* *dark-green-gc* (xfontstruct-fid *roman-font*)) (xsetlineattributes *display* *dark-green-gc* 0 linesolid capround joinround) (set! *blue* (xallocnamedcolor *display* (xdefaultcolormap *display* *screen*) "Blue")) (unless (= (first *blue*) 1) (panic "Can't allocate blue colorcell")) (set! *blue-gc* (xcreategc *display* *window* 0 (make-xgcvalues))) (xsetbackground *display* *blue-gc* (xcolor-pixel (second *background*))) (xsetforeground *display* *blue-gc* (xcolor-pixel (second *blue*))) (xsetfont *display* *blue-gc* (xfontstruct-fid *roman-font*)) (xsetlineattributes *display* *blue-gc* 0 linesolid capround joinround) (set! *yellow* (xallocnamedcolor *display* (xdefaultcolormap *display* *screen*) "Yellow")) (unless (= (first *yellow*) 1) (panic "Can't allocate yellow colorcell")) (set! *yellow-gc* (xcreategc *display* *window* 0 (make-xgcvalues))) (xsetbackground *display* *yellow-gc* (xcolor-pixel (second *background*))) (xsetforeground *display* *yellow-gc* (xcolor-pixel (second *yellow*))) (xsetfont *display* *yellow-gc* (xfontstruct-fid *roman-font*)) (xsetlineattributes *display* *yellow-gc* 0 linesolid capround joinround) (set! *violet* (xallocnamedcolor *display* (xdefaultcolormap *display* *screen*) "Violet")) (unless (= (first *violet*) 1) (panic "Can't allocate violet colorcell")) (set! *violet-gc* (xcreategc *display* *window* 0 (make-xgcvalues))) (xsetbackground *display* *violet-gc* (xcolor-pixel (second *background*))) (xsetforeground *display* *violet-gc* (xcolor-pixel (second *violet*))) (xsetfont *display* *violet-gc* (xfontstruct-fid *roman-font*)) (xsetlineattributes *display* *violet-gc* 0 linesolid capround joinround) (set! *orange* (xallocnamedcolor *display* (xdefaultcolormap *display* *screen*) "Orange")) (unless (= (first *orange*) 1) (panic "Can't allocate orange colorcell")) (set! *orange-gc* (xcreategc *display* *window* 0 (make-xgcvalues))) (xsetbackground *display* *orange-gc* (xcolor-pixel (second *background*))) (xsetforeground *display* *orange-gc* (xcolor-pixel (second *orange*))) (xsetfont *display* *orange-gc* (xfontstruct-fid *roman-font*)) (xsetlineattributes *display* *orange-gc* 0 linesolid capround joinround) (set! *dark-orange* (xallocnamedcolor *display* (xdefaultcolormap *display* *screen*) "Dark Orange")) (unless (= (first *dark-orange*) 1) (panic "Can't allocate dark orange colorcell")) (set! *dark-orange-gc* (xcreategc *display* *window* 0 (make-xgcvalues))) (xsetbackground *display* *dark-orange-gc* (xcolor-pixel (second *background*))) (xsetforeground *display* *dark-orange-gc* (xcolor-pixel (second *dark-orange*))) (xsetfont *display* *dark-orange-gc* (xfontstruct-fid *roman-font*)) (xsetlineattributes *display* *dark-orange-gc* 0 linesolid capround joinround)) (set! *color-gc* (xcreategc *display* *window* 0 (make-xgcvalues))) (xsetbackground *display* *color-gc* (if stalin? *white-pixel* (xcolor-pixel (second *background*)))) (xsetforeground *display* *color-gc* (if stalin? *black-pixel* (xcolor-pixel (second *foreground*)))) (xsetlineattributes *display* *color-gc* 0 linesolid capround joinround) (set! *window-methods* '()) (set! *abort-button* #f) (set! *abort-key* #f) (set! *comtab* (make-vector 256 #f)) (set! *help* '()) (define-key (control #\h) "Help" help-command) (set! *help* '()) (define-key (control #\n) "Scroll help window down one line" help-scroll-down-line-command) (define-key (control #\p) "Scroll help window up one line" help-scroll-up-line-command) (define-key (control #\v) "Scroll help window down one page" help-scroll-down-page-command) (define-key (meta #\v) "Scroll help window up one page" help-scroll-up-page-command) (define-key (meta #\<) "Scroll help window to beginning" help-scroll-beginning-command) (define-key (meta #\>) "Scroll help window to end" help-scroll-end-command) (set! *help-comtab* *comtab*) (set! *comtab* (make-vector 256 #f)) (when transcript-lines (set! *transcript* '()) (set! *input* "") (set! *input-position* 0) (let ((help *help*)) (for-each (lambda (character) (define-key character "Enter the typed character into the echo pane" (lambda () (echo-pane-insert-character-command character)))) (append (string->list "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz") (string->list "1234567890-=\\`!@#$%^&*()_+|~[]{};':\",./<>? "))) (set! *help* help)) (define-key (control #\a) "Move the cursor to the beginning of the echo pane" echo-pane-beginning-of-line-command) (define-key (control #\b) "Move the cursor backward one character in the echo pane" echo-pane-backward-char-command) (define-key (control #\d) "Delete the character after the cursor in the echo pane" echo-pane-delete-char-command) (define-key (control #\e) "Move the cursor to the end of the echo pane" echo-pane-end-of-line-command) (define-key (control #\f) "Move the cursor forward one character in the echo pane" echo-pane-forward-char-command) (define-key (control #\k) "Delete all characters after the cursor in the echo pane" echo-pane-kill-line-command) (define-key delete "Delete the character before the cursor in the echo pane" echo-pane-backward-delete-char-command) (define-key return "Process the input in the echo pane" (lambda () (set! *transcript* (cons (list 'user *input*) *transcript*)) (listener-procedure) (set! *input* "") (set! *input-position* 0) (redraw-transcript-pane) (redraw-echo-pane))) (define-key (meta #\b) "Move the cursor backward one word in the echo pane" echo-pane-backward-word-command) (define-key (meta #\d) "Delete the word after the cursor in the echo pane" echo-pane-kill-word-command) (define-key (meta #\f) "Move the cursor forward one word in the echo pane" echo-pane-forward-word-command) (define-key (meta delete) "Delete the word before the cursor in the echo pane" echo-pane-backward-kill-word-command)) (set! *prefix* '()) (set! *status* "Tyi") (set! *message* "") (set! *redraw-procedure* redraw-procedure) (set! *buttons* '()) (set! *pause?* #f) (set! *help?* #f) (set! *clear-display-pane?* #t) (let ((hints (make-xwmhints))) (set-xwmhints-input! hints 1) ;changed (set-xwmhints-flags! hints inputhint) ;changed (xsetwmhints *display* *window* hints)) (let ((hints (make-xsizehints)) (height (if transcript-lines (if (zero? transcript-lines) (+ (* button-rows (+ *button-height* 4)) *display-pane-height* *echo-pane-height* *who-line-height* 14) (+ (* button-rows (+ *button-height* 4)) *display-pane-height* *transcript-pane-height* *echo-pane-height* *who-line-height* 18)) (+ (* button-rows (+ *button-height* 4)) *display-pane-height* *who-line-height* 10)))) (when *window-position?* (set-xsizehints-x! hints *window-position-x*) ;changed (set-xsizehints-y! hints *window-position-y*)) ;changed (set-xsizehints-min_width! hints width) ;changed (set-xsizehints-max_width! hints width) ;changed (set-xsizehints-min_height! hints height) ;changed (set-xsizehints-max_height! hints height) ;changed (set-xsizehints-flags! hints (if *window-position?* (+ usposition pposition pminsize pmaxsize) (+ pminsize pmaxsize))) (xsetwmnormalhints *display* *window* hints)) (pre-initialize-procedure) (set-window-method! *display-pane* 'expose redraw-display-pane) (set-window-method! *display-pane* 'buttonpress region-handler) (when *transcript-pane* (set-window-method! *transcript-pane* 'expose redraw-transcript-pane)) (when *echo-pane* (set-window-method! *echo-pane* 'expose redraw-echo-pane)) (set-window-method! *status-pane* 'expose redraw-status-pane) (set-window-method! *message-pane* 'expose redraw-message-pane) (set! ;changed kill-application (lambda () (set! kill-application (lambda () #t)) (finalize-procedure) (when *display* (xfreegc *display* *thin-gc*) (xfreegc *display* *thin-flipping-gc*) (xfreegc *display* *medium-gc*) (xfreegc *display* *medium-flipping-gc*) (xfreegc *display* *thick-gc*) (xfreegc *display* *thick-flipping-gc*) (xfreegc *display* *dashed-gc*) (xfreegc *display* *dashed-flipping-gc*) (xfreegc *display* *roman-gc*) (xfreegc *display* *bold-gc*) (xfreegc *display* *bold-flipping-gc*) (unless stalin? (xfreegc *display* *light-gray-gc*) (xfreegc *display* *gray-gc*) (xfreegc *display* *red-gc*) (xfreegc *display* *dark-red-gc*) (xfreegc *display* *green-gc*) (xfreegc *display* *dark-green-gc*) (xfreegc *display* *blue-gc*) (xfreegc *display* *yellow-gc*) (xfreegc *display* *violet-gc*) (xfreegc *display* *orange-gc*) (xfreegc *display* *dark-orange-gc*) (xfreegc *display* *color-gc*) (xfreecolors *display* (xdefaultcolormap *display* *screen*) (unsigned-list->unsigneda (list (xcolor-pixel (second *background*)))) 1 0) (xfreecolors *display* (xdefaultcolormap *display* *screen*) (unsigned-list->unsigneda (list (xcolor-pixel (second *foreground*)))) 1 0) (xfreecolors *display* (xdefaultcolormap *display* *screen*) (unsigned-list->unsigneda (list (xcolor-pixel (second *light-gray*)))) 1 0) (xfreecolors *display* (xdefaultcolormap *display* *screen*) (unsigned-list->unsigneda (list (xcolor-pixel (second *gray*)))) 1 0) (xfreecolors *display* (xdefaultcolormap *display* *screen*) (unsigned-list->unsigneda (list (xcolor-pixel (second *red*)))) 1 0) (xfreecolors *display* (xdefaultcolormap *display* *screen*) (unsigned-list->unsigneda (list (xcolor-pixel (second *dark-red*)))) 1 0) (xfreecolors *display* (xdefaultcolormap *display* *screen*) (unsigned-list->unsigneda (list (xcolor-pixel (second *green*)))) 1 0) (xfreecolors *display* (xdefaultcolormap *display* *screen*) (unsigned-list->unsigneda (list (xcolor-pixel (second *dark-green*)))) 1 0) (xfreecolors *display* (xdefaultcolormap *display* *screen*) (unsigned-list->unsigneda (list (xcolor-pixel (second *blue*)))) 1 0) (xfreecolors *display* (xdefaultcolormap *display* *screen*) (unsigned-list->unsigneda (list (xcolor-pixel (second *yellow*)))) 1 0) (xfreecolors *display* (xdefaultcolormap *display* *screen*) (unsigned-list->unsigneda (list (xcolor-pixel (second *violet*)))) 1 0) (xfreecolors *display* (xdefaultcolormap *display* *screen*) (unsigned-list->unsigneda (list (xcolor-pixel (second *orange*)))) 1 0) (xfreecolors *display* (xdefaultcolormap *display* *screen*) (unsigned-list->unsigneda (list (xcolor-pixel (second *dark-orange*)))) 1 0)) (xunloadfont *display* (xfontstruct-fid *roman-font*)) (xunloadfont *display* (xfontstruct-fid *bold-font*)) (xdestroywindow *display* *window*) (xclosedisplay *display*) (set! *display* #f)) #t)) (xmapsubwindows *display* *window*) (xmapraised *display* *window*) (process-events) (kill-application))))) (list 'define-command (lambda (s) (define (valid-command-arguments? l) (define (valid-optional-parameter? l) (and (sx-list? l) (= (sx-length l) 4) (sx-symbol? (sx-first l)) (sx-string? (sx-second l)))) (define (valid-required-parameter? l) (and (sx-list? l) (= (sx-length l) 3) (sx-symbol? (sx-first l)) (sx-string? (sx-second l)))) (define (order-ok-optional? l) (or (sx-null? l) (and (sx-eq? (sx-first (sx-first l)) 'optional) (order-ok-optional? (sx-rest l))) (and (sx-eq? (sx-first (sx-first l)) 'rest) (sx-null? (sx-rest l))))) (define (order-ok-required? l) (or (sx-null? l) (and (sx-eq? (sx-first (sx-first l)) 'required) (order-ok-required? (sx-rest l))) (and (sx-eq? (sx-first (sx-first l)) 'optional) (order-ok-optional? (sx-rest l))) (and (sx-eq? (sx-first (sx-first l)) 'rest) (sx-null? (sx-rest l))))) (define (order-ok? l) (or (sx-null? l) (and (or (sx-eq? (sx-first (sx-first l)) 'any-number) (sx-eq? (sx-first (sx-first l)) 'at-least-one) (sx-eq? (sx-first (sx-first l)) 'at-most-one) (sx-eq? (sx-first (sx-first l)) 'exactly-one)) (order-ok? (sx-rest l))) (and (sx-eq? (sx-first (sx-first l)) 'required) (order-ok-required? (sx-rest l))) (and (sx-eq? (sx-first (sx-first l)) 'optional) (order-ok-optional? (sx-rest l))) (and (sx-eq? (sx-first (sx-first l)) 'rest) (sx-null? (sx-rest l))))) (and (sx-list? l) (>= (sx-length l) 1) (sx-symbol? (sx-first l)) (sx-every (lambda (l) (and (sx-list? l) (>= (sx-length l) 1) (or (and (or (sx-eq? (sx-first l) 'exactly-one) (sx-eq? (sx-first l) 'at-most-one)) (>= (sx-length l) 2) (sx-every (lambda (l) (and (sx-list? l) (>= (sx-length l) 2) (sx-string? (sx-first l)) (sx-symbol? (sx-second l)) (sx-every valid-optional-parameter? (sx-rest (sx-rest l))))) (sx-rest l))) (and (or (sx-eq? (sx-first l) 'at-least-one) (sx-eq? (sx-first l) 'any-number)) (>= (sx-length l) 2) (sx-every (lambda (l) (and (sx-list? l) (>= (sx-length l) 2) (sx-string? (sx-first l)) (sx-symbol? (sx-second l)) (sx-every valid-required-parameter? (sx-rest (sx-rest l))))) (sx-rest l))) (and (or (sx-eq? (sx-first l) 'required) (sx-eq? (sx-first l) 'rest)) (= (sx-length l) 2) (valid-required-parameter? (sx-second l))) (and (sx-eq? (sx-first l) 'optional) (= (sx-length l) 2) (valid-optional-parameter? (sx-second l)))))) (sx-rest l)) (order-ok? (sx-rest l)))) (define (command-usage l) (define (command-usage1 l) (let ((s (let loop ((l l)) (define (command-usage l) (string-append "-" (sx-datum (sx-first l)) (let loop ((l (sx-rest (sx-rest l)))) (cond ((sx-null? l) "") ((sx-null? (sx-rest l)) (string-append " " (sx-datum (sx-second (sx-first l))))) (else (string-append " " (sx-datum (sx-second (sx-first l))) (loop (sx-rest l)))))))) (if (sx-null? (sx-rest l)) (command-usage (sx-first l)) (string-append (command-usage (sx-first l)) "|" (loop (sx-rest l))))))) (if (= (sx-length l) 1) s (string-append "[" s "]")))) (if (sx-null? l) "" (case (sx-datum (sx-first (sx-first l))) ((any-number) (string-append " [" (command-usage1 (sx-rest (sx-first l))) "]*" (command-usage (sx-rest l)))) ((at-least-one) (string-append " [" (command-usage1 (sx-rest (sx-first l))) "]+" (command-usage (sx-rest l)))) ((at-most-one) (string-append " [" (command-usage1 (sx-rest (sx-first l))) "]" (command-usage (sx-rest l)))) ((exactly-one) (string-append " " (command-usage1 (sx-rest (sx-first l))) (command-usage (sx-rest l)))) ((required) (string-append " " (sx-datum (sx-second (sx-second (sx-first l)))) (command-usage (sx-rest l)))) ((optional) (string-append " [" (sx-datum (sx-second (sx-second (sx-first l)))) (command-usage (sx-rest l)) "]")) ((rest) (string-append " [" (sx-datum (sx-second (sx-second (sx-first l)))) "]*")) (else (fuck-up))))) (define (command-bindings l) (if (sx-null? l) '() (case (sx-datum (sx-first (sx-first l))) ((any-number at-least-one) (append (reduce append (sx-map (lambda (l) (cons (list (sx-second l) #f) (sx-map (lambda (l) (list (sx-first l) ''())) (sx-rest (sx-rest l))))) (sx-rest (sx-first l))) '()) (command-bindings (sx-rest l)))) ((at-most-one exactly-one) (append (reduce append (sx-map (lambda (l) (cons (list (sx-second l) #f) (sx-map (lambda (l) (list (sx-first l) (sx-fourth l))) (sx-rest (sx-rest l))))) (sx-rest (sx-first l))) '()) (command-bindings (sx-rest l)))) ;; changed ((required) (cons (sx-first (sx-second (sx-first l))) (command-bindings (sx-rest l)))) ((optional) (cons (list (sx-first (sx-second (sx-first l))) (sx-fourth (sx-second (sx-first l)))) (command-bindings (sx-rest l)))) ((rest) (cons (list (sx-first (sx-second (sx-first l))) ''()) (command-bindings (sx-rest l)))) (else (fuck-up))))) (define (command-keyword-argument-parser l) (cons `(let loop () (unless (null? arguments) (cond ,@(let loop ((l l)) (if (sx-null? l) '(((string=? (car arguments) "-usage") (usage))) ;changed (case (sx-datum (sx-first (sx-first l))) ((any-number at-least-one) (append (sx-map (lambda (l) `((string=? (car arguments) ;changed ,(string-append "-" (sx-datum (sx-first l)))) (set! arguments (cdr arguments)) ;changed (set! ,(sx-second l) #t) ,@(reduce append (sx-map (lambda (l) `((when (null? arguments) (usage)) (set! ,(sx-first l) (cons (,(sx-third l) ;; changed (car arguments) usage) ,(sx-first l))) ;; changed (set! arguments (cdr arguments)))) (sx-rest (sx-rest l))) '()) (loop))) (sx-rest (sx-first l))) (loop (sx-rest l)))) ((at-most-one exactly-one) (append (sx-map (lambda (l1) `((string=? (car arguments) ;changed ,(string-append "-" (sx-datum (sx-first l1)))) (set! arguments (cdr arguments)) ;changed (when (or ,@(sx-map sx-second (sx-rest (sx-first l)))) (usage)) (set! ,(sx-second l1) #t) ,@(reduce append (sx-map (lambda (l) `((when (null? arguments) (usage)) (set! ,(sx-first l) (,(sx-third l) ;; changed (car arguments) usage)) ;; changed (set! arguments (cdr arguments)))) (sx-rest (sx-rest l1))) '()) (loop))) (sx-rest (sx-first l))) (loop (sx-rest l)))) ((required optional rest) (loop (sx-rest l))) (else (fuck-up)))))))) (let loop ((l l)) (if (sx-null? l) '() (case (sx-datum (sx-first (sx-first l))) ((at-least-one exactly-one) (cons `(unless (or ,@(sx-map sx-second (sx-rest (sx-first l)))) (usage)) (loop (sx-rest l)))) ((at-most-one any-number required optional rest) (loop (sx-rest l))) (else (fuck-up))))))) (define (command-positional-argument-parser l) (let loop ((l l)) (if (sx-null? l) '((unless (null? arguments) (usage))) (case (sx-datum (sx-first (sx-first l))) ((any-number at-least-one at-most-one exactly-one) (loop (sx-rest l))) ((required) (append `((when (null? arguments) (usage)) (set! ,(sx-first (sx-second (sx-first l))) (,(sx-third (sx-second (sx-first l))) (car arguments) usage)) ;changed (set! arguments (cdr arguments))) ;changed (loop (sx-rest l)))) ((optional) (cons `(unless (null? arguments) (set! ,(sx-first (sx-second (sx-first l))) (,(sx-third (sx-second (sx-first l))) (car arguments) usage)) ;changed (set! arguments (cdr arguments))) ;changed (loop (sx-rest l)))) ((rest) `((let loop () (unless (null? arguments) (set! ,(sx-first (sx-second (sx-first l))) (cons (,(sx-third (sx-second (sx-first l))) (car arguments) usage) ;changed ,(sx-first (sx-second (sx-first l))))) (set! arguments (cdr arguments)) ;changed (loop))))) (else (fuck-up)))))) (unless (and (sx-list? s) (>= (sx-length s) 2) (valid-command-arguments? (sx-second s))) (syntax-error s "Improper DEFINE-COMMAND")) ;; changed `(let ((arguments (vector->list argv))) (define (string-argument string usage) ;; changed (if (string? string) string (panic "This shouldn't happen"))) (define (integer-argument string usage) (let ((integer (string->number string))) ;; changed (if (integer? integer) (if (exact? integer) integer (usage)) (usage)))) (define (real-argument string usage) (let ((real (string->number string))) ;; changed (if (real? real) (exact->inexact real) (usage)))) (let ((program (car arguments))) ;changed (define (usage) ;; removed: STDERR-PORT (panic (string-append "usage: " program ,(command-usage (sx-rest (sx-second s)))))) (set! arguments (cdr arguments)) ;changed (let ,(command-bindings (sx-rest (sx-second s))) ,@(command-keyword-argument-parser (sx-rest (sx-second s))) ,@(command-positional-argument-parser (sx-rest (sx-second s))) ,@(sx-unlist (sx-rest (sx-rest s)))))))) (list 'parallel-begin (lambda (s) (cond ((sx-null? (sx-rest s)) '((lambda ()))) ((sx-null? (sx-rest (sx-rest s))) (sx-second s)) (else `((primitive-procedure fork) (lambda () ,(sx-second s)) (lambda () (parallel-begin ,@(sx-unlist (sx-rest (sx-rest s)))))))))) (list 'parallel-call (lambda (s) (unless (and (sx-list? s) (>= (sx-length s) 2)) (syntax-error s "Improper PARALLEL-CALL")) (let ((variables (sx-map (lambda (s) (gensym "x")) (sx-rest (sx-rest s))))) `(let ,variables (parallel-begin ,@(map (lambda (variable s) `(set! ,variable ,s)) variables (sx-unlist (sx-rest (sx-rest s))))) (,(sx-second s) ,@variables))))) (list 'parallel-do (lambda (s) ;; Extension to R4RS: Iterators can be empty. (unless (and (>= (sx-length s) 3) (sx-list? (sx-second s)) (sx-every (lambda (s) (and (sx-list? s) (or (= (sx-length s) 2) (= (sx-length s) 3)))) (sx-second s)) (sx-list? (sx-third s)) (>= (sx-length (sx-third s)) 1)) (syntax-error s "Improper PARALLEL-DO")) (let ((loop (gensym "loop"))) ;; conventions: LOOP `(letrec ((,loop (lambda ,(sx-map sx-first (sx-second s)) (if ,(sx-first (sx-third s)) (begin ,@(sx-unlist (sx-rest (sx-third s)))) (parallel-begin ,@(sx-unlist (sx-rest (sx-rest (sx-rest s)))) (,loop ,@(sx-map (lambda (s) (if (= (sx-length s) 2) (sx-first s) (sx-third s))) (sx-second s)))))))) (,loop ,@(sx-map sx-second (sx-second s))))))) (list 'mutex-begin (lambda (s) `((primitive-procedure mutex) (lambda () ,@(sx-unlist (sx-rest s)))))))) (define *Trotsky-macros* (list (list 'define-primitive-procedure (lambda (s) (unless (= (sx-length s) 9) (syntax-error s "Wrong number of arguments")) `(set! *primitive-procedure-handlers* (cons (cons ',(sx-second s) (make-primitive-procedure ,(sx-third s) (lambda (y u0 w0) ,(sx-fourth s)) (lambda (y u0 n w0) ,(sx-fifth s)) (lambda (y u0 n w0) ,(sx-sixth s)) (lambda (y u0 propagate-result! propagate-type-predicate! w0) ,(sx-seventh s)) (lambda (r y u0 ws w w0 w1 w2 w3) ,(sx-eighth s)) (lambda (r y u0 ts ws t w compile-type-predicate t0 w0 t1 w1 t2 w2 t3 w3) ,(sx-ninth s)))) *primitive-procedure-handlers*)))))) ;;; Input/Output (define (search-include-path-without-extension pathname) ;; conventions: PATHNAME (cond ((can-open-file-for-input? pathname) pathname) ((and (>= (string-length pathname) 1) (char=? (string-ref pathname 0) #\/)) (notify "Cannot find: ~a" pathname) (terminate)) (else (let loop ((include-path *include-path*)) ;; conventions: INCLUDE-PATH (cond ((null? include-path) (notify "Cannot find: ~a" pathname) (terminate)) ((can-open-file-for-input? (string-append (first include-path) "/" pathname)) (string-append (first include-path) "/" pathname)) (else (loop (rest include-path)))))))) (define (search-include-path pathname) ;; conventions: PATHNAME (search-include-path-without-extension (default-extension pathname "sc"))) (define (read-s-expressions pathname) ;; conventions (let ((line-position 0) (character-position -1) (character-position-within-line -1) (newline? #t) (last-line-position 0) (last-character-position -1) (last-character-position-within-line -1) (last-newline? #t) (last-char #f) ;; needs work: The DOT and CLOSE gensyms should be extracted and bound ;; by a LET that is outside the DEFINE of READ. (dot (gensym "dot")) (close (gensym "close"))) (call-with-input-file pathname (lambda (port) (define (read-s-expression) ;; needs work: Long predecimal point digit strings can overflow. ;; needs work: Mantissa can overflow or underflow even though exponent ;; would prevent that overflow or underflow. ;; needs work: Can't read largest negative number. ;; needs work: To handle polar numbers with @ ;; needs work: To handle rectangular numbers with i ;; needs work: To handle ratios with / ;; needs work: To handle numbers with embedded # ;; needs work: To handle exactness with #e #i ;; needs work: To handle structures (define (read-error error) (notify "~a:~s:~a" pathname line-position error) (terminate)) (define (unget-char c) (set! line-position last-line-position) (set! character-position last-character-position) (set! character-position-within-line last-character-position-within-line) (set! newline? last-newline?) (set! last-char c)) (define (get-char) (set! last-line-position line-position) (set! last-character-position character-position) (set! last-character-position-within-line character-position-within-line) (set! last-newline? newline?) (cond (newline? (set! line-position (+ line-position 1)) (set! character-position-within-line 0)) (else (set! character-position-within-line (+ character-position-within-line 1)))) (set! character-position (+ character-position 1)) (let ((c (or last-char (read-char port)))) (set! last-char #f) (set! newline? (and (not (eof-object? c)) (char=? c #\newline))) c)) (let read ((state 'object) (comments '())) ;; conventions: STATE COMMENTS (define (read-exact-binary-integer n) (let ((c (get-char))) (cond ((eof-object? c) n) ((char=? c #\0) (read-exact-binary-integer (* 2 n))) ((char=? c #\1) (read-exact-binary-integer (+ (* 2 n) 1))) (else (unget-char c) n)))) (define (read-exact-octal-integer n) (let ((c (get-char))) (cond ((eof-object? c) n) ((and (char>=? c #\0) (char<=? c #\7)) (read-exact-octal-integer (+ (* 8 n) (- (char->integer c) (char->integer #\0))))) (else (unget-char c) n)))) (define (read-exact-decimal-integer n) (let ((c (get-char))) (cond ((eof-object? c) n) ((char-numeric? c) (read-exact-decimal-integer (+ (* 10 n) (- (char->integer c) (char->integer #\0))))) (else (unget-char c) n)))) (define (read-exact-hexadecimal-integer n) (let ((c (get-char))) (cond ((eof-object? c) n) ((char-numeric? c) (read-exact-hexadecimal-integer (+ (* 16 n) (- (char->integer c) (char->integer #\0))))) ((and (char>=? c #\a) (char<=? c #\f)) (read-exact-hexadecimal-integer (+ (* 16 n) (- (char->integer c) (char->integer #\a)) 10))) ((and (char>=? c #\A) (char<=? c #\F)) (read-exact-hexadecimal-integer (+ (* 16 n) (- (char->integer c) (char->integer #\A)) 10))) (else (unget-char c) n)))) (define (read-inexact-number n m) (let ((c1 (get-char))) (cond ((eof-object? c1) n) ((char-numeric? c1) (read-inexact-number (+ n (/ (- (char->integer c1) (char->integer #\0)) m)) (* m 10.0))) ((or (char=? c1 #\e) (char=? c1 #\E) (char=? c1 #\s) (char=? c1 #\S) (char=? c1 #\f) (char=? c1 #\F) (char=? c1 #\d) (char=? c1 #\D) (char=? c1 #\l) (char=? c1 #\L)) (let ((c2 (get-char))) (when (eof-object? c2) (read-error "EOF while reading exponent")) (cond ((char-numeric? c2) (* n (expt 10.0 (read-exact-decimal-integer (- (char->integer c2) (char->integer #\0)))))) ((char=? c2 #\+) (let ((c3 (get-char))) (when (eof-object? c3) (read-error "EOF while reading exponent")) (unless (char-numeric? c3) (read-error "Unfinished exponent")) (* n (expt 10.0 (read-exact-decimal-integer (- (char->integer c3) (char->integer #\0))))))) ((char=? c2 #\-) (let ((c3 (get-char))) (when (eof-object? c3) (read-error "EOF while reading exponent")) (unless (char-numeric? c3) (read-error "Unfinished exponent")) (* n (expt 10.0 (- (read-exact-decimal-integer (- (char->integer c3) (char->integer #\0)))))))) (else (read-error "Unfinished exponent"))))) (else (unget-char c1) n)))) (define (read-number n) (let ((c1 (get-char))) (cond ((eof-object? c1) n) ((char-numeric? c1) (read-number (+ (* 10 n) (- (char->integer c1) (char->integer #\0))))) ((char=? c1 #\.) (read-inexact-number (exact->inexact n) 10.0)) ((or (char=? c1 #\e) (char=? c1 #\E) (char=? c1 #\s) (char=? c1 #\S) (char=? c1 #\f) (char=? c1 #\F) (char=? c1 #\d) (char=? c1 #\D) (char=? c1 #\l) (char=? c1 #\L)) (let ((c2 (get-char))) (when (eof-object? c2) (read-error "EOF while reading exponent")) (cond ((char-numeric? c2) (* (exact->inexact n) (expt 10.0 (read-exact-decimal-integer (- (char->integer c2) (char->integer #\0)))))) ((char=? c2 #\+) (let ((c3 (get-char))) (when (eof-object? c3) (read-error "EOF while reading exponent")) (unless (char-numeric? c3) (read-error "Unfinished exponent")) (* (exact->inexact n) (expt 10.0 (read-exact-decimal-integer (- (char->integer c3) (char->integer #\0))))))) ((char=? c2 #\-) (let ((c3 (get-char))) (when (eof-object? c3) (read-error "EOF while reading exponent")) (unless (char-numeric? c3) (read-error "Unfinished exponent")) (* (exact->inexact n) (expt 10.0 (- (read-exact-decimal-integer (- (char->integer c3) (char->integer #\0)))))))) (else (read-error "Unfinished exponent"))))) (else (unget-char c1) n)))) (define (char-initial? c) (or (char-alphabetic? c) (char=? c #\~) (char=? c #\!) (char=? c #\$) (char=? c #\%) (char=? c #\^) (char=? c #\&) (char=? c #\*) (char=? c #\_) (char=? c #\/) (char=? c #\:) (char=? c #\<) (char=? c #\=) (char=? c #\>) (char=? c #\?))) (define (char-subsequent? c) (or (char-initial? c) (char-numeric? c) (char=? c #\+) (char=? c #\-) (char=? c #\.))) (define (read-symbol s) ;; needs work: To eliminate REVERSE. (let ((c (get-char))) (cond ((eof-object? c) (string->symbol (list->string (reverse s)))) ((char-subsequent? c) (read-symbol (cons (char-downcase c) s))) (else (unget-char c) (string->symbol (list->string (reverse s))))))) (define (lookup-character-name s) (let loop ((names '(((#\e #\c #\a #\p #\s) . #\space) ((#\e #\n #\i #\l #\w #\e #\n) . #\newline)))) (when (null? names) (read-error "Unrecognized character name")) (if (let loop? ((s s) (name (car (first names)))) (or (and (null? s) (null? name)) (and (not (null? s)) (not (null? name)) (char-ci=? (first s) (first name)) (loop? (rest s) (rest name))))) (cdr (first names)) (loop (rest names))))) (define (unescape c) (case c ((#\n) (integer->char 10)) ((#\r) (integer->char 13)) ((#\t) (integer->char 9)) ((#\e) (integer->char 27)) (else c))) (define (read-character-name s) (let ((c (get-char))) (cond ((eof-object? c) (lookup-character-name s)) ((char-alphabetic? c) (read-character-name (cons c s))) (else (unget-char c) (if (and (not (null? s)) (null? (rest s))) (first s) (lookup-character-name s)))))) (let* ((c1 (get-char)) (line-position line-position) (character-position character-position) (character-position-within-line character-position-within-line) (datum (cond ((eof-object? c1) (case state ((object) c1) ((list) (read-error "EOF while reading list")) ((vector) (read-error "EOF while reading vector")) ((quote) (read-error "EOF while reading quoted object")) ((quasiquote) (read-error "EOF while reading quasiquoted object")) ((unquote-splicing) (read-error "EOF while reading unquote-slicing object")) ((unquote) (read-error "EOF while reading unquoted object")) ((close) (read-error "EOF while reading pair")))) ((char=? c1 #\;) (let loop ((cs '(#\;))) (let ((c1 (get-char))) (if (char=? c1 #\newline) (read state (cons (list->string (reverse cs)) comments)) (loop (cons c1 cs)))))) ((char=? c1 #\)) (unless (or (eq? state 'list) (eq? state 'vector) (eq? state 'close)) (read-error "Mismatched closing parenthesis")) close) ((char-whitespace? c1) (read state comments)) ((eq? state 'close) (read-error "Only one object allowed after dot")) ((char=? c1 #\') (let ((s (create-s-expression pathname line-position character-position character-position-within-line (reverse comments) 'quote))) (cons s (create-anonymous-s-expression (cons (read 'quote '()) (create-anonymous-s-expression '())))))) ((char=? c1 #\`) (let ((s (create-s-expression pathname line-position character-position character-position-within-line (reverse comments) 'quasiquote))) (cons s (create-anonymous-s-expression (cons (read 'quasiquote '()) (create-anonymous-s-expression '())))))) ((char=? c1 #\,) (let ((c2 (get-char))) (when (eof-object? c2) (read-error "EOF after dot")) (cond ((char=? c2 #\@) (let ((s (create-s-expression pathname line-position character-position character-position-within-line (reverse comments) 'unquote-splicing))) (cons s (create-anonymous-s-expression (cons (read 'unquote-splicing '()) (create-anonymous-s-expression '())))))) (else (unget-char c2) (let ((s (create-s-expression pathname line-position character-position character-position-within-line (reverse comments) 'unquote))) (cons s (create-anonymous-s-expression (cons (read 'unquote '()) (create-anonymous-s-expression '()))))))))) ((char=? c1 #\() ;; needs work: Redundant consing. (let loop ((s '())) (let ((e (read 'list '()))) (cond ((eq? (s-expression-datum e) dot) (when (null? s) (read-error "Dot cannot be first element of list")) (let* ((e1 (read 'object '())) (e2 (read 'close '()))) (let loop ((s (rest s)) (c (create-anonymous-s-expression (cons (first s) e1)))) (if (null? s) (sx-datum c) (loop (rest s) (create-anonymous-s-expression (cons (first s) c))))))) ((eq? (s-expression-datum e) close) (let loop ((s s) (c (create-anonymous-s-expression '()))) (if (null? s) (sx-datum c) (loop (rest s) (create-anonymous-s-expression (cons (first s) c)))))) (else (loop (cons e s))))))) ((char=? c1 #\#) (let ((c2 (get-char))) (when (eof-object? c2) (read-error "EOF after sharp sign")) (cond ((or (char=? c2 #\t) (char=? c2 #\T)) #t) ((or (char=? c2 #\f) (char=? c2 #\F)) #f) ((or (char=? c2 #\b) (char=? c2 #\B)) (let ((c3 (get-char))) (when (eof-object? c3) (read-error "EOF while reading binary number")) (cond ((char=? c3 #\0) (read-exact-binary-integer 0)) ((char=? c3 #\1) (read-exact-binary-integer 1)) ((char=? c3 #\+) (let ((c4 (get-char))) (when (eof-object? c4) (read-error "EOF while reading binary number")) (cond ((char=? c4 #\0) (read-exact-binary-integer 0)) ((char=? c4 #\1) (read-exact-binary-integer 1)) (else (read-error "Unfinished binary number"))))) ((char=? c3 #\-) (let ((c4 (get-char))) (when (eof-object? c4) (read-error "EOF while reading binary number")) (cond ((char=? c4 #\0) (- (read-exact-binary-integer 0))) ((char=? c4 #\1) (- (read-exact-binary-integer 1))) (else (read-error "Unfinished binary number"))))) (else (read-error "Unfinished binary number"))))) ((or (char=? c2 #\o) (char=? c2 #\O)) (let ((c3 (get-char))) (when (eof-object? c3) (read-error "EOF while reading octal number")) (cond ((and (char>=? c3 #\0) (char<=? c3 #\7)) (read-exact-octal-integer (- (char->integer c3) (char->integer #\0)))) ((char=? c3 #\+) (let ((c4 (get-char))) (when (eof-object? c4) (read-error "EOF while reading octal number")) (unless (and (char>=? c4 #\0) (char<=? c4 #\7)) (read-error "Unfinished octal number")) (read-exact-octal-integer (- (char->integer c4) (char->integer #\0))))) ((char=? c3 #\-) (let ((c4 (get-char))) (when (eof-object? c4) (read-error "EOF while reading octal number")) (unless (and (char>=? c4 #\0) (char<=? c4 #\7)) (read-error "Unfinished octal number")) (- (read-exact-octal-integer (- (char->integer c4) (char->integer #\0)))))) (else (read-error "Unfinished octal number"))))) ((or (char=? c2 #\d) (char=? c2 #\D)) (let ((c3 (get-char))) (when (eof-object? c3) (read-error "EOF while reading decimal number")) (cond ((char=? c3 #\+) (let ((c4 (get-char))) (when (eof-object? c4) (read-error "EOF while reading decimal number")) (cond ((char-numeric? c4) (read-number (- (char->integer c4) (char->integer #\0)))) ((char=? c4 #\.) (let ((c5 (get-char))) (when (eof-object? c5) (read-error "EOF while reading decimal number")) (unless (char-numeric? c5) (read-error "Unfinished decimal number")) (read-inexact-number (/ (- (char->integer c5) (char->integer #\0)) 10.0) 100.0))) (else (read-error "Unfinished decimal number"))))) ((char=? c3 #\-) (let ((c4 (get-char))) (when (eof-object? c4) (read-error "EOF while reading decimal number")) (cond ((char-numeric? c4) (- (read-number (- (char->integer c4) (char->integer #\0))))) ((char=? c4 #\.) (let ((c5 (get-char))) (when (eof-object? c5) (read-error "EOF while reading decimal number")) (unless (char-numeric? c5) (read-error "Unfinished decimal number")) (- (read-inexact-number (/ (- (char->integer c5) (char->integer #\0)) 10.0) 100.0)))) (else (read-error "Unfinished decimal number"))))) ((char=? c3 #\.) (let ((c4 (get-char))) (when (eof-object? c4) (read-error "EOF while reading decimal number")) (unless (char-numeric? c4) (read-error "Unfinished decimal number")) (read-inexact-number (/ (- (char->integer c4) (char->integer #\0)) 10.0) 100.0))) ((char-numeric? c3) (read-number (- (char->integer c3) (char->integer #\0)))) (else (read-error "Unfinished decimal number"))))) ((or (char=? c2 #\x) (char=? c2 #\X)) (let ((c3 (get-char))) (when (eof-object? c3) (read-error "EOF while reading hexadecimal number")) (cond ((char-numeric? c3) (read-exact-hexadecimal-integer (- (char->integer c3) (char->integer #\0)))) ((and (char>=? c3 #\a) (char<=? c3 #\f)) (read-exact-hexadecimal-integer (+ (- (char->integer c3) (char->integer #\a)) 10))) ((and (char>=? c3 #\A) (char<=? c3 #\F)) (read-exact-hexadecimal-integer (+ (- (char->integer c3) (char->integer #\A)) 10))) ((char=? c3 #\+) (let ((c4 (get-char))) (when (eof-object? c4) (read-error "EOF while reading hexadecimal number")) (cond ((char-numeric? c4) (read-exact-hexadecimal-integer (- (char->integer c4) (char->integer #\0)))) ((and (char>=? c4 #\a) (char<=? c4 #\f)) (read-exact-hexadecimal-integer (+ (- (char->integer c4) (char->integer #\a)) 10))) ((and (char>=? c4 #\A) (char<=? c4 #\F)) (read-exact-hexadecimal-integer (+ (- (char->integer c4) (char->integer #\A)) 10))) (else (read-error "Unfinished hexadecimal number"))))) ((char=? c3 #\-) (let ((c4 (get-char))) (when (eof-object? c4) (read-error "EOF while reading hexadecimal number")) (cond ((char-numeric? c4) (- (read-exact-hexadecimal-integer (- (char->integer c4) (char->integer #\0))))) ((and (char>=? c4 #\a) (char<=? c4 #\f)) (- (read-exact-hexadecimal-integer (+ (- (char->integer c4) (char->integer #\a)) 10)))) ((and (char>=? c4 #\A) (char<=? c4 #\F)) (- (read-exact-hexadecimal-integer (+ (- (char->integer c4) (char->integer #\A)) 10)))) (else (read-error "Unfinished hexadecimal number"))))) (else (read-error "Unfinished hexadecimal number"))))) ((char=? c2 #\() (let loop ((s '())) (let ((e (read 'vector '()))) ;; needs work: To eliminate REVERSE. (if (eq? (s-expression-datum e) close) (list->vector (reverse s)) (loop (cons e s)))))) ((char=? c2 #\\) (let ((c3 (get-char))) (when (eof-object? c3) (read-error "EOF while reading character constant")) (if (char-alphabetic? c3) (read-character-name (list c3)) c3))) (else (read-error "Improper character after sharp sign"))))) ((char=? c1 #\") ;; needs work: To eliminate REVERSE. (let loop ((s '())) (let ((c (get-char))) (when (eof-object? c) (read-error "EOF while reading string")) (cond ((char=? c #\\) (let ((c1 (get-char))) (when (eof-object? c1) (read-error "EOF after backslash in string")) (loop (cons (unescape c1) s)))) ((char=? c #\") (list->string (reverse s))) (else (loop (cons c s))))))) ((char=? c1 #\+) (let ((c2 (get-char))) (cond ((eof-object? c2) '+) ((char-numeric? c2) (read-number (- (char->integer c2) (char->integer #\0)))) ((char=? c2 #\.) (let ((c3 (get-char))) (cond ((eof-object? c3) '+.) ((char-numeric? c3) (read-inexact-number (/ (- (char->integer c3) (char->integer #\0)) 10.0) 100.0)) ((char-subsequent? c3) (read-symbol (list (char-downcase c3) (char-downcase c2) (char-downcase c1)))) (else (unget-char c3) '+.)))) ((char-subsequent? c2) (read-symbol (list (char-downcase c2) (char-downcase c1)))) (else (unget-char c2) '+)))) ((char=? c1 #\-) (let ((c2 (get-char))) (cond ((eof-object? c2) '-) ((char-numeric? c2) (- (read-number (- (char->integer c2) (char->integer #\0))))) ((char=? c2 #\.) (let ((c3 (get-char))) (cond ((eof-object? c3) '-.) ((char-numeric? c3) (- (read-inexact-number (/ (- (char->integer c3) (char->integer #\0)) 10.0) 100.0))) ((char-subsequent? c3) (read-symbol (list (char-downcase c3) (char-downcase c2) (char-downcase c1)))) (else (unget-char c3) '-.)))) ((char-subsequent? c2) (read-symbol (list (char-downcase c2) (char-downcase c1)))) (else (unget-char c2) '-)))) ((char=? c1 #\.) (let ((c2 (get-char))) (when (eof-object? c2) (read-error "EOF after dot")) (cond ((char-numeric? c2) (read-inexact-number (/ (- (char->integer c2) (char->integer #\0)) 10.0) 100.0)) ((char-subsequent? c2) (read-symbol (list (char-downcase c2) (char-downcase c1)))) ((eq? state 'list) (unget-char c2) dot) (else (read-error "Dot allowed only inside list"))))) ((char-numeric? c1) (read-number (- (char->integer c1) (char->integer #\0)))) ((char-initial? c1) (read-symbol (list (char-downcase c1)))) (else (read-error "Attempt to READ invalid character"))))) (if (s-expression? datum) datum (create-s-expression pathname line-position character-position character-position-within-line (reverse comments) datum))))) (let loop ((ss '())) (let ((s (read-s-expression))) (cond ((eof-object? (s-expression-datum s)) (reverse ss)) ((and (sx-list? s) (= (sx-length s) 2) (sx-eq? (sx-first s) 'include) (sx-string? (sx-second s))) (let ((pathname (search-include-path (sx-datum (sx-second s))))) ;; conventions: PATHNAME (cond ((member pathname *includes*) (loop ss)) (else (set! *includes* (cons pathname *includes*)) (loop (append (reverse (read-s-expressions pathname)) ss)))))) (else (loop (cons s ss)))))))))) (define (generate c pathname spitter) ;; note: This will not handle braces inside comments. ;; conventions: PATHNAME SPITTER (call-with-output-file (replace-extension pathname "c") (lambda (port) (spitter port) ;; conventions: PORT (let ((backslash? #f) (newline? #f) (open? #f) (state 'code) (indent 0)) ;; conventions: BACKSLASH? STATE INDENT (define (generate-char c) (case state ((code) (cond ((char=? c #\") (set! state 'string)) ((char=? c #\') (set! state 'char)) ((char=? c #\{) (set! indent (+ indent 1))) ((char=? c #\}) (set! indent (- indent 1))))) ((string) (cond (backslash? (set! backslash? #f)) ((char=? c #\\) (set! backslash? #t)) ((char=? c #\") (set! state 'code)))) ((char) (cond (backslash? (set! backslash? #f)) ((char=? c #\\) (set! backslash? #t)) ((char=? c #\') (set! state 'code))))) (set! newline? #f) (set! open? (char=? c #\{)) (write-char c port)) (let loop ((c c)) (cond ((char? c) (unless (char=? c #\newline) (fuck-up)) (unless (or newline? open?) (newline port) (for-each-n (lambda (i) ;; conventions: I (write-char #\space port)) indent) (set! newline? #t))) ((string? c) (for-each-n (lambda (i) ;; conventions: I (generate-char (string-ref c i))) (string-length c))) ((c:declaration? c) (loop (third c))) ((c:protect? c) (loop (second c))) ((c:no-return? c) (loop (second c))) ((pair? c) (loop (car c)) (loop (cdr c))) ((null? c) #f) (else (fuck-up)))))))) ;;; The compiler top level ;;; Options (define *Scheme->C-compatibility?* #f) (define *QobiScheme?* #f) (define *Trotsky?* #f) (define *treat-all-symbols-as-external?* #f) (define *index-allocated-string-types-by-expression?* #f) (define *index-constant-structure-types-by-slot-types?* #f) (define *index-constant-structure-types-by-expression?* #f) (define *index-allocated-structure-types-by-slot-types?* #f) (define *index-allocated-structure-types-by-expression?* #f) (define *index-constant-headed-vector-types-by-element-type?* #f) (define *index-constant-headed-vector-types-by-expression?* #f) (define *index-allocated-headed-vector-types-by-element-type?* #f) (define *index-allocated-headed-vector-types-by-expression?* #f) (define *index-constant-nonheaded-vector-types-by-element-type?* #f) (define *index-constant-nonheaded-vector-types-by-expression?* #f) (define *index-allocated-nonheaded-vector-types-by-element-type?* #f) (define *index-allocated-nonheaded-vector-types-by-expression?* #f) (define *clone-size-limit* 0) (define *split-even-if-no-widening?* #f) (define *fully-convert-to-CPS?* #f) (define *no-escaping-continuations?* #f) (define *uniqueness?* #f) (define *bounds-checks?* #f) (define *memory-checks?* #f) (define *overflow-checks?* #f) (define *runtime-checks?* #f) (define *type-checks?* #f) (define *p1?* #f) (define *p2?* #f) (define *p3?* #f) (define *p4?* #f) (define *p5?* #f) (define *p6?* #f) (define *p7?* #f) (define *closure-conversion-statistics?* #f) (define *stack-allocation?* #f) (define *heap-allocation?* #f) (define *region-allocation?* #f) (define *memory-messages?* #f) (define *expandable-regions?* #f) (define *flonum-representation* #f) (define *architecture-name* #f) (define *closure-conversion-method* #f) (define *closure-representation* #f) (define *align-strings?* #f) (define *eq?-forgery?* #f) (define *forgery?* #f) (define *globals?* #f) (define *type-if?* #f) (define *immediate-structures?* #f) (define *promote-representations?* #f) (define *copy-propagation?* #f) (define *squeeze?* #f) (define *squish?* #f) (define *treadmarks?* #f) (define *tail-call-optimization?* #f) (define *database?* #f) (define *run-cc?* #f) (define *keep-c?* #f) (define *cc* "") (define *copts* '()) ;;; Global variables (define *include-path* '()) (define *includes* '()) (define *herald* #f) (define *heralds* '()) (define *program-has-pthreads?* #f) (define *current-architecture-name* #f) (define (current-architecture-name) (unless *current-architecture-name* (set! *current-architecture-name* (get-architecture-name)) ) *current-architecture-name*) (define (initialize-architecture!) (let ((architecture (assoc *architecture-name* +architectures+))) ;; conventions: PATHNAME ARCHITECTURE (unless architecture (notify "Unknown architecture: ~a" *architecture-name*) (terminate)) (set! *char* (list-ref architecture 1)) (set! *fixnum* (list-ref architecture 2)) (set! *flonum* (case *flonum-representation* ((float) (list-ref architecture 3)) ((double) (list-ref architecture 4)) (else (fuck-up)))) (set! *length* (list-ref architecture 5)) (set! *tag* (list-ref architecture 6)) (set! *squished* (list-ref architecture 7)) (set! *signed-squished* (list-ref architecture 8)) (set! *file* (list-ref architecture 9)) (set! *jmpbuf* (list-ref architecture 10)) (set! *char-alignment* (list-ref architecture 11)) (set! *fixnum-alignment* (list-ref architecture 12)) (set! *flonum-alignment* (case *flonum-representation* ((float) (list-ref architecture 13)) ((double) (list-ref architecture 14)) (else (fuck-up)))) (set! *pointer-alignment* (list-ref architecture 15)) (set! *length-alignment* (list-ref architecture 16)) (set! *tag-alignment* (list-ref architecture 17)) (set! *squished-alignment* (list-ref architecture 18)) (set! *file-alignment* (list-ref architecture 19)) (set! *jmpbuf-alignment* (list-ref architecture 20)) (set! *char-size* (list-ref architecture 21)) (set! *fixnum-size* (list-ref architecture 22)) (set! *flonum-size* (case *flonum-representation* ((float) (list-ref architecture 23)) ((double) (list-ref architecture 24)) (else (fuck-up)))) (set! *pointer-size* (list-ref architecture 25)) (set! *length-size* (list-ref architecture 26)) (set! *tag-size* (list-ref architecture 27)) (set! *squished-size* (if *squish?* (list-ref architecture 28) 0)) (set! *include-malloc-for-alloca?* (list-ref architecture 29)))) (define (initialize-options! include-path) ;; conventions: INCLUDE-PATH (set! *include-path* include-path) (set! *Scheme->C-compatibility?* #f) (set! *QobiScheme?* #f) (set! *Trotsky?* #f) (set! *treat-all-symbols-as-external?* #f) (set! *index-allocated-string-types-by-expression?* #t) (set! *index-constant-structure-types-by-slot-types?* #f) (set! *index-constant-structure-types-by-expression?* #t) (set! *index-allocated-structure-types-by-slot-types?* #f) (set! *index-allocated-structure-types-by-expression?* #t) (set! *index-constant-headed-vector-types-by-element-type?* #f) (set! *index-constant-headed-vector-types-by-expression?* #t) (set! *index-allocated-headed-vector-types-by-element-type?* #f) (set! *index-allocated-headed-vector-types-by-expression?* #t) (set! *index-constant-nonheaded-vector-types-by-element-type?* #f) (set! *index-constant-nonheaded-vector-types-by-expression?* #t) (set! *index-allocated-nonheaded-vector-types-by-element-type?* #f) (set! *index-allocated-nonheaded-vector-types-by-expression?* #t) (set! *clone-size-limit* 80) (set! *split-even-if-no-widening?* #f) (set! *fully-convert-to-CPS?* #f) (set! *no-escaping-continuations?* #f) (set! *uniqueness?* #t) (set! *bounds-checks?* #t) (set! *memory-checks?* #t) (set! *overflow-checks?* #t) (set! *runtime-checks?* #t) (set! *type-checks?* #t) (set! *p1?* #f) (set! *p2?* #f) (set! *p3?* #f) (set! *p4?* #f) (set! *p5?* #f) (set! *p6?* #f) (set! *p7?* #f) (set! *closure-conversion-statistics?* #f) (set! *stack-allocation?* #t) (set! *heap-allocation?* #t) (set! *region-allocation?* #t) (set! *memory-messages?* #f) (set! *expandable-regions?* #t) (set! *flonum-representation* 'float) (set! *architecture-name* (current-architecture-name)) (set! *closure-conversion-method* 'lightweight) (set! *closure-representation* 'linked) (set! *align-strings?* #t) (set! *eq?-forgery?* #f) (set! *forgery?* #t) (set! *globals?* #f) (set! *type-if?* #f) (set! *immediate-structures?* #f) (set! *promote-representations?* #f) (set! *copy-propagation?* #f) (set! *squeeze?* #t) (set! *squish?* #t) (set! *treadmarks?* #f) (set! *tail-call-optimization?* #t) (set! *database?* #t) (set! *run-cc?* #t) (set! *keep-c?* #f) (set! *cc* "gcc") (set! *copts* '())) (define (initialize-stalin!) (initialize-architecture!) (set! *types-frozen?* #t) (set! *during-closure-conversion?* #f) (initialize-expressions!) (initialize-types!) (initialize-variables!) (initialize-environments!) (set! *abbreviate?* #f) (set! *worst-alignment* #f) (set! *allocation-alignment* #f) (set! *char-alignment?* #f) (set! *fixnum-alignment?* #f) (set! *flonum-alignment?* #f) (set! *rectangular-alignment?* #f) (set! *void*-alignment?* #f) (set! *char*-alignment?* #f) (set! *file*-alignment?* #f) (set! *jmpbuf*-alignment?* #f) (set! *length-alignment?* #f) (set! *tag-alignment?* #f) (set! *squished-alignment?* #f) (set! *file-alignment?* #f) (set! *jmpbuf-alignment?* #f) (set! *char-size?* #f) (set! *fixnum-size?* #f) (set! *flonum-size?* #f) (set! *rectangular-size?* #f) (set! *void*-size?* #f) (set! *char*-size?* #f) (set! *file*-size?* #f) (set! *jmpbuf*-size?* #f) (set! *length-size?* #f) (set! *tag-size?* #f) (set! *squished-size?* #f) (set! *strings* '()) (set! *symbols* '()) (set! *outside-main* '()) (set! *inside-main* '()) (set! *outside-body* '()) (set! *discard* (create-discard-result)) (set! *errors-used* '()) (set! *warnings* '()) (set! *ti* 0) (set! *li* 0) (set! *list->vector* (gensym "list->vector")) (set! *append* (gensym "append")) (set! *cons* (gensym "cons")) (set! *eqv?* (gensym "eqv?")) (set! *c:noreturn?* #f) (set! *c:c?* #f) (set! *c:panic?* #f) (set! *c:backtrace?* #f) (set! *c:backtrace-internal?* #f) (set! *c:ipow?* #f) (set! *c:input-waiting?* #f) (set! *c:includes* '()) (set! *includes* '()) (set! *herald* #f) (set! *heralds* '()) (set! *program-has-pthreads?* #f) ;; needs work: This is the only unconditional include because ;; FOREIGN-PROCEDURE doesn't (yet) allow specification of an ;; include file. (include! "stdlib")) ;system exit (define (herald p? text) ;; conventions: TEXT (when p? (notify text)) (let ((t (clock-sample))) ;; conventions: T (when *herald* (let ((herald (find-if (lambda (herald) ;; conventions: HERALD (string=? (second herald) (second *herald*))) *heralds*))) ;; conventions: HERALD (if herald (set-car! herald (+ (first herald) (- t (first *herald*)))) (set! *heralds* (cons (list (- t (first *herald*)) (second *herald*)) *heralds*))))) (set! *herald* (list t text)))) (define (display-heralds) (notify "Compilation time summary (in CPU seconds)") (let ((t (clock-sample))) ;; conventions: T (when *herald* (let ((herald (find-if (lambda (herald) ;; conventions: HERALD (string=? (second herald) (second *herald*))) *heralds*))) ;; conventions: HERALD (if herald (set-car! herald (+ (first herald) (- t (first *herald*)))) (set! *heralds* (cons (list (- t (first *herald*)) (second *herald*)) *heralds*)))))) (for-each (lambda (herald) (notify "~a - ~a% - ~a" (number->string-of-length (inexact->exact (round (first herald))) 6) (number->string-of-length (inexact->exact (round (/ (* 100 (first herald)) (reduce + (map first *heralds*) 0)))) 2) (second herald))) (reverse *heralds*))) (define (replace-true-and-false-with-t-and-nil c) (if c 't 'nil)) (define (replace-symbols-with-strings c) (cond ((pair? c) (cons (replace-symbols-with-strings (car c)) (replace-symbols-with-strings (cdr c)))) ((symbol? c) (symbol->string c)) (else c))) (define (type-kind u) (cond ((null-type? u) 'null-type) ((true-type? u) 'true-type) ((false-type? u) 'false-type) ((char-type? u) 'char-type) ((fixnum-type? u) 'fixnum-type) ((flonum-type? u) 'flonum-type) ((rectangular-type? u) 'rectangular-type) ((input-port-type? u) 'input-port-type) ((output-port-type? u) 'output-port-type) ((eof-object-type? u) 'eof-object-type) ((pointer-type? u) 'pointer-type) ((internal-symbol-type? u) 'internal-symbol-type) ((external-symbol-type? u) 'external-symbol-type) ((primitive-procedure-type? u) 'primitive-procedure-type) ((native-procedure-type? u) 'native-procedure-type) ((foreign-procedure-type? u) 'foreign-procedure-type) ((continuation-type? u) 'continuation-type) ((string-type? u) 'string-type) ((structure-type? u) 'structure-type) ((headed-vector-type? u) 'headed-vector-type) ((nonheaded-vector-type? u) 'nonheaded-vector-type) ((displaced-vector-type? u) 'displaced-vector-type) (else (fuck-up)))) (define (write-database pathname) ;; conventions: PATHNAME (define (map-variable-index gs) (cond ((pair? gs) (cons (variable-index (car gs)) (map-variable-index (cdr gs)))) ((variable? gs) (variable-index gs)) ((null? gs) '()) (else (fuck-up)))) (call-with-output-file (replace-extension pathname "db") (lambda (port) ;; conventions: PORT (write (list (map (lambda (x) ;; No need for: LINK, ;; CONSTANT, ;; INFERRED?, ;; NEEDS-CONVERSION-TO-CPS?, ;; RESULT, ;; CONTINUATION-TYPE, ;; STRING-TYPE, ;; STRUCTURE-TYPES, ;; HEADED-VECTOR-TYPES, and ;; NONHEADED-VECTOR-TYPES. ;; Should add: ORIGINAL-EXPRESSION, ;; REACHABLE?, ;; ACCESSED?, ;; RETURNS?, and ;; FREE-REFERENCE? (but these only apply to references). (list (expression-kind x) (expression-pathname x) (expression-line-position x) (expression-character-position x) (expression-character-position-within-line x) (expression-index x) (if (expression-environment x) (environment-index (expression-environment x)) 'nil) (type-set-index (expression-type-set x)) (if (expression-parent x) (expression-index (expression-parent x)) 'nil) ;; This is a real kludge. (cond ((eq? (expression-lambda-environment x) (unused)) 'unused) ((eq? (expression-lambda-environment x) (unspecified)) 'unspecified) ((environment? (expression-lambda-environment x)) (environment-index (expression-lambda-environment x))) (else 'nil)) ;; This is a real kludge. (cond ((eq? (expression-parameters x) (unused)) 'unused) ((eq? (expression-parameters x) (unspecified)) 'unspecified) (else (map-variable-index (expression-parameters x)))) ;; This is a real kludge. (cond ((eq? (expression-body x) (unused)) 'unused) ((noop? x) 'nil) (else (expression-index (expression-body x)))) ;; This is a real kludge. (if (eq? (expression-variable x) (unused)) 'unused (variable-index (expression-variable x))) ;; This is a real kludge. (if (eq? (expression-source x) (unused)) 'unused (expression-index (expression-source x))) ;; This is a real kludge. (if (eq? (expression-antecedent x) (unused)) 'unused (expression-index (expression-antecedent x))) ;; This is a real kludge. (if (eq? (expression-consequent x) (unused)) 'unused (expression-index (expression-consequent x))) ;; This is a real kludge. (if (eq? (expression-alternate x) (unused)) 'unused (expression-index (expression-alternate x))) ;; This is a real kludge. (if (eq? (expression-callee x) (unused)) 'unused (expression-index (expression-callee x))) ;; This is a real kludge. (if (eq? (expression-arguments x) (unused)) 'unused (map expression-index (expression-arguments x))) (map (lambda (u-e) (cons (type-index (car u-e)) (cond ((region-allocation? (cdr u-e)) (environment-index (cdr u-e))) ((stack-allocation? (cdr u-e)) 'stack) ((heap-allocation? (cdr u-e)) 'heap) (else (fuck-up))))) (expression-type-allocation-alist x)))) (remove-if-not expression-pathname *xs*)) (map (lambda (u) ;; No need for: MARKED?, ;; USED?, and ;; LINK. ;; Should add: TYPES-AND-TYPE-SETS-THAT-DIRECTLY-POINT-TO, ;; TYPE-PREDICATE-ACCESSED?, ;; EQ?-ACCESSED?, ;; SYMBOL->STRING-ACCESSED, ;; STRING-LENGTH-ACCESSED, ;; STRING-REF-ACCESSED, ;; STRUCTURE-REF-ACCESSED?, ;; VECTOR-LENGTH-ACCESSED, ;; VECTOR-REF-ACCESSED, ;; NARROW-PROTOTYPE, ;; ALIGNMENT?, ;; ALIGNMENT&?, ;; SIZE?, ;; ACCESSED-AFTER-RETURN?, ;; REFERENCED-RECURSIVELY?, ;; CALL-SITES, ;; NEVER-ALLOCATED-ON-THE-HEAP?, ;; EXTERNAL-SYMBOL-TYPE, and ;; DISPLACED-VECTOR-TYPE. (list (type-kind u) (if (internal-symbol-type? u) (replace-symbols-with-strings (internal-symbol-type-name u)) 'unused) (if (external-symbol-type? u) (type-index (external-symbol-type-displaced-string-type u)) 'unused) (if (primitive-procedure-type? u) (replace-symbols-with-strings (primitive-procedure-type-name u)) 'unused) (if (primitive-procedure-type? u) (primitive-procedure-type-arguments u) 'unused) (if (native-procedure-type? u) (map (lambda (y-e) (cons (if (top-level-call-site? (car y-e)) 'nil (cons (expression-index (call-site-expression (car y-e))) (call-site-offsets (car y-e)))) (environment-index (cdr y-e)))) (native-procedure-type-call-site-environment-alist u)) 'unused) (if (foreign-procedure-type? u) (foreign-procedure-type-name u) 'unused) (if (foreign-procedure-type? u) (foreign-procedure-type-parameters u) 'unused) (if (foreign-procedure-type? u) (foreign-procedure-type-result u) 'unused) (if (foreign-procedure-type? u) (replace-true-and-false-with-t-and-nil (foreign-procedure-type-called? u)) 'unused) (if (continuation-type? u) (expression-index (continuation-type-allocating-expression u)) 'unused) (if (continuation-type? u) (replace-true-and-false-with-t-and-nil (continuation-type-continuation-accessed? u)) 'unused) (if (string-type? u) (map (lambda (x) (if (expression? x) (expression-index x) 'nil)) (string-type-allocating-expressions u)) 'unused) (if (structure-type? u) (replace-symbols-with-strings (structure-type-name u)) 'unused) (if (structure-type? u) (map type-set-index (structure-type-slots u)) 'unused) (if (structure-type? u) (replace-true-and-false-with-t-and-nil (structure-type-immediate? u)) 'unused) (if (structure-type? u) (map expression-index (structure-type-allocating-expressions u)) 'unused) (if (headed-vector-type? u) (type-set-index (headed-vector-type-element u)) 'unused) (if (headed-vector-type? u) (map expression-index (headed-vector-type-allocating-expressions u)) 'unused) (if (nonheaded-vector-type? u) (type-set-index (nonheaded-vector-type-element u)) 'unused) (if (nonheaded-vector-type? u) (map (lambda (x) (if (expression? x) (expression-index x) 'nil)) (nonheaded-vector-type-allocating-expressions u)) 'unused) (if (displaced-vector-type? u) (type-index (displaced-vector-type-displaced-vector-type u)) 'unused) (type-index u) (type-use-count u) (replace-true-and-false-with-t-and-nil (fictitious? u)))) (append (list ) *internal-symbol-types* *external-symbol-types* *primitive-procedure-types* *native-procedure-types* *foreign-procedure-types* *continuation-types* *string-types* *structure-types* *headed-vector-types* *nonheaded-vector-types* *displaced-vector-types*)) (map (lambda (w) ;; No need for: LINK and ;; USED? ;; Should add: LOCATION, ;; MINIMAL-ALIGNMENT, ;; ALIGNMENT?, ;; SIZE?, ;; SQUEEZABLE, and ;; SQUISHABLE. (list (map type-index (members w)) (type-set-index w) (replace-true-and-false-with-t-and-nil (fictitious? w)) (replace-true-and-false-with-t-and-nil (void? w)) (replace-true-and-false-with-t-and-nil (monomorphic? w)) (replace-true-and-false-with-t-and-nil (multimorphic? w)) (replace-true-and-false-with-t-and-nil (tag-only? w)) (replace-true-and-false-with-t-and-nil (has-union? w)) (replace-true-and-false-with-t-and-nil (squeezed? w)) (replace-true-and-false-with-t-and-nil (squished? w)))) *ws*) (map (lambda (g) ;; Should add: ASSIGNED?, ;; HAS-NON-IN-LINED-REFERENCE?, ;; REFERENCED-AFTER-RETURN?, ;; REFERENCED-RECURSIVELY?, and ;; HIDEABLE?. (list (variable-pathname g) (variable-line-position g) (variable-character-position g) (variable-character-position-within-line g) (variable-index g) (replace-symbols-with-strings (variable-name g)) (environment-index (variable-environment g)) (replace-true-and-false-with-t-and-nil (accessed? g)) (type-set-index (variable-type-set g)) (map expression-index (accesses g)) (map expression-index (assignments g)) (map expression-index (references g)) (replace-true-and-false-with-t-and-nil (local? g)) (replace-true-and-false-with-t-and-nil (global? g)) (replace-true-and-false-with-t-and-nil (hidden? g)) (replace-true-and-false-with-t-and-nil (slotted? g)))) (remove-if-not variable-pathname *gs*)) (map (lambda (e) ;; No need for: MARKED1?, ;; MARKED2?, ;; SPLIT, ;; Should add: RECURSIVE?, ;; HAS-EXTERNAL-SELF-TAIL-CALL? ;; HAS-EXTERNAL-CONTINUATION-CALL?, ;; DISTANCE-FROM-ROOT, ;; FREE-VARIABLES, ;; QUICK-PARENT, ;; PARENT-PARAMETER, ;; PARENT-SLOT, ;; ANCESTORS, ;; DESCENDENTS, ;; PROPERLY-IN-LINED-ENVIRONMENTS, ;; NARROW-PROTOTYPE, ;; NARROW-CLONES ;; WIDE-PROTOTYPE, ;; DIRECT-TAIL-CALLERS, ;; DIRECT-NON-TAIL-CALLERS, ;; DIRECT-TAIL-CALLEES, ;; DIRECT-NON-TAIL-CALLEES, ;; BLOCKED-ENVIRONMENTS, ;; EXPRESSIONS, ;; CONTINUATION-CALLS, ;; ESCAPING-TYPES, and ;; NON-SELF-TAIL-CALL-SITES. (list (environment-index e) (if (environment-expression e) (expression-index (environment-expression e)) 'nil) (environment-name e) (replace-true-and-false-with-t-and-nil (has-region? e)) ;; needs work: The offsets are discarded here. But it doesn't ;; matter for now since this field is not used by ;; stalin.el. (map (lambda (y) (expression-index (call-site-expression y))) ;; needs work: Should have abstraction for top-level call ;; site. (remove-if top-level-call-site? (call-sites e))) (cond ((region-allocation? (allocation e)) (environment-index (allocation e))) ((stack-allocation? (allocation e)) 'stack) ((heap-allocation? (allocation e)) 'heap) (else 'nil)) (replace-true-and-false-with-t-and-nil (reentrant? e)) (replace-true-and-false-with-t-and-nil (called-more-than-once? e)) (if (or (empty? e) (not (called? e))) 'nil (replace-true-and-false-with-t-and-nil (has-closure? e))) ;; needs work: The offsets are discarded here. But it doesn't ;; matter for now since this field is not used by ;; stalin.el. (if (unique-call-site? e) (expression-index (call-site-expression (unique-call-site e))) 'nil))) ;; note: We used to do (REMOVE-IF LET? *ES*) but then m-sh-Q gave ;; "allocates on nil" because it allocated on a let ;; environment. *es*) (map (lambda (warning) ;; conventions: WARNING (list (first warning) (second warning) (third warning))) *warnings*)) port) (newline port)))) (define (stalin pathname thunk) (when *overflow-checks?* (unimplemented #f "For now, you must specify -On because safe fixnum arithmetic is not (yet) implemented")) (when *treadmarks?* (when *heap-allocation?* (unimplemented #f "For now, with -Tmk you must specify -dC")) (when *stack-allocation?* (unimplemented #f "With -Tmk you must specify -dc")) (unless *region-allocation?* (unimplemented #f "For now, with -Tmk you cannot specify -dH")) (when *globals?* (unimplemented #f "For now, with -Tmk you cannot specify -dG"))) (initialize-stalin!) (set! *macros* *r4rs-macros*) (when *Scheme->C-compatibility?* (set! *macros* (append *macros* *Scheme->C-compatibility-macros*))) (when *QobiScheme?* (set! *macros* (append *macros* *QobiScheme-macros*))) (when *Trotsky?* (set! *macros* (append *macros* *Trotsky-macros*))) (herald *p1?* "Reading source") (let* ((ss-spitter (thunk)) (ss (first ss-spitter)) (spitter (second ss-spitter))) ;; conventions: SPITTER (herald *p1?* "Expanding macros") (set! *x* (macroexpand ss)) (set! *gs* (reverse *gs*)) (herald *p1?* "Fast tree shake") (fast-tree-shake!) (when *fully-convert-to-CPS?* (herald *p1?* "Fully converting to CPS") (set! *x* (fully-convert-to-CPS *x*))) (let loop ((again? #f)) (herald *p1?* "Annotating expressions with their parents") (annotate-expressions-with-their-parents!) (herald *p1?* "Annotating variables with their environments") (annotate-variables-with-their-environments!) (herald *p1?* "Annotating expressions with their environments") (annotate-expressions-with-their-environments!) (herald *p1?* "In-lining first-order calls to primitive procedures") (in-line-first-order-calls-to-primitive-procedures!) (herald *p1?* "Annotating expressions with their parents") (annotate-expressions-with-their-parents!) (herald *p1?* "Annotating variables with their environments") (annotate-variables-with-their-environments!) (herald *p1?* "Annotating expressions with their environments") (annotate-expressions-with-their-environments!) (herald *p1?* "Annotating variables with their references") (annotate-variables-with-their-references!) (let loop ((i 1)) ;; conventions: I (when (>= i 3) (fuck-up)) (herald *p1?* "Performing flow analysis") (perform-flow-analysis!) (herald *p1?* "Enumerating call sites") (enumerate-call-sites!) (herald *p1?* "Determining which types and type sets are used") (determine-which-types-and-type-sets-are-used!) ;; needs work: The next three expressions have their time assigned to ;; determining which types and type sets are used. (remove-unused-objects! #f) (when *p1?* (print-counts) (print-number-of-call-sites-that-dispatch-on-clones) (print-maximal-non-let-lexical-nesting-depth) (print-maximal-clone-rate)) (herald *p1?* "Determining which call sites to split") (if (and (not (zero? *clone-size-limit*)) (determine-which-call-sites-to-split!)) (loop (+ i 1)) (when *p1?* (notify "~a pass~a of flow analysis" i (if (= i 1) "" "es"))))) (set! *during-closure-conversion?* #t) (herald *p1?* "Computing call graph") (compute-call-graph! (expression-lambda-environment *x*)) (herald *p1?* "Determining which environments are called more than once") (determine-which-environments-are-called-more-than-once!) (herald *p1?* "Determining which variables are referenced") (determine-which-variables-are-referenced!) (herald *p1?* "Determining free variables") (determine-free-variables!) (herald *p1?* "Determining necessarily-fictitious native procedure types") (determine-necessarily-fictitious-native-procedure-types!) (herald *p1?* "Annotating environments and continuation types") (annotate-environments-and-continuation-types!) (herald *p1?* "Inverting points-to relation") (invert-points-to-relation!) (herald *p1?* "Determining escaping types") (determine-escaping-types!) (herald *p1?* "Determining which environments have unique call sites") (determine-which-environments-have-unique-call-sites!) (herald *p1?* "Determining which environments are recursive") (determine-which-environments-are-recursive!) (herald *p1?* "Determining which environments are reentrant") (determine-which-environments-are-reentrant!) (when *uniqueness?* ;; needs work: The following comment is out of date. ;; I believe that it is not necessary to do this before determining which ;; types and type sets are used, computing the call graph, determining ;; which environments are called more than once, determining which ;; variables are accessed, determining referenced types, determining ;; escaping types, determining which environments have unique call sites, ;; and determining which environments are reentrant. But it must come ;; before performing lightweight closure conversion, determining parents ;; determining allocations, applying closed-world assumption, determining ;; indirect structure types, determining which environments have regions, ;; determining which type sets are squeezable, determining which type sets ;; are squishable, and determining alignments. I'm not sure about ;; converting to CPS, determining environment distances from root, ;; determining which environments have external self tail calls, ;; determining which environments have external continuation calls, and ;; determining which types are never allocated on the heap. (herald *p1?* "Asserting uniqueness") (assert-uniqueness!)) (herald *p1?* "Performing lightweight closure conversion") (perform-lightweight-closure-conversion!) (herald *p1?* "Determining parents") (determine-parents!) (set! *during-closure-conversion?* #f) (unless *fully-convert-to-CPS?* (herald *p1?* "Determining which expressions need conversion to CPS") (unless *no-escaping-continuations?* (determine-which-expressions-need-conversion-to-CPS!)) (when (and again? (not *no-escaping-continuations?*) (some expression-needs-conversion-to-CPS? *xs*)) (notify "Warning! Double CPS conversion")) (when (and (not again?) (not *no-escaping-continuations?*) (some expression-needs-conversion-to-CPS? *xs*)) (when again? (fuck-up)) (when (some (lambda (e) (not (eq? e (wide-prototype e)))) *es*) (unimplemented #f "For now, this program must be compiled with -clone-size-limit 0")) (herald *p1?* "Converting to CPS") (set! *x* (nonconvert-to-CPS *x*)) (when (converted? *y*) (fuck-up)) ;; This is needed because ANNOTATE-EXPRESSIONS-WITH-THEIR-PARENTS! will ;; remove orphaned expressions from *XS* so clear out the REACHED? bits ;; before we lose an easy handle on such expressions. (for-each (lambda (x) (set-expression-reached?! x #f)) *xs*) (set! *es* (remove-if-not (lambda (e) (eq? e (wide-prototype e))) *es*)) ;; This call to ANNOTATE-VARIABLES-WITH-THEIR-ENVIRONMENTS! is necessary ;; for VARIABLE-ENVIRONMENT to be set on variables created or moved by ;; conversion to CPS. (annotate-variables-with-their-environments!) (set! *gs* (remove-if-not (lambda (g) (eq? (variable-environment g) (wide-prototype (variable-environment g)))) *gs*)) (for-each (lambda (e) (set-environment-narrow-clones! e (list e)) (set-environment-direct-tail-callers! e (unspecified)) (set-environment-direct-non-tail-callers! e (unspecified)) (set-environment-direct-tail-callees! e (unspecified)) (set-environment-direct-non-tail-callees! e (unspecified)) (set-environment-expressions! e (unspecified)) (set-environment-continuation-calls! e (unspecified)) (set-environment-escaping-types! e (unspecified)) (set-environment-non-self-tail-call-sites! e (unspecified))) *es*) (initialize-types!) (loop #t)))) ;; needs work: The next three expressions have their time assigned to ;; determining environment distances from root. (when *closure-conversion-statistics?* (set! *during-closure-conversion?* #t) (notify "~s" (list 'static-counts (length *gs*) (count-if assigned? *gs*) (count-if accessed? *gs*) (count-if (lambda (g) (not (fictitious? (variable-type-set g)))) *gs*) (count-if local? *gs*) (count-if global? *gs*) (count-if hidden? *gs*) (count-if slotted? *gs*) (length *es*) (count-if has-closure? *es*) (count-if (lambda (e) (and (environment-used? e) (has-parent-slot? e))) *es*) (count-if (lambda (e) (and (environment-used? e) (has-parent-parameter? e))) *es*) (count-if (lambda (e) (and (environment-used? e) (has-parent-slot? e) (not (eq? (parent-slot e) (parent e))))) *es*) (count-if (lambda (e) (and (environment-used? e) (has-parent-parameter? e) (not (eq? (parent-parameter e) (parent e))))) *es*) (let ((counts (map number-of-accessor-indirections (remove-if-not (lambda (x) (environment-used? (expression-environment x))) *references*)))) (/ (reduce + counts 0) (exact->inexact (length counts)))) (length *accesses*) (count-if nontrivial-reference? *accesses*) (length *assignments*) (count-if nontrivial-reference? *assignments*))) (set! *during-closure-conversion?* #f)) (remove-unused-objects! #t) (check-for-corruption #t) (when *p1?* (print-counts) (print-number-of-call-sites-that-dispatch-on-clones) (print-maximal-non-let-lexical-nesting-depth) (print-maximal-clone-rate)) (herald *p1?* "Determining environment distances from root") (determine-environment-distances-from-root!) (herald *p1?* "Determining which environments have external self tail calls") (determine-which-environments-have-external-self-tail-calls!) (herald *p1?* "Determining which environments have external continuation calls") (determine-which-environments-have-external-continuation-calls!) (herald *p1?* "Determining blocked environments") (determine-blocked-environments!) (herald *p1?* "Determining which environments need to pass parameters globally") (determine-which-environments-need-to-pass-parameters-globally!) (herald *p1?* "Determining allocations") (determine-allocations!) ;; needs work: The next expression has its time assigned to determining ;; allocations. (when *p2?* (pp (externalize-expression *x*)) (for-each (lambda (w) (pp (list (type-set-index w) (externalize-type-set w)))) *ws*)) (herald *p1?* "Applying closed-world assumption") (apply-closed-world-assumption!) (check-for-corruption #t) (herald *p1?* "Determining indirect structure types") (determine-indirect-structure-types!) (herald *p1?* "Determining which types are never allocated on the heap") (determine-which-types-are-never-allocated-on-the-heap!) (herald *p1?* "Determining which types are atomic") (determine-which-types-are-atomic!) (herald *p1?* "Determining which environments have regions") (determine-which-environments-have-regions!) ;; needs work: The next eight expressions have their time assigned to ;; determining which environments have regions. (when *p3?* (pp (externalize-expression *x*)) (for-each (lambda (w) (pp (list (type-set-index w) (externalize-type-set w)))) *ws*)) (when *p4?* (for-each (lambda (e) (unless (and (null? (direct-tail-callees e)) (null? (direct-callees e)) (null? (proper-tail-callees e)) (null? (proper-callees e))) (notify (environment-name e)) (unless (null? (direct-tail-callees e)) (notify " Direct tail callees:") (for-each (lambda (e) (notify " ~a" (environment-name e))) (direct-tail-callees e))) (unless (null? (direct-callees e)) (notify " Direct callees:") (for-each (lambda (e) (notify " ~a" (environment-name e))) (direct-callees e))) (unless (null? (proper-tail-callees e)) (notify " Proper tail callees:") (for-each (lambda (e) (notify " ~a" (environment-name e))) (proper-tail-callees e))) (unless (null? (proper-callees e)) (notify " Proper callees:") (for-each (lambda (e) (notify " ~a" (environment-name e))) (proper-callees e))))) *es*)) (when *p5?* (let ((es (remove-if unique-call-site? *es*))) (notify (if (= (length es) 1) "The following non-in-line native procedure will be generated:" "The following non-in-line native procedures will be generated:")) (for-each (lambda (e) (notify " ~a~a~a~a" (environment-name e) (if (reentrant? e) " reentrant" "") (if (converted? e) " converted" "") (if (environment-passes-parameters-globally? e) " passes parameters globally" "")) (case *closure-representation* ((immediate-flat) (unimplemented #f "Immediate flat closures are not (yet) implemented")) ((indirect-flat) (unimplemented #f "Indirect flat closures are not (yet) implemented")) ((immediate-display indirect-display) (when (has-parent-parameter? e) (notify (if (= (length (ancestors e)) 1) " has the following ancestor:" " has the following ancestors")) (for-each (lambda (e) (notify " ~a" (environment-name e))) (ancestors e))) (when (has-closure? e) (notify " has closure"))) ((linked) (when (has-parent-parameter? e) (notify " has parent parameter ~a" (environment-name (parent-parameter e)))) (when (has-closure? e) (notify " has closure")) (when (has-parent-slot? e) (notify " has parent slot ~a" (environment-name (parent-slot e))))) (else (fuck-up))) (when (has-region? e) (notify " has region")) (let ((gs (remove-if-not (lambda (g) (or (local? g) (global? g) (hidden? g) (slotted? g))) (variables e)))) (unless (null? gs) (notify (if (= (length gs) 1) " has the following parameter:" " has the following parameters:")) (for-each (lambda (g) (notify " ~a{~s}~a~a~a~a" (variable-name g) (variable-index g) (if (local? g) " local" "") (if (global? g) " global" "") (if (slotted? g) " slotted" "") (if (hidden? g) " hidden as" "")) (when (hidden? g) (for-each (lambda (e) (notify " ~a" (environment-name e))) (narrow-clones (the-member (variable-type-set g)))))) gs))) (let ((gs (remove-if-not local? (sort (reduce append (map variables (properly-in-lined-environments e)) '()) < variable-index)))) (unless (null? gs) (notify (if (= (length gs) 1) " has the following in-lined local:" " has the following in-lined locals:")) (for-each (lambda (g) (notify " ~a{~s}" (variable-name g) (variable-index g))) gs)))) es)) (let ((es (remove-if-not (lambda (e) (and (unique-call-site? e) (or (reentrant? e) (converted? e) (case *closure-representation* ((immediate-flat) (unimplemented #f "Immediate flat closures are not (yet) implemented")) ((indirect-flat) (unimplemented #f "Indirect flat closures are not (yet) implemented")) ((immediate-display indirect-display) (or (has-parent-parameter? e) (has-closure? e))) ((linked) (or (has-parent-parameter? e) (has-closure? e) (has-parent-slot? e))) (else (fuck-up))) (has-region? e) (some (lambda (g) (or (local? g) (global? g) (hidden? g) (slotted? g))) (variables e))))) *es*))) (unless (null? es) (notify (if (= (length es) 1) "The following non-trivial in-line native procedure will be generated:" "The following non-trivial in-line native procedures will be generated:"))) (for-each (lambda (e) (notify " ~a~a~a" (environment-name e) (if (reentrant? e) " reentrant" "") (if (converted? e) " converted" "")) (case *closure-representation* ((immediate-flat) (unimplemented #f "Immediate flat closures are not (yet) implemented")) ((indirect-flat) (unimplemented #f "Indirect flat closures are not (yet) implemented")) ((immediate-display indirect-display) (when (has-parent-parameter? e) (notify (if (= (length (ancestors e)) 1) " has the following ancestor:" " has the following ancestors:")) (for-each (lambda (e) (notify " ~a" (environment-name e))) (ancestors e))) (when (has-closure? e) (notify " has closure"))) ((linked) (when (has-parent-parameter? e) (notify " has parent parameter ~a" (environment-name (parent-parameter e)))) (when (has-closure? e) (notify " has closure")) (when (has-parent-slot? e) (notify " has parent slot ~a" (environment-name (parent-slot e))))) (else (fuck-up))) (when (has-region? e) (notify " has region")) (let ((gs (remove-if-not (lambda (g) (or (local? g) (global? g) (hidden? g) (slotted? g))) (variables e)))) (unless (null? gs) (notify (if (= (length gs) 1) " has the following parameter:" " has the following parameters:")) (for-each (lambda (g) (notify " ~a{~s}~a~a~a~a" (variable-name g) (variable-index g) (if (local? g) " local" "") (if (global? g) " global" "") (if (slotted? g) " slotted" "") (if (hidden? g) " hidden as" "")) (when (hidden? g) (for-each (lambda (e) (notify " ~a" (environment-name e))) (narrow-clones (the-member (variable-type-set g)))))) gs)))) es))) (if *tail-call-optimization?* ;; note: I believe that all call-graph cycles that consist only of tail ;; calls have the property that all return types sets of procedures ;; in that cycle are equal and thus EQ?. Thus there cannot be return- ;; value coercion at a tail-recursive call site. (let ((ys (remove-if-not (lambda (y) (and (nonmerged-tail-recursive-purely-tail-call-site? y) (let* ((e1 (expression-environment (call-site-expression y))) (e2 (home e1))) ;; needs work: There is another case that foils tail-call ;; optimization in gcc that we don't (yet) check: ;; use of unary & on a local variable in the ;; caller. This is done by C:FORGERY-CAST and also ;; ZERO-VALUE and EQ? when *EQ?-FORGERY?* is true. ;; There are also cases unary & is applied to ;; a jump_buf but those are already handled by ;; HAS-SETJMP?. And MUTEX applies unary & to a ;; mutex to pass its address to pthread_mutex_lock ;; and pthread_mutex_unlock. (or (and (has-region? e1) (reentrant? e1)) (has-alloca? e2) (has-setjmp? e2))))) *ys*))) (unless (null? ys) ;; needs work: These warnings should go in the warning database. (notify (if (= (reduce + (map (lambda (y) (length (nonmerged-tail-recursive-purely-tail-call-site-callees y))) ys) 0) 1) "Warning! The following tail-recursive tail call is not merged:" "Warning! The following tail-recursive tail calls are not merged:")) (for-each (lambda (y) (cond ((expression-pathname (call-site-expression y)) (notify " From the following expression, ~a:~s:~s:" (expression-pathname (call-site-expression y)) (expression-line-position (call-site-expression y)) (expression-character-position (call-site-expression y)))) (else (notify " From the following expression:"))) (notify-pp3 " ~s" (undecorate (call-site-expression y))) (let* ((e1 (expression-environment (call-site-expression y))) (e2 (home e1))) (notify " in ~a" (environment-name e2)) (for-each (lambda (e) (notify " to ~a" (environment-name e))) (nonmerged-tail-recursive-purely-tail-call-site-callees y)) ;; You can't panic and still need to give these warning because the ;; user might have specified -dC that forces the use of regions and ;; alloca. (when (and (has-region? e1) (reentrant? e1)) (notify " because the call site has a reentrant region")) (when (has-alloca? e2) (notify " because the call site has calls to alloca")) (when (has-setjmp? e2) (notify " because the call site has calls to setjmp")))) ys))) (let ((ys (remove-if-not nonmerged-tail-recursive-purely-tail-call-site? *ys*))) (unless (null? ys) ;; needs work: These warnings should go in the warning database. (notify (if (= (reduce + (map (lambda (y) (length (nonmerged-tail-recursive-purely-tail-call-site-callees y))) ys) 0) 1) "Warning! The following tail-recursive tail call is not merged:" "Warning! The following tail-recursive tail calls are not merged:")) (for-each (lambda (y) (cond ((expression-pathname (call-site-expression y)) (notify " From the following expression, ~a:~s:~s:" (expression-pathname (call-site-expression y)) (expression-line-position (call-site-expression y)) (expression-character-position (call-site-expression y)))) (else (notify " From the following expression:"))) (notify-pp3 " ~s" (undecorate (call-site-expression y))) (notify " in ~a" (environment-name (home (expression-environment (call-site-expression y))))) (for-each (lambda (e) (notify " to ~a" (environment-name e))) (nonmerged-tail-recursive-purely-tail-call-site-callees y))) ys)))) (when *p6?* (for-each (lambda (x) (for-each (lambda (u-e) (let ((u (car u-e)) (e (cdr u-e))) (cond ((expression-pathname x) (notify "The following expression, ~a:~s:~s, allocates on ~a:" (expression-pathname x) (expression-line-position x) (expression-character-position x) (cond ((region-allocation? e) (environment-name e)) ((stack-allocation? e) "the stack") ((heap-allocation? e) "the heap") (else (fuck-up))))) (else (notify "The following expression allocates on ~a:" (cond ((region-allocation? e) (environment-name e)) ((stack-allocation? e) "the stack") ((heap-allocation? e) "the heap") (else (fuck-up)))))) (notify-pp3 "~s" (undecorate x)))) (expression-type-allocation-alist x))) *calls*) (for-each (lambda (e) (when (has-closure? e) (notify "The closure for ~a is allocated on ~a" (environment-name e) (cond ((region-allocation? (allocation e)) (environment-name (allocation e))) ((stack-allocation? (allocation e)) "the stack") ((heap-allocation? (allocation e)) "the heap") (else (fuck-up)))))) *es*)) (herald *p1?* "Determining which type sets are squeezable") (determine-which-type-sets-are-squeezable!) (herald *p1?* "Determining which type sets are squishable") (determine-which-type-sets-are-squishable!) (herald *p1?* "Determining alignments") (determine-alignments!) (herald *p1?* "Assigning global squish tags") (assign-global-squish-tags!) (when *promote-representations?* (herald *p1?* "Promoting representations") (promote-representations!)) (when *p1?* (print-reasons-why-type-sets-are-not-squishable!)) ;; needs work: To handle fake structure slots and vector elements. ;; Vector elements may be tricky because it can lead to ;; degeneracy. (for-each (lambda (g) (when (fake? (variable-type-set g)) (cond ((local? g) (format #t "Warning! Unlocalizing ~a{~a}:W~s because it is fake~%" (variable-name g) (variable-index g) (type-set-index (variable-type-set g))) (set-variable-local?! g #f)) ((global? g) (format #t "Warning! Unglobalizing ~a{~a}:W~s because it is fake~%" (variable-name g) (variable-index g) (type-set-index (variable-type-set g))) (set-variable-global?! g #f)) ;; needs work: I'm not sure about this one. ((hidden? g) (format #t "Warning! Unhidding ~a{~a}:W~s because it is fake~%" (variable-name g) (variable-index g) (type-set-index (variable-type-set g))) (set-variable-hidden?! g #f)) ((slotted? g) (format #t "Warning! Unslotting ~a{~a}:W~s because it is fake~%" (variable-name g) (variable-index g) (type-set-index (variable-type-set g))) (set-variable-slotted?! g #f))))) *gs*) (herald *p1?* "Generating code") ;; needs work: To move all quote variables before any procedures. (let* ((c1 (compile-native-procedures)) (c1 (newline-between (compile-error-procedures) c1))) (set! *outside-body* '()) (when (hidden? (first (variables *x*))) (fuck-up)) (when (or (eq? *closure-conversion-method* 'baseline) (eq? *closure-conversion-method* 'conventional)) ;; needs work: needs abstraction for initialized declaration (outside-main (semicolon-after (space-between *fixnum* (unparenthesize (c:= "fake" (c:value-offset))))))) (let* ((u (the-member (expression-type-set *x*))) (g (first (variables *x*))) (w (variable-type-set g)) (t (if (or (local? g) (slotted? g)) (allocate-temporary w) (c:noop))) (w1 (return-type-set (callee-environment u *y*))) (c (if (and (or (local? g) (slotted? g)) (not (environment-passes-parameters-globally? (callee-environment u *y*)))) (c:call (c:f (callee-environment u *y*)) t) (c:call (c:f (callee-environment u *y*))))) (c (newline-between (if (or (local? g) (global? g) (slotted? g)) (move-displaced-vector (if (global? g) (create-accessor-result (variable-type-set g) (accessor g #f)) (create-accessor-result w t)) (the-member-that top-level-nonheaded-vector-type? w) (c:argv) (c:argc)) (c:noop)) (if (and (or (local? g) (slotted? g)) (environment-passes-parameters-globally? (callee-environment u *y*))) (c::= (c:b g) t) (c:noop)) (if (can-be? fixnum-type? w1) (if (can-be-non? fixnum-type? w1) (let ((t1 (allocate-temporary w1))) (newline-between (move (create-accessor-result w1 t1) c w1) (type-switch fixnum-type? w1 *discard* t1 (lambda (u1) (cond (*treadmarks?* (include! "Tmk") ;Tmk_exit (c:gosub "Tmk_exit" (c:value t1 u1 w1))) (else (c:return (c:value t1 u1 w1))))) (lambda (p?) (cond (*treadmarks?* (include! "Tmk") ;Tmk_exit (c:gosub "Tmk_exit" (c:0))) (else (c:return (c:0)))))))) (c:return c)) (newline-between (semicolon-after c) (c:return (c:0)))))) (c (newline-between (compile-regions) (compile-closures) (compile-type-declarations) (compile-closure-levels) (compile-global-variables) (compile-error-procedure-prototypes) (compile-native-procedure-prototypes) (if *october?* (c:noop) (compile-foreign-procedure-prototypes)) (compile-constant-initialization-procedure-prototypes) (newlines-between (reverse *outside-main*)) c1 (compile-constant-initialization-procedures) ;; needs work: To use code-generation abstractions. (space-between "int" (if (or (accessed? g) (eq? *closure-conversion-method* 'baseline) (eq? *closure-conversion-method* 'conventional) *treadmarks?*) ;; needs work: To generate a prototype. (c:header (c:main) (space-between "int" (c:argc)) (space-between "char" (star-before (star-before (c:argv))))) ;; needs work: To generate a prototype. (c:header (c:main)))) (braces-around (newline-between (newlines-between (reverse *outside-body*)) (compile-assertions) (cond (*treadmarks?* (include! "Tmk") ;Tmk_startup (include! "unistd") ;optind (include! "string") ;strcmp (newline-between (c:while (c:&& (c:< "optind" (c:argc)) (c:!=0 (c:call "strcmp" (c:subscript (c:argv) "optind") "\"--\""))) (semicolon-after (c:++ "optind"))) (c:if (c:&& (c:< "optind" (c:argc)) (c:==0 (c:call "strcmp" (c:subscript (c:argv) "optind") "\"--\""))) (semicolon-after (c:++ "optind")) (c:noop) #f) (c:gosub "Tmk_startup" (c:argc) (c:argv)))) (else (c:noop))) (compile-constant-initialization-procedure-calls) ;; For now, we don't use GC_enable_incremental because it is ;; flakey under Solaris 2.6 and IRIX64 6.2. Also, for some ;; reason, self-compilation runs out of memory with ;; GC_enable_incremental but not without it. (if (and #f *program-has-heap?*) (c:gc-enable-incremental) (c:noop)) (if *expandable-regions?* (cond (*treadmarks?* (include! "Tmk") ;Tmk_proc_id (c:if (c:== "Tmk_proc_id" (c:0)) (newline-between (newlines-between (map (lambda (e) (if (and (has-region? e) (reentrant? e)) (c:align (c:fp e)) (c:noop))) *es*)) (compile-region-distribution) (compile-global-variable-distribution)) (c:noop) #f)) (else (newlines-between (map (lambda (e) (if (and (has-region? e) (reentrant? e)) (c:align (c:fp e)) (c:noop))) *es*)))) (cond (*treadmarks?* (include! "Tmk") ;Tmk_proc_id (c:if (c:== "Tmk_proc_id" (c:0)) (newline-between (compile-region-distribution) (compile-global-variable-distribution)) (c:noop) #f)) (else (c:noop)))) (cond (*treadmarks?* (include! "Tmk") ;Tmk_barrier (c:gosub "Tmk_barrier" (c:0))) (else (c:noop))) c))))) (let ((c (list (newline-between (c-library) (compile-offsets) c) #\newline))) (when *copy-propagation?* (herald *p1?* "Copy propagation") (c:copy-propagate! c)) (herald *p1?* "Removing unused declarations") (c:remove-unused-declarations! c) (herald *p1?* "Removing unused labels") (c:remove-unused-labels! c) (herald *p1?* "Generating C code") (generate c pathname spitter)))) (when *database?* (herald *p1?* "Writing database") (write-database pathname)) (when *run-cc?* (herald *p1?* "Compiling C code") (unless (zero? (system (reduce (lambda (s1 s2) ;; conventions: S1 S2 (string-append s1 " " s2)) `(,*cc* ,@(reduce append (map (lambda (s) ;; conventions: S (list "-I" s)) *include-path*) '()) "-o" ,(strip-extension pathname) ,(replace-extension pathname "c") ,@(reverse *copts*) ,@(map (lambda (s) ;; conventions: S (string-append "-L" s)) *include-path*) "-lm" ;"-lstalin" ,@(if *program-has-heap?* '("-lgc") '()) ,@(if *program-has-pthreads?* '("-lpthread") '()) ,@(if *treadmarks?* '("-lTmk") '())) ""))) (fuck-up))) (when (and *run-cc?* (not *keep-c?*)) (rm (replace-extension pathname "c"))) (when *p1?* (display-heralds)))) (define-command (main (at-most-one ("version" version?)) (any-number ("I" include-path? (include-path "include-directory" string-argument))) (at-most-one ("s" s?) ("x" x?) ("q" q?) ("t" t?)) (at-most-one ("treat-all-symbols-as-external" treat-all-symbols-as-external?) ("do-not-treat-all-symbols-as-external" do-not-treat-all-symbols-as-external?)) (at-most-one ("index-allocated-string-types-by-expression" index-allocated-string-types-by-expression?) ("do-not-index-allocated-string-types-by-expression" do-not-index-allocated-string-types-by-expression?)) (at-most-one ("index-constant-structure-types-by-slot-types" index-constant-structure-types-by-slot-types?) ("do-not-index-constant-structure-types-by-slot-types" do-not-index-constant-structure-types-by-slot-types?)) (at-most-one ("index-constant-structure-types-by-expression" index-constant-structure-types-by-expression?) ("do-not-index-constant-structure-types-by-expression" do-not-index-constant-structure-types-by-expression?)) (at-most-one ("index-allocated-structure-types-by-slot-types" index-allocated-structure-types-by-slot-types?) ("do-not-index-allocated-structure-types-by-slot-types" do-not-index-allocated-structure-types-by-slot-types?)) (at-most-one ("index-allocated-structure-types-by-expression" index-allocated-structure-types-by-expression?) ("do-not-index-allocated-structure-types-by-expression" do-not-index-allocated-structure-types-by-expression?)) (at-most-one ("index-constant-headed-vector-types-by-element-type" index-constant-headed-vector-types-by-element-type?) ("do-not-index-constant-headed-vector-types-by-element-type" do-not-index-constant-headed-vector-types-by-element-type?)) (at-most-one ("index-constant-headed-vector-types-by-expression" index-constant-headed-vector-types-by-expression?) ("do-not-index-constant-headed-vector-types-by-expression" do-not-index-constant-headed-vector-types-by-expression?)) (at-most-one ("index-allocated-headed-vector-types-by-element-type" index-allocated-headed-vector-types-by-element-type?) ("do-not-index-allocated-headed-vector-types-by-element-type" do-not-index-allocated-headed-vector-types-by-element-type?)) (at-most-one ("index-allocated-headed-vector-types-by-expression" index-allocated-headed-vector-types-by-expression?) ("do-not-index-allocated-headed-vector-types-by-expression" do-not-index-allocated-headed-vector-types-by-expression?)) (at-most-one ("index-constant-nonheaded-vector-types-by-element-type" index-constant-nonheaded-vector-types-by-element-type?) ("do-not-index-constant-nonheaded-vector-types-by-element-type" do-not-index-constant-nonheaded-vector-types-by-element-type?)) (at-most-one ("index-constant-nonheaded-vector-types-by-expression" index-constant-nonheaded-vector-types-by-expression?) ("do-not-index-constant-nonheaded-vector-types-by-expression" do-not-index-constant-nonheaded-vector-types-by-expression?)) (at-most-one ("index-allocated-nonheaded-vector-types-by-element-type" index-allocated-nonheaded-vector-types-by-element-type?) ("do-not-index-allocated-nonheaded-vector-types-by-element-type" do-not-index-allocated-nonheaded-vector-types-by-element-type?)) (at-most-one ("index-allocated-nonheaded-vector-types-by-expression" index-allocated-nonheaded-vector-types-by-expression?) ("do-not-index-allocated-nonheaded-vector-types-by-expression" do-not-index-allocated-nonheaded-vector-types-by-expression?)) (at-most-one ("no-clone-size-limit" no-clone-size-limit?) ("clone-size-limit" clone-size-limit? (clone-size-limit "number-of-expressions" integer-argument 80))) (at-most-one ("split-even-if-no-widening" split-even-if-no-widening?)) (at-most-one ("fully-convert-to-CPS" fully-convert-to-CPS?) ("no-escaping-continuations" no-escaping-continuations?)) (at-most-one ("du" disable-uniqueness?)) (at-most-one ("Ob" disable-bounds-checks?)) (at-most-one ("Om" disable-memory-checks?)) (at-most-one ("On" disable-overflow-checks?)) (at-most-one ("Or" disable-runtime-checks?)) (at-most-one ("Ot" disable-type-checks?)) (at-most-one ("d0" p0?)) (at-most-one ("d1" p1?)) (at-most-one ("d2" p2?)) (at-most-one ("d3" p3?)) (at-most-one ("d4" p4?)) (at-most-one ("d5" p5?)) (at-most-one ("d6" p6?)) (at-most-one ("d7" p7?)) (at-most-one ("closure-conversion-statistics" closure-conversion-statistics?)) (at-most-one ("dc" disable-stack-allocation?)) (at-most-one ("dC" disable-heap-allocation?)) (at-most-one ("dH" disable-region-allocation?)) (at-most-one ("dg" memory-messages?)) (at-most-one ("dh" disable-expandable-regions?)) (at-most-one ("d" d?)) (at-most-one ("architecture" architecture-name? (architecture-name "name" string-argument ""))) (at-most-one ("baseline" baseline?) ("conventional" conventional?) ("lightweight" lightweight?)) (at-most-one ("immediate-flat" immediate-flat?) ("indirect-flat" indirect-flat?) ("immediate-display" immediate-display?) ("indirect-display" indirect-display?) ("linked" linked?)) (at-most-one ("align-strings" align-strings?) ("do-not-align-strings" do-not-align-strings?)) (at-most-one ("de" eq?-forgery?)) (at-most-one ("df" disable-forgery?)) (at-most-one ("dG" globals?)) (at-most-one ("di" type-if?)) (at-most-one ("dI" immediate-structures?)) (at-most-one ("dp" promote-representations?)) (at-most-one ("dP" copy-propagation?)) (at-most-one ("ds" disable-squeezing?)) (at-most-one ("dS" disable-squishing?)) (at-most-one ("Tmk" treadmarks?)) (at-most-one ("no-tail-call-optimization" disable-tail-call-optimization?)) (at-most-one ("db" disable-database?)) (at-most-one ("c" disable-run-cc?)) (at-most-one ("k" keep-c?)) (at-most-one ("cc" cc? (cc "C-compiler" string-argument "gcc"))) (any-number ("copt" copt? (copts "C-compiler-options" string-argument))) (optional (pathname "pathname" string-argument #f))) ;; conventions (set! *program* "stalin") (set! *october?* #f) (when version? (format #t "0.11.2~%") (exit -1)) (unless pathname (panic "You must specify a pathname")) (initialize-options! (append '(".") include-path ##sys#include-pathnames)) (when s? (set! *Scheme->C-compatibility?* #t)) (when x? (set! *Scheme->C-compatibility?* #t)) (when q? (set! *Scheme->C-compatibility?* #t) (set! *QobiScheme?* #t)) (when t? (set! *Scheme->C-compatibility?* #t) (set! *QobiScheme?* #t) (set! *Trotsky?* #t)) (when treat-all-symbols-as-external? (set! *treat-all-symbols-as-external?* #t)) (when do-not-treat-all-symbols-as-external? (set! *treat-all-symbols-as-external?* #f)) (when index-allocated-string-types-by-expression? (set! *index-allocated-string-types-by-expression?* #t)) (when do-not-index-allocated-string-types-by-expression? (set! *index-allocated-string-types-by-expression?* #f)) (when index-constant-structure-types-by-slot-types? (set! *index-constant-structure-types-by-slot-types?* #t)) (when do-not-index-constant-structure-types-by-slot-types? (set! *index-constant-structure-types-by-slot-types?* #f)) (when index-constant-structure-types-by-expression? (set! *index-constant-structure-types-by-expression?* #t)) (when do-not-index-constant-structure-types-by-expression? (set! *index-constant-structure-types-by-expression?* #f)) (when index-allocated-structure-types-by-slot-types? (set! *index-allocated-structure-types-by-slot-types?* #t)) (when do-not-index-allocated-structure-types-by-slot-types? (set! *index-allocated-structure-types-by-slot-types?* #f)) (when index-allocated-structure-types-by-expression? (set! *index-allocated-structure-types-by-expression?* #t)) (when do-not-index-allocated-structure-types-by-expression? (set! *index-allocated-structure-types-by-expression?* #f)) (when index-constant-headed-vector-types-by-element-type? (set! *index-constant-headed-vector-types-by-element-type?* #t)) (when do-not-index-constant-headed-vector-types-by-element-type? (set! *index-constant-headed-vector-types-by-element-type?* #f)) (when index-constant-headed-vector-types-by-expression? (set! *index-constant-headed-vector-types-by-expression?* #t)) (when do-not-index-constant-headed-vector-types-by-expression? (set! *index-constant-headed-vector-types-by-expression?* #f)) (when index-allocated-headed-vector-types-by-element-type? (set! *index-allocated-headed-vector-types-by-element-type?* #t)) (when do-not-index-allocated-headed-vector-types-by-element-type? (set! *index-allocated-headed-vector-types-by-element-type?* #f)) (when index-allocated-headed-vector-types-by-expression? (set! *index-allocated-headed-vector-types-by-expression?* #t)) (when do-not-index-allocated-headed-vector-types-by-expression? (set! *index-allocated-headed-vector-types-by-expression?* #f)) (when index-constant-nonheaded-vector-types-by-element-type? (set! *index-constant-nonheaded-vector-types-by-element-type?* #t)) (when do-not-index-constant-nonheaded-vector-types-by-element-type? (set! *index-constant-nonheaded-vector-types-by-element-type?* #f)) (when index-constant-nonheaded-vector-types-by-expression? (set! *index-constant-nonheaded-vector-types-by-expression?* #t)) (when do-not-index-constant-nonheaded-vector-types-by-expression? (set! *index-constant-nonheaded-vector-types-by-expression?* #f)) (when index-allocated-nonheaded-vector-types-by-element-type? (set! *index-allocated-nonheaded-vector-types-by-element-type?* #t)) (when do-not-index-allocated-nonheaded-vector-types-by-element-type? (set! *index-allocated-nonheaded-vector-types-by-element-type?* #f)) (when index-allocated-nonheaded-vector-types-by-expression? (set! *index-allocated-nonheaded-vector-types-by-expression?* #t)) (when do-not-index-allocated-nonheaded-vector-types-by-expression? (set! *index-allocated-nonheaded-vector-types-by-expression?* #f)) (cond (no-clone-size-limit? (set! *clone-size-limit* -1)) (clone-size-limit? (when (or (not (integer? clone-size-limit)) (not (exact? clone-size-limit)) (negative? clone-size-limit)) (notify "Invalid clone size limit: ~a" clone-size-limit) (terminate)) (set! *clone-size-limit* clone-size-limit))) (when split-even-if-no-widening? (set! *split-even-if-no-widening?* #t)) (when fully-convert-to-CPS? (set! *fully-convert-to-CPS?* #t)) (when no-escaping-continuations? (set! *no-escaping-continuations?* #t)) (when disable-uniqueness? (set! *uniqueness?* #f)) (when disable-bounds-checks? (set! *bounds-checks?* #f)) (when disable-memory-checks? (set! *memory-checks?* #f)) (when disable-overflow-checks? (set! *overflow-checks?* #f)) (when disable-runtime-checks? (set! *runtime-checks?* #f)) (when disable-type-checks? (set! *type-checks?* #f)) (when p0? (set! *panic?* #f)) (when p1? (set! *p1?* #t)) (when p2? (set! *p2?* #t)) (when p3? (set! *p3?* #t)) (when p4? (set! *p4?* #t)) (when p5? (set! *p5?* #t)) (when p6? (set! *p6?* #t)) (when p7? (set! *p7?* #t)) (when closure-conversion-statistics? (set! *closure-conversion-statistics?* #t)) (when disable-stack-allocation? (set! *stack-allocation?* #f)) (when disable-heap-allocation? (set! *heap-allocation?* #f)) (when disable-region-allocation? (set! *region-allocation?* #f)) (when memory-messages? (set! *memory-messages?* #t)) (when disable-expandable-regions? (set! *expandable-regions?* #f)) (when d? (set! *flonum-representation* 'double)) (when architecture-name? (set! *architecture-name* architecture-name)) (when baseline? (set! *closure-conversion-method* 'baseline)) (when conventional? (set! *closure-conversion-method* 'conventional)) (when lightweight? (set! *closure-conversion-method* 'lightweight)) (when immediate-flat? (set! *closure-representation* 'immediate-flat)) (when indirect-flat? (set! *closure-representation* 'indirect-flat)) (when immediate-display? (set! *closure-representation* 'immediate-display)) (when indirect-display? (set! *closure-representation* 'indirect-display)) (when linked? (set! *closure-representation* 'linked)) (when align-strings? (set! *align-strings?* #t)) (when do-not-align-strings? (set! *align-strings?* #f)) (when eq?-forgery? (set! *eq?-forgery?* #t)) (when disable-forgery? (set! *forgery?* #f)) (when globals? (set! *globals?* #t)) (when type-if? (set! *type-if?* #t)) (when immediate-structures? (set! *immediate-structures?* #t)) (when promote-representations? (set! *promote-representations?* #t)) (when copy-propagation? (set! *copy-propagation?* #t)) (when disable-squeezing? (set! *squeeze?* #f) (set! *squish?* #f)) (when disable-squishing? (set! *squish?* #f)) (when treadmarks? (set! *treadmarks?* #t)) (when disable-tail-call-optimization? (set! *tail-call-optimization?* #f)) (when disable-database? (set! *database?* #f)) (when disable-run-cc? (set! *run-cc?* #f)) (when keep-c? (set! *keep-c?* #t)) (when cc? (set! *cc* cc)) (set! *copts* copts) (stalin pathname (lambda () (unless (can-open-file-for-input? (default-extension pathname "sc")) (notify "Cannot find: ~a" (default-extension pathname "sc")) (terminate)) (let ((ss (read-s-expressions (default-extension pathname "sc")))) (list (scheme-library (symbols-in (scheme-library '() ss)) ss) (lambda (output-port) ;; conventions: OUTPUT-PORT #f)))))) ;;; Tam V'Nishlam Shevah L'El Borei Olam