From e9899d3ed5ae58d16db94c9c4a5aacbee6b8da3e Mon Sep 17 00:00:00 2001 From: Bike Date: Sat, 14 Jan 2017 16:27:21 -0800 Subject: [PATCH 1/4] add boxedness handling for array HIR --- .../compile-array-related-asts.lisp | 29 ++++++++++--------- .../array-related-asts.lisp | 19 ++++++------ .../Abstract-syntax-tree/packages.lisp | 2 +- Code/Cleavir/Generate-AST/convert-primop.lisp | 14 ++++----- .../HIR/array-related-instructions.lisp | 7 +++-- .../Intermediate-representation/packages.lisp | 2 +- 6 files changed, 40 insertions(+), 33 deletions(-) diff --git a/Code/Cleavir/AST-to-HIR/compile-array-related-asts.lisp b/Code/Cleavir/AST-to-HIR/compile-array-related-asts.lisp index 3481719a88..19b99f8b56 100644 --- a/Code/Cleavir/AST-to-HIR/compile-array-related-asts.lisp +++ b/Code/Cleavir/AST-to-HIR/compile-array-related-asts.lisp @@ -17,12 +17,13 @@ (let* ((array-temp (make-temp)) (index-temp (make-temp)) (type (cleavir-ast:element-type ast)) - (unboxed (if (cleavir-ast:box-p ast) - (list (make-temp)) - (results context))) - (succ (if (cleavir-ast:box-p ast) - (list (box-for-type type unboxed context)) - (successors context)))) + (unboxed (if (cleavir-ast:boxed-p ast) + (results context) + ;; need an additional boxing step. + (list (make-temp)))) + (succ (if (cleavir-ast:boxed-p ast) + (successors context) + (list (box-for-type type unboxed context))))) (compile-ast (cleavir-ast:array-ast ast) (context @@ -33,6 +34,7 @@ (list (make-instance 'cleavir-ir:aref-instruction :element-type type :simple-p (cleavir-ast:simple-p ast) + :boxed-p (cleavir-ast:boxed-p ast) :inputs (list array-temp index-temp) :outputs unboxed :successors succ)) @@ -58,6 +60,7 @@ (aset (make-instance 'cleavir-ir:aset-instruction :element-type type :simple-p (cleavir-ast:simple-p ast) + :boxed-p (cleavir-ast:boxed-p ast) :inputs (list array-temp index-temp element-temp) :outputs (results context) :successors (successors context)))) @@ -71,8 +74,12 @@ (list index-temp) (compile-ast (cleavir-ast:element-ast ast) - (if (cleavir-ast:unbox-p ast) - ;; if we have to unbox the element first, compile + (if (cleavir-ast:boxed-p ast) + ;; simple case: no unbox required + (context (list element-temp) + (list aset) + (invocation context)) + ;; if we have to unbox the new value first, compile ;; the element-ast in a context where the successor ;; is an unboxer and the output is a different temp. (let ((boxed-temp (make-temp))) @@ -81,10 +88,6 @@ (list (unbox-for-type type boxed-temp element-temp aset)) - (invocation context))) - ;; otherwise it's simple. - (context (list element-temp) - (list aset) - (invocation context)))) + (invocation context))))) (invocation context))) (invocation context))))) diff --git a/Code/Cleavir/Abstract-syntax-tree/array-related-asts.lisp b/Code/Cleavir/Abstract-syntax-tree/array-related-asts.lisp index e7612cd850..dcd5f804ec 100644 --- a/Code/Cleavir/Abstract-syntax-tree/array-related-asts.lisp +++ b/Code/Cleavir/Abstract-syntax-tree/array-related-asts.lisp @@ -9,22 +9,23 @@ ;;; INDEX-AST is an AST that evaluates to a row-major index into ;;; the array that is the value of ARRAY-AST. ELEMENT-TYPE is the ;;; actual element-type of the array. SIMPLE-P is whether it's -;;; actually simple. BOX-P is whether the value read should be -;;; boxed in an additional instruction. +;;; actually simple. BOXED-P is whether the values in the array +;;; are boxed or not (if not, an additional BOX-INSTRUCTION will +;;; be added at the output) (defclass aref-ast (ast one-value-ast-mixin) ((%array-ast :initarg :array-ast :reader array-ast) (%index-ast :initarg :index-ast :reader index-ast) (%element-type :initarg :element-type :reader element-type) (%simple-p :initarg :simple-p :reader simple-p) - (%box-p :initarg :box-p :reader box-p))) + (%boxed-p :initarg :boxed-p :reader boxed-p))) (cleavir-io:define-save-info aref-ast (:array-ast array-ast) (:index-ast index-ast) (:element-type element-type) (:simple-p simple-p) - (:box-p box-p)) + (:boxed-p boxed-p)) (defmethod children ((ast aref-ast)) (list (array-ast ast) (index-ast ast))) @@ -39,9 +40,9 @@ ;;; to the element to be written, and that element must be of a type ;;; that is acceptable to store in the array, according to how the ;;; array is specialized. SIMPLE-P is whether the array is actually -;;; simple and ELEMENT-TYPE is its actual element-type. UNBOX-P -;;; indicates whether the object must be unboxed before being -;;; written into the array. +;;; simple and ELEMENT-TYPE is its actual element-type. BOXED-P +;;; indicates whether the values in the array are boxed or not (if +;;; not an additional UNBOX-INSTRUCTION will be added at the input) (defclass aset-ast (ast no-value-ast-mixin) ((%array-ast :initarg :array-ast :reader array-ast) @@ -49,7 +50,7 @@ (%element-ast :initarg :element-ast :reader element-ast) (%element-type :initarg :element-type :reader element-type) (%simple-p :initarg :simple-p :reader simple-p) - (%unbox-p :initarg :unbox-p :reader unbox-p))) + (%boxed-p :initarg :boxed-p :reader boxed-p))) (cleavir-io:define-save-info aset-ast (:array-ast array-ast) @@ -57,7 +58,7 @@ (:element-ast element-ast) (:element-type element-type) (:simple-p simple-p) - (:unbox-p unbox-p)) + (:boxed-p boxed-p)) (defmethod children ((ast aset-ast)) (list (array-ast ast) (index-ast ast) (element-ast ast))) diff --git a/Code/Cleavir/Abstract-syntax-tree/packages.lisp b/Code/Cleavir/Abstract-syntax-tree/packages.lisp index 7deb36dc59..a25f1706d8 100644 --- a/Code/Cleavir/Abstract-syntax-tree/packages.lisp +++ b/Code/Cleavir/Abstract-syntax-tree/packages.lisp @@ -111,7 +111,7 @@ #:slot-write-ast #:make-slot-write-ast #:aref-ast #:aset-ast #:element-ast #:array-ast #:index-ast - #:element-type #:simple-p #:box-p #:unbox-p + #:element-type #:simple-p #:boxed-p #:child-ast #:scope-ast #:make-scope-ast #:map-ast-depth-first-preorder diff --git a/Code/Cleavir/Generate-AST/convert-primop.lisp b/Code/Cleavir/Generate-AST/convert-primop.lisp index 7d9c8d6693..fc6a02b523 100644 --- a/Code/Cleavir/Generate-AST/convert-primop.lisp +++ b/Code/Cleavir/Generate-AST/convert-primop.lisp @@ -466,19 +466,19 @@ ;;; array and an index into it, as forms. The remainder of the ;;; arguments are not evaluated. The third is the actual element ;;; type of the array. The fourth is whether the array is actually -;;; simple. The fifth is whether the value from aref should be +;;; simple. The fifth is whether the value in the array is already ;;; boxed. (defmethod convert-special ((symbol (eql 'cleavir-primop:aref)) form env system) - (db origin (array-form index-form type simple-p box-p) + (db origin (array-form index-form type simple-p boxed-p) (rest form) (make-instance 'cleavir-ast:aref-ast :array-ast (convert array-form env system) :index-ast (convert index-form env system) :element-type type :simple-p simple-p - :box-p box-p + :boxed-p boxed-p :origin origin))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -487,8 +487,8 @@ ;;; ;;; This primop takes six arguments. The first two are an array and ;;; an index into it. The third is the object to be written in. The -;;; fourth and fifth are as above. The sixth is whether the object -;;; has to be unboxed before being written into the array. +;;; fourth and fifth are as above. The sixth is whether the objects +;;; in the array are boxed. ;;; ;;; Forms using this primitive operation must occur in a context ;;; that does not require a value, such as in a PROGN other than as @@ -497,7 +497,7 @@ (defmethod convert-special ((symbol (eql 'cleavir-primop:aset)) form env system) (db origin (array-form index-form object-form - type simple-p unbox-p) + type simple-p boxed-p) (rest form) (make-instance 'cleavir-ast:aset-ast :array-ast (convert array-form env system) @@ -505,7 +505,7 @@ :element-ast (convert object-form env system) :element-type type :simple-p simple-p - :unbox-p unbox-p + :boxed-p boxed-p :origin origin))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/Code/Cleavir/Intermediate-representation/HIR/array-related-instructions.lisp b/Code/Cleavir/Intermediate-representation/HIR/array-related-instructions.lisp index 2a9d2715ac..3a57999930 100644 --- a/Code/Cleavir/Intermediate-representation/HIR/array-related-instructions.lisp +++ b/Code/Cleavir/Intermediate-representation/HIR/array-related-instructions.lisp @@ -8,12 +8,14 @@ ;;; This instruction takes two inputs: an array and an index. ;;; The array must have the actual element-type of the instruction, ;;; and have actual simplicity corresponding to simple-p. +;;; Boxed-p indicates whether elements in the array are boxed. ;;; The index is row-major. ;;; There is a single output, the read value. (defclass aref-instruction (instruction one-successor-mixin) ((%element-type :initarg :element-type :reader element-type) - (%simple-p :initarg :simple-p :reader simple-p))) + (%simple-p :initarg :simple-p :reader simple-p) + (%boxed-p :initarg :boxed-p :reader boxed-p))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -28,4 +30,5 @@ (defclass aset-instruction (instruction one-successor-mixin side-effect-mixin) ((%element-type :initarg :element-type :reader element-type) - (%simple-p :initarg :simple-p :reader simple-p))) + (%simple-p :initarg :simple-p :reader simple-p) + (%boxed-p :initarg :boxed-p :reader boxed-p))) diff --git a/Code/Cleavir/Intermediate-representation/packages.lisp b/Code/Cleavir/Intermediate-representation/packages.lisp index e39431d7fa..2e77f5844e 100644 --- a/Code/Cleavir/Intermediate-representation/packages.lisp +++ b/Code/Cleavir/Intermediate-representation/packages.lisp @@ -65,7 +65,7 @@ #:phi-instruction #:make-phi-instruction #:use-instruction #:make-use-instruction #:aref-instruction #:aset-instruction - #:element-type #:simple-p + #:element-type #:simple-p #:boxed-p #:fixnum-add-instruction #:make-fixnum-add-instruction #:fixnum-sub-instruction #:make-fixnum-sub-instruction #:fixnum-less-instruction #:make-fixnum-less-instruction From 73844d7a3082011f2b26fabe6fb489fefa563c31 Mon Sep 17 00:00:00 2001 From: Bike Date: Sat, 14 Jan 2017 18:59:16 -0800 Subject: [PATCH 2/4] teach type inferencer a bit about arrays & boxes --- Code/Cleavir/Type-inference/packages.lisp | 3 +- Code/Cleavir/Type-inference/transfer.lisp | 96 ++++++++----- .../Type-inference/type-descriptor.lisp | 126 ++++-------------- 3 files changed, 90 insertions(+), 135 deletions(-) diff --git a/Code/Cleavir/Type-inference/packages.lisp b/Code/Cleavir/Type-inference/packages.lisp index c1cc683cc1..fd14d3b04f 100644 --- a/Code/Cleavir/Type-inference/packages.lisp +++ b/Code/Cleavir/Type-inference/packages.lisp @@ -5,7 +5,8 @@ (:export #:approximate-type #:canonicalize-type #:top-p #:bottom-p #:binary-join #:binary-meet #:difference - #:join #:meet) + #:join #:meet + #:descriptor-box #:descriptor-unbox) (:export #:approximate-values #:values-nth #:values-rest-p #:values-top-p #:values-bottom-p #:values-required #:values-required-count diff --git a/Code/Cleavir/Type-inference/transfer.lisp b/Code/Cleavir/Type-inference/transfer.lisp index a18dbbe8d4..027ab56848 100644 --- a/Code/Cleavir/Type-inference/transfer.lisp +++ b/Code/Cleavir/Type-inference/transfer.lisp @@ -94,44 +94,76 @@ input-bag)))) (defmethod one-successor-transfer - ((instruction cleavir-ir:short-float-unbox-instruction) input-bag) - (let ((output (first (cleavir-ir:outputs instruction)))) - (update output 'unboxed-short-float input-bag))) + ((instruction cleavir-ir:aref-instruction) input-bag) + ;; TODO: update array + (let ((index (second (cleavir-ir:inputs instruction))) + (output (first (cleavir-ir:outputs instruction))) + (element-descriptor + (approximate-type + (cleavir-ir:element-type instruction)))) + (update output + (if (cleavir-ir:boxed-p instruction) + element-descriptor + (descriptor-unbox element-descriptor)) + (update index + (binary-meet (find-type index input-bag) + ;; could use array dimensions, + ;; or a more proper thing with + ;; ARRAY-TOTAL-SIZE + (approximate-type 'fixnum)) + input-bag)))) (defmethod one-successor-transfer - ((instruction cleavir-ir:short-float-box-instruction) input-bag) - (let ((output (first (cleavir-ir:outputs instruction)))) - (update output 'short-float input-bag))) + ((instruction cleavir-ir:aset-instruction) input-bag) + ;; TODO: update array + (let ((index (second (cleavir-ir:inputs instruction))) + (object (third (cleavir-ir:inputs instruction))) + (element-descriptor + (approximate-type + (cleavir-ir:element-type instruction)))) + (update object + (binary-meet + (find-type object input-bag) + (if (cleavir-ir:boxed-p instruction) + element-descriptor + ;; if the array's elements are unboxed, the object + ;; being written must be unboxed. + (descriptor-unbox element-descriptor))) + (update index + (binary-meet (find-type index input-bag) + ;; could use array dimensions, + ;; or a more proper thing with + ;; ARRAY-TOTAL-SIZE + (approximate-type 'fixnum)) + input-bag)))) (defmethod one-successor-transfer - ((instruction cleavir-ir:single-float-unbox-instruction) input-bag) - (let ((output (first (cleavir-ir:outputs instruction)))) - (update output 'unboxed-single-float input-bag))) + ((instruction cleavir-ir:box-instruction) input-bag) + (let ((input (first (cleavir-ir:inputs instruction))) + (output (first (cleavir-ir:outputs instruction))) + (element-descriptor + (approximate-type + (cleavir-ir:element-type instruction)))) + (update input + (binary-meet (find-type input input-bag) + (descriptor-unbox element-descriptor)) + (update output + element-descriptor + input-bag)))) (defmethod one-successor-transfer - ((instruction cleavir-ir:single-float-box-instruction) input-bag) - (let ((output (first (cleavir-ir:outputs instruction)))) - (update output 'single-float input-bag))) - -(defmethod one-successor-transfer - ((instruction cleavir-ir:double-float-unbox-instruction) input-bag) - (let ((output (first (cleavir-ir:outputs instruction)))) - (update output 'unboxed-double-float input-bag))) - -(defmethod one-successor-transfer - ((instruction cleavir-ir:double-float-box-instruction) input-bag) - (let ((output (first (cleavir-ir:outputs instruction)))) - (update output 'double-float input-bag))) - -(defmethod one-successor-transfer - ((instruction cleavir-ir:long-float-unbox-instruction) input-bag) - (let ((output (first (cleavir-ir:outputs instruction)))) - (update output 'unboxed-long-float input-bag))) - -(defmethod one-successor-transfer - ((instruction cleavir-ir:long-float-box-instruction) input-bag) - (let ((output (first (cleavir-ir:outputs instruction)))) - (update output 'long-float input-bag))) + ((instruction cleavir-ir:unbox-instruction) input-bag) + (let ((input (first (cleavir-ir:inputs instruction))) + (output (first (cleavir-ir:outputs instruction))) + (element-descriptor + (approximate-type + (cleavir-ir:element-type instruction)))) + (update input + (binary-meet (find-type input input-bag) + element-descriptor) + (update output + (descriptor-unbox element-descriptor) + input-bag)))) (defmethod one-successor-transfer ((instruction cleavir-ir:the-values-instruction) input-bag) diff --git a/Code/Cleavir/Type-inference/type-descriptor.lisp b/Code/Cleavir/Type-inference/type-descriptor.lisp index f78c1e7063..260abf5bd0 100644 --- a/Code/Cleavir/Type-inference/type-descriptor.lisp +++ b/Code/Cleavir/Type-inference/type-descriptor.lisp @@ -119,26 +119,6 @@ ;;;; This type descriptor means that the variable must have the ;;;; type LONG-FLOAT. ;;;; -;;;; UNBOXED-SHORT-FLOAT -;;;; -;;;; This type descriptor means that the variable must contain an -;;;; unboxed SHORT-FLOAT value. -;;;; -;;;; UNBOXED-SINGLE-FLOAT -;;;; -;;;; This type descriptor means that the variable must contain an -;;;; unboxed SINGLE-FLOAT value. -;;;; -;;;; UNBOXED-DOUBLE-FLOAT -;;;; -;;;; This type descriptor means that the variable must contain an -;;;; unboxed DOUBLE-FLOAT value. -;;;; -;;;; UNBOXED-LONG-FLOAT -;;;; -;;;; This type descriptor means that the variable must contain an -;;;; unboxed LONG-FLOAT value. -;;;; ;;;; COMPLEX-SHORT-FLOAT ;;;; ;;;; This type descriptor means that the variable must contain a @@ -158,89 +138,10 @@ ;;;; ;;;; This type descriptor means that the variable must contain a ;;;; complex number with an upgraded element type of LONG-FLOAT. +;;;; (UNBOXED x) ;;;; -;;;; SIMPLE-ARRAY-BIT -;;;; -;;;; This type descriptor means that the variable must contain a -;;;; simple array with an upgraded element type of BIT. -;;;; -;;;; SIMPLE-ARRAY-UNSIGNED-BYTE-8 -;;;; -;;;; This type descriptor means that the variable must contain a -;;;; simple array with an upgraded element type of (UNSIGNED-BYTE -;;;; 8). -;;;; -;;;; SIMPLE-ARRAY-UNSIGNED-BYTE-16 -;;;; -;;;; This type descriptor means that the variable must contain a -;;;; simple array with an upgraded element type of (UNSIGNED-BYTE -;;;; 16). -;;;; -;;;; SIMPLE-ARRAY-UNSIGNED-BYTE-32 -;;;; -;;;; This type descriptor means that the variable must contain a -;;;; simple array with an upgraded element type of (UNSIGNED-BYTE -;;;; 32). -;;;; -;;;; SIMPLE-ARRAY-UNSIGNED-BYTE-64 -;;;; -;;;; This type descriptor means that the variable must contain a -;;;; simple array with an upgraded element type of (UNSIGNED-BYTE -;;;; 64). -;;;; -;;;; SIMPLE-ARRAY-SIGNED-BYTE-8 -;;;; -;;;; This type descriptor means that the variable must contain a -;;;; simple array with an upgraded element type of (SIGNED-BYTE -;;;; 8). -;;;; -;;;; SIMPLE-ARRAY-SIGNED-BYTE-16 -;;;; -;;;; This type descriptor means that the variable must contain a -;;;; simple array with an upgraded element type of (SIGNED-BYTE -;;;; 16). -;;;; -;;;; SIMPLE-ARRAY-SIGNED-BYTE-32 -;;;; -;;;; This type descriptor means that the variable must contain a -;;;; simple array with an upgraded element type of (SIGNED-BYTE -;;;; 32). -;;;; -;;;; SIMPLE-ARRAY-SIGNED-BYTE-64 -;;;; -;;;; This type descriptor means that the variable must contain a -;;;; simple array with an upgraded element type of (SIGNED-BYTE -;;;; 64). -;;;; -;;;; SIMPLE-ARRAY-BASE-CHAR -;;;; -;;;; This type descriptor means that the variable must contain a -;;;; simple array with an upgraded element type of BASE-CHAR. -;;;; -;;;; SIMPLE-ARRAY-CHARACTER -;;;; -;;;; This type descriptor means that the variable must contain a -;;;; simple array with an upgraded element type of CHARACTER. -;;;; -;;;; SIMPLE-ARRAY-SHORT-FLOAT -;;;; -;;;; This type descriptor means that the variable must contain a -;;;; simple array with an upgraded element type of SHORT-FLOAT. -;;;; -;;;; SIMPLE-ARRAY-SINGLE-FLOAT -;;;; -;;;; This type descriptor means that the variable must contain a -;;;; simple array with an upgraded element type of SINGLE-FLOAT. -;;;; -;;;; SIMPLE-ARRAY-DOUBLE-FLOAT -;;;; -;;;; This type descriptor means that the variable must contain a -;;;; simple array with an upgraded element type of DOUBLE-FLOAT. -;;;; -;;;; SIMPLE-ARRAY-LONG-FLOAT -;;;; -;;;; This type descriptor means that the variable must contain a -;;;; simple array with an upgraded element type of LONG-FLOAT. +;;;; The variable contains an unboxed x, where x is another +;;;; type descriptor. ;;;; Ideally, other code in this system will not worry itself with ;;;; subtypep and so on, and only use the functions here. @@ -424,4 +325,25 @@ (defun meet (&rest descriptors) (reduce #'binary-meet descriptors :initial-value 't)) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; DESCRIPTOR-UNBOX and DESCRIPTOR-BOX. +;;; +;;; (unboxed [descriptor]) is a descriptor, but not one that will +;;; ever be returned by approximate- or canonicalize-type. +;;; +;;; -UNBOX returns the descriptor for the unboxed version of the +;;; given descriptor, while -BOX returns the underlying descriptor +;;; of an (unboxed [x]) descriptor. + +(defun descriptor-unbox (descriptor) + (assert (not (and (consp descriptor) + (eq (first descriptor) 'unboxed)))) + `(unboxed ,descriptor)) + +(defun descriptor-box (descriptor) + (assert (and (consp descriptor) + (eq (first descriptor) 'unboxed))) + (second descriptor)) + ;; LocalWords: canonicalize inferencer From a44209c5374b686b7fa1973cff1c4844dd73b209 Mon Sep 17 00:00:00 2001 From: Bike Date: Sat, 14 Jan 2017 19:19:29 -0800 Subject: [PATCH 3/4] fix compilation of aset ASTs --- .../compile-array-related-asts.lisp | 46 ++++++++++--------- 1 file changed, 24 insertions(+), 22 deletions(-) diff --git a/Code/Cleavir/AST-to-HIR/compile-array-related-asts.lisp b/Code/Cleavir/AST-to-HIR/compile-array-related-asts.lisp index 19b99f8b56..455381ae53 100644 --- a/Code/Cleavir/AST-to-HIR/compile-array-related-asts.lisp +++ b/Code/Cleavir/AST-to-HIR/compile-array-related-asts.lisp @@ -68,26 +68,28 @@ (cleavir-ast:array-ast ast) (context (list array-temp) - (compile-ast - (cleavir-ast:index-ast ast) - (context - (list index-temp) - (compile-ast - (cleavir-ast:element-ast ast) - (if (cleavir-ast:boxed-p ast) - ;; simple case: no unbox required - (context (list element-temp) - (list aset) - (invocation context)) - ;; if we have to unbox the new value first, compile - ;; the element-ast in a context where the successor - ;; is an unboxer and the output is a different temp. - (let ((boxed-temp (make-temp))) - (context - (list boxed-temp) - (list - (unbox-for-type type boxed-temp - element-temp aset)) - (invocation context))))) - (invocation context))) + (list + (compile-ast + (cleavir-ast:index-ast ast) + (context + (list index-temp) + (list + (compile-ast + (cleavir-ast:element-ast ast) + (if (cleavir-ast:boxed-p ast) + ;; simple case: no unbox required + (context (list element-temp) + (list aset) + (invocation context)) + ;; if we have to unbox the new value first, compile + ;; the element-ast in a context where the successor + ;; is an unboxer and the output is a different temp. + (let ((boxed-temp (make-temp))) + (context + (list boxed-temp) + (list + (unbox-for-type type boxed-temp + element-temp aset)) + (invocation context)))))) + (invocation context)))) (invocation context))))) From aa3a02530b8da106979efe27961af8714a6e8e4b Mon Sep 17 00:00:00 2001 From: Bike Date: Sat, 14 Jan 2017 21:27:54 -0800 Subject: [PATCH 4/4] alter some type proclamations --- Code/Types/type-proclamations-to-move.lisp | 247 +++++++++++---------- 1 file changed, 125 insertions(+), 122 deletions(-) diff --git a/Code/Types/type-proclamations-to-move.lisp b/Code/Types/type-proclamations-to-move.lisp index 3e692590b6..2b22c2945d 100644 --- a/Code/Types/type-proclamations-to-move.lisp +++ b/Code/Types/type-proclamations-to-move.lisp @@ -1,5 +1,20 @@ (cl:in-package #:sicl-type-proclamations) +;;; like FUNCTION but returning an exact number of values. +;;; does not accept values types with lambda list keywords. + +;;; CLHS 1.6 says standard functions can't return more values than +;;; they are specified to. But some types here are arguments, like +;;; keyfun, and in that case conforming programs can pass a +;;; function that returns more values if they really want to. + +;;; Having (values ... &rest nil) should conformingly mean no more +;;; values, so we do that here. Works in Cleavir and works in SBCL. +(deftype sfunction (&optional args result) + `(function ,args ,(if (consp result) + `(,@result &rest nil) + `(values ,result &rest nil)))) + (declaim (ftype symbol-predicate name-of-length-1)) (deftype character-designator () @@ -28,7 +43,7 @@ Some implementations define their own function names, like SBCL's (SB-PCL:CTOR . This type should be restricted to non-side-effectful functions for human-understandability. INPUT is an optional restriction of input types to the predicate." ;; i'm (Bike) not sure that (function (*)) is a legal type. - `(function (,input) generalized-boolean)) + `(sfunction (,input) generalized-boolean)) (deftype predicate-designator (&optional input) `(function-designator (predicate ,input))) (deftype type-predicate (type &optional input) @@ -137,16 +152,17 @@ See CLHS 9.1.2.1." "Glossary definition." '(or null readtable)) -(declaim (ftype (function (function method) function) +(declaim (ftype (sfunction (function method) function) add-method)) -(declaim (ftype (function (t list +(declaim (ftype (sfunction (t list &key (:key keyfun) (:test testfun2-designator) - (:test-not testfun2-designator))) + (:test-not testfun2-designator)) + list) adjoin)) -(declaim (ftype (function (array (or array-dimension list) ; "list of valid array dimensions" is complex and inexpressible +(declaim (ftype (sfunction (array (or array-dimension list) ; "list of valid array dimensions" is complex and inexpressible &key (:element-type type-specifier) (:initial-element t) (:initial-contents t) ; could be more complicated @@ -157,19 +173,21 @@ See CLHS 9.1.2.1." adjust-array)) ;; kind of a type predicate... but not really. -(declaim (ftype (function (array) generalized-boolean) +(declaim (ftype (sfunction (array) generalized-boolean) adjustable-array-p)) ;; note that the list is specifically a plist -(declaim (ftype (function (class &rest list &key &allow-other-keys) t) +(declaim (ftype (sfunction (class &rest list &key &allow-other-keys) t) allocate-instance)) ;; again not really type predicates -(declaim (ftype (function (character) generalized-boolean) +(declaim (ftype (sfunction (character) generalized-boolean) alpha-char-p alphanumericp)) -(declaim (ftype (function (&rest list) t) +;;; "each must be a proper list except the last, which can be +;;; any object" +(declaim (ftype (sfunction (&rest t) t) append)) (declaim (ftype (function (function-designator &rest args) *) @@ -177,57 +195,57 @@ See CLHS 9.1.2.1." (declaim (ftype (function (string-designator &optional (or package-designator null)) - nil) + (values &rest nil)) ; no values apropos)) -(declaim (ftype (function (string-designator +(declaim (ftype (sfunction (string-designator &optional (or package-designator null)) list) ; a list of symbols apropos-list)) -(declaim (ftype (function (array &rest array-index) t) +(declaim (ftype (sfunction (array &rest array-index) t) aref)) -(declaim (ftype (function (array valid-array-rank) array-dimension) +(declaim (ftype (sfunction (array valid-array-rank) array-dimension) array-dimension)) -(declaim (ftype (function (array) list) ; a list of array dimensions +(declaim (ftype (sfunction (array) list) ; a list of array dimensions array-dimensions)) -(declaim (ftype (function (array) +(declaim (ftype (sfunction (array) (values (or array nil) non-negative-fixnum)) array-displacement)) -(declaim (ftype (function (array) +(declaim (ftype (sfunction (array) type-specifier) array-element-type)) -(declaim (ftype (function (array) generalized-boolean) +(declaim (ftype (sfunction (array) generalized-boolean) array-has-fill-pointer-p)) -(declaim (ftype (function (array &rest integer) generalized-boolean) +(declaim (ftype (sfunction (array &rest integer) generalized-boolean) array-in-bounds-p)) -(declaim (ftype (function (array) valid-array-rank) +(declaim (ftype (sfunction (array) valid-array-rank) array-rank)) -(declaim (ftype (function (array &rest array-index) non-negative-fixnum) +(declaim (ftype (sfunction (array &rest array-index) non-negative-fixnum) array-row-major-index)) -(declaim (ftype (function (array) (integer 0)) +(declaim (ftype (sfunction (array) (integer 0)) array-total-size)) (declaim (ftype (type-predicate array) arrayp)) -(declaim (ftype (function (t list +(declaim (ftype (sfunction (t list &key (:key keyfun-designator) (:test testfun2-designator) (:test-not testfun2-designator)) (or cons null)) assoc)) -(declaim (ftype (function (testfun1-designator +(declaim (ftype (sfunction (testfun1-designator list &key (:key keyfun-designator) (or cons null)) @@ -237,10 +255,10 @@ See CLHS 9.1.2.1." (declaim (ftype (type-predicate atom) atom)) -(declaim (ftype (function ((array bit) &rest array-index) bit) +(declaim (ftype (sfunction ((array bit) &rest array-index) bit) bit)) -(declaim (ftype (function ((array bit) (array bit) +(declaim (ftype (sfunction ((array bit) (array bit) &optional (or (array bit) (member t nil))) (array bit)) bit-and @@ -254,7 +272,7 @@ See CLHS 9.1.2.1." bit-orc2 bit-xor)) -(declaim (ftype (function ((array bit) +(declaim (ftype (sfunction ((array bit) &optional (or (array bit) (member t nil))) (array bit)) bit-not)) @@ -263,77 +281,77 @@ See CLHS 9.1.2.1." bit-vector-p)) ;;; This could be done better for any particular implementation. -(declaim (ftype (function (t integer integer) +(declaim (ftype (sfunction (t integer integer) integer) boole)) -(declaim (ftype (function (character) generalized-boolean) +(declaim (ftype (sfunction (character) generalized-boolean) upper-case-p lower-case-p both-case-p)) -(declaim (ftype (function (symbol) generalized-boolean) +(declaim (ftype (sfunction (symbol) generalized-boolean) boundp)) -(declaim (ftype (function (&optional format-control &rest t) null) +(declaim (ftype (sfunction (&optional format-control &rest t) null) break)) -(declaim (ftype (function (broadcast-stream) list) ; list of streams +(declaim (ftype (sfunction (broadcast-stream) list) ; list of streams broadcast-stream-streams)) -(declaim (ftype (function ((integer 0) (integer 0)) byte-specifier) +(declaim (ftype (sfunction ((integer 0) (integer 0)) byte-specifier) byte)) -(declaim (ftype (function (byte-specifier) (integer 0)) +(declaim (ftype (sfunction (byte-specifier) (integer 0)) byte-size byte-position)) -(declaim (ftype (function (number &optional (real 0)) +(declaim (ftype (sfunction (real &optional (real 0)) (values integer real)) floor ceiling truncate round)) -(declaim (ftype (function (cell-error) t) +(declaim (ftype (sfunction (cell-error) t) cell-error-name)) ;; note that condition designator arguments have to be a plist -(declaim (ftype (function (format-control condition-designator-datum &rest t) nil) +(declaim (ftype (sfunction (format-control condition-designator-datum &rest t) nil) cerror)) -(declaim (ftype (function (t class-designator &key &allow-other-keys) t) +(declaim (ftype (sfunction (t class-designator &key &allow-other-keys) t) change-class)) -(declaim (ftype (function (real) complex) +(declaim (ftype (sfunction (real) complex) cis)) -(declaim (ftype (function (class) symbol) +(declaim (ftype (sfunction (class) symbol) class-name)) -(declaim (ftype (function (t) class) +(declaim (ftype (sfunction (t) class) class-of)) -(declaim (ftype (function (stream &key (:abort generalized-boolean)) t) +(declaim (ftype (sfunction (stream &key (:abort generalized-boolean)) t) close)) -(declaim (ftype (function (hash-table) hash-table) +(declaim (ftype (sfunction (hash-table) hash-table) clrhash)) -(declaim (ftype (function (character-code) (or character null)) +(declaim (ftype (sfunction (character-code) (or character null)) code-char)) -(declaim (ftype (function (t type-specifier) t) +(declaim (ftype (sfunction (t type-specifier) t) coerce)) -(declaim (ftype (function ((or function-name null) +(declaim (ftype (sfunction ((or function-name null) &optional (or function lambda-expression)) (values (or function-name compiled-function) generalized-boolean generalized-boolean)) compile)) -(declaim (ftype (function (pathname-designator &key +(declaim (ftype (sfunction (pathname-designator &key (:output-file pathname-designator) (:verbose generalized-boolean) (:print generalized-boolean) @@ -343,74 +361,74 @@ See CLHS 9.1.2.1." generalized-boolean)) compile-file)) -(declaim (ftype (function (pathname-designator &key (:output-file pathname-designator) &allow-other-keys) pathname) +(declaim (ftype (sfunction (pathname-designator &key (:output-file pathname-designator) &allow-other-keys) pathname) compile-file-pathname)) (declaim (ftype (type-predicate compiled-function) compiled-function-p)) -(declaim (ftype (function (function-name &optional t #|an environment|#) (or function null)) +(declaim (ftype (sfunction (function-name &optional t #|an environment|#) (or function null)) compiler-macro-function)) -(declaim (ftype (function (function) (function * generalized-boolean)) +(declaim (ftype (sfunction (function) (function * generalized-boolean)) complement)) -(declaim (ftype (function (real &optional real) (or rational complex)) +(declaim (ftype (sfunction (real &optional real) (or rational complex)) complex)) (declaim (ftype (type-predicate complex) complexp)) -(declaim (ftype (function (generic-function list) list #|of methods|#) +(declaim (ftype (sfunction (generic-function list) list #|of methods|#) compute-applicable-methods)) ;; I'm not sure that concatenate is defined on improper sequences. -(declaim (ftype (function (type-specifier &rest sequence) proper-sequence) +(declaim (ftype (sfunction (type-specifier &rest sequence) proper-sequence) concatenate)) -(declaim (ftype (function (concatenated-stream) list #|of streams|#) +(declaim (ftype (sfunction (concatenated-stream) list #|of streams|#) concatenated-stream-streams)) -(declaim (ftype (function (number) number) +(declaim (ftype (sfunction (number) number) conjugate)) -(declaim (ftype (function (t t) cons) +(declaim (ftype (sfunction (t t) cons) cons)) (declaim (ftype (type-predicate cons) consp)) -(declaim (ftype (function (t) (function * t)) +(declaim (ftype (sfunction (t) (sfunction * t)) constantly)) -(declaim (ftype (function (t &optional t #|an environment|#) generalized-boolean) +(declaim (ftype (sfunction (t &optional t #|an environment|#) generalized-boolean) constantp)) -(declaim (ftype (function (&optional (or condition null)) null) +(declaim (ftype (sfunction (&optional (or condition null)) null) continue)) -(declaim (ftype (function (list) list) +(declaim (ftype (sfunction (list) list) copy-alist copy-list)) -(declaim (ftype (function (&optional t) t) ; objects are pprint dispatch tables +(declaim (ftype (sfunction (&optional t) t) ; objects are pprint dispatch tables copy-pprint-dispatch)) -(declaim (ftype (function (&optional readtable-designator (or null readtable)) +(declaim (ftype (sfunction (&optional readtable-designator (or null readtable)) readtable) copy-readtable)) -(declaim (ftype (function (proper-sequence) proper-sequence) +(declaim (ftype (sfunction (proper-sequence) proper-sequence) copy-seq)) -(declaim (ftype (function (structure-object) structure-object) copy-structure)) +(declaim (ftype (sfunction (structure-object) structure-object) copy-structure)) -(declaim (ftype (function (symbol &optional generalized-boolean) symbol) +(declaim (ftype (sfunction (symbol &optional generalized-boolean) symbol) copy-symbol)) -(declaim (ftype (function (t) t) +(declaim (ftype (sfunction (t) t) copy-tree)) -(declaim (ftype (function (t +(declaim (ftype (sfunction (t sequence &key (:from-end generalized-boolean) @@ -422,7 +440,7 @@ See CLHS 9.1.2.1." (integer 0)) count)) -(declaim (ftype (function (testfun1-designator +(declaim (ftype (sfunction (testfun1-designator sequence &key (:from-end generalized-boolean) @@ -433,17 +451,10 @@ See CLHS 9.1.2.1." count-if count-if-not)) -(declaim (ftype (or (function (short-float) - (values short-float integer (member 1S0 -1S0))) - (function (single-float) - (values single-float integer (member 1F0 -1F0))) - (function (double-float) - (values double-float integer (member 1D0 -1D0))) - (function (long-float) - (values long-float integer (member 1L0 -1L0)))) +(declaim (ftype (sfunction (float) (values float integer float)) decode-float)) -(declaim (ftype (function ((integer 0)) +(declaim (ftype (sfunction ((integer 0)) (values (integer 0 59) (integer 0 59) (integer 0 23) @@ -455,7 +466,7 @@ See CLHS 9.1.2.1." rational)) decode-universal-time)) -(declaim (ftype (function (t +(declaim (ftype (sfunction (t proper-sequence &key (:from-end generalized-boolean) @@ -468,7 +479,7 @@ See CLHS 9.1.2.1." delete remove)) -(declaim (ftype (function (testfun1-designator +(declaim (ftype (sfunction (testfun1-designator proper-sequence &key (:from-end generalized-boolean) @@ -481,7 +492,7 @@ See CLHS 9.1.2.1." remove-if remove-if-not)) -(declaim (ftype (function (proper-sequence +(declaim (ftype (sfunction (proper-sequence &key (:from-end generalized-boolean) (:test testfun2-designator) @@ -492,72 +503,71 @@ See CLHS 9.1.2.1." delete-duplicates remove-duplicates)) -(declaim (ftype (function (pathname-designator) (eql t)) +(declaim (ftype (sfunction (pathname-designator) (eql t)) delete-file)) -(declaim (ftype (function (package-designator) generalized-boolean) +(declaim (ftype (sfunction (package-designator) generalized-boolean) delete-package)) -(declaim (ftype (function (rational) integer) +(declaim (ftype (sfunction (rational) integer) denominator numerator)) -(declaim (ftype (function (integer byte-specifier integer) integer) +(declaim (ftype (sfunction (integer byte-specifier integer) integer) deposit-field)) -(declaim (ftype (function (t &optional stream-designator) (values)) +(declaim (ftype (sfunction (t &optional stream-designator) (values)) describe)) -(declaim (ftype (function (t stream) t) +(declaim (ftype (function (t stream) + ;; no values + (values &rest nil)) describe-object)) -(declaim (ftype (function ((integer 0) &optional radix) (or character null)) +(declaim (ftype (sfunction ((integer 0) &optional radix) (or character null)) digit-char)) -(declaim (ftype (function (character &optional radix) (or (integer 0) null)) +(declaim (ftype (sfunction (character &optional radix) (or (integer 0) null)) digit-char-p)) -(declaim (ftype (function (pathname-designator) list) +(declaim (ftype (sfunction (pathname-designator) list) directory)) -(declaim (ftype (function (pathname-designator) (or string null)) +(declaim (ftype (sfunction (pathname-designator) (or string null)) directory-namestring file-namestring host-namestring namestring)) -(declaim (ftype (function ((or extended-function-designator lambda-expression)) null) +(declaim (ftype (sfunction ((or extended-function-designator lambda-expression)) null) disassemble)) -(declaim (ftype (function (integer byte-specifier integer) integer) +(declaim (ftype (sfunction (integer byte-specifier integer) integer) dpb)) -(declaim (ftype (function (&optional pathname-designator) t) +(declaim (ftype (sfunction (&optional pathname-designator) t) dribble)) -(declaim (ftype (function (pathname-designator &optional pathname-designator) +(declaim (ftype (sfunction (pathname-designator &optional pathname-designator) (or string null)) enough-namestring)) -(declaim (ftype (function (simple-string array-index) character) +(declaim (ftype (sfunction (simple-string array-index) character) schar)) -(declaim (ftype (function ((simple-array bit) &rest array-index) bit) +(declaim (ftype (sfunction ((simple-array bit) &rest array-index) bit) sbit)) -(declaim (ftype (or (function (short-float integer) short-float) - (function (single-float integer) single-float) - (function (double-float integer) double-float) - (function (long-float integer) long-float)) +(declaim (ftype (sfunction (float integer) float) scale-float)) -(declaim (ftype (function (function function-name) function) +(declaim (ftype (sfunction (function function-name) function) (setf fdefinition))) -(declaim (ftype (function (symbol &optional generalized-boolean t)) +(declaim (ftype (sfunction (symbol &optional generalized-boolean t)) find-class)) -(declaim (ftype (function (proper-sequence +(declaim (ftype (sfunction (proper-sequence &key (:from-end generalized-boolean) (:test testfun2) (:test-not testfun2) @@ -567,7 +577,7 @@ See CLHS 9.1.2.1." t) find)) -(declaim (ftype (function (predicate-designator +(declaim (ftype (sfunction (predicate-designator proper-sequence &key (:from-end generalized-boolean) (:start bounding-index-designator) @@ -577,7 +587,7 @@ See CLHS 9.1.2.1." find-if find-if-not)) -(declaim (ftype (function (generic-function +(declaim (ftype (sfunction (generic-function list list generalized-boolean) @@ -585,28 +595,27 @@ See CLHS 9.1.2.1." find-method)) ;; CLHS doesn't say "package designator" even though this is the same, why rock the boat -(declaim (ftype (function (or string-designator package) (or package null)) +(declaim (ftype (sfunction (or string-designator package) (or package null)) find-package)) -(declaim (ftype (function ((or (and symbol (not null)) restart) +(declaim (ftype (sfunction ((or (and symbol (not null)) restart) &optional (or condition null)) (or restart null)) find-restart)) -(declaim (ftype (function (string ; not a string designator +(declaim (ftype (sfunction (string ; not a string designator &optional package-designator) (values (or symbol null) ; redundant, but human-helpful (member :inherited :external :internal nil))) find-symbol)) -;; one wonders why this doesn't return no values -(declaim (ftype (function (&optional stream-designator) null) +(declaim (ftype (sfunction (&optional stream-designator) null) finish-output force-output clear-input clear-output)) -(declaim (ftype (function list t) +(declaim (ftype (sfunction list t) first second third @@ -618,32 +627,26 @@ See CLHS 9.1.2.1." ninth tenth)) -(declaim (ftype (function function-name function-name) +(declaim (ftype (sfunction function-name function-name) fmakunbound)) -(declaim (ftype (function ((or null (eql t) stream string) ; note "string with fill-pointer" specified +(declaim (ftype (sfunction ((or null (eql t) stream string) ; note "string with fill-pointer" specified format-control &rest t) (or null string)) format)) -(declaim (ftype (function string formatter) - formatter)) - -(declaim (ftype (function (&optional stream-designator) generalized-boolean) +(declaim (ftype (sfunction (&optional stream-designator) generalized-boolean) fresh-line)) (declaim (ftype (function (function-designator &rest t) *) funcall)) -(declaim (ftype (function (function) - (values lambda-expression generalized-boolean t)) +(declaim (ftype (sfunction (function) + (values (or lambda-expression null) generalized-boolean t)) function-lambda-expression)) (declaim (ftype (type-predicate function) functionp)) -(declaim (ftype (or - (function (null) (eql t)) - (function ((not null)) null)) - null)) +(declaim (ftype (type-predicate null) null))